diff options
author | markm <markm@FreeBSD.org> | 2002-05-16 10:09:28 +0000 |
---|---|---|
committer | markm <markm@FreeBSD.org> | 2002-05-16 10:09:28 +0000 |
commit | f56e05005c751822074f0a22aa9a98d2eb189924 (patch) | |
tree | e28fc632241c9d248069d45dd9ab2a41fa64868f /contrib/perl5/lib/Term | |
parent | 344ddc14973a1519f100f54051dcb068069fe43c (diff) | |
download | FreeBSD-src-f56e05005c751822074f0a22aa9a98d2eb189924.zip FreeBSD-src-f56e05005c751822074f0a22aa9a98d2eb189924.tar.gz |
Perl is no longer in base. Long live the port!
Diffstat (limited to 'contrib/perl5/lib/Term')
-rw-r--r-- | contrib/perl5/lib/Term/ANSIColor.pm | 351 | ||||
-rw-r--r-- | contrib/perl5/lib/Term/Cap.pm | 410 | ||||
-rw-r--r-- | contrib/perl5/lib/Term/Complete.pm | 154 | ||||
-rw-r--r-- | contrib/perl5/lib/Term/ReadLine.pm | 369 |
4 files changed, 0 insertions, 1284 deletions
diff --git a/contrib/perl5/lib/Term/ANSIColor.pm b/contrib/perl5/lib/Term/ANSIColor.pm deleted file mode 100644 index b61efcb..0000000 --- a/contrib/perl5/lib/Term/ANSIColor.pm +++ /dev/null @@ -1,351 +0,0 @@ -# Term::ANSIColor -- Color screen output using ANSI escape sequences. -# $Id: ANSIColor.pm,v 1.3 2000/08/06 18:28:10 eagle Exp $ -# -# Copyright 1996, 1997, 1998, 2000 -# by Russ Allbery <rra@stanford.edu> and Zenin <zenin@best.com> -# -# This program is free software; you can 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(@ISA @EXPORT %EXPORT_TAGS $VERSION $AUTOLOAD %attributes - $AUTORESET $EACHLINE); - -use Exporter (); -@ISA = qw(Exporter); -@EXPORT = qw(color colored); -%EXPORT_TAGS = (constants => [qw(CLEAR RESET BOLD 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.03; - - -############################################################################ -# 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); - - -############################################################################ -# 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. -sub AUTOLOAD { - my $sub; - ($sub = $AUTOLOAD) =~ s/^.*:://; - my $attr = $attributes{lc $sub}; - if ($sub =~ /^[A-Z_]+$/ && defined $attr) { - $attr = "\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 { - 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; -} - -# 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 = @_; - } - if (defined $EACHLINE) { - my $attr = color (@codes); - join '', - map { $_ && $_ ne $EACHLINE ? $attr . $_ . "\e[0m" : $_ } - 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(: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. - -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). - -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, 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 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 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). - -=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 - -Jean Delvare provided the following table of different common terminal -emulators and their support for the various attributes: - - 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 - -Where the entry is other than yes or no, that emulator interpret 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. - -=head1 AUTHORS - -Original idea (using constants) by Zenin (zenin@best.com), reimplemented -using subs by Russ Allbery (rra@stanford.edu), and then combined with the -original idea by Russ with input from Zenin. - -=cut diff --git a/contrib/perl5/lib/Term/Cap.pm b/contrib/perl5/lib/Term/Cap.pm deleted file mode 100644 index 0954000..0000000 --- a/contrib/perl5/lib/Term/Cap.pm +++ /dev/null @@ -1,410 +0,0 @@ -package Term::Cap; -use Carp; - -# Last updated: Thu Dec 14 20:02:42 CST 1995 by sanders@bsdi.com - -# 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. - -The B<Tgetent> 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. - -I<OSPEED> is the terminal output bit rate (often mistakenly called -the baud rate). I<OSPEED> can be specified as either a POSIX -termios/SYSV termio speeds (where 9600 equals 9600) or an old -BSD-style speeds (where 13 equals 9600). - -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>. It calls C<croak> on failure. - -B<Tgoto> decodes a cursor addressing string with the given parameters. - -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. - -The extracted termcap entry is available in the object -as C<$self-E<gt>{TERMCAP}>. - -=head1 EXAMPLES - - # 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); - -=cut - -# 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 - grep(-f, @termcap_path); -} - -sub Tgetent { ## public -- static method - my $class = shift; - my $self = bless shift, $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}) { - 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; - 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 .= $_; - }; - - 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 ($field =~ /^(\w\w)$/) { - $self->{'_' . $field} = 1 unless defined $self->{'_' . $1}; - # print STDERR "DEBUG: flag $1\n"; - } - elsif ($field =~ /^(\w\w)\@/) { - $self->{'_' . $1} = ""; - # print STDERR "DEBUG: unset $1\n"; - } - elsif ($field =~ /^(\w\w)#(.*)/) { - $self->{'_' . $1} = $2 unless defined $self->{'_' . $1}; - # print STDERR "DEBUG: numeric $1 = $2\n"; - } - elsif ($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); -sub Tpad { ## public - my $self = shift; - my($string, $cnt, $FH) = @_; - my($decr, $ms); - - if ($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); -sub Tputs { ## public - my $self = shift; - my($cap, $cnt, $FH) = @_; - my $string; - - if ($cnt > 1) { - $string = Tpad($self, $self->{'_' . $cap}, $cnt); - } else { - # cache result because Tpad can be slow - $string = defined $self->{$cap} ? $self->{$cap} : - ($self->{$cap} = Tpad($self, $self->{'_' . $cap}, 1)); - } - print $FH $string if $FH; - $string; -} - -# %% 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) -# -# $terminal->Tgoto($cap, $col, $row, $FH); -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/); -sub Trequire { ## public - my $self = shift; - my($cap,@undefined); - foreach $cap (@_) { - push(@undefined, $cap) - unless defined $self->{'_' . $cap} && $self->{'_' . $cap}; - } - croak "Terminal does not support: (@undefined)" if @undefined; -} - -1; - diff --git a/contrib/perl5/lib/Term/Complete.pm b/contrib/perl5/lib/Term/Complete.pm deleted file mode 100644 index 445dfca..0000000 --- a/contrib/perl5/lib/Term/Complete.pm +++ /dev/null @@ -1,154 +0,0 @@ -package Term::Complete; -require 5.000; -require Exporter; - -@ISA = qw(Exporter); -@EXPORT = qw(Complete); - -# @(#)complete.pl,v1.2 (me@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 using the system command -C<stty raw -echo> and restored using C<stty -raw echo>. - -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 - -CONFIG: { - $complete = "\004"; - $kill = "\025"; - $erase1 = "\177"; - $erase2 = "\010"; -} - -sub Complete { - my($prompt, @cmp_list, $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(@_); - } - - system('stty raw -echo'); - LOOP: { - print($prompt, $return); - while (($_ = getc(STDIN)) ne "\r") { - CASE: { - # (TAB) attempt completion - $_ eq "\t" && do { - @match = grep(/^$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(/^$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('stty -raw echo'); - print("\n"); - $return; -} - -1; - diff --git a/contrib/perl5/lib/Term/ReadLine.pm b/contrib/perl5/lib/Term/ReadLine.pm deleted file mode 100644 index fc78d7b..0000000 --- a/contrib/perl5/lib/Term/ReadLine.pm +++ /dev/null @@ -1,369 +0,0 @@ -=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; - $term = new Term::ReadLine 'Simple Perl calc'; - $prompt = "Enter your arithmetic expression: "; - $OUT = $term->OUT || STDOUT; - while ( defined ($_ = $term->readline($prompt)) ) { - $res = eval($_), "\n"; - warn $@ if $@; - print $OUT $res, "\n" unless $@; - $term->addhistory($_) if /\S/; - } - -=head1 DESCRIPTION - -This package is just a front end to some other packages. At the moment -this description is written, the only such package is Term-ReadLine, -available on CPAN near you. The real target of this stub package is to -set up a common interface to whatever Readline emerges with time. - -=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>Init. - -=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 Exporter>. - -=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 reacher 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). - -=cut - -package Term::ReadLine::Stub; -@ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap'; - -$DB::emacs = $DB::emacs; # To peacify -w -*rl_term_set = \@Term::ReadLine::TermCap::rl_term_set; - -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'); - 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"; - } - } - - $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) { - ($console, $consoleOUT) = findConsole; - - open(FIN, "<$console"); - open(FOUT,">$consoleOUT"); - #OUT->autoflush(1); # Conflicts with debugger? - $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? - $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? - -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). - -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); -} 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. -@rl_term_set = ("","","",""); -# string encoded: -$rl_term_set = ',,,'; - -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; - -$count_handle = $count_DoOne = $count_loop = 0; - -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; - |