File Coverage

lib/Badger/Rainbow.pm

Criterion	Covered	Total	%
statement	24	28	85.7
branch	5	6	83.3
condition	2	6	33.3
subroutine	6	7	85.7
pod	2	2	100.0
total	39	49	79.5

#========================================================================
#
# Badger::Rainbow
#
# DESCRIPTION
#   Colour-related functionality, used primarily for debugging.
#
# AUTHOR
#   Andy Wardley
#
#========================================================================

package Badger::Rainbow;

use Carp;
#use Badger::Debug ':debug';
use Badger::Class
    version   => 0.01,
    base      => 'Badger::Exporter',
    constants => 'DELIMITER ARRAY REFS PKG ALL',
    exports   => {
        any   => 'ANSI_escape ANSI_colours strip_ANSI_escapes',
        hooks => {
            ANSI => \&_export_ANSI_colours,
        },
    },
    constant => {
        ANSI_colours => {
            bold    =>  1,
            dark    =>  2,
            black   => 30,
            red     => 31,
            green   => 32,
            yellow  => 33,
            blue    => 34,
            magenta => 35,
            cyan    => 36,
            grey    => 37,
            white   => 38,
        },
    };

# can't import this via Badger::Debug as it depends on Badger::Rainbow
our $DEBUG = 0 unless defined $DEBUG;

sub _export_ANSI_colours {
    my ($class, $target, $symbol, $more_symbols) = @_;
    my $ansi = ANSI_colours;
    my $cols = shift(@$more_symbols)
        || croak "You didn't specify any ANSI colours to import";

    no strict REFS;

    $cols = [ keys %$ansi ]
        if $cols eq ALL;

    $cols = [ split(DELIMITER, $cols) ]
        unless ref $cols eq ARRAY;

    foreach my $col (@$cols) {
#        $class->debug("Exporting ANSI clolour $col to $target\n") if $DEBUG;
        my $val = $ansi->{ $col }
            || croak "Invalid ANSI colour specified to import: $col";
        *{ $target.PKG.$col } = sub(@) {
            ANSI_escape($val, @_)
        };
    }
}


#-----------------------------------------------------------------------
# ANSI_escape($attr, $text)
#
# Adds ANSI escape codes to each line of text to colour output.
#-----------------------------------------------------------------------

sub ANSI_escape {
    my $attr = shift;
    my $text = join('', grep { defined $_ } @_);
    return join("\n",
        map {
            # look for an existing escape start sequence and add new
            # attribute to it, otherwise add escape start/end sequences
            s/ \e \[ ([1-9][\d;]*) m/\e[$1;${attr}m/gx
                ? $_
                : "\e[${attr}m" . $_ . "\e[0m";
        }
        split(/\n/, $text, -1)   # -1 prevents it from ignoring trailing fields
    );
}


sub strip_ANSI_escapes {
    my $text = join('', grep { defined $_ } @_);
    $text =~ s/ \e .*? m//gx;
    return $text;
}




1;

__END__