dslinux/user/perl/lib/Term ANSIColor.pm Cap.pm Cap.t Complete.pm Complete.t ReadLine.pm ReadLine.t
cayenne
dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:01:02 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/lib/Term
In directory antilope:/tmp/cvs-serv17422/lib/Term
Added Files:
ANSIColor.pm Cap.pm Cap.t Complete.pm Complete.t ReadLine.pm
ReadLine.t
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: Complete.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
use warnings;
use Test::More tests => 8;
use vars qw( $Term::Complete::complete $complete $Term::Complete::stty );
SKIP: {
skip('PERL_SKIP_TTY_TEST', 8) if $ENV{PERL_SKIP_TTY_TEST};
use_ok( 'Term::Complete' );
# this skips tests AND prevents the "used only once" warning
skip('No stty, Term::Complete will not run here', 7)
unless defined $Term::Complete::tty_raw_noecho &&
defined $Term::Complete::tty_restore;
# also prevent Term::Complete from running stty and messing up the terminal
undef $Term::Complete::tty_restore;
undef $Term::Complete::tty_raw_noecho;
undef $Term::Complete::stty;
*complete = \$Term::Complete::complete;
my $in = tie *STDIN, 'FakeIn', "fro\t";
my $out = tie *STDOUT, 'FakeOut';
my @words = ( 'frobnitz', 'frobozz', 'frostychocolatemilkshakes' );
Complete('', \@words);
my $data = get_expected('fro', @words);
# there should be an \a after our word
like( $$out, qr/fro\a/, 'found bell character' );
# now remove the \a -- there should be only one
is( $out->scrub(), 1, '(single) bell removed');
# 'fro' should match all three words
like( $$out, qr/$data/, 'all three words possible' );
$out->clear();
# should only find 'frobnitz' and 'frobozz'
$in->add('frob');
Complete('', @words);
$out->scrub();
is( $$out, get_expected('frob', 'frobnitz', 'frobozz'), 'expected frob*' );
$out->clear();
# should only do 'frobozz'
$in->add('frobo');
Complete('', @words);
$out->scrub();
is( $$out, get_expected( 'frobo', 'frobozz' ), 'only frobozz possible' );
$out->clear();
# change the completion character
$complete = "!";
$in->add('frobn');
Complete('prompt:', @words);
$out->scrub();
like( $$out, qr/prompt:frobn/, 'prompt is okay' );
# now remove the prompt and we should be okay
$$out =~ s/prompt://g;
is( $$out, get_expected('frobn', 'frobnitz' ), 'works with new $complete' );
} # end of SKIP, end of tests
# easier than matching space characters
sub get_expected {
my $word = shift;
return join('.', $word, @_, $word, '.');
}
package FakeIn;
sub TIEHANDLE {
my ($class, $text) = @_;
$text .= "$main::complete\025";
bless(\$text, $class);
}
sub add {
my ($self, $text) = @_;
$$self = $text . "$main::complete\025";
}
sub GETC {
my $self = shift;
return length $$self ? substr($$self, 0, 1, '') : "\r";
}
package FakeOut;
sub TIEHANDLE {
bless(\(my $text), $_[0]);
}
sub clear {
${ $_[0] } = '';
}
# remove the bell character
sub scrub {
${ $_[0] } =~ tr/\a//d;
}
# must shift off self
sub PRINT {
my $self = shift;
($$self .= join('', @_)) =~ s/\s+/./gm;
}
--- NEW FILE: Complete.pm ---
package Term::Complete;
require 5.000;
require Exporter;
use strict;
our @ISA = qw(Exporter);
our @EXPORT = qw(Complete);
our $VERSION = '1.402';
# @(#)complete.pl,v1.2 (me at anywhere.EBay.Sun.COM) 09/23/91
=head1 NAME
Term::Complete - Perl word completion module
=head1 SYNOPSIS
$input = Complete('prompt_string', \@completion_list);
$input = Complete('prompt_string', @completion_list);
=head1 DESCRIPTION
This routine provides word completion on the list of words in
the array (or array ref).
The tty driver is put into raw mode and restored using an operating
system specific command, in UNIX-like environments C<stty>.
The following command characters are defined:
=over 4
=item E<lt>tabE<gt>
Attempts word completion.
Cannot be changed.
=item ^D
Prints completion list.
Defined by I<$Term::Complete::complete>.
=item ^U
Erases the current input.
Defined by I<$Term::Complete::kill>.
=item E<lt>delE<gt>, E<lt>bsE<gt>
Erases one character.
Defined by I<$Term::Complete::erase1> and I<$Term::Complete::erase2>.
=back
=head1 DIAGNOSTICS
Bell sounds when word completion fails.
=head1 BUGS
The completion character E<lt>tabE<gt> cannot be changed.
=head1 AUTHOR
Wayne Thompson
=cut
our($complete, $kill, $erase1, $erase2, $tty_raw_noecho, $tty_restore, $stty, $tty_safe_restore);
our($tty_saved_state) = '';
CONFIG: {
$complete = "\004";
$kill = "\025";
$erase1 = "\177";
$erase2 = "\010";
foreach my $s (qw(/bin/stty /usr/bin/stty)) {
if (-x $s) {
$tty_raw_noecho = "$s raw -echo";
$tty_restore = "$s -raw echo";
$tty_safe_restore = $tty_restore;
$stty = $s;
last;
}
}
}
sub Complete {
my($prompt, @cmp_lst, $cmp, $test, $l, @match);
my ($return, $r) = ("", 0);
$return = "";
$r = 0;
$prompt = shift;
if (ref $_[0] || $_[0] =~ /^\*/) {
@cmp_lst = sort @{$_[0]};
}
else {
@cmp_lst = sort(@_);
}
# Attempt to save the current stty state, to be restored later
if (defined $stty && defined $tty_saved_state && $tty_saved_state eq '') {
$tty_saved_state = qx($stty -g 2>/dev/null);
if ($?) {
# stty -g not supported
$tty_saved_state = undef;
}
else {
$tty_saved_state =~ s/\s+$//g;
$tty_restore = qq($stty "$tty_saved_state" 2>/dev/null);
}
}
system $tty_raw_noecho if defined $tty_raw_noecho;
LOOP: {
local $_;
print($prompt, $return);
while (($_ = getc(STDIN)) ne "\r") {
CASE: {
# (TAB) attempt completion
$_ eq "\t" && do {
@match = grep(/^\Q$return/, @cmp_lst);
unless ($#match < 0) {
$l = length($test = shift(@match));
foreach $cmp (@match) {
until (substr($cmp, 0, $l) eq substr($test, 0, $l)) {
$l--;
}
}
print("\a");
print($test = substr($test, $r, $l - $r));
$r = length($return .= $test);
}
last CASE;
};
# (^D) completion list
$_ eq $complete && do {
print(join("\r\n", '', grep(/^\Q$return/, @cmp_lst)), "\r\n");
redo LOOP;
};
# (^U) kill
$_ eq $kill && do {
if ($r) {
$r = 0;
$return = "";
print("\r\n");
redo LOOP;
}
last CASE;
};
# (DEL) || (BS) erase
($_ eq $erase1 || $_ eq $erase2) && do {
if($r) {
print("\b \b");
chop($return);
$r--;
}
last CASE;
};
# printable char
ord >= 32 && do {
$return .= $_;
$r++;
print;
last CASE;
};
}
}
}
# system $tty_restore if defined $tty_restore;
if (defined $tty_saved_state && defined $tty_restore && defined $tty_safe_restore)
{
system $tty_restore;
if ($?) {
# tty_restore caused error
system $tty_safe_restore;
}
}
print("\n");
$return;
}
1;
--- NEW FILE: ReadLine.pm ---
=head1 NAME
Term::ReadLine - Perl interface to various C<readline> packages.
If no real package is found, substitutes stubs instead of basic functions.
=head1 SYNOPSIS
use Term::ReadLine;
my $term = new Term::ReadLine 'Simple Perl calc';
my $prompt = "Enter your arithmetic expression: ";
my $OUT = $term->OUT || \*STDOUT;
while ( defined ($_ = $term->readline($prompt)) ) {
my $res = eval($_);
warn $@ if $@;
print $OUT $res, "\n" unless $@;
$term->addhistory($_) if /\S/;
}
=head1 DESCRIPTION
This package is just a front end to some other packages. It's a stub to
set up a common interface to the various ReadLine implementations found on
CPAN (under the C<Term::ReadLine::*> namespace).
=head1 Minimal set of supported functions
All the supported functions should be called as methods, i.e., either as
$term = new Term::ReadLine 'name';
or as
$term->addhistory('row');
where $term is a return value of Term::ReadLine-E<gt>new().
=over 12
=item C<ReadLine>
returns the actual package that executes the commands. Among possible
values are C<Term::ReadLine::Gnu>, C<Term::ReadLine::Perl>,
C<Term::ReadLine::Stub>.
=item C<new>
returns the handle for subsequent calls to following
functions. Argument is the name of the application. Optionally can be
followed by two arguments for C<IN> and C<OUT> filehandles. These
arguments should be globs.
=item C<readline>
gets an input line, I<possibly> with actual C<readline>
support. Trailing newline is removed. Returns C<undef> on C<EOF>.
=item C<addhistory>
adds the line to the history of input, from where it can be used if
the actual C<readline> is present.
=item C<IN>, C<OUT>
return the filehandles for input and output or C<undef> if C<readline>
input and output cannot be used for Perl.
=item C<MinLine>
If argument is specified, it is an advice on minimal size of line to
be included into history. C<undef> means do not include anything into
history. Returns the old value.
=item C<findConsole>
returns an array with two strings that give most appropriate names for
files for input and output using conventions C<"E<lt>$in">, C<"E<gt>out">.
=item Attribs
returns a reference to a hash which describes internal configuration
of the package. Names of keys in this hash conform to standard
conventions with the leading C<rl_> stripped.
=item C<Features>
Returns a reference to a hash with keys being features present in
current implementation. Several optional features are used in the
minimal interface: C<appname> should be present if the first argument
to C<new> is recognized, and C<minline> should be present if
C<MinLine> method is not dummy. C<autohistory> should be present if
lines are put into history automatically (maybe subject to
C<MinLine>), and C<addhistory> if C<addhistory> method is not dummy.
If C<Features> method reports a feature C<attribs> as present, the
method C<Attribs> is not dummy.
=back
=head1 Additional supported functions
Actually C<Term::ReadLine> can use some other package, that will
support a richer set of commands.
All these commands are callable via method interface and have names
which conform to standard conventions with the leading C<rl_> stripped.
The stub package included with the perl distribution allows some
additional methods:
=over 12
=item C<tkRunning>
makes Tk event loop run when waiting for user input (i.e., during
C<readline> method).
=item C<ornaments>
makes the command line stand out by using termcap data. The argument
to C<ornaments> should be 0, 1, or a string of a form
C<"aa,bb,cc,dd">. Four components of this string should be names of
I<terminal capacities>, first two will be issued to make the prompt
standout, last two to make the input line standout.
=item C<newTTY>
takes two arguments which are input filehandle and output filehandle.
Switches to use these filehandles.
=back
One can check whether the currently loaded ReadLine package supports
these methods by checking for corresponding C<Features>.
=head1 EXPORTS
None
=head1 ENVIRONMENT
The environment variable C<PERL_RL> governs which ReadLine clone is
loaded. If the value is false, a dummy interface is used. If the value
is true, it should be tail of the name of the package to use, such as
C<Perl> or C<Gnu>.
As a special case, if the value of this variable is space-separated,
the tail might be used to disable the ornaments by setting the tail to
be C<o=0> or C<ornaments=0>. The head should be as described above, say
If the variable is not set, or if the head of space-separated list is
empty, the best available package is loaded.
export "PERL_RL=Perl o=0" # Use Perl ReadLine without ornaments
export "PERL_RL= o=0" # Use best available ReadLine without ornaments
(Note that processing of C<PERL_RL> for ornaments is in the discretion of the
particular used C<Term::ReadLine::*> package).
=head1 CAVEATS
It seems that using Term::ReadLine from Emacs minibuffer doesn't work
quite right and one will get an error message like
Cannot open /dev/tty for read at ...
One possible workaround for this is to explicitly open /dev/tty like this
open (FH, "/dev/tty" )
or eval 'sub Term::ReadLine::findConsole { ("&STDIN", "&STDERR") }';
die $@ if $@;
close (FH);
or you can try using the 4-argument form of Term::ReadLine->new().
=cut
use strict;
package Term::ReadLine::Stub;
our @ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap';
$DB::emacs = $DB::emacs; # To peacify -w
our @rl_term_set;
*rl_term_set = \@Term::ReadLine::TermCap::rl_term_set;
sub PERL_UNICODE_STDIN () { 0x0001 }
sub ReadLine {'Term::ReadLine::Stub'}
sub readline {
my $self = shift;
my ($in,$out,$str) = @$self;
my $prompt = shift;
print $out $rl_term_set[0], $prompt, $rl_term_set[1], $rl_term_set[2];
$self->register_Tk
if not $Term::ReadLine::registered and $Term::ReadLine::toloop
and defined &Tk::DoOneEvent;
#$str = scalar <$in>;
$str = $self->get_line;
$str =~ s/^\s*\Q$prompt\E// if ($^O eq 'MacOS');
utf8::upgrade($str)
if (${^UNICODE} & PERL_UNICODE_STDIN || defined ${^ENCODING}) &&
utf8::valid($str);
print $out $rl_term_set[3];
# bug in 5.000: chomping empty string creats length -1:
chomp $str if defined $str;
$str;
}
sub addhistory {}
sub findConsole {
my $console;
if ($^O eq 'MacOS') {
$console = "Dev:Console";
} elsif (-e "/dev/tty") {
$console = "/dev/tty";
} elsif (-e "con" or $^O eq 'MSWin32') {
$console = "con";
} else {
$console = "sys\$command";
}
if (($^O eq 'amigaos') || ($^O eq 'beos') || ($^O eq 'epoc')) {
$console = undef;
}
elsif ($^O eq 'os2') {
if ($DB::emacs) {
$console = undef;
} else {
$console = "/dev/con";
}
}
my $consoleOUT = $console;
$console = "&STDIN" unless defined $console;
if (!defined $consoleOUT) {
$consoleOUT = defined fileno(STDERR) ? "&STDERR" : "&STDOUT";
}
($console,$consoleOUT);
}
sub new {
die "method new called with wrong number of arguments"
unless @_==2 or @_==4;
#local (*FIN, *FOUT);
my ($FIN, $FOUT, $ret);
if (@_==2) {
my($console, $consoleOUT) = $_[0]->findConsole;
open(FIN, "<$console");
open(FOUT,">$consoleOUT");
#OUT->autoflush(1); # Conflicts with debugger?
my $sel = select(FOUT);
$| = 1; # for DB::OUT
select($sel);
$ret = bless [\*FIN, \*FOUT];
} else { # Filehandles supplied
$FIN = $_[2]; $FOUT = $_[3];
#OUT->autoflush(1); # Conflicts with debugger?
my $sel = select($FOUT);
$| = 1; # for DB::OUT
select($sel);
$ret = bless [$FIN, $FOUT];
}
if ($ret->Features->{ornaments}
and not ($ENV{PERL_RL} and $ENV{PERL_RL} =~ /\bo\w*=0/)) {
local $Term::ReadLine::termcap_nowarn = 1;
$ret->ornaments(1);
}
return $ret;
}
sub newTTY {
my ($self, $in, $out) = @_;
$self->[0] = $in;
$self->[1] = $out;
my $sel = select($out);
$| = 1; # for DB::OUT
select($sel);
}
sub IN { shift->[0] }
sub OUT { shift->[1] }
sub MinLine { undef }
sub Attribs { {} }
my %features = (tkRunning => 1, ornaments => 1, 'newTTY' => 1);
sub Features { \%features }
package Term::ReadLine; # So late to allow the above code be defined?
our $VERSION = '1.02';
my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef;
if ($which) {
if ($which =~ /\bgnu\b/i){
eval "use Term::ReadLine::Gnu;";
} elsif ($which =~ /\bperl\b/i) {
eval "use Term::ReadLine::Perl;";
} else {
eval "use Term::ReadLine::$which;";
}
} elsif (defined $which and $which ne '') { # Defined but false
# Do nothing fancy
} else {
eval "use Term::ReadLine::Gnu; 1" or eval "use Term::ReadLine::Perl; 1";
}
#require FileHandle;
# To make possible switch off RL in debugger: (Not needed, work done
# in debugger).
our @ISA;
if (defined &Term::ReadLine::Gnu::readline) {
@ISA = qw(Term::ReadLine::Gnu Term::ReadLine::Stub);
} elsif (defined &Term::ReadLine::Perl::readline) {
@ISA = qw(Term::ReadLine::Perl Term::ReadLine::Stub);
} elsif (defined $which && defined &{"Term::ReadLine::$which\::readline"}) {
@ISA = "Term::ReadLine::$which";
} else {
@ISA = qw(Term::ReadLine::Stub);
}
package Term::ReadLine::TermCap;
# Prompt-start, prompt-end, command-line-start, command-line-end
# -- zero-width beautifies to emit around prompt and the command line.
our @rl_term_set = ("","","","");
# string encoded:
our $rl_term_set = ',,,';
our $terminal;
sub LoadTermCap {
return if defined $terminal;
require Term::Cap;
$terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
}
sub ornaments {
shift;
return $rl_term_set unless @_;
$rl_term_set = shift;
$rl_term_set ||= ',,,';
$rl_term_set = 'us,ue,md,me' if $rl_term_set eq '1';
my @ts = split /,/, $rl_term_set, 4;
eval { LoadTermCap };
unless (defined $terminal) {
warn("Cannot find termcap: $@\n") unless $Term::ReadLine::termcap_nowarn;
$rl_term_set = ',,,';
return;
}
@rl_term_set = map {$_ ? $terminal->Tputs($_,1) || '' : ''} @ts;
return $rl_term_set;
}
package Term::ReadLine::Tk;
our($count_handle, $count_DoOne, $count_loop);
$count_handle = $count_DoOne = $count_loop = 0;
our($giveup);
sub handle {$giveup = 1; $count_handle++}
sub Tk_loop {
# Tk->tkwait('variable',\$giveup); # needs Widget
$count_DoOne++, Tk::DoOneEvent(0) until $giveup;
$count_loop++;
$giveup = 0;
}
sub register_Tk {
my $self = shift;
$Term::ReadLine::registered++
or Tk->fileevent($self->IN,'readable',\&handle);
}
sub tkRunning {
$Term::ReadLine::toloop = $_[1] if @_ > 1;
$Term::ReadLine::toloop;
}
sub get_c {
my $self = shift;
$self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
return getc $self->IN;
}
sub get_line {
my $self = shift;
$self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
my $in = $self->IN;
local ($/) = "\n";
return scalar <$in>;
}
1;
--- NEW FILE: ANSIColor.pm ---
# Term::ANSIColor -- Color screen output using ANSI escape sequences.
# $Id: ANSIColor.pm,v 1.2 2006-12-04 17:00:59 dslinux_cayenne Exp $
#
# Copyright 1996, 1997, 1998, 2000, 2001, 2002, 2005
# by Russ Allbery <rra at stanford.edu> and Zenin
#
# This program is free software; you may redistribute it and/or modify it
# under the same terms as Perl itself.
#
# Ah, September, when the sysadmins turn colors and fall off the trees....
# -- Dave Van Domelen
##############################################################################
# Modules and declarations
##############################################################################
package Term::ANSIColor;
require 5.001;
use strict;
use vars qw($AUTOLOAD $AUTORESET $EACHLINE @ISA @EXPORT @EXPORT_OK
%EXPORT_TAGS $VERSION %attributes %attributes_r);
use Exporter ();
@ISA = qw(Exporter);
@EXPORT = qw(color colored);
@EXPORT_OK = qw(uncolor);
%EXPORT_TAGS = (constants => [qw(CLEAR RESET BOLD DARK UNDERLINE UNDERSCORE
BLINK REVERSE CONCEALED BLACK RED GREEN
YELLOW BLUE MAGENTA CYAN WHITE ON_BLACK
ON_RED ON_GREEN ON_YELLOW ON_BLUE ON_MAGENTA
ON_CYAN ON_WHITE)]);
Exporter::export_ok_tags ('constants');
# Don't use the CVS revision as the version, since this module is also in Perl
# core and too many things could munge CVS magic revision strings.
$VERSION = '1.10';
##############################################################################
# Internal data structures
##############################################################################
%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);
# Reverse lookup. Alphabetically first name for a sequence is preferred.
for (reverse sort keys %attributes) {
$attributes_r{$attributes{$_}} = $_;
}
##############################################################################
# Implementation (constant form)
##############################################################################
# Time to have fun! We now want to define the constant subs, which are named
# the same as the attributes above but in all caps. Each constant sub needs
# to act differently depending on whether $AUTORESET is set. Without
# autoreset:
#
# BLUE "text\n" ==> "\e[34mtext\n"
#
# If $AUTORESET is set, we should instead get:
#
# BLUE "text\n" ==> "\e[34mtext\n\e[0m"
#
# The sub also needs to handle the case where it has no arguments correctly.
# Maintaining all of this as separate subs would be a major nightmare, as well
# as duplicate the %attributes hash, so instead we define an AUTOLOAD sub to
# define the constant subs on demand. To do that, we check the name of the
# called sub against the list of attributes, and if it's an all-caps version
# of one of them, we define the sub on the fly and then run it.
#
# If the environment variable ANSI_COLORS_DISABLED is set, turn all of the
# generated subs into pass-through functions that don't add any escape
# sequences. This is to make it easier to write scripts that also work on
# systems without any ANSI support, like Windows consoles.
sub AUTOLOAD {
my $enable_colors = !defined $ENV{ANSI_COLORS_DISABLED};
my $sub;
($sub = $AUTOLOAD) =~ s/^.*:://;
my $attr = $attributes{lc $sub};
if ($sub =~ /^[A-Z_]+$/ && defined $attr) {
$attr = $enable_colors ? "\e[" . $attr . 'm' : '';
eval qq {
sub $AUTOLOAD {
if (\$AUTORESET && \@_) {
'$attr' . "\@_" . "\e[0m";
} else {
('$attr' . "\@_");
}
}
};
goto &$AUTOLOAD;
} else {
require Carp;
Carp::croak ("undefined subroutine &$AUTOLOAD called");
}
}
##############################################################################
# Implementation (attribute string form)
##############################################################################
# Return the escape code for a given set of color attributes.
sub color {
return '' if defined $ENV{ANSI_COLORS_DISABLED};
my @codes = map { split } @_;
my $attribute = '';
foreach (@codes) {
$_ = lc $_;
unless (defined $attributes{$_}) {
require Carp;
Carp::croak ("Invalid attribute name $_");
}
$attribute .= $attributes{$_} . ';';
}
chop $attribute;
($attribute ne '') ? "\e[${attribute}m" : undef;
}
# Return a list of named color attributes for a given set of escape codes.
# Escape sequences can be given with or without enclosing "\e[" and "m". The
# empty escape sequence '' or "\e[m" gives an empty list of attrs.
sub uncolor {
my (@nums, @result);
for (@_) {
my $escape = $_;
$escape =~ s/^\e\[//;
$escape =~ s/m$//;
unless ($escape =~ /^((?:\d+;)*\d*)$/) {
require Carp;
Carp::croak ("Bad escape sequence $_");
}
push (@nums, split (/;/, $1));
}
for (@nums) {
$_ += 0; # Strip leading zeroes
my $name = $attributes_r{$_};
if (!defined $name) {
require Carp;
Carp::croak ("No name for escape sequence $_" );
}
push (@result, $name);
}
@result;
}
# Given a string and a set of attributes, returns the string surrounded by
# escape codes to set those attributes and then clear them at the end of the
# string. The attributes can be given either as an array ref as the first
# argument or as a list as the second and subsequent arguments. If $EACHLINE
# is set, insert a reset before each occurrence of the string $EACHLINE and
# the starting attribute code after the string $EACHLINE, so that no attribute
# crosses line delimiters (this is often desirable if the output is to be
# piped to a pager or some other program).
sub colored {
my ($string, @codes);
if (ref $_[0]) {
@codes = @{+shift};
$string = join ('', @_);
} else {
$string = shift;
@codes = @_;
}
return $string if defined $ENV{ANSI_COLORS_DISABLED};
if (defined $EACHLINE) {
my $attr = color (@codes);
join '',
map { $_ ne $EACHLINE ? $attr . $_ . "\e[0m" : $_ }
grep { length ($_) > 0 }
split (/(\Q$EACHLINE\E)/, $string);
} else {
color (@codes) . $string . "\e[0m";
}
}
##############################################################################
# Module return value and documentation
##############################################################################
# Ensure we evaluate to true.
1;
__END__
=head1 NAME
Term::ANSIColor - Color screen output using ANSI escape sequences
=head1 SYNOPSIS
use Term::ANSIColor;
print color 'bold blue';
print "This text is bold blue.\n";
print color 'reset';
print "This text is normal.\n";
print colored ("Yellow on magenta.\n", 'yellow on_magenta');
print "This text is normal.\n";
print colored ['yellow on_magenta'], "Yellow on magenta.\n";
use Term::ANSIColor qw(uncolor);
print uncolor '01;31', "\n";
use Term::ANSIColor qw(:constants);
print BOLD, BLUE, "This text is in bold blue.\n", RESET;
use Term::ANSIColor qw(:constants);
$Term::ANSIColor::AUTORESET = 1;
print BOLD BLUE "This text is in bold blue.\n";
print "This text is normal.\n";
=head1 DESCRIPTION
This module has two interfaces, one through color() and colored() and the
other through constants. It also offers the utility function uncolor(),
which has to be explicitly imported to be used (see L<SYNOPSIS>).
color() takes any number of strings as arguments and considers them to be
space-separated lists of attributes. It then forms and returns the escape
sequence to set those attributes. It doesn't print it out, just returns it,
so you'll have to print it yourself if you want to (this is so that you can
save it as a string, pass it to something else, send it to a file handle, or
do anything else with it that you might care to).
uncolor() performs the opposite translation, turning escape sequences
into a list of strings.
The recognized attributes (all of which should be fairly intuitive) are
clear, reset, dark, bold, underline, underscore, blink, reverse, concealed,
black, red, green, yellow, blue, magenta, on_black, on_red, on_green,
on_yellow, on_blue, on_magenta, on_cyan, and on_white. Case is not
significant. Underline and underscore are equivalent, as are clear and
reset, so use whichever is the most intuitive to you. The color alone sets
the foreground color, and on_color sets the background color.
Note that not all attributes are supported by all terminal types, and some
terminals may not support any of these sequences. Dark, blink, and
concealed in particular are frequently not implemented.
Attributes, once set, last until they are unset (by sending the attribute
"reset"). Be careful to do this, or otherwise your attribute will last
after your script is done running, and people get very annoyed at having
their prompt and typing changed to weird colors.
As an aid to help with this, colored() takes a scalar as the first argument
and any number of attribute strings as the second argument and returns the
scalar wrapped in escape codes so that the attributes will be set as
requested before the string and reset to normal after the string.
Alternately, you can pass a reference to an array as the first argument, and
then the contents of that array will be taken as attributes and color codes
and the remainder of the arguments as text to colorize.
Normally, colored() just puts attribute codes at the beginning and end of
the string, but if you set $Term::ANSIColor::EACHLINE to some string, that
string will be considered the line delimiter and the attribute will be set
at the beginning of each line of the passed string and reset at the end of
each line. This is often desirable if the output is being sent to a program
like a pager that can be confused by attributes that span lines. Normally
you'll want to set $Term::ANSIColor::EACHLINE to C<"\n"> to use this
feature.
Alternately, if you import C<:constants>, you can use the constants CLEAR,
RESET, BOLD, DARK, UNDERLINE, UNDERSCORE, BLINK, REVERSE, CONCEALED, BLACK,
RED, GREEN, YELLOW, BLUE, MAGENTA, CYAN, WHITE, ON_BLACK, ON_RED, ON_GREEN,
ON_YELLOW, ON_BLUE, ON_MAGENTA, ON_CYAN, and ON_WHITE directly. These are
the same as color('attribute') and can be used if you prefer typing:
print BOLD BLUE ON_WHITE "Text\n", RESET;
to
print colored ("Text\n", 'bold blue on_white');
When using the constants, if you don't want to have to remember to add the
C<, RESET> at the end of each print line, you can set
$Term::ANSIColor::AUTORESET to a true value. Then, the display mode will
automatically be reset if there is no comma after the constant. In other
words, with that variable set:
print BOLD BLUE "Text\n";
will reset the display mode afterwards, whereas:
print BOLD, BLUE, "Text\n";
will not.
The subroutine interface has the advantage over the constants interface in
that only two subroutines are exported into your namespace, versus
twenty-two in the constants interface. On the flip side, the constants
interface has the advantage of better compile time error checking, since
misspelled names of colors or attributes in calls to color() and colored()
won't be caught until runtime whereas misspelled names of constants will be
caught at compile time. So, polute your namespace with almost two dozen
subroutines that you may not even use that often, or risk a silly bug by
mistyping an attribute. Your choice, TMTOWTDI after all.
=head1 DIAGNOSTICS
=over 4
=item Bad escape sequence %s
(F) You passed an invalid ANSI escape sequence to uncolor().
=item Bareword "%s" not allowed while "strict subs" in use
(F) You probably mistyped a constant color name such as:
$Foobar = FOOBAR . "This line should be blue\n";
or:
@Foobar = FOOBAR, "This line should be blue\n";
This will only show up under use strict (another good reason to run under
use strict).
=item Invalid attribute name %s
(F) You passed an invalid attribute name to either color() or colored().
=item Name "%s" used only once: possible typo
(W) You probably mistyped a constant color name such as:
print FOOBAR "This text is color FOOBAR\n";
It's probably better to always use commas after constant names in order to
force the next error.
=item No comma allowed after filehandle
(F) You probably mistyped a constant color name such as:
print FOOBAR, "This text is color FOOBAR\n";
Generating this fatal compile error is one of the main advantages of using
the constants interface, since you'll immediately know if you mistype a
color name.
=item No name for escape sequence %s
(F) The ANSI escape sequence passed to uncolor() contains escapes which
aren't recognized and can't be translated to names.
=back
=head1 ENVIRONMENT
=over 4
=item ANSI_COLORS_DISABLED
If this environment variable is set, all of the functions defined by this
module (color(), colored(), and all of the constants not previously used in
the program) will not output any escape sequences and instead will just
return the empty string or pass through the original text as appropriate.
This is intended to support easy use of scripts using this module on
platforms that don't support ANSI escape sequences.
For it to have its proper effect, this environment variable must be set
before any color constants are used in the program.
=back
=head1 RESTRICTIONS
It would be nice if one could leave off the commas around the constants
entirely and just say:
print BOLD BLUE ON_WHITE "Text\n" RESET;
but the syntax of Perl doesn't allow this. You need a comma after the
string. (Of course, you may consider it a bug that commas between all the
constants aren't required, in which case you may feel free to insert commas
unless you're using $Term::ANSIColor::AUTORESET.)
For easier debuging, you may prefer to always use the commas when not
setting $Term::ANSIColor::AUTORESET so that you'll get a fatal compile error
rather than a warning.
=head1 NOTES
The codes generated by this module are standard terminal control codes,
complying with ECMA-48 and ISO 6429 (generally referred to as "ANSI color"
for the color codes). The non-color control codes (bold, dark, italic,
underline, and reverse) are part of the earlier ANSI X3.64 standard for
control sequences for video terminals and peripherals.
Note that not all displays are ISO 6429-compliant, or even X3.64-compliant
(or are even attempting to be so). This module will not work as expected on
displays that do not honor these escape sequences, such as cmd.exe, 4nt.exe,
and command.com under either Windows NT or Windows 2000. They may just be
ignored, or they may display as an ESC character followed by some apparent
garbage.
Jean Delvare provided the following table of different common terminal
emulators and their support for the various attributes and others have helped
me flesh it out:
clear bold dark under blink reverse conceal
------------------------------------------------------------------------
xterm yes yes no yes bold yes yes
linux yes yes yes bold yes yes no
rxvt yes yes no yes bold/black yes no
dtterm yes yes yes yes reverse yes yes
teraterm yes reverse no yes rev/red yes no
aixterm kinda normal no yes no yes yes
PuTTY yes color no yes no yes no
Windows yes no no no no yes no
Cygwin SSH yes yes no color color color yes
Mac Terminal yes yes no yes yes yes yes
Windows is Windows telnet, Cygwin SSH is the OpenSSH implementation under
Cygwin on Windows NT, and Mac Terminal is the Terminal application in Mac OS
X. Where the entry is other than yes or no, that emulator displays the
given attribute as something else instead. Note that on an aixterm, clear
doesn't reset colors; you have to explicitly set the colors back to what you
want. More entries in this table are welcome.
Note that codes 3 (italic), 6 (rapid blink), and 9 (strikethrough) are
specified in ANSI X3.64 and ECMA-048 but are not commonly supported by most
displays and emulators and therefore aren't supported by this module at the
present time. ECMA-048 also specifies a large number of other attributes,
including a sequence of attributes for font changes, Fraktur characters,
double-underlining, framing, circling, and overlining. As none of these
attributes are widely supported or useful, they also aren't currently
supported by this module.
=head1 SEE ALSO
ECMA-048 is available on-line (at least at the time of this writing) at
L<http://www.ecma-international.org/publications/standards/ECMA-048.HTM>.
ISO 6429 is available from ISO for a charge; the author of this module does
not own a copy of it. Since the source material for ISO 6429 was ECMA-048
and the latter is available for free, there seems little reason to obtain
the ISO standard.
The current version of this module is always available from its web site at
L<http://www.eyrie.org/~eagle/software/ansicolor/>. It is also part of the
Perl core distribution as of 5.6.0.
=head1 AUTHORS
Original idea (using constants) by Zenin, reimplemented using subs by Russ
Allbery <rra at stanford.edu>, and then combined with the original idea by Russ
with input from Zenin. Russ Allbery now maintains this module.
=head1 COPYRIGHT AND LICENSE
Copyright 1996, 1997, 1998, 2000, 2001, 2002 Russ Allbery <rra at stanford.edu>
and Zenin. This program is free software; you may redistribute it and/or
modify it under the same terms as Perl itself.
=cut
--- NEW FILE: Cap.t ---
#!./perl
my $file;
BEGIN {
$file = $0;
chdir 't' if -d 't';
if ( $ENV{PERL_CORE} ) {
@INC = '../lib';
}
}
END {
# let VMS whack all versions
1 while unlink('tcout');
}
use Test::More;
# these names are hardcoded in Term::Cap
my $files = join '',
grep { -f $_ }
( $ENV{HOME} . '/.termcap', # we assume pretty UNIXy system anyway
'/etc/termcap',
'/usr/share/misc/termcap' );
unless( $files || $^O eq 'VMS') {
plan skip_all => 'no termcap available to test';
}
else {
plan tests => 44;
}
use_ok( 'Term::Cap' );
local (*TCOUT, *OUT);
my $out = tie *OUT, 'TieOut';
my $writable = 1;
if (open(TCOUT, ">tcout")) {
print TCOUT <DATA>;
close TCOUT;
} else {
$writable = 0;
}
# termcap_path -- the names are hardcoded in Term::Cap
$ENV{TERMCAP} = '';
my $path = join '', Term::Cap::termcap_path();
is( $path, $files, 'termcap_path() should find default files' );
SKIP: {
# this is ugly, but -f $0 really *ought* to work
skip("-f $file fails, some tests difficult now", 2) unless -f $file;
$ENV{TERMCAP} = $ENV{TERMPATH} = $file;
ok( grep($file, Term::Cap::termcap_path()),
'termcap_path() should find file from $ENV{TERMCAP}' );
$ENV{TERMCAP} = '/';
ok( grep($file, Term::Cap::termcap_path()),
'termcap_path() should find file from $ENV{TERMPATH}' );
}
# make a Term::Cap "object"
my $t = {
PADDING => 1,
_pc => 'pc',
};
bless($t, 'Term::Cap' );
# see if Tpad() works
is( $t->Tpad(), undef, 'Tpad() should return undef with no arguments' );
is( $t->Tpad('x'), 'x', 'Tpad() should return strings verbatim with no match' );
is( $t->Tpad( '1*a', 2 ), 'apcpc', 'Tpad() should pad paddable strings' );
$t->{PADDING} = 2;
is( $t->Tpad( '1*a', 3, *OUT ), 'apcpc', 'Tpad() should perform pad math' );
is( $out->read(), 'apcpc', 'Tpad() should write to filehandle when passed' );
is( $t->Tputs('PADDING'), 2, 'Tputs() should return existing value' );
is( $t->Tputs('pc', 2), 'pc', 'Tputs() should delegate to Tpad()' );
$t->Tputs('pc', 1, *OUT);
is( $t->{pc}, 'pc', 'Tputs() should cache pc value when asked' );
is( $out->read(), 'pc', 'Tputs() should write to filehandle when passed' );
eval { $t->Trequire( 'pc' ) };
is( $@, '', 'Trequire() should finds existing cap' );
eval { $t->Trequire( 'nonsense' ) };
like( $@, qr/support: \(nonsense\)/,
'Trequire() should croak with unsupported cap' );
my $warn;
local $SIG{__WARN__} = sub {
$warn = $_[0];
};
# test the first few features by forcing Tgetent() to croak (line 156)
undef $ENV{TERM};
my $vals = {};
eval { local $^W = 1; $t = Term::Cap->Tgetent($vals) };
like( $@, qr/TERM not set/, 'Tgetent() should croaks without TERM' );
like( $warn, qr/OSPEED was not set/, 'Tgetent() should set default OSPEED' );
is( $vals->{PADDING}, 10000/9600, 'Default OSPEED implies default PADDING' );
$warn = 'xxxx';
eval { local $^W = 0; $t = Term::Cap->Tgetent($vals) };
is($warn,'xxxx',"Tgetent() doesn't carp() without warnings on");
# check values for very slow speeds
$vals->{OSPEED} = 1;
$warn = '';
eval { $t = Term::Cap->Tgetent($vals) };
is( $warn, '', 'Tgetent() should not work if OSPEED is provided' );
is( $vals->{PADDING}, 200, 'Tgetent() should set slow PADDING when needed' );
SKIP: {
skip('Tgetent() bad termcap test, since using a fixed termcap',1)
if $^O eq 'VMS';
# now see if lines 177 or 180 will fail
$ENV{TERM} = 'foo';
$ENV{TERMPATH} = '!';
$ENV{TERMCAP} = '';
eval { $t = Term::Cap->Tgetent($vals) };
isn't( $@, '', 'Tgetent() should catch bad termcap file' );
}
SKIP: {
skip( "Can't write 'tcout' file for tests", 9 ) unless $writable;
# it won't find the termtype in this fake file, so it should croak
$vals->{TERM} = 'quux';
$ENV{TERMPATH} = 'tcout';
eval { $t = Term::Cap->Tgetent($vals) };
like( $@, qr/failed termcap/, 'Tgetent() should die with bad termcap' );
# it shouldn't try to read one file more than 32(!) times
# see __END__ for a really awful termcap example
$ENV{TERMPATH} = join(' ', ('tcout') x 33);
$vals->{TERM} = 'bar';
eval { $t = Term::Cap->Tgetent($vals) };
like( $@, qr/failed termcap loop/, 'Tgetent() should catch deep recursion');
# now let it read a fake termcap file, and see if it sets properties
$ENV{TERMPATH} = 'tcout';
$vals->{TERM} = 'baz';
$t = Term::Cap->Tgetent($vals);
is( $t->{_f1}, 1, 'Tgetent() should set a single field correctly' );
is( $t->{_f2}, 1, 'Tgetent() should set another field on the same line' );
is( $t->{_no}, '', 'Tgetent() should set a blank field correctly' );
is( $t->{_k1}, 'v1', 'Tgetent() should set a key value pair correctly' );
like( $t->{_k2}, qr/v2\\\n2/, 'Tgetent() should set and translate pairs' );
# and it should have set these two fields
is( $t->{_pc}, "\0", 'should set _pc field correctly' );
is( $t->{_bc}, "\b", 'should set _bc field correctly' );
}
# Tgoto has comments on the expected formats
$t->{_test} = "a%d";
is( $t->Tgoto('test', '', 1, *OUT), 'a1', 'Tgoto() should handle %d code' );
is( $out->read(), 'a1', 'Tgoto() should print to filehandle if passed' );
$t->{_test} = "a%.";
like( $t->Tgoto('test', '', 1), qr/^a\x01/, 'Tgoto() should handle %.' );
if (ord('A') == 193) { # EBCDIC platform
like( $t->Tgoto('test', '', 0), qr/\x81\x01\x16/,
'Tgoto() should handle %. and magic' );
} else { # ASCII platform
like( $t->Tgoto('test', '', 0), qr/\x61\x01\x08/,
'Tgoto() should handle %. and magic' );
}
$t->{_test} = 'a%+';
like( $t->Tgoto('test', '', 1), qr/a\x01/, 'Tgoto() should handle %+' );
$t->{_test} = 'a%+a';
is( $t->Tgoto('test', '', 1), 'ab', 'Tgoto() should handle %+char' );
$t->{_test} .= 'a' x 99;
like( $t->Tgoto('test', '', 1), qr/ba{98}/,
'Tgoto() should substr()s %+ if needed' );
$t->{_test} = '%ra%d';
is( $t->Tgoto('test', 1, ''), 'a1', 'Tgoto() should swaps params with %r' );
$t->{_test} = 'a%>11bc';
is( $t->Tgoto('test', '', 1), 'abc', 'Tgoto() should unpack args with %>' );
$t->{_test} = 'a%21';
is( $t->Tgoto('test'), 'a001', 'Tgoto() should format with %2' );
$t->{_test} = 'a%31';
is( $t->Tgoto('test'), 'a0001', 'Tgoto() should also formats with %3' );
$t->{_test} = '%ia%21';
is( $t->Tgoto('test', '', 1), 'a021', 'Tgoto() should increment args with %i' );
$t->{_test} = '%z';
is( $t->Tgoto('test'), 'OOPS', 'Tgoto() should catch invalid args' );
# and this is pretty standard
package TieOut;
sub TIEHANDLE {
bless( \(my $self), $_[0] );
}
sub PRINT {
my $self = shift;
$$self .= join('', @_);
}
sub read {
my $self = shift;
substr( $$self, 0, length($$self), '' );
}
__END__
bar: :tc=bar: \
baz: \
:f1: :f2: \
:no@ \
:k1#v1\
:k2=v2\\n2
--- NEW FILE: ReadLine.t ---
#!./perl -w
use strict;
BEGIN {
if ( $ENV{PERL_CORE} ) {
chdir 't' if -d 't';
@INC = '../lib';
}
}
package Term::ReadLine::Mock;
our @ISA = 'Term::ReadLine::Stub';
sub ReadLine {'Term::ReadLine::Mock'};
sub readline { "a line" }
sub new { bless {} }
package main;
use Test::More tests => 15;
BEGIN {
$ENV{PERL_RL} = 'Mock'; # test against our instrumented class
use_ok('Term::ReadLine');
}
my $t = new Term::ReadLine 'test term::readline';
ok($t, "made something");
isa_ok($t, 'Term::ReadLine::Mock');
for my $method (qw( ReadLine readline addhistory IN OUT MinLine
findConsole Attribs Features new ) ) {
can_ok($t, $method);
}
is($t->ReadLine, 'Term::ReadLine::Mock', "\$object->ReadLine");
is($t->readline, 'a line', "\$object->readline");
--- NEW FILE: Cap.pm ---
package Term::Cap;
# Since the debugger uses Term::ReadLine which uses Term::Cap, we want
# to load as few modules as possible. This includes Carp.pm.
sub carp {
require Carp;
goto &Carp::carp;
}
sub croak {
require Carp;
goto &Carp::croak;
}
use strict;
use vars qw($VERSION $VMS_TERMCAP);
use vars qw($termpat $state $first $entry);
$VERSION = '1.09';
# Version undef: Thu Dec 14 20:02:42 CST 1995 by sanders at bsdi.com
# Version 1.00: Thu Nov 30 23:34:29 EST 2000 by schwern at pobox.com
# [PATCH] $VERSION crusade, strict, tests, etc... all over lib/
# Version 1.01: Wed May 23 00:00:00 CST 2001 by d-lewart at uiuc.edu
# Avoid warnings in Tgetent and Tputs
# Version 1.02: Sat Nov 17 13:50:39 GMT 2001 by jns at gellyfish.com
# Altered layout of the POD
# Added Test::More to PREREQ_PM in Makefile.PL
# Fixed no argument Tgetent()
# Version 1.03: Wed Nov 28 10:09:38 GMT 2001
# VMS Support from Charles Lane <lane at DUPHY4.Physics.Drexel.Edu>
# Version 1.04: Thu Nov 29 16:22:03 GMT 2001
# Fixed warnings in test
# Version 1.05: Mon Dec 3 15:33:49 GMT 2001
# Don't try to fall back on infocmp if it's not there. From chromatic.
# Version 1.06: Thu Dec 6 18:43:22 GMT 2001
# Preload the default VMS termcap from Charles Lane
# Don't carp at setting OSPEED unless warnings are on.
# Version 1.07: Wed Jan 2 21:35:09 GMT 2002
# Sanity check on infocmp output from Norton Allen
# Repaired INSTALLDIRS thanks to Michael Schwern
# Version 1.08: Sat Sep 28 11:33:15 BST 2002
# Late loading of 'Carp' as per Michael Schwern
# Version 1.09: Tue Apr 20 12:06:51 BST 2004
# Merged in changes from and to Core
# Core (Fri Aug 30 14:15:55 CEST 2002):
# Cope with comments lines from 'infocmp' from Brendan O'Dea
# Allow for EBCDIC in Tgoto magic test.
# TODO:
# support Berkeley DB termcaps
# should probably be a .xs module
# force $FH into callers package?
# keep $FH in object at Tgetent time?
=head1 NAME
Term::Cap - Perl termcap interface
=head1 SYNOPSIS
require Term::Cap;
$terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
$terminal->Trequire(qw/ce ku kd/);
$terminal->Tgoto('cm', $col, $row, $FH);
$terminal->Tputs('dl', $count, $FH);
$terminal->Tpad($string, $count, $FH);
=head1 DESCRIPTION
These are low-level functions to extract and use capabilities from
a terminal capability (termcap) database.
More information on the terminal capabilities will be found in the
termcap manpage on most Unix-like systems.
=head2 METHODS
=over 4
The output strings for B<Tputs> are cached for counts of 1 for performance.
B<Tgoto> and B<Tpad> do not cache. C<$self-E<gt>{_xx}> is the raw termcap
data and C<$self-E<gt>{xx}> is the cached version.
print $terminal->Tpad($self->{_xx}, 1);
B<Tgoto>, B<Tputs>, and B<Tpad> return the string and will also
output the string to $FH if specified.
=cut
# Preload the default VMS termcap.
# If a different termcap is required then the text of one can be supplied
# in $Term::Cap::VMS_TERMCAP before Tgetent is called.
if ( $^O eq 'VMS') {
chomp (my @entry = <DATA>);
$VMS_TERMCAP = join '', @entry;
}
# Returns a list of termcap files to check.
sub termcap_path { ## private
my @termcap_path;
# $TERMCAP, if it's a filespec
push(@termcap_path, $ENV{TERMCAP})
if ((exists $ENV{TERMCAP}) &&
(($^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos')
? $ENV{TERMCAP} =~ /^[a-z]:[\\\/]/is
: $ENV{TERMCAP} =~ /^\//s));
if ((exists $ENV{TERMPATH}) && ($ENV{TERMPATH})) {
# Add the users $TERMPATH
push(@termcap_path, split(/(:|\s+)/, $ENV{TERMPATH}))
}
else {
# Defaults
push(@termcap_path,
$ENV{'HOME'} . '/.termcap',
'/etc/termcap',
'/usr/share/misc/termcap',
);
}
# return the list of those termcaps that exist
return grep(-f, @termcap_path);
}
=item B<Tgetent>
Returns a blessed object reference which the user can
then use to send the control strings to the terminal using B<Tputs>
and B<Tgoto>.
The function extracts the entry of the specified terminal
type I<TERM> (defaults to the environment variable I<TERM>) from the
database.
It will look in the environment for a I<TERMCAP> variable. If
found, and the value does not begin with a slash, and the terminal
type name is the same as the environment string I<TERM>, the
I<TERMCAP> string is used instead of reading a termcap file. If
it does begin with a slash, the string is used as a path name of
the termcap file to search. If I<TERMCAP> does not begin with a
slash and name is different from I<TERM>, B<Tgetent> searches the
files F<$HOME/.termcap>, F</etc/termcap>, and F</usr/share/misc/termcap>,
in that order, unless the environment variable I<TERMPATH> exists,
in which case it specifies a list of file pathnames (separated by
spaces or colons) to be searched B<instead>. Whenever multiple
files are searched and a tc field occurs in the requested entry,
the entry it names must be found in the same file or one of the
succeeding files. If there is a C<:tc=...:> in the I<TERMCAP>
environment variable string it will continue the search in the
files as above.
The extracted termcap entry is available in the object
as C<$self-E<gt>{TERMCAP}>.
It takes a hash reference as an argument with two optional keys:
=over 2
=item OSPEED
The terminal output bit rate (often mistakenly called the baud rate)
for this terminal - if not set a warning will be generated
and it will be defaulted to 9600. I<OSPEED> can be be specified as
either a POSIX termios/SYSV termio speeds (where 9600 equals 9600) or
an old DSD-style speed ( where 13 equals 9600).
=item TERM
The terminal type whose termcap entry will be used - if not supplied it will
default to $ENV{TERM}: if that is not set then B<Tgetent> will croak.
=back
It calls C<croak> on failure.
=cut
sub Tgetent { ## public -- static method
my $class = shift;
my ($self) = @_;
$self = {} unless defined $self;
bless $self, $class;
my($term,$cap,$search,$field,$max,$tmp_term,$TERMCAP);
local($termpat,$state,$first,$entry); # used inside eval
local $_;
# Compute PADDING factor from OSPEED (to be used by Tpad)
if (! $self->{OSPEED}) {
if ( $^W ) {
carp "OSPEED was not set, defaulting to 9600";
}
$self->{OSPEED} = 9600;
}
if ($self->{OSPEED} < 16) {
# delays for old style speeds
my @pad = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2);
$self->{PADDING} = $pad[$self->{OSPEED}];
}
else {
$self->{PADDING} = 10000 / $self->{OSPEED};
}
$self->{TERM} = ($self->{TERM} || $ENV{TERM} || croak "TERM not set");
$term = $self->{TERM}; # $term is the term type we are looking for
# $tmp_term is always the next term (possibly :tc=...:) we are looking for
$tmp_term = $self->{TERM};
# protect any pattern metacharacters in $tmp_term
$termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
my $foo = (exists $ENV{TERMCAP} ? $ENV{TERMCAP} : '');
# $entry is the extracted termcap entry
if (($foo !~ m:^/:s) && ($foo =~ m/(^|\|)${termpat}[:|]/s)) {
$entry = $foo;
}
my @termcap_path = termcap_path();
unless (@termcap_path || $entry)
{
# last resort--fake up a termcap from terminfo
local $ENV{TERM} = $term;
if ( $^O eq 'VMS' ) {
$entry = $VMS_TERMCAP;
}
else {
if ( grep { -x "$_/infocmp" } split /:/, $ENV{PATH} ) {
eval
{
my $tmp = `infocmp -C 2>/dev/null`;
$tmp =~ s/^#.*\n//gm; # remove comments
if (( $tmp !~ m%^/%s ) && ( $tmp =~ /(^|\|)${termpat}[:|]/s)) {
$entry = $tmp;
}
};
}
}
}
croak "Can't find a valid termcap file" unless @termcap_path || $entry;
$state = 1; # 0 == finished
# 1 == next file
# 2 == search again
$first = 0; # first entry (keeps term name)
$max = 32; # max :tc=...:'s
if ($entry) {
# ok, we're starting with $TERMCAP
$first++; # we're the first entry
# do we need to continue?
if ($entry =~ s/:tc=([^:]+):/:/) {
$tmp_term = $1;
# protect any pattern metacharacters in $tmp_term
$termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
}
else {
$state = 0; # we're already finished
}
}
# This is eval'ed inside the while loop for each file
$search = q{
while (<TERMCAP>) {
next if /^\\t/ || /^#/;
if ($_ =~ m/(^|\\|)${termpat}[:|]/o) {
chomp;
s/^[^:]*:// if $first++;
$state = 0;
while ($_ =~ s/\\\\$//) {
defined(my $x = <TERMCAP>) or last;
$_ .= $x; chomp;
}
last;
}
}
defined $entry or $entry = '';
$entry .= $_ if $_;
};
while ($state != 0) {
if ($state == 1) {
# get the next TERMCAP
$TERMCAP = shift @termcap_path
|| croak "failed termcap lookup on $tmp_term";
}
else {
# do the same file again
# prevent endless recursion
$max-- || croak "failed termcap loop at $tmp_term";
$state = 1; # ok, maybe do a new file next time
}
open(TERMCAP,"< $TERMCAP\0") || croak "open $TERMCAP: $!";
eval $search;
die $@ if $@;
close TERMCAP;
# If :tc=...: found then search this file again
$entry =~ s/:tc=([^:]+):/:/ && ($tmp_term = $1, $state = 2);
# protect any pattern metacharacters in $tmp_term
$termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
}
croak "Can't find $term" if $entry eq '';
$entry =~ s/:+\s*:+/:/g; # cleanup $entry
$entry =~ s/:+/:/g; # cleanup $entry
$self->{TERMCAP} = $entry; # save it
# print STDERR "DEBUG: $entry = ", $entry, "\n";
# Precompile $entry into the object
$entry =~ s/^[^:]*://;
foreach $field (split(/:[\s:\\]*/,$entry)) {
if (defined $field && $field =~ /^(\w\w)$/) {
$self->{'_' . $field} = 1 unless defined $self->{'_' . $1};
# print STDERR "DEBUG: flag $1\n";
}
elsif (defined $field && $field =~ /^(\w\w)\@/) {
$self->{'_' . $1} = "";
# print STDERR "DEBUG: unset $1\n";
}
elsif (defined $field && $field =~ /^(\w\w)#(.*)/) {
$self->{'_' . $1} = $2 unless defined $self->{'_' . $1};
# print STDERR "DEBUG: numeric $1 = $2\n";
}
elsif (defined $field && $field =~ /^(\w\w)=(.*)/) {
# print STDERR "DEBUG: string $1 = $2\n";
next if defined $self->{'_' . ($cap = $1)};
$_ = $2;
s/\\E/\033/g;
s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
s/\\n/\n/g;
s/\\r/\r/g;
s/\\t/\t/g;
s/\\b/\b/g;
s/\\f/\f/g;
s/\\\^/\377/g;
s/\^\?/\177/g;
s/\^(.)/pack('c',ord($1) & 31)/eg;
s/\\(.)/$1/g;
s/\377/^/g;
$self->{'_' . $cap} = $_;
}
# else { carp "junk in $term ignored: $field"; }
}
$self->{'_pc'} = "\0" unless defined $self->{'_pc'};
$self->{'_bc'} = "\b" unless defined $self->{'_bc'};
$self;
}
# $terminal->Tpad($string, $cnt, $FH);
=item B<Tpad>
Outputs a literal string with appropriate padding for the current terminal.
It takes three arguments:
=over 2
=item B<$string>
The literal string to be output. If it starts with a number and an optional
'*' then the padding will be increased by an amount relative to this number,
if the '*' is present then this amount will me multiplied by $cnt. This part
of $string is removed before output/
=item B<$cnt>
Will be used to modify the padding applied to string as described above.
=item B<$FH>
An optional filehandle (or IO::Handle ) that output will be printed to.
=back
The padded $string is returned.
=cut
sub Tpad { ## public
my $self = shift;
my($string, $cnt, $FH) = @_;
my($decr, $ms);
if (defined $string && $string =~ /(^[\d.]+)(\*?)(.*)$/) {
$ms = $1;
$ms *= $cnt if $2;
$string = $3;
$decr = $self->{PADDING};
if ($decr > .1) {
$ms += $decr / 2;
$string .= $self->{'_pc'} x ($ms / $decr);
}
}
print $FH $string if $FH;
$string;
}
# $terminal->Tputs($cap, $cnt, $FH);
=item B<Tputs>
Output the string for the given capability padded as appropriate without
any parameter substitution.
It takes three arguments:
=over 2
=item B<$cap>
The capability whose string is to be output.
=item B<$cnt>
A count passed to Tpad to modify the padding applied to the output string.
If $cnt is zero or one then the resulting string will be cached.
=item B<$FH>
An optional filehandle (or IO::Handle ) that output will be printed to.
=back
The appropriate string for the capability will be returned.
=cut
sub Tputs { ## public
my $self = shift;
my($cap, $cnt, $FH) = @_;
my $string;
$cnt = 0 unless $cnt;
if ($cnt > 1) {
$string = Tpad($self, $self->{'_' . $cap}, $cnt);
} else {
# cache result because Tpad can be slow
unless (exists $self->{$cap}) {
$self->{$cap} = exists $self->{"_$cap"} ?
Tpad($self, $self->{"_$cap"}, 1) : undef;
}
$string = $self->{$cap};
}
print $FH $string if $FH;
$string;
}
# $terminal->Tgoto($cap, $col, $row, $FH);
=item B<Tgoto>
B<Tgoto> decodes a cursor addressing string with the given parameters.
There are four arguments:
=over 2
=item B<$cap>
The name of the capability to be output.
=item B<$col>
The first value to be substituted in the output string ( usually the column
in a cursor addressing capability )
=item B<$row>
The second value to be substituted in the output string (usually the row
in cursor addressing capabilities)
=item B<$FH>
An optional filehandle (or IO::Handle ) to which the output string will be
printed.
=back
Substitutions are made with $col and $row in the output string with the
following sprintf() line formats:
%% output `%'
%d output value as in printf %d
%2 output value as in printf %2d
%3 output value as in printf %3d
%. output value as in printf %c
%+x add x to value, then do %.
%>xy if value > x then add y, no output
%r reverse order of two parameters, no output
%i increment by one, no output
%B BCD (16*(value/10)) + (value%10), no output
%n exclusive-or all parameters with 0140 (Datamedia 2500)
%D Reverse coding (value - 2*(value%16)), no output (Delta Data)
The output string will be returned.
=cut
sub Tgoto { ## public
my $self = shift;
my($cap, $code, $tmp, $FH) = @_;
my $string = $self->{'_' . $cap};
my $result = '';
my $after = '';
my $online = 0;
my @tmp = ($tmp,$code);
my $cnt = $code;
while ($string =~ /^([^%]*)%(.)(.*)/) {
$result .= $1;
$code = $2;
$string = $3;
if ($code eq 'd') {
$result .= sprintf("%d",shift(@tmp));
}
elsif ($code eq '.') {
$tmp = shift(@tmp);
if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
if ($online) {
++$tmp, $after .= $self->{'_up'} if $self->{'_up'};
}
else {
++$tmp, $after .= $self->{'_bc'};
}
}
$result .= sprintf("%c",$tmp);
$online = !$online;
}
elsif ($code eq '+') {
$result .= sprintf("%c",shift(@tmp)+ord($string));
$string = substr($string,1,99);
$online = !$online;
}
elsif ($code eq 'r') {
($code,$tmp) = @tmp;
@tmp = ($tmp,$code);
$online = !$online;
}
elsif ($code eq '>') {
($code,$tmp,$string) = unpack("CCa99",$string);
if ($tmp[$[] > $code) {
$tmp[$[] += $tmp;
}
}
elsif ($code eq '2') {
$result .= sprintf("%02d",shift(@tmp));
$online = !$online;
}
elsif ($code eq '3') {
$result .= sprintf("%03d",shift(@tmp));
$online = !$online;
}
elsif ($code eq 'i') {
($code,$tmp) = @tmp;
@tmp = ($code+1,$tmp+1);
}
else {
return "OOPS";
}
}
$string = Tpad($self, $result . $string . $after, $cnt);
print $FH $string if $FH;
$string;
}
# $terminal->Trequire(qw/ce ku kd/);
=item B<Trequire>
Takes a list of capabilities as an argument and will croak if one is not
found.
=cut
sub Trequire { ## public
my $self = shift;
my($cap, at undefined);
foreach $cap (@_) {
push(@undefined, $cap)
unless defined $self->{'_' . $cap} && $self->{'_' . $cap};
}
croak "Terminal does not support: (@undefined)" if @undefined;
}
=back
=head1 EXAMPLES
use Term::Cap;
# Get terminal output speed
require POSIX;
my $termios = new POSIX::Termios;
$termios->getattr;
my $ospeed = $termios->getospeed;
# Old-style ioctl code to get ospeed:
# require 'ioctl.pl';
# ioctl(TTY,$TIOCGETP,$sgtty);
# ($ispeed,$ospeed) = unpack('cc',$sgtty);
# allocate and initialize a terminal structure
$terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
# require certain capabilities to be available
$terminal->Trequire(qw/ce ku kd/);
# Output Routines, if $FH is undefined these just return the string
# Tgoto does the % expansion stuff with the given args
$terminal->Tgoto('cm', $col, $row, $FH);
# Tputs doesn't do any % expansion.
$terminal->Tputs('dl', $count = 1, $FH);
=head1 COPYRIGHT AND LICENSE
Please see the README file in distribution.
=head1 AUTHOR
This module is part of the core Perl distribution and is also maintained
for CPAN by Jonathan Stowe <jns at gellyfish.com>.
=head1 SEE ALSO
termcap(5)
=cut
# Below is a default entry for systems where there are terminals but no
# termcap
1;
__DATA__
vt220|vt200|DEC VT220 in vt100 emulation mode:
am:mi:xn:xo:
co#80:li#24:
RA=\E[?7l:SA=\E[?7h:
ac=kkllmmjjnnwwqquuttvvxx:ae=\E(B:al=\E[L:as=\E(0:
bl=^G:cd=\E[J:ce=\E[K:cl=\E[H\E[2J:cm=\E[%i%d;%dH:
cr=^M:cs=\E[%i%d;%dr:dc=\E[P:dl=\E[M:do=\E[B:
ei=\E[4l:ho=\E[H:im=\E[4h:
is=\E[1;24r\E[24;1H:
nd=\E[C:
kd=\E[B::kl=\E[D:kr=\E[C:ku=\E[A:le=^H:
mb=\E[5m:md=\E[1m:me=\E[m:mr=\E[7m:
kb=\0177:
r2=\E>\E[24;1H\E[?3l\E[?4l\E[?5l\E[?7h\E[?8h\E=:rc=\E8:
sc=\E7:se=\E[27m:sf=\ED:so=\E[7m:sr=\EM:ta=^I:
ue=\E[24m:up=\E[A:us=\E[4m:ve=\E[?25h:vi=\E[?25l:
More information about the dslinux-commit
mailing list