File Coverage

blib/lib/Term/ANSIColor/Print.pm

Criterion	Covered	Total	%
statement	53	71	74.6
branch	17	34	50.0
condition			n/a
subroutine	7	8	87.5
pod	0	1	0.0
total	77	114	67.5

package Term::ANSIColor::Print;

$VERSION = '0.08';

use strict;
use warnings;
use Carp;
use vars qw( $AUTOLOAD );

my ( $COLOR_REGEX, $SUB_COLOR_REGEX, %ANSI_CODE_FOR );
{
    use Readonly;

    Readonly $COLOR_REGEX => qr{
        \A ( . \[\d+m .*? . \[0m ) \z
    }xms;

    Readonly $SUB_COLOR_REGEX => qr{
        \A ( .+? )
           ( . \[\d+m .* . \[0m )
           (?! . \[0m )
           ( .+ ) \z
    }xms;

    # http://en.wikipedia.org/wiki/ANSI_escape_code
    Readonly %ANSI_CODE_FOR => (
        black     => 30,
        blue      => 94,
        bold      => 1,
        cyan      => 96,
        green     => 92,
        grey      => 37,
        magenta   => 95,
        red       => 91,
        white     => 97,
        yellow    => 93,
        conceal   => 8,
        faint     => 2,
        italic    => 3,
        negative  => 7,
        positive  => 27,
        reset     => 0,
        reveal    => 28,
        underline => 4,
        normal    => {
            foreground => 39,
            background => 99,
        },
        blink     => {
            slow  => 5,
            rapid => 6,
        },
        light => {
            black => 90,
        },
        double => {
            underline => 21,
        },
        normal => {
            intensity => 22,
        },
        no => {
            underline => 24,
            blink     => 25,
        },
        dark => {
            red     => 31,
            green   => 32,
            yellow  => 33,
            blue    => 34,
            magenta => 35,
            cyan    => 36,
        },
        on => {
            red     => 101,
            green   => 102,
            yellow  => 103,
            blue    => 104,
            magenta => 105,
            cyan    => 106,
            white   => 107,
            normal  => 109,
            black   => 40,
            grey    => 47,
            light   => {
                black => 100,
            },
            dark => {
                red     => 41,
                green   => 42,
                yellow  => 43,
                blue    => 44,
                magenta => 45,
                cyan    => 46,
                normal  => 49,
            },
        },
    );
}

sub new {
    my $class = shift;
    my %args  = @_;

    my $self = bless {
        output => defined $args{output} ? $args{output} : \*STDOUT,
        eol    => defined $args{eol}    ? $args{eol}    : "\n",
        pad    => defined $args{pad}    ? $args{pad}    : "",
        alias  => defined $args{alias}  ? $args{alias}  : {},
    }, $class;

    delete @args{qw( output eol pad alias )};

    for my $arg ( keys %args ) {
        warn "unrecognized argument $arg";
    }

    return $self;
}

sub AUTOLOAD {
    my ($self,@strings) = @_;

    my $method = ( split /::/, $AUTOLOAD )[-1];

    ALIAS:
    while ( my ( $alias, $token ) = each %{ $self->{alias} } ) {

        if ( $token !~ m{\A \w+ \z}xms ) {

            carp "alias '$alias': token '$token' is invalid\n";
            next ALIAS;
        }

        if ( $alias !~ m{\A \w+ \z}xms ) {

            carp "alias key '$alias' is a invalid\n";
            next ALIAS;
        }

        $method =~ s{$alias}{$token}g;
    }

    my $eol = $method =~ s{ _+ \z}{}xms ? "" : $self->{eol};

    my @tokens = split /_/, $method;

    my $color_start = "";
    my $color_end   = "\x{1B}[0m";

    my $code_for_rh = \%ANSI_CODE_FOR;

    TOK:
    for my $token (@tokens) {

        my $code = $code_for_rh->{$token};

        if ( ref $code eq 'HASH' ) {
            $code_for_rh = $code;
            next TOK;
        }

        if ( not $code ) {

            if ( defined $ANSI_CODE_FOR{$token} ) {

                $code_for_rh = \%ANSI_CODE_FOR;
                redo TOK;
            }

            carp "unrecognized token: $token";
            next TOK;
        }

        $color_start .= "\x{1B}[${code}m";
    }

    my @color_strings;

    @strings = map { ref $_ eq 'ARRAY' ? @{ $_ } : $_ } @strings;

    for my $string ( @strings ) {

        # pre text ESC sub text ESC end text
        if ( $string =~ $SUB_COLOR_REGEX ) {

            my $pre
                = $1
                ? $color_start . $1 . $color_end
                : "";

            my $sub = $2;

            my $end
                = $3
                ? $color_start . $3 . $color_end
                : "";

            $string
                = $pre
                . $sub
                . $end;
        }

        # no color ESC
        elsif ( $string !~ $COLOR_REGEX ) {

            $string
                = $color_start
                . $string
                . $color_end;
        }

        # else ESC text ESC

        push @color_strings, $string;
    }

    if ( @strings ) {

        $strings[-1] .= $eol;
    }
    else {

        push @strings, $eol;
    }

    my $string = join $self->{pad}, @strings;

    if ( ref $self->{output} eq 'GLOB' ) {

        print { $self->{output} } $string;
    }

    return $string;
}

sub DESTROY {
    return;
}

1;