diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Term')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Term/ANSIColor.pm | 472 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Term/Cap.pm | 669 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Term/Complete.pm | 188 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Term/ReadLine.pm | 399 |
4 files changed, 1728 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Term/ANSIColor.pm b/Master/tlpkg/tlperl/lib/Term/ANSIColor.pm new file mode 100644 index 00000000000..9320fa06b23 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Term/ANSIColor.pm @@ -0,0 +1,472 @@ +# Term::ANSIColor -- Color screen output using ANSI escape sequences. +# $Id: ANSIColor.pm,v 1.10 2005/08/21 18:31:58 eagle Exp $ +# +# Copyright 1996, 1997, 1998, 2000, 2001, 2002, 2005 +# by Russ Allbery <rra@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@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@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 diff --git a/Master/tlpkg/tlperl/lib/Term/Cap.pm b/Master/tlpkg/tlperl/lib/Term/Cap.pm new file mode 100644 index 00000000000..b71c51ceba4 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Term/Cap.pm @@ -0,0 +1,669 @@ +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@bsdi.com +# Version 1.00: Thu Nov 30 23:34:29 EST 2000 by schwern@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@uiuc.edu +# Avoid warnings in Tgetent and Tputs +# Version 1.02: Sat Nov 17 13:50:39 GMT 2001 by jns@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@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,@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@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: + diff --git a/Master/tlpkg/tlperl/lib/Term/Complete.pm b/Master/tlpkg/tlperl/lib/Term/Complete.pm new file mode 100644 index 00000000000..601e4956430 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Term/Complete.pm @@ -0,0 +1,188 @@ +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@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; diff --git a/Master/tlpkg/tlperl/lib/Term/ReadLine.pm b/Master/tlpkg/tlperl/lib/Term/ReadLine.pm new file mode 100644 index 00000000000..48eb9911a6f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Term/ReadLine.pm @@ -0,0 +1,399 @@ +=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; + |