File Coverage

blib/lib/Term/ANSIColor/Concise.pm

Criterion	Covered	Total	%
statement	178	212	83.9
branch	78	116	67.2
condition	26	35	74.2
subroutine	31	33	93.9
pod	8	17	47.0
total	321	413	77.7

# -*- indent-tabs-mode: nil -*-

package Term::ANSIColor::Concise;

our $VERSION = "3.02";

use v5.14;
use warnings;
use utf8;

use Exporter 'import';
our @EXPORT      = qw();
our @EXPORT_OK   = qw(
    ansi_color ansi_color_24 ansi_code ansi_pair csi_code csi_report
    cached_ansi_color
    map_256_to_6 map_to_256
    );
our %EXPORT_TAGS = (all => [ @EXPORT_OK ]);

use Carp;
use Data::Dumper;
$Data::Dumper::Sortkeys = 1;
use List::Util qw(min max first);

use Term::ANSIColor::Concise::Util;

use aliased;
my $Color = alias 'Term::ANSIColor::Concise::' . ($ENV{TAC_COLOR_PACKAGE} || 'ColorObject');
sub Color { $Color }

our $NO_NO_COLOR   //= $ENV{ANSICOLOR_NO_NO_COLOR};
our $NO_COLOR      //= !$NO_NO_COLOR && defined $ENV{NO_COLOR};
our $RGB24         //= $ENV{ANSICOLOR_RGB24} // ($ENV{COLORTERM}//'' eq 'truecolor');
our $LINEAR_256    //= $ENV{ANSICOLOR_LINEAR_256};
our $LINEAR_GRAY   //= $ENV{ANSICOLOR_LINEAR_GRAY};
our $NO_RESET_EL   //= $ENV{ANSICOLOR_NO_RESET_EL};
our $SPLIT_ANSI    //= $ENV{ANSICOLOR_SPLIT_ANSI};
our $NO_CUMULATIVE //= $ENV{ANSICOLOR_NO_CUMULATIVE};

my @nonlinear = do {
    map { ( $_->[0] ) x $_->[1] } (
        [ 0, 75 ], #   0 ..  74
        [ 1, 40 ], #  75 .. 114
        [ 2, 40 ], # 115 .. 154
        [ 3, 40 ], # 155 .. 194
        [ 4, 40 ], # 195 .. 234
        [ 5, 21 ], # 235 .. 255
    );
};

sub map_256_to_6 {
    use integer;
    my $i = shift;
    if ($LINEAR_256) {
        5 * $i / 255;
    } else {
        # ( $i - 35 ) / 40;
        $nonlinear[$i];
    }
}

sub map_to_256 {
    my($base, $i) = @_;
    if    ($i == 0)     { 0 }
    elsif ($base ==  6) { $i * 40 + 55 }
    elsif ($base == 12) { $i * 20 + 35 }
    elsif ($base == 24) { $i * 10 + 25 }
    else  { die }
}

sub ansi256_number {
    my $code = shift;
    my($r, $g, $b, $gray);
    if ($code =~ /^([0-5])([0-5])([0-5])$/) {
        ($r, $g, $b) = ($1, $2, $3);
    }
    elsif (my($n) = $code =~ /^L(\d+)/i) {
        $n > 25 and croak "Color spec error: $code.";
        if ($n == 0 or $n == 25) {
            $r = $g = $b = $n / 5;
        } else {
            $gray = $n - 1;
        }
    }
    else {
        croak "Color spec error: $code.";
    }
    defined $gray ? ($gray + 232) : ($r*36 + $g*6 + $b + 16);
}

sub rgb24_number {
    use integer;
    my($rx, $gx, $bx) = @_;
    my($r, $g, $b, $gray);
    if ($rx != 0 and $rx != 255 and $rx == $gx and $rx == $bx) {
        if ($LINEAR_GRAY) {
            ##
            ## Divide area into 25 segments, and map to BLACK and 24 GRAYS
            ##
            $gray = $rx * 25 / 255 - 1;
            if ($gray < 0) {
                $r = $g = $b = 0;
                $gray = undef;
            }
        } else {
            ## map to 8, 18, 28, ... 238
            $gray = min(23, ($rx - 3) / 10);
        }
    } else {
        ($r, $g, $b) = map { map_256_to_6 $_ } $rx, $gx, $bx;
    }
    defined $gray ? ($gray + 232) : ($r*36 + $g*6 + $b + 16);
}

sub rgb24 {
    my $rgb = shift;
    $rgb  =~ s/^#//;
    my $len = length $rgb;
    croak "$rgb: Invalid RGB value." if $len == 0 || $len % 3;
    $len /= 3;
    my $max = (2 ** ($len * 4)) - 1;
    map { hex($_) * 255 / $max } $rgb =~ /[0-9a-z]{$len}/gi;
}

sub rgbseq {
    my($mod, @rgb) = @_;
    if ($mod) {
        @rgb  = transform($mod, @rgb);
    }
    if ($RGB24) {
        return (2, @rgb);
    } else {
        return (5, rgb24_number @rgb);
    }
}

my %numbers = (
    ';' => undef,       # ; : NOP
    N   => undef,       # N : None (NOP)
    E => 'EL',          # E : Erase Line
    Z => 0,             # Z : Zero (Reset)
    D => 1,             # D : Double Strike (Bold)
    P => 2,             # P : Pale (Dark)
    I => 3,             # I : Italic
    U => 4,             # U : Underline
    F => 5,             # F : Flash (Blink: Slow)
    Q => 6,             # Q : Quick (Blink: Rapid)
    S => 7,             # S : Stand out (Reverse)
    H => 8,             # H : Hide (Concealed)
    X => 9,             # X : Cross out
    K => 30, k => 90,   # K : Kuro (Black)
    R => 31, r => 91,   # R : Red
    G => 32, g => 92,   # G : Green
    Y => 33, y => 93,   # Y : Yellow
    B => 34, b => 94,   # B : Blue
    M => 35, m => 95,   # M : Magenta
    C => 36, c => 96,   # C : Cyan
    W => 37, w => 97,   # W : White
    );

use Term::ANSIColor::Concise::Transform qw(transform $mod_re);

my $colorspec_re = qr{
    (?
      (? /)                      # /
    | (? \^)                      # ^
    # Fullcolor with modifier
    | ((?
         (?     [0-9a-f]{6}         ## RGB 24bit hex
                | \#([0-9a-f]{3})+ )     ## RGB generic hex
       | (?(rgb)? (?&TRIPLET) )     ## RGB 24bit decimal (0-255, 0-255, 0-255)
       | (? hsl   (?&TRIPLET) )     ## HSL   (0-360, 0-100, 0-100)
       | (? lch   (?&TRIPLET) )     ## LCHab (0-100, 0~130, 0-360)
       | (? lab   (?&TRIPLET) )     ## Lab   (0-100, -128-127, -128-127)
       | < (? \w+ ) >              ##
       )
       (? $mod_re* )                ## color modifiers
      )
    # Basic 256/16 colors
    | (?   [0-5][0-5][0-5]         # 216 (6x6x6) colors
             | L([01][0-9]|[2][0-5]) )   # 24 gray levels + B/W
    | (?  [KRGYBMCW] )              # 16 colors
    # Effects and controls
    | (?   ~[DPIUFQSHX]            # ~effect
             | [;NZDPIUFQSHX] )          # effect
    | (?  \{ (?[A-Z]+)    # other CSI
                  (?   \( )?          # optional (
                  (?[\d,;]*)  # 0;1;2
                  (?() \) )           # closing )
               \}
             | (?[E]) )        # abbreviation
    )
    (?(DEFINE)
        (?   -? \d+ (\.\d+)? )
        (? \( (?&DIGIT), (?&DIGIT), (?&DIGIT) \) )
    )
}xi;

sub ansi_numbers {
    local $_ = shift // '';
    my @numbers;
    my $toggle = ToggleValue->new(value => 10);
    my %F;
    my $rgb_numbers = sub { 38 + $toggle->value, rgbseq($F{mod}, @_) };

    while (m{\G (?: $colorspec_re | (? .+ ) ) }xig) {
        %F = %+;
        if ($+{toggle}) {
            $toggle->toggle;
        }
        elsif ($+{reset}) {
            $toggle->reset;
        }
        elsif ($+{hex}) {
            my @rgb = rgb24($+{hex});
            push @numbers, $rgb_numbers->(@rgb);
        }
        elsif (my $dec = $+{dec}) {
            my @rgb = $dec =~ /\d+/g;
            croak "Unexpected value: $dec." if grep { $_ > 255 } @rgb;
            push @numbers, $rgb_numbers->(@rgb);
        }
        elsif (my $hsl = $+{hsl}) {
            Color->can('hsl') or die "HSL format is not supported.\n";
            my @hsl = $hsl =~ /\d+/g;
            my @rgb = Color->hsl(@hsl)->rgb;
            push @numbers, $rgb_numbers->(@rgb);
        }
        elsif (my $lch = $+{lch}) {
            Color->can('lch') or die "LCHab format is not supported.\n";
            my($L, $C, $H) = $lch =~ /-?\d+/g;
            my @rgb = Color->lch($L, $C, $H)->rgb;
            push @numbers, $rgb_numbers->(@rgb);
        }
        elsif (my $lab = $+{lab}) {
            Color->can('lab') or die "Lab format is not supported.\n";
            my($L, $a, $b) = $lab =~ /-?\d+/g;
            my @rgb = Color->lab($L, $a, $b)->rgb;
            push @numbers, $rgb_numbers->(@rgb);
        }
        elsif ($+{name}) {
            require Graphics::ColorNames;
            state $colornames = Graphics::ColorNames->new;
            if (my @rgb = $colornames->rgb($+{name})) {
                push @numbers, $rgb_numbers->(@rgb);
            } else {
                croak "Unknown color name: $+{name}.";
            }
        }
        elsif ($+{c256}) {
            push @numbers, 38 + $toggle->value, 5, ansi256_number $+{c256};
        }
        elsif ($+{c16}) {
            push @numbers, $numbers{$+{c16}} + $toggle->value;
        }
        elsif ($+{efct}) {
            my $efct = uc $+{efct};
            my $offset = $efct =~ s/^~// ? 20 : 0;
            if (defined (my $n = $numbers{$efct})) {
                push @numbers, $n + $offset;
            }
        }
        elsif ($+{csi}) {
            push @numbers, do {
                if ($+{csi_abbr}) {
                    [ $numbers{uc $+{csi_abbr}} ];
                } else {
                    [ uc $+{csi_name}, $+{csi_param} =~ /\d+/g ];
                }
            };
        }
        elsif (my $err = $+{err}) {
            croak "Color spec error: \"$err\" in \"$_\"."
        }
        else {
            croak "$_: Something strange.";
        }
    } continue {
        if ($SPLIT_ANSI) {
            my $index = first { not ref $numbers[$_] } keys @numbers;
            if (defined $index) {
                my @sgr = splice @numbers, $index;
                push @numbers, [ 'SGR', @sgr ];
            }
        }
    }
    @numbers;
}

use constant {
    CSI   => "\e[",     # Control Sequence Introducer
    RESET => "\e[m",    # SGR Reset
    EL    => "\e[K",    # Erase Line
};

my %csi_terminator = (
    ICH => '@',  # Insert Character
    CUU => 'A',  # Cursor up
    CUD => 'B',  # Cursor Down
    CUF => 'C',  # Cursor Forward
    CUB => 'D',  # Cursor Back
    CNL => 'E',  # Cursor Next Line
    CPL => 'F',  # Cursor Previous line
    CHA => 'G',  # Cursor Horizontal Absolute
    CUP => 'H',  # Cursor Position
    ED  => 'J',  # Erase in Display (0 after, 1 before, 2 entire, 3 w/buffer)
    EL  => 'K',  # Erase in Line (0 after, 1 before, 2 entire)
    IL  => 'L',  # Insert Line
    DL  => 'M',  # Delete Line
    DCH => 'P',  # Delete Character
    SU  => 'S',  # Scroll Up
    SD  => 'T',  # Scroll Down
    ECH => 'X',  # Erase Character
    VPA => 'd',  # Vertical Position Absolute
    VPR => 'e',  # Vertical Position Relative
    HVP => 'f',  # Horizontal Vertical Position
    SGR => 'm',  # Select Graphic Rendition
    DSR => 'n',  # Device Status Report (6 cursor position)
    SCP => 's',  # Save Cursor Position
    RCP => 'u',  # Restore Cursor Position

    # Non-standard
    CPR  => 'R', # Cursor Position Report – VT100 to Host
    STBM => 'r', # Set Top and Bottom Margins
    SLRM => 's', # Set Left Right Margins
    );

my %other_sequence = (
    CSI => "\e[",         # Control Sequence Introducer
    OSC => "\e]",         # Operating System Command
    RIS => "\ec",         # Reset to Initial State
    DECSC => "\e7",       # DEC Save Cursor
    DECRC => "\e8",       # DEC Restore Cursor
    DECEC => "\e[?25h",   # DEC Enable Cursor
    DECDC => "\e[?25l",   # DEC Disable Cursor
    DECELRM => "\e[?69h", # DEC Enable Left Right Margin Mode
    DECDLRM => "\e[?69l", # DEC Disable Left Right Margin Mode
    );

sub csi_code {
    my $name = shift;
    if (my $seq = $other_sequence{$name}) {
        return $seq;
    }
    my $c = $csi_terminator{$name} or die "$name: Unknown ANSI name.\n";
    if ($name eq 'SGR' and @_ == 1 and $_[0] == 0) {
        @_ = ();
    }
    CSI . join(';', @_) . $c;
}

sub csi_report {
    my($name, $n, $report) = @_;
    my $c = $csi_terminator{$name} or die "$name: Unknown ANSI name.\n";
    my $format = quotemeta(CSI) . join(';', ('(\d+)') x $n) . $c;
    $report =~ /$format/;
}

sub ansi_code {
    my $spec = shift;
    my @numbers = ansi_numbers $spec;
    my @code;
    while (@numbers) {
        my $item = shift @numbers;
        if (ref($item) eq 'ARRAY') {
            push @code, csi_code @$item;
        } else {
            my @sgr = ($item);
            while (@numbers and not ref $numbers[0]) {
                push @sgr, shift @numbers;
            }
            push @code, csi_code 'SGR', @sgr;
        }
    }
    join '', @code;
}

sub ansi_pair {
    my $spec = shift;
    my $el = 0;
    my $start = ansi_code $spec // '';
    my $end = $start eq '' ? '' : do {
        if ($start =~ /(.*)(\e\[[0;]*K)(.*)/) {
            $el = 1;
            if ($3) {
                $1 . EL . RESET;
            } else {
                EL . RESET;
            }
        } else {
            if ($NO_RESET_EL) {
                RESET;
            } else {
                RESET . EL;
            }
        }
    };
    ($start, $end, $el);
}

sub ansi_color {
    cached_ansi_color(state $cache = {}, @_);
}

sub ansi_color_24 {
    local $RGB24 = 1;
    cached_ansi_color(state $cache = {}, @_);
}

sub cached_ansi_color {
    my $cache = shift;
    my @result;
    while (@_ >= 2) {
        my($spec, $text) = splice @_, 0, 2;
        for my $color (ref $spec eq 'ARRAY' ? @$spec : $spec) {
            $text = apply_color($cache, $color, $text);
        }
        push @result, $text;
    }
    croak "Wrong number of parameters." if @_;
    wantarray ? @result : join('', @result);
}

sub IsEOL {
    <<"END";
0000\t0000
000A\t000D
2028\t2029
END
}

use Scalar::Util qw(blessed);

sub apply_color {
    (my($cache, $color), local($_)) = @_;
    if (ref $color eq 'CODE') {
        return $color->($_);
    }
    elsif (blessed $color and $color->can('call')) {
        return $color->call;
    }
    elsif ($NO_COLOR) {
        return $_;
    }
    elsif ($NO_CUMULATIVE) { # old behavior
        my($s, $e, $el) = @{ $cache->{$color} //= [ ansi_pair($color) ] };
        state $reset = qr{ \e\[[0;]*m (?: \e\[[0;]*[Km] )* }x;
        if ($el) {
            s/(\A|(?<=\p{IsEOL})|$reset)\K(?[^\e\p{IsEOL}]+|(?
        } else {
            s/(\A|(?<=\p{IsEOL})|$reset)\K(?[^\e\p{IsEOL}]+)/${s}$+{x}${e}/g;
        }
        return $_;
    }
    else {
        my($s, $e, $el) = @{ $cache->{$color} //= [ ansi_pair($color) ] };
        state $reset = qr{ \e\[[0;]*m (?: \e\[[0;]*[Km] )* }x;
        if ($el) {
            s/(?:\A|(?:\p{IsEOL}(?!\z)|$reset++))\K/${s}/g;
            s/(\p{IsEOL}|(?
        } else {
            s/(?:\A|\p{IsEOL}|$reset++)(?=.)\K/${s}/g;
            s/(?
        }
        return $_;
    }
}

1;

__END__