File Coverage

blib/lib/Term/ANSIColor/Concise.pm

Criterion	Covered	Total	%
statement	153	177	86.4
branch	66	96	68.7
condition	25	33	75.7
subroutine	26	27	96.3
pod	6	13	46.1
total	276	346	79.7

package Term::ANSIColor::Concise;

our $VERSION = "2.04";

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
    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 Term::ANSIColor::Concise::Util;
use List::Util qw(min max first);

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};

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 rgbhex {
    my $rgb = shift =~ s/^#//r;
    my $len = length $rgb;
    croak "$rgb: Invalid RGB value." if $len == 0 || $len % 3;
    $len /= 3;
    my $max = (2 ** ($len * 4)) - 1;
    my @rgb24 = map { hex($_) * 255 / $max } $rgb =~ /[0-9a-z]{$len}/gi or die;
    if ($RGB24) {
	return (2, @rgb24);
    } else {
	return (5, rgb24_number @rgb24);
    }
}

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
    );

my $colorspec_re = qr{
      (? /)			 # /
    | (? \^)			 # ^
    | (?	 [0-9a-f]{6}		 # 24bit hex
	     | \#[0-9a-f]{3,} )		 # generic hex
    | (?  \(\d+,\d+,\d+\) )	 # 24bit decimal
    | (?	 [0-5][0-5][0-5]	 # 216 (6x6x6) colors
	     | L(?:[01][0-9]|[2][0-5]) ) # 24 gray levels + B/W
    | (?  [KRGYBMCW] )		 # 16 colors
    | (? ~?[;NZDPIUFQSHX] )	 # effects
    | (?  { (?[A-Z]+)	 # other CSI
		 (? \( )?		 # optional (
		 (?[\d,;]*)	 # 0;1;2
		 (?() \) )		 # closing )
	       }
	     | (?[E]) )	 # abbreviation
    | < (? \w+ ) >		 #
}xi;

sub ansi_numbers {
    local $_ = shift // '';
    my @numbers;
    my $toggle = ToggleValue->new(value => 10);

    while (m{\G (?: $colorspec_re | (? .+ ) ) }xig) {
	if ($+{toggle}) {
	    $toggle->toggle;
	}
	elsif ($+{reset}) {
	    $toggle->reset;
	}
	elsif ($+{hex}) {
	    push @numbers, 38 + $toggle->value, rgbhex($+{hex});
	}
	elsif (my $rgb = $+{rgb}) {
	    my @rgb = $rgb =~ /(\d+)/g;
	    croak "Unexpected value: $rgb." if grep { $_ > 255 } @rgb;
	    my $hex = sprintf "%02X%02X%02X", @rgb;
	    push @numbers, 38 + $toggle->value, rgbhex($hex);
	}
	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 ($+{name}) {
	    state $colornames = do {
		require Graphics::ColorNames;
		Graphics::ColorNames->new;
	    };
	    if (my $rgb = $colornames->hex($+{name})) {
		push @numbers, 38 + $toggle->value, rgbhex($rgb);
	    } else {
		croak "Unknown color name: $+{name}.";
	    }
	}
	elsif (my $err = $+{err}) {
	    croak "Color spec error: \"$err\" in \"$_\"."
	}
	else {
	    croak "$_: Something strange.";
	}
    } continue {
	if ($SPLIT_ANSI) {
	    my $index = first { not ref $numbers[$_] } 0 .. $#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 (0 cursor position)
    SCP => 's',	 # Save Cursor Position
    RCP => 'u',	 # Restore Cursor Position
    );

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
    );

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

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 @_;
    join '', @result;
}

use Scalar::Util qw(blessed);

sub apply_color {
    my($cache, $color, $text) = @_;
    if (ref $color eq 'CODE') {
	return $color->($text);
    }
    elsif (blessed $color and $color->can('call')) {
	return $color->call for $text;
    }
    elsif ($NO_COLOR) {
        return $text;
    }
    else {
	my($s, $e, $el) = @{ $cache->{$color} //= [ ansi_pair($color) ] };
	state $reset = qr{ \e\[[0;]*m (?: \e\[[0;]*[Km] )* }x;
	if ($el) {
	    $text =~ s/(\A|(?<=[\r\n])|$reset)\K(?[^\e\r\n]+|(?
	} else {
	    $text =~ s/(\A|(?<=[\r\n])|$reset)\K(?[^\e\r\n]+)/${s}$+{x}${e}/mg;
	}
	return $text;
    }
}

1;

__END__