File Coverage

blib/lib/Term/Chrome.pm

Criterion	Covered	Total	%
statement	89	92	96.7
branch	50	68	73.5
condition	14	18	77.7
subroutine	22	22	100.0
pod	3	5	60.0
total	178	205	86.8

use strict;
use warnings;

package Term::Chrome;
# ABSTRACT: DSL for colors and other terminal chrome
our $VERSION = '2.01';

# Pre-declare packages
{
    package # no index: private package
        Term::Chrome::Color;
}


use Exporter 5.57 'import';  # perl 5.8.3
# @EXPORT is defined at the end

use Carp ();
use Scalar::Util ();
our @CARP_NOT = qw< Term::Chrome::Color >;

# Private constructor for Term::Chrome objects. Lexical, so cross-packages.
# Arguments:
# - class name
# - foreground color
# - background color
# - flags list
my $new = sub
{
    my ($class, @self) = @_;

    my $fg = $self[0];
    Carp::croak "invalid fg color $fg"
        if defined($fg) && ($fg < 0 || $fg > 255);
    my $bg = $self[1];
    Carp::croak "invalid bg color $bg"
        if defined($bg) && ($bg < 0 || $bg > 255);
    # TODO check flags

    bless \@self, $class
};


# Cache for color objects
my %COLOR_CACHE;

sub color ($)
{
    my $color = shift;
    die "invalid color" if ref $color;
    my $c = chr $color;
    # We can not use '$COLOR_CACHE{$c} ||= ...' because this requires overloading
    # We can not use 'no overloading' because this requires perl 5.10
    exists $COLOR_CACHE{$c}
    ?  $COLOR_CACHE{$c}
    : ($COLOR_CACHE{$c} = Term::Chrome::Color->$new($color, undef))
}


use overload
    '""' => 'term',
    '+'  => '_plus',
    '${}' => '_deref',
    '&{}' => '_chromizer',
    '.'   => '_concat',
    '!'   => '_reverse',
    'bool' => sub () { 1 },
    fallback => 0,
;

sub term
{
    my $self = shift;
    my ($fg, $bg) = @{$self}[0, 1];
    my $r = join(';', @{$self}[2 .. $#$self]);
    if (defined($fg) || defined($bg)) {
        $r .= ';' if @$self > 2;
        if (defined $fg) {
            # LeoNerd says that this should be ----------> "38:5:$fg"
            # according to the spec but gnome-terminal doesn't support that
            $r .= $fg < 8 ? (30+$fg) : $fg < 16 ? "9$fg" : "38;5;$fg";
            $r .= ';' if defined $bg;
        }
        #                                      -------> "48:5:$bg"
        $r .= $bg < 8 ? (40+$bg) : $bg < 16 ? "10$bg" : "48;5;$bg" if defined $bg;
    } else {
        return '' unless @$self > 2
    }
    "\e[${r}m"
}


sub _plus
{
    my ($self, $other, $swap) = @_;

    return $self unless defined $other;

    die 'invalid value for +' unless $other->isa(__PACKAGE__);

    my @new = @$self;
    $new[0] = $other->[0] if defined $other->[0];
    $new[1] = $other->[1] if defined $other->[1];
    push @new, @{$other}[2 .. $#$other];

    bless \@new
}

my %reverse = (
    # Unfortunately there isn't a perfect mapping
    # Reference:
    # https://www.ecma-international.org/publications/files/ECMA-ST/Ecma-048.pdf page 75
    1 => 22,
    2 => 22,
    3 => 23,
    4 => 24,   # Underlined
    5 => 25,
    6 => 25,
    7 => 27,
    8 => 28,
    9 => 29,
    21 => 24,  # Double underline

    22 => 1,
    23 => 3,
    24 => 4,
    25 => 5,
    27 => 7,
    28 => 8,
    29 => 9,
);

sub _reverse
{
    my $self = shift;
    my @new = (undef, undef);
    push @new, 39 if $self->[0]; # ResetFg
    push @new, 49 if $self->[1]; # ResetBg
    # Reset/ResetFlags/ResetFg/ResetBg are removed
    # Other flags are reversed
    push @new, map { (!$_ || $_ > 30 || !exists $reverse{$_}) ? () : $reverse{$_} } @{$self}[2..$#$self];
    bless \@new, 'Term::Chrome::Flag'
}

sub _deref
{
    \("$_[0]")
}

sub _concat
{
    $_[2] ? $_[1].$_[0]->term
          : $_[0]->term.$_[1]
}


sub _chromizer
{
    my $self = shift;
    my $begin = $self->term;
    my $end = $self->_reverse->term;
    sub {
        unless (defined $_[0]) {
            Carp::carp "missing argument in Term::Chrome chromizer";
            return
        }
        $begin . $_[0] . $end
    }
}

sub fg
{
    my $c = $_[0]->[0];
    defined($c) ? color($c) : undef
}

sub bg
{
    my $c = $_[0]->[1];
    defined($c) ? color($c) : undef
}

sub flags
{
    my $self = shift;
    return undef unless @$self > 2;
    __PACKAGE__->$new(undef, undef, @{$self}[2..$#$self])
}

package # no index: private package
    Term::Chrome::Color;

our @ISA = qw< Term::Chrome >;

use overload
    '/'   => '_over',
    # Even if overloading is set in the super class, we have to repeat it for old perls
    (
        $^V ge v5.18.0
        ? ()
        : (
            '""'  => \&Term::Chrome::term,
            '+'   => \&Term::Chrome::_plus,
            '${}' => \&Term::Chrome::_deref,
            '.'   => \&Term::Chrome::_concat,
            '!'   => \&Term::Chrome::_reverse,
            'bool' => sub () { 1 },
        )
    ),
    fallback => 0,
;

sub _over
{
    die 'invalid bg color for /' unless ref($_[1]) eq __PACKAGE__;
    Term::Chrome->$new($_[0]->[0], $_[1]->[0])
}

package # no index: private package
    Term::Chrome::Flag;

our @ISA = qw< Term::Chrome >;

use overload
    '+'   => '_plus',
    '!'   => '_reverse',
    # Even if overloading is set in the super class, we have to repeat it for old perls
    (
        $^V ge v5.18.0
        ? ()
        : (
            '""'  => \&Term::Chrome::term,
            '${}' => \&Term::Chrome::_deref,
            '.'   => \&Term::Chrome::_concat,
            'bool' => sub () { 1 },
        )
    ),
    fallback => 0,
;

sub _reverse
{
    my $self = shift;
    bless [
        undef, undef,
        # Reset/ResetFlags/ResetFg/ResetBg are removed
        map { (!$_ || $_ > 30 || !exists $reverse{$_}) ? () : $reverse{$_} } @{$self}[2..$#$self]
    ]
}

sub _plus
{
    my ($self, $other, $swap) = @_;

    return $self unless defined $other;

    Carp::croak(q{Can't combine Term::Chrome with }.$other)
        unless Scalar::Util::blessed $other;

    if ($other->isa(__PACKAGE__)) {
        # Reset
        return $other if !$other->[2];
        # ResetFlags
        return $other if $#$other == 8 || ($self->[2] && $self->[2] < 30 && $other->[2] == $reverse{$self->[2]});
        # Concat flags
        __PACKAGE__->$new(@$self, @{$other}[2..$#$other])
    } elsif ($other->isa(Term::Chrome::)) {
        $other->_plus($self, '')
    } else {
        Carp::croak(q{Can't combine Term::Chrome with }.ref($other))
    }
}


package
    Term::Chrome;

# Build the constants and the @EXPORT list
#
# This block must be after "use overload" (for both Term::Chrome
# and Term::Chrome::Color) because overload must be set before blessing
# due to a bug in perl < 5.18
# (according to a comment in Types::Serialiser source)

my $mk_flag = sub { Term::Chrome::Flag->$new(undef, undef, @_) };

my %const = (
    Reset      => $mk_flag->(''),
    ResetFg    => $mk_flag->(39),
    ResetBg    => $mk_flag->(49),
    ResetFlags => $mk_flag->(22, 23, 24, 25, 27, 28),
    Standout   => $mk_flag->(7),
    Underline  => $mk_flag->(4),
    Reverse    => $mk_flag->(7),
    Blink      => $mk_flag->(5),
    Bold       => $mk_flag->(1),

    Black      => color 0,
    Red        => color 1,
    Green      => color 2,
    Yellow     => color 3,
    Blue       => color 4,
    Magenta    => color 5,
    Cyan       => color 6,
    White      => color 7,

    # Larry Wall's favorite color
    # The true 'chartreuse' color from X11 colors is #7fff00
    # The xterm-256 color #118 is near: #87ff00
    Chartreuse => color 118,
);

our @EXPORT = ('color', keys %const);

# In 17fd029f we avoided to use constant.pm on perl < 5.16
# This does not seem necessary anymore.
require constant;
constant->import(\%const);

1;
# vim:set et ts=8 sw=4 sts=4: