#!/usr/bin/perl -w
#
# Usage example:
#    PS1=`colorstring -ps Cyan` Hello, `colorstring -ps green`"world ==>"
#
# Written <2006-10-04, Steven J. DeRose, sderose@acm.org.
# 2008-02-11 sjd: Add -perl, perl -w.
# 2008-09-03 sjd: BSD. Improve doc, error-checking, fix bug in -all.
# 2010-03-28 sjd: perldoc. Add \[\] to -ps.
# 2010-09-20ff sjd: Cleanup. Add -color; ls and dircolors support. Simplify
#     numeric handling of codes. Support color combinations. Add -setenv.
#     Change 'fg2_' prefix to 'bold_' and factor out of code.
#
# To do:
#     Use rgb.txt with xterm-256color to pick by name.
#     Cache the calculated values in the environment to save time later?
#     Offer alternate color sets for setenv, especially for light vs. dark
#     backgrounds.
#     lsset should support replacing all mappings for a given color.
#

use strict;
use Getopt::Long;

my $version="2010-09-22";

my $all        = 0;
my $break      = 0;
my $color      = $ENV{USE_COLOR} ? 1:0;
my $envPrefix  = "COLORSTRING";
my $list       = 0;
my $lsget      = "";
my $lslist     = 0;
my $lsset      = "";
my $lscolorset = "";
my $message    = "";
my $perl       = 0;
my $print      = 0;
my $ps         = 0;
my $quiet      = 0;
my $setenv     = 0;
my $verbose    = 0;
my $warnmsg    = "";

# Define explanations for the non-file-glob cases used by LS_COLORS.
#
my %lsSpecials = (
    "bd" => "BLK                    Block device driver",
    "ca" => "CAPABILITY             File with capability",
    "cd" => "CHR                    Character device driver",
    "di" => "DIR                    Directories",
    "do" => "DOOR                   Door (eh?)",
    "ex" => "EXEC                   Executable files",
    "??" => "FILE                   Other file (normally not set)",
    "hl" => "HARDLINK               Hard link",
    "ln" => "LINK                   Symbolic link (can use 'target' color)",
    "or" => "ORPHAN                 Broken symbolic link, etc.",
    "ow" => "OTHER_WRITABLE         Other-writable, non-sticky file",
    "pi" => "FIFO                   Pipe",
    "rs" => "RESET                  Reset to default color",
    "sg" => "SETGID                 SetGID",
    "so" => "SOCK                   Socket?",
    "st" => "STICKY                 Directory with sticky bit set (+t)",
    "su" => "SETUID                 SetUID",
    "tw" => "STICKY_OTHER_WRITABLE  Sticky other writable file",
    );

my $boldPrefix    = "bold";
my $blinkPrefix   = "blink";
my $inversePrefix = "inverse";
my $ulPrefix      = "ul";
my $esc = chr(27);

my @atomicColors = ();   # Table of basic color names.
my @atomicCodes = ();    # Table of number meanings.
my %colorTable = ();     # Map from named colors to codes.
setupColors();


###############################################################################
# Process options
#
Getopt::Long::Configure ("ignore_case");
my $result = GetOptions(
    "all"               => \$all,
    "break!"            => \$break,
    "color!"            => \$color,
    "h|help|?"          => sub { system "perldoc colorstring"; exit; },
    "help-keys"         => sub {
        print "The LS_COLORS keys are (see also dircolors --print-database):\n";
        for my $sp (sort keys %lsSpecials) {
            print "    $sp\t" . $lsSpecials{$sp} . "\n";
        }
    },
    "list"              => \$list,
    "lscolorset=s"      => \$lscolorset,
    "lsget=s"           => \$lsget,
    "lslist!"           => \$lslist,
    "lsset=s"           => \$lsset,
    "m=s"               => \$message,
	"perl!"             => \$perl,
    "print"             => \$print,
    "ps"                => \$ps,
    "q|quiet!"          => \$quiet,
    "setenv|envset!"    => \$setenv,
    "v|verbose+"        => \$verbose,
    "version"           => sub {
        die "Version of $version, by Steven J. DeRose.\n";
    },
    "w=s"               => \$warnmsg,
    );

($result) || die "Bad options.\n";

my $con = my $coff = "";
if ($color) {
    $con = $esc . "[1;34m";
    $coff = $esc . "[0;39m";
}

my @lsColors = ();


###############################################################################
# Check for and do various one-off options first.
# For '-list', show all the colors
#
if ($list) {
    foreach my $c (sort keys %colorTable) {
        ($c =~ m/fg2_/) && next; # only for backward-compatibility
        print $esc . $colorTable{$c} . $c .
            $esc . $colorTable{"fg_default"} .
            $esc . $colorTable{"bg_default"} .
            ($break ? "\n":", ");
    }
    print $esc . $colorTable{"fg_default"} .
        $esc . $colorTable{"bg_default"} . "\n";
    exit;
}

if ($lslist) {
    setupDircolors();
    my %byColor = ();
    for my $lsc (@lsColors) {
        $lsc =~ m/^(.*)=(.*)/;
        my $expr = $1; my $colorCode = $2;
        if (!defined $byColor{$colorCode}) { $byColor{$colorCode} = ""; }
        $byColor{$colorCode} .= "$expr ";
    }
    print "Colors for 'ls':\n";
    for my $code (sort keys %byColor) {
        my $name = getColorName($code);
        my $con2 = (defined $colorTable{$name}) ? 
            ($esc . $colorTable{$name}) : "";
        print "$con2$code ($name):$coff $byColor{$code}\n";
    }
    exit;
}

if ($lsget ne "") {
    setupDircolors();
    my $found = 0;
    for my $lsc (@lsColors) {
        if ($lsc =~ $lsget) {
            $found++;
            (my $code = $lsc) =~ s/^.*=//;
            my $name = getColorName($code);
            my $con2 = (defined $colorTable{$name}) ? 
                ($esc . $colorTable{$name}) : "";
            print "$lsc\t$code ($con2$name$coff)\n";            
        }
    }
    ($found>0) || print "No LS_COLORS mapping found for '$lsget'.\n";
    exit;
}

# You can't actually set the relevant environment from Perl, since it's
# owned by the parent process (typically the shell). So we return a big
# string the caller can use....
#
if ($setenv) {
    my $buf = "";
    for my $c (keys %colorTable) {
        (my $seq = $colorTable{$c}) =~ s/\[//;
        $seq =~ s/m$//;
        $buf .= $envPrefix . "_$c='$seq';";
    }
    print $buf;
    exit;
}


###############################################################################
# Remaining commands require that a color be specified.
#
(scalar @ARGV) || die "No color specified.\n";

# For '-all', copy stdin coloring each line.
# Support a list of colors to alternate among.
#
if ($all) {
    my $reset = $colorTable{"fg_default"};
    my $bg_reset = $colorTable{"bg_default"};
    my @clist = ();
    while ($ARGV[0]) {
        my $colorName = shift;
        if ($colorName eq "usa")  {
            push(@clist, $colorTable{$boldPrefix . "_red"});
            push(@clist, $colorTable{$boldPrefix . "_default"});
            push(@clist, $colorTable{$boldPrefix . "_blue"});
        }
        elsif ($colorName eq "christmas")  {
            push(@clist, $colorTable{$boldPrefix . "_red"});
            push(@clist, $colorTable{$boldPrefix . "_green"});
        }
        elsif ($colorName eq "italy")  {
            push(@clist, $colorTable{$boldPrefix . "_red"});
            push(@clist, $colorTable{$boldPrefix . "_green"});
            push(@clist, $colorTable{$boldPrefix . "_default"});
        }
        elsif ($colorName eq "rainbow")  {
            push(@clist, $colorTable{$boldPrefix . "_red"});
            push(@clist, $colorTable{"fg_red"});
            push(@clist, $colorTable{$boldPrefix . "_yellow"});
            push(@clist, $colorTable{$boldPrefix . "_green"});
            push(@clist, $colorTable{$boldPrefix . "_blue"});
            push(@clist, $colorTable{$boldPrefix . "_magenta"});
            push(@clist, $colorTable{"fg_magenta"});
        }
        else {
            my $seq = $colorTable{$colorName};
            if (!$seq) { $seq = $colorTable{$boldPrefix . "_$colorName"}; }
            if (!$seq) {
            	die "colorstring: Unknown color '$colorName'.\n";
            }
            push(@clist, $seq); 
        }
    }
    #warn "Color sequence: " . join(" ",@clist) . "\n";

    my $n = 0;
    while (my $l = <>) {
        chomp($l);
        print $esc . $clist[$n] . $l
            . $esc . $reset
            . $esc . $bg_reset . "\n";
        $n++;
        if ($n >= scalar @clist) { $n = 0; }
    }
    exit;
}


###############################################################################
# Look up the color name(s) they requested.
#
my $colorName = lc(shift);
my $escString = $colorTable{$colorName};
if (!$escString) {
    $escString = $colorTable{$boldPrefix . "_$colorName"};
}
($escString) || 
    die "colorstring: Unknown color key '$colorName'. Use -h for help.\n";


###############################################################################
# Convert to the desired output syntax
#
if ($lsset ne "") {
    ($verbose) && warn "Attempting -lsset for expr '$lsset'.\n";
    my $orig = $ENV{LS_COLORS};
    (my $new = $orig) =~ s/$lsset=.*?(:|$)//;
    $new =~ s/:+$//;
    $escString =~ s/^\[//;
    $escString =~ s/m$//;
    $escString = "$new:$lsset=$escString";
}
elsif ($lscolorset ne "") {
    ($verbose) && warn "Attempting -lscolorset for color '$lscolorset'.\n";
    $escString =~ s/^\[//;
    $escString =~ s/m$//;
    my $orig = $ENV{LS_COLORS};
    my $new = $orig;
    my $n = ($new =~ s/=$lscolorset(:|$)/=$escString/g);
    ($quiet) || warn "Changing $n LS_COLOR mappings to new color.\n";
    $new =~ s/:+$//;
    $escString = $new;    
}
elsif ($ps) {
    $escString = "\\[\\e" . $escString . "\\]";
}
elsif ($perl) {
    $escString = "   \$c$colorName = $esc . \"" . $escString . "\";\n";
}
elsif ($print) {
    $escString = "   ESC " . $escString . "\n";
}
elsif ($message || $warnmsg) {
    my $s1 = $esc . $escString;
    my $s3 = $esc . $colorTable{"cancel"} . "\n";
    $escString = "$s1$message$s3\n";
    if ($warnmsg) {
        print STDERR "$s1$warnmsg$s3\n";
    }
    if (!$message) { exit; }
}
else {
    $escString = $esc . $escString;
}

# Issue it and we're done (no newline).
#
print $escString;

exit;


###############################################################################
# Create lists of color names and meanings. When setting up the codes,
# don't include the initial escape character,
# because it has to be expressed differently depending on context.
#
sub setupColors {
    # These basic color names are re-used for foreground, bold foreground,
    # and background (with different offsets).
    #
    $atomicColors[0] = "black";
    $atomicColors[1] = "red";
    $atomicColors[2] = "green";
    $atomicColors[3] = "yellow";
    $atomicColors[4] = "blue";
    $atomicColors[5] = "magenta";
    $atomicColors[6] = "cyan";
    $atomicColors[7] = "white";
    (scalar @atomicColors == 8) || die "Bad color table!\n";

    # The full set of numeric color/property codes.
    #
    $atomicCodes[ 0] = "none";
    $atomicCodes[ 1] = "bold";
    $atomicCodes[ 4] = "underscore";
    $atomicCodes[ 5] = "blink";
    $atomicCodes[ 7] = "reverse";
    $atomicCodes[ 8] = "concealed";

    $atomicCodes[30] = "fg_black";
    $atomicCodes[31] = "fg_red";
    $atomicCodes[32] = "fg_green";
    $atomicCodes[33] = "fg_yellow";
    $atomicCodes[34] = "fg_blue";
    $atomicCodes[35] = "fg_magenta";
    $atomicCodes[36] = "fg_cyan";
    $atomicCodes[37] = "fg_white";

    $atomicCodes[40] = "bg_black";
    $atomicCodes[41] = "bg_red";
    $atomicCodes[42] = "bg_green";
    $atomicCodes[43] = "bg_yellow";
    $atomicCodes[44] = "bg_blue";
    $atomicCodes[45] = "bg_magenta";
    $atomicCodes[46] = "bg_cyan";
    $atomicCodes[47] = "bg_white";

    # Make up the full tables of all known color names, combos, whatever.
    #
    # Other properties
    # ('off' ones are for xterm. Other terminals vary)
    #
    %colorTable = (
        "cancel"      => "[m",    # Better or worse with '0' included???
        "off"         => "[m",

        "bold"        => "[1m",
        "inverse"     => "[7m",
        "ul"          => "[4m",
        "blink"       => "[5m",   # cons25/vt100 only.
        "invisible"   => "[8m",   # not in some terminal emulators

        "bold_off"    => "[22m",
        "inverse_off" => "[27m",
        "ul_off"      => "[24m",
        "blink_off"   => "[25m",
        # invisible off?

        "fg_default"  => "[39m",
        $boldPrefix . "_default" => "[39m",
        "bg_default"  => "[49m",
        );
    $colorTable{"default"} = 
        ($colorTable{"fg_default"});
    # . $colorTable{"bg_default"});

    for (my $i=0; $i<scalar(@atomicColors); $i++) {
        # Foreground color
        $colorTable{"$atomicColors[$i]"} =
            "[0;" . (30+$i) . "m";
        # Bold foreground color
        $colorTable{$boldPrefix."_$atomicColors[$i]"} =
            "[1;" . (30+$i) . "m";
        $colorTable{"fg2" . "_$atomicColors[$i]"} =  # backward-compatibility
            "[1;" . (30+$i) . "m";
        # Background color (why does this set bold, too?)
        $colorTable{"bg_$atomicColors[$i]"} =
            "[1;" . (40+$i) . "m";
        # Foreground/background combos
        for (my $j=0; $j<scalar(@atomicColors); $j++) {
            ($i==$j) && next;
            $colorTable{"$atomicColors[$i]/$atomicColors[$j]"} =
                "[" . (30+$i) . ";" . (40+$j) . "m";
            $colorTable{$boldPrefix . "_" . $atomicColors[$i] .
                            "/" . $atomicColors[$j]} =
                            "[1;" . (30+$i) . ";" . (40+$j) . "m";            
        }
    } # for
} # setupColors


###############################################################################
# Take an n;m... string as used in environment variable LS_COLORS,
# and try to look up what it means. 
# Normalizes to increasing (numeric) order.
#
sub getColorName {
    my ($code) = @_;
    $code =~ s/0+(\d)/$1/g; # Strip any leading zeros
    my $code2 = join(';', sort(split(/;/,$code)));
    ($verbose) && warn
        "normalized order: '$code' -> '$code2'\n";
    $code = $code2;
    $code = "[$code" . "m";
    for my $k (keys %colorTable) {
        if ($colorTable{$k} eq $code) { return($k); }
    }
    ($verbose) && warn "Couldn't find '$code' in color table.\n";
    return("?");
}


###############################################################################
#
sub setupDircolors {
    @lsColors = split(/:/,`dircolors`);
    $lsColors[0] =~ s/LS_COLORS='//;
    pop @lsColors; # "export LS_COLORS"
    $lsColors[-1] =~ s/';//;
}


###############################################################################
#
sub showUsage {
    print "

=head1 Usage

colorstring [options] colorname

Returns the escape string needed to switch an ANSI terminal to a given color,
in various forms as needed for use in bash scripts, bash prompt-strings,
Perl code, etc. (see options). Can also colorize files, messages, and warnings.

The basic colors are (case ignored):
black, red, green, yellow, blue, magenta, cyan,
white (which is often grey), and default. 

You can specify the color name by itself to get the regular foreground (text)
color; prefix 'bold_' to get a bold (brighter) foreground color,
or prefix 'bg_' to get the background color.
Combinations are also supported, such as 'red/blue' for red text over blue
background, or 'bold_magenta/white' (but not 'red/red', etc).

Can also interact with the 'ls' color setup kept in environment variable
'LS_COLORS' (much easier to examineand tweak it with this, than with
'dircolors').


=head1 Options

=over

=item * B<-all>      Show all of stdin in the specified color
(with I<-all>, multiple 'colorname's will alternate, or you
can say 'usa', 'christmas', 'italy', or 'rainbow').

=item * B<-break>    With I<-list>, put each example on a separate line.

=item * B<-color>    Use color in our own output.

=item * B<-envPrefix> I<s>   Specify what to prefix to color names to
make the environment variable names generated by I<-setenv> (which see).

=item * B<-help-keys>   Show the reserve LS_COLORS names for setting file
colors by file types rather than filename-expressions (for example,
'ex' is used to set the color for executable files).

=item * B<-list>     Show all known colors, properties, and combinations
(well, except invisible, which you won't see).

=item * B<-lsget> I<fileExpr>   Figure out what color 'ls' will use to
display a given file's name. If you give an expression such as '*.html' that's
ok, too.

=item * B<-lscolorset>  I<oldcolor>  Replace all the LS_COLOR mappings 
for a given color, with a new color (see I<-lslist> option for a description
of a typical default mapping).

=item * B<-lslist>  List how 'ls' colors are set up, organized by color
(see also the I<dircolors> command). In general, the default settings are (at
least on my system):

=over

=item Red: Archives (tar, jar, zip, etc.)

=item Green: Executables

=item Blue: Directories

=item Magenta: Picture and video (jpeg, mov, mp4, etc.),
as well as some special files (sockets and doors (eg?)).

=item Cyan: Audio files (mp3, midi, flac, wav, etc.

=item Bold Cyan: Symbolic links.

=item Black on Red: Capability files.

=item Black on Yellow: SetGID files.

=item White on Red: SetUID files.

=item White on Blue: Directory with sticky bit set (+t), and hard links.

=item Black on Green: Other sticky writable files.

=item Blue on Green: Other writable files.

=item Yellow on Black: Pipes.

=item Bold Yellow on black: Block and character device files.

=item Bold Red on Black: Orphan files (such as broken symbolic links).

=item

=back


=item * B<-lsset> I<fileExpr> Return a modified 'ls' color setup
(which the caller should then store in environment variable LS_COLORS),
that assigns a
named color to files that match the given fileExpr (the color name will
be translated to a numeric code). The I<fileExpr> can be a glob (usually of 
the form '*.ext' to distinguish files by their extensions), or a 2-letter
reserved code to distinguish files by some property (such as 'ex' for
executable files); see I<-help-keys> for information on those codes.
If there is already an assignment for exactly
the given I<fileExpr>, it will be replaced. For example:

    colorstring -lsset '*.html' magenta

=item * B<-m 'msg'>  Send this message to stdout in the specified color.

=item * B<-w 'msg'>  Send this message to stderr in the specified color.

=item * B<-perl>     Return Perl code to generate and assign the color string.

=item * B<-print>    Print out the color string requested.

=item * B<-ps> Return color command with '\\e' to put in a Bash prompt string.

=item * B<-q>        Suppress most messages.

=item * B<-setenv>   Returns a (probably long) string you can
use to set a lot of environment variables, to hold the required escapes
to set given colors. They variable names are 'COLORSTRING_' plus the names
you can give to this script (but you can change the prefix using I<-envPrefix>.

=item * B<-v>        Add more messages.

=item * B<-version>  Display version information and exit.

=back


=head1 Known bugs and limitations

Not all combinations of colors and properties area available. For example, you
can't set more than one of blink, bold, inverse, hidden, and ul (underline)
at once, or set foreground and background to the same color.

The color-name lookup used with the -lslist option can't handle 
simultaneous property, foreground, and background settings unless the
environment variable
LS_COLORS specifies them in increasing numeric order (which seems typical).
For now, such entries unmatched entries print the color name as '?'.

For I<TERM=xterm-256color>, you can have many more colors, apparently accessible
with the codes '38;5;n' for n from 0 to at least 231. These are not yet
supported.


=head1 Related commands:

Several *nix commands have a I<--color=auto> option, including ls and grep.
'dircolors' can be used to set up the colors used by 'ls'.
'info terminfo' has more information about terminal colors.
'grc' and 'logtool' can colorize log files.


=head1 Ownership

This work by Steven J. DeRose is licensed under a Creative Commons 
Attribution-Share Alike 3.0 Unported License. For further information on
this license, see http://creativecommons.org/licenses/by-sa/3.0/.

The author's present email is sderose at acm.org.

For the most recent version, see http://www.derose.net/steve/utilities/.

=cut

";
}