File Coverage

blib/lib/Term/ANSIScreen.pm

Criterion	Covered	Total	%
statement	89	118	75.4
branch	32	62	51.6
condition	10	15	66.6
subroutine	13	21	61.9
pod	4	12	33.3
total	148	228	64.9

use 5.005;
package Term::ANSIScreen;
$Term::ANSIScreen::VERSION = '1.50';

use strict;
use vars qw/@ISA @EXPORT %EXPORT_TAGS $VERSION $AUTOLOAD
            %attributes %attributes_r %sequences $AUTORESET $EACHLINE/;
use Exporter;

=head1 NAME

Term::ANSIScreen - Terminal control using ANSI escape sequences

=head1 SYNOPSIS

    # qw/:color/ is exported by default, i.e. color() & colored()

    use Term::ANSIScreen qw/:color :cursor :screen :keyboard/;

    print setmode(1), setkey('a','b');
    print "40x25 mode now, with 'a' mapped to 'b'.";
    ; resetkey; setmode 3; cls;

    locate 1, 1; print "@ This is (1,1)", savepos;
    print locate(24,60), "@ This is (24,60)"; loadpos;
    print down(2), clline, "@ This is (3,15)\n";

    setscroll 1, 20;

    color 'black on white'; clline;
    print "This line is black on white.\n";
    print color 'reset'; print "This text is normal.\n";

    print colored ("This text is bold blue.\n", 'bold blue');
    print "This text is normal.\n";
    print colored ['bold blue'], "This text is bold blue.\n";
    print "This text is normal.\n";

    use Term::ANSIScreen qw/:constants/; # constants mode
    print BLUE ON GREEN . "Blue on green.\n";

    $Term::ANSIScreen::AUTORESET = 1;
    print BOLD GREEN . ON_BLUE "Bold green on blue.", CLEAR;
    print "\nThis text is normal.\n";

    # Win32::Console emulation mode
    # this returns a Win32::Console object on a Win32 platform
    my $console = Term::ANSIScreen->new;
    $console->Cls;	# also works on non-Win32 platform

=cut

# -----------------------
# Internal data structure
# -----------------------

%attributes = (
    'clear'      => 0,    'reset'      => 0,
    'bold'       => 1,    'dark'       => 2,
    'underline'  => 4,    'underscore' => 4,
    'blink'      => 5,    'reverse'    => 7,
    'concealed'  => 8,

    'black'      => 30,   'on_black'   => 40,
    'red'        => 31,   'on_red'     => 41,
    'green'      => 32,   'on_green'   => 42,
    'yellow'     => 33,   'on_yellow'  => 43,
    'blue'       => 34,   'on_blue'    => 44,
    'magenta'    => 35,   'on_magenta' => 45,
    'cyan'       => 36,   'on_cyan'    => 46,
    'white'      => 37,   'on_white'   => 47,
);

%sequences = (
    'up'        => '?A',      'down'      => '?B',
    'right'     => '?C',      'left'      => '?D',
    'savepos'   => 's',       'loadpos'   => 'u',
    'cls'       => '2J',      'clline'    => 'K',
    'cldown'    => '0J',      'clup'      => '1J',
    'locate'    => '?;?H',    'setmode'   => '?h',
    'wrapon'    => '7h',      'wrapoff'   => '7l',
    'setscroll'	=> '?;?r',
);

my %mapped;

# ----------------
# Exporter section
# ----------------

@ISA         = qw/Exporter/;
%EXPORT_TAGS = (
    'color'     => [qw/color colored uncolor/],
    'cursor'    => [qw/locate up down right left savepos loadpos/],
    'screen'    => [qw/cls clline cldown clup setmode wrapon wrapoff setscroll/],
    'keyboard'  => [qw/setkey resetkey/],
    'constants' => [map {uc($_)} keys(%attributes), 'ON'],
);

$EXPORT_TAGS{all} = [map {@{$_}} values (%EXPORT_TAGS)];

@EXPORT = qw(color colored);
Exporter::export_ok_tags (keys(%EXPORT_TAGS));

sub new {
    my $class = shift;

    if ($^O eq 'MSWin32' and eval { require Win32::Console } ) {
        return Win32::Console->new(@_);
    }

    no strict 'refs';
    unless ($main::FG_WHITE) {
        foreach my $color (grep { $attributes{$_} >= 30 } keys %attributes) {
            my $name = "FG_\U$color";
            $name =~ s/^FG_ON_/BG_/;
            ${"main::$name"} = color($color);
            $name =~ s/_/_LIGHT/;
            ${"main::$name"} = color('bold', $color);
        }
        $main::FG_LIGHTWHITE = $main::FG_WHITE;
        $main::FG_BROWN      = $main::FG_YELLOW;
        $main::FG_YELLOW     = $main::FG_LIGHTYELLOW;
        $main::FG_WHITE      = color('clear');
    }

    return bless([ @_ ], $class);
}

sub Attr {
    shift;
    print STDERR @_;
}

sub Cls {
    print STDERR cls();
}

sub Cursor {
    shift;
    print STDERR locate($_[1]+1, $_[0]+1);
}

sub Write {
    shift;
    print STDERR @_;
}

sub Display {
}


# --------------
# Implementation
# --------------

sub AUTOLOAD {
    my $enable_colors = !defined $ENV{ANSI_COLORS_DISABLED};
    my $sub = $AUTOLOAD;
    $sub =~ s/^.*:://;

    if (my $seq = $sequences{$sub}) {
	return '' unless $enable_colors;

        $seq =~ s/\?/defined($_[0]) ? shift(@_) : 1/eg;
        return((defined wantarray) ? "\e[$seq"
                                   : print("\e[$seq"));
    }
    elsif (defined(my $attr = $attributes{lc($sub)}) and $sub =~ /^[A-Z_]+$/) {
	my $out = "@_";
	if ($enable_colors) {
	    $out = "\e[${attr}m" . $out;
	    $out .= "\e[0m" if ($AUTORESET and @_ and $out !~ /\e\[0m$/s);
	}
        return((defined wantarray) ? $out
                                   : print($out));
    }
    else {
	require Carp;
        Carp::croak("Undefined subroutine &$AUTOLOAD called");
    }
}

# ------------------------------------------------
# Convert foreground constants to background ones,
# for sequences like (XXX ON YYY "text")
# ------------------------------------------------

sub ON {
    return '' if defined $ENV{ANSI_COLORS_DISABLED};

    my $out = "@_";
    $out =~ s/^\e\[3(\d)m/\e\[4$1m/;
    return $out;
}

# ---------------------------------------
# Color subroutines, from Term::ANSIColor
# ---------------------------------------

sub color {
    return '' if defined $ENV{ANSI_COLORS_DISABLED};

    my @codes = map { split } @_;
    my $attribute;

    no warnings 'uninitialized';
    while (my $code = lc(shift(@codes))) {
        $code .= '_' . shift(@codes) if ($code eq 'on');

        if (defined $attributes{$code}) {
            $attribute .= $attributes{$code} . ';';
        }
        else {
            warn "Invalid attribute name $code";
        }
    }

    if ($attribute) {
        chop $attribute;
        return (defined wantarray) ? "\e[${attribute}m"
                                   : print("\e[${attribute}m");
    }
}

sub colored {
    my $output;
    my ($string, $attr) = (ref $_[0])
        ? (join('', @_[1..$#_]), color(@{$_[0]}))
        : (+shift, color(@_));

    return $string if defined $ENV{ANSI_COLORS_DISABLED};

    if (defined $EACHLINE) {
        $output  = join '',
            map { ($_ && $_ ne $EACHLINE) ? $attr . $_ . "\e[0m" : $_ }
                split (/(\Q$EACHLINE\E)/, $string);
    } else {
        $output = "$attr$string\e[0m";
    }

    return (defined wantarray) ? $output
                               : print($output);
}

sub uncolor {
    my (@nums, @result);

    foreach my $seq (@_) {
        my $escape = $seq;
        $escape =~ s/^\e\[//;
        $escape =~ s/m$//;
        unless ($escape =~ /^((?:\d+;)*\d*)$/) {
            require Carp;
            Carp::croak("Bad escape sequence $seq");
        }
        push (@nums, split (/;/, $1));
    }

    _init_attributes_r();

    foreach my $num (@nums) {
        $num += 0; # Strip leading zeroes
        my $name = $attributes_r{$num};
        if (!defined $name) {
            require Carp;
            Carp::croak("No name for escape sequence $num" );
        }
        push (@result, $name);
    }

    return @result;
}

sub _init_attributes_r {
    return if %attributes_r;

    # Reverse lookup.  Alphabetically first name for a sequence is preferred.
    for (reverse sort keys %attributes) {
	$attributes_r{$attributes{$_}} = $_;
    }
}

sub setkey {
    my ($key, $mapto) = @_;

    if ($key eq $mapto) {
        delete $mapped{$key} if exists $mapped{$key};
    }
    else {
        $mapped{$key} = 1;
    }

    $key   = ord($key)    unless ($key =~ /^\d+;\d+$/);
    $mapto = qq("$mapto") unless ($mapto =~ /^\d+;\d+$/);

    return (defined wantarray) ? "\e[$key;${mapto}p"
                               : print("\e[$key;${mapto}p");
}

sub resetkey {
    my $output;

    foreach my $key (@_ ? @_ : keys(%mapped)) {
        $output .= setkey($key, $key);
    }

    return (defined wantarray) ? $output
                               : print($output);
}

sub DESTROY {
    return;
}

1;

__END__