diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Term')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Term/ANSIColor.pm | 609 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Term/Cap.pm | 799 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Term/Complete.pm | 188 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Term/ReadLine.pm | 416 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Term/UI.pm | 620 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Term/UI/History.pm | 137 |
6 files changed, 2769 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..1ee7a1ef7ad --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Term/ANSIColor.pm @@ -0,0 +1,609 @@ +# Term::ANSIColor -- Color screen output using ANSI escape sequences. +# +# Copyright 1996, 1997, 1998, 2000, 2001, 2002, 2005, 2006, 2008, 2009 +# Russ Allbery <rra@stanford.edu> and Zenin +# PUSH/POP support submitted 2007 by openmethods.com voice solutions +# +# 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; + +$VERSION = '2.02'; + +use strict; +use vars qw($AUTOLOAD $AUTOLOCAL $AUTORESET @COLORLIST @COLORSTACK $EACHLINE + @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION %ATTRIBUTES + %ATTRIBUTES_R); + +use Exporter (); +BEGIN { + @COLORLIST = qw(CLEAR RESET BOLD DARK FAINT 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); + @ISA = qw(Exporter); + @EXPORT = qw(color colored); + @EXPORT_OK = qw(uncolor colorstrip colorvalid); + %EXPORT_TAGS = (constants => \@COLORLIST, + pushpop => [ @COLORLIST, + qw(PUSHCOLOR POPCOLOR LOCALCOLOR) ]); + Exporter::export_ok_tags ('pushpop'); +} + +############################################################################## +# Internal data structures +############################################################################## + +%ATTRIBUTES = ('clear' => 0, + 'reset' => 0, + 'bold' => 1, + 'dark' => 2, + 'faint' => 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, just return the +# arguments without adding 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 { + if (defined $ENV{ANSI_COLORS_DISABLED}) { + return join ('', @_); + } + if ($AUTOLOAD =~ /^([\w:]*::([A-Z_]+))$/ and defined $ATTRIBUTES{lc $2}) { + $AUTOLOAD = $1; + my $attr = "\e[" . $ATTRIBUTES{lc $2} . 'm'; + eval qq { + sub $AUTOLOAD { + if (\$AUTORESET && \@_) { + return '$attr' . join ('', \@_) . "\e[0m"; + } elsif (\$AUTOLOCAL && \@_) { + return PUSHCOLOR ('$attr') . join ('', \@_) . POPCOLOR; + } else { + return '$attr' . join ('', \@_); + } + } + }; + goto &$AUTOLOAD; + } else { + require Carp; + Carp::croak ("undefined subroutine &$AUTOLOAD called"); + } +} + +# Append a new color to the top of the color stack and return the top of +# the stack. +sub PUSHCOLOR { + my ($text) = @_; + my ($color) = ($text =~ m/^((?:\e\[[\d;]+m)+)/); + if (@COLORSTACK) { + $color = $COLORSTACK[-1] . $color; + } + push (@COLORSTACK, $color); + return $text; +} + +# Pop the color stack and return the new top of the stack (or reset, if +# the stack is empty). +sub POPCOLOR { + pop @COLORSTACK; + if (@COLORSTACK) { + return $COLORSTACK[-1] . join ('', @_); + } else { + return RESET (@_); + } +} + +# Surround arguments with a push and a pop. +sub LOCALCOLOR { + return PUSHCOLOR (join ('', @_)) . POPCOLOR (); +} + +############################################################################## +# 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; + return ($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 $escape"); + } + 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); + } + return @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); + return join '', + map { ($_ ne $EACHLINE) ? $attr . $_ . "\e[0m" : $_ } + grep { length ($_) > 0 } + split (/(\Q$EACHLINE\E)/, $string); + } else { + return color (@codes) . $string . "\e[0m"; + } +} + +# Given a string, strip the ANSI color codes out of that string and return the +# result. This removes only ANSI color codes, not movement codes and other +# escape sequences. +sub colorstrip { + my (@string) = @_; + for my $string (@string) { + $string =~ s/\e\[[\d;]*m//g; + } + return wantarray ? @string : join ('', @string); +} + +# Given a list of color attributes (arguments for color, for instance), return +# true if they're all valid or false if any of them are invalid. +sub colorvalid { + my @codes = map { split } @_; + for (@codes) { + unless (defined $ATTRIBUTES{lc $_}) { + return; + } + } + return 1; +} + +############################################################################## +# Module return value and documentation +############################################################################## + +# Ensure we evaluate to true. +1; +__END__ + +=head1 NAME + +Term::ANSIColor - Color screen output using ANSI escape sequences + +=for stopwords +cyan colorize namespace runtime TMTOWTDI cmd.exe 4nt.exe command.com NT +ESC Delvare SSH OpenSSH aixterm ECMA-048 Fraktur overlining Zenin +reimplemented Allbery PUSHCOLOR POPCOLOR LOCALCOLOR openmethods.com + +=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.", 'yellow on_magenta'), "\n"; + print "This text is normal.\n"; + print colored ['yellow on_magenta'], 'Yellow on magenta.'; + print "\n"; + + use Term::ANSIColor qw(uncolor); + print uncolor ('01;31'), "\n"; + + use Term::ANSIColor qw(colorstrip); + print colorstrip '\e[1mThis is bold\e[0m', "\n"; + + use Term::ANSIColor qw(colorvalid); + my $valid = colorvalid ('blue bold', 'on_magenta'); + print "Color string is ", $valid ? "valid\n" : "invalid\n"; + + use Term::ANSIColor qw(:constants); + print BOLD, BLUE, "This text is in bold blue.\n", RESET; + + use Term::ANSIColor qw(:constants); + { + local $Term::ANSIColor::AUTORESET = 1; + print BOLD BLUE "This text is in bold blue.\n"; + print "This text is normal.\n"; + } + + use Term::ANSIColor qw(:pushpop); + print PUSHCOLOR RED ON_GREEN "This text is red on green.\n"; + print PUSHCOLOR BLUE "This text is blue on green.\n"; + print RESET BLUE "This text is just blue.\n"; + print POPCOLOR "Back to red on green.\n"; + print LOCALCOLOR GREEN ON_BLUE "This text is green on blue.\n"; + print "This text is red on green.\n"; + { + local $Term::ANSIColor::AUTOLOCAL = 1; + print ON_BLUE "This text is red on blue.\n"; + print "This text is red on green.\n"; + } + print POPCOLOR "Back to whatever we started as.\n"; + +=head1 DESCRIPTION + +This module has two interfaces, one through color() and colored() and the +other through constants. It also offers the utility functions uncolor(), +colorstrip(), and colorvalid(), which have to be explicitly imported to be +used (see L</SYNOPSIS>). + +=head2 Function Interface + +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). color() +throws an exception if given an invalid attribute, so you can also use it +to check attribute names for validity (see L</EXAMPLES>). + +uncolor() performs the opposite translation, turning escape sequences +into a list of strings. + +colorstrip() removes all color escape sequences from the provided strings, +returning the modified strings separately in array context or joined +together in scalar context. Its arguments are not modified. + +colorvalid() takes attribute strings the same as color() and returns true +if all attributes are known and false otherwise. + +The recognized non-color attributes are clear, reset, bold, dark, faint, +underline, underscore, blink, reverse, and concealed. Clear and reset +(reset to default attributes), dark and faint (dim and saturated), and +underline and underscore are equivalent, so use whichever is the most +intuitive to you. The recognized foreground color attributes are black, +red, green, yellow, blue, magenta, cyan, and white. The recognized +background color attributes are on_black, on_red, on_green, on_yellow, +on_blue, on_magenta, on_cyan, and on_white. Case is not significant. + +Note that not all attributes are supported by all terminal types, and some +terminals may not support any of these sequences. Dark and faint, blink, +and concealed in particular are frequently not implemented. + +Attributes, once set, last until they are unset (by sending the attribute +C<clear> or C<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 contains newlines and +you're using background colors, since a background color that persists +across a newline is often interpreted by the terminal as providing the +default background color for the next line. Programs like pagers can also +be confused by attributes that span lines. Normally you'll want to set +$Term::ANSIColor::EACHLINE to C<"\n"> to use this feature. + +=head2 Constant Interface + +Alternately, if you import C<:constants>, you can use the constants CLEAR, +RESET, BOLD, DARK, FAINT, 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", RESET, "\n"; + +to + + print colored ("Text", 'bold blue on_white'), "\n"; + +(Note that the newline is kept separate to avoid confusing the terminal as +described above since a background color is being used.) + +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 afterward, whereas: + + print BOLD, BLUE, "Text\n"; + +will not. If you are using background colors, you will probably want to +print the newline with a separate print statement to avoid confusing the +terminal. + +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, pollute 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. + +=head2 The Color Stack + +As of Term::ANSIColor 2.0, you can import C<:pushpop> and maintain a stack +of colors using PUSHCOLOR, POPCOLOR, and LOCALCOLOR. PUSHCOLOR takes the +attribute string that starts its argument and pushes it onto a stack of +attributes. POPCOLOR removes the top of the stack and restores the +previous attributes set by the argument of a prior PUSHCOLOR. LOCALCOLOR +surrounds its argument in a PUSHCOLOR and POPCOLOR so that the color +resets afterward. + +When using PUSHCOLOR, POPCOLOR, and LOCALCOLOR, it's particularly +important to not put commas between the constants. + + print PUSHCOLOR BLUE "Text\n"; + +will correctly push BLUE onto the top of the stack. + + print PUSHCOLOR, BLUE, "Text\n"; # wrong! + +will not, and a subsequent pop won't restore the correct attributes. +PUSHCOLOR pushes the attributes set by its argument, which is normally a +string of color constants. It can't ask the terminal what the current +attributes are. + +=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 or +PUSHCOLOR/POPCOLOR.) + +For easier debugging, you may prefer to always use the commas when not +setting $Term::ANSIColor::AUTORESET or PUSHCOLOR/POPCOLOR 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-048 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 faint under blink reverse conceal + ------------------------------------------------------------------------ + xterm yes yes no yes yes 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 (strike-through) 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, 2005, 2006, 2008, 2009 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. + +PUSHCOLOR, POPCOLOR, and LOCALCOLOR were contributed by openmethods.com +voice solutions. + +=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..004a03c4124 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Term/Cap.pm @@ -0,0 +1,799 @@ +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.12'; + +# 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. +# Version 1.10: Thu Oct 18 16:52:20 BST 2007 +# Don't use try to use $ENV{HOME} if it doesn't exist +# Give Win32 'dumb' if TERM isn't set +# Provide fallback 'dumb' termcap entry as last resort +# Version 1.11: Thu Oct 25 09:33:07 BST 2007 +# EBDIC fixes from Chun Bing Ge <gecb@cn.ibm.com> +# Version 1.12: Sat Dec 8 00:10:21 GMT 2007 +# QNX test fix from Matt Kraai <kraai@ftbfs.org> +# +# TODO: +# support Berkeley DB termcaps +# 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, + exists $ENV{'HOME'} ? $ENV{'HOME'} . '/.termcap' : undef, + '/etc/termcap', '/usr/share/misc/termcap', ); + } + + # return the list of those termcaps that exist + return grep { defined $_ && -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}; + } + + unless ( $self->{TERM} ) + { + if ( $ENV{TERM} ) + { + $self->{TERM} = $ENV{TERM} ; + } + else + { + if ( $^O eq 'Win32' ) + { + $self->{TERM} = 'dumb'; + } + else + { + 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; + } + }; + } + else + { + # this is getting desperate now + if ( $self->{TERM} eq 'dumb' ) + { + $entry = 'dumb|80-column dumb tty::am::co#80::bl=^G:cr=^M:do=^J:sf=^J:'; + } + } + } + } + + 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; + if ( ord('A') == 193 ) + { + s/\\E/\047/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/\\\^/\337/g; + s/\^\?/\007/g; + s/\^(.)/pack('c',ord($1) & 31)/eg; + s/\\(.)/$1/g; + s/\337/^/g; + } + else + { + 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..29acb849015 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Term/ReadLine.pm @@ -0,0 +1,416 @@ +=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 = Term::ReadLine->new('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 = Term::ReadLine->new('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; + my $consoleOUT; + + if ($^O eq 'MacOS') { + $console = "Dev:Console"; + } elsif (-e "/dev/tty") { + $console = "/dev/tty"; + } elsif (-e "con" or $^O eq 'MSWin32') { + $console = 'CONIN$'; + $consoleOUT = 'CONOUT$'; + } 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 unless defined $consoleOUT; + $console = "&STDIN" unless defined $console; + if (!defined $consoleOUT) { + $consoleOUT = defined fileno(STDERR) && $^O ne 'MSWin32' ? "&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; + + + # the Windows CONIN$ needs GENERIC_WRITE mode to allow + # a SetConsoleMode() if we end up using Term::ReadKey + open FIN, ( $^O eq 'MSWin32' && $console eq 'CONIN$' ) ? "+<$console" : + "<$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 } + +sub get_line { + my $self = shift; + my $in = $self->IN; + local ($/) = "\n"; + return scalar <$in>; +} + +package Term::ReadLine; # So late to allow the above code be defined? + +our $VERSION = '1.05'; + +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;"; + } elsif ($which =~ /^(Stub|TermCap|Tk)$/) { + # it is already in memory to avoid false exception as seen in: + # PERL_RL=Stub perl -e'$SIG{__DIE__} = sub { print @_ }; require Term::ReadLine' + } 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; + diff --git a/Master/tlpkg/tlperl/lib/Term/UI.pm b/Master/tlpkg/tlperl/lib/Term/UI.pm new file mode 100644 index 00000000000..136f75bb6ad --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Term/UI.pm @@ -0,0 +1,620 @@ +package Term::UI; + +use Carp; +use Params::Check qw[check allow]; +use Term::ReadLine; +use Locale::Maketext::Simple Style => 'gettext'; +use Term::UI::History; + +use strict; + +BEGIN { + use vars qw[$VERSION $AUTOREPLY $VERBOSE $INVALID]; + $VERBOSE = 1; + $VERSION = '0.20'; + $INVALID = loc('Invalid selection, please try again: '); +} + +push @Term::ReadLine::Stub::ISA, __PACKAGE__ + unless grep { $_ eq __PACKAGE__ } @Term::ReadLine::Stub::ISA; + + +=pod + +=head1 NAME + +Term::UI - Term::ReadLine UI made easy + +=head1 SYNOPSIS + + use Term::UI; + use Term::ReadLine; + + my $term = Term::ReadLine->new('brand'); + + my $reply = $term->get_reply( + prompt => 'What is your favourite colour?', + choices => [qw|blue red green|], + default => blue, + ); + + my $bool = $term->ask_yn( + prompt => 'Do you like cookies?', + default => 'y', + ); + + + my $string = q[some_command -option --no-foo --quux='this thing']; + + my ($options,$munged_input) = $term->parse_options($string); + + + ### don't have Term::UI issue warnings -- default is '1' + $Term::UI::VERBOSE = 0; + + ### always pick the default (good for non-interactive terms) + ### -- default is '0' + $Term::UI::AUTOREPLY = 1; + + ### Retrieve the entire session as a printable string: + $hist = Term::UI::History->history_as_string; + $hist = $term->history_as_string; + +=head1 DESCRIPTION + +C<Term::UI> is a transparent way of eliminating the overhead of having +to format a question and then validate the reply, informing the user +if the answer was not proper and re-issuing the question. + +Simply give it the question you want to ask, optionally with choices +the user can pick from and a default and C<Term::UI> will DWYM. + +For asking a yes or no question, there's even a shortcut. + +=head1 HOW IT WORKS + +C<Term::UI> places itself at the back of the C<Term::ReadLine> +C<@ISA> array, so you can call its functions through your term object. + +C<Term::UI> uses C<Term::UI::History> to record all interactions +with the commandline. You can retrieve this history, or alter +the filehandle the interaction is printed to. See the +C<Term::UI::History> manpage or the C<SYNOPSIS> for details. + +=head1 METHODS + +=head2 $reply = $term->get_reply( prompt => 'question?', [choices => \@list, default => $list[0], multi => BOOL, print_me => "extra text to print & record", allow => $ref] ); + +C<get_reply> asks a user a question, and then returns the reply to the +caller. If the answer is invalid (more on that below), the question will +be reposed, until a satisfactory answer has been entered. + +You have the option of providing a list of choices the user can pick from +using the C<choices> argument. If the answer is not in the list of choices +presented, the question will be reposed. + +If you provide a C<default> answer, this will be returned when either +C<$AUTOREPLY> is set to true, (see the C<GLOBAL VARIABLES> section further +below), or when the user just hits C<enter>. + +You can indicate that the user is allowed to enter multiple answers by +toggling the C<multi> flag. Note that a list of answers will then be +returned to you, rather than a simple string. + +By specifying an C<allow> hander, you can yourself validate the answer +a user gives. This can be any of the types that the Params::Check C<allow> +function allows, so please refer to that manpage for details. + +Finally, you have the option of adding a C<print_me> argument, which is +simply printed before the prompt. It's printed to the same file handle +as the rest of the questions, so you can use this to keep track of a +full session of Q&A with the user, and retrieve it later using the +C<< Term::UI->history_as_string >> function. + +See the C<EXAMPLES> section for samples of how to use this function. + +=cut + +sub get_reply { + my $term = shift; + my %hash = @_; + + my $tmpl = { + default => { default => undef, strict_type => 1 }, + prompt => { default => '', strict_type => 1, required => 1 }, + choices => { default => [], strict_type => 1 }, + multi => { default => 0, allow => [0, 1] }, + allow => { default => qr/.*/ }, + print_me => { default => '', strict_type => 1 }, + }; + + my $args = check( $tmpl, \%hash, $VERBOSE ) + or ( carp( loc(q[Could not parse arguments]) ), return ); + + + ### add this to the prompt to indicate the default + ### answer to the question if there is one. + my $prompt_add; + + ### if you supplied several choices to pick from, + ### we'll print them seperately before the prompt + if( @{$args->{choices}} ) { + my $i; + + for my $choice ( @{$args->{choices}} ) { + $i++; # the answer counter -- but humans start counting + # at 1 :D + + ### so this choice is the default? add it to 'prompt_add' + ### so we can construct a "foo? [DIGIT]" type prompt + $prompt_add = $i if (defined $args->{default} and $choice eq $args->{default}); + + ### create a "DIGIT> choice" type line + $args->{print_me} .= sprintf "\n%3s> %-s", $i, $choice; + } + + ### we listed some choices -- add another newline for + ### pretty printing + $args->{print_me} .= "\n" if $i; + + ### allowable answers are now equal to the choices listed + $args->{allow} = $args->{choices}; + + ### no choices, but a default? set 'prompt_add' to the default + ### to construct a 'foo? [DEFAULT]' type prompt + } elsif ( defined $args->{default} ) { + $prompt_add = $args->{default}; + } + + ### we set up the defaults, prompts etc, dispatch to the readline call + return $term->_tt_readline( %$args, prompt_add => $prompt_add ); + +} + +=head2 $bool = $term->ask_yn( prompt => "your question", [default => (y|1,n|0), print_me => "extra text to print & record"] ) + +Asks a simple C<yes> or C<no> question to the user, returning a boolean +indicating C<true> or C<false> to the caller. + +The C<default> answer will automatically returned, if the user hits +C<enter> or if C<$AUTOREPLY> is set to true. See the C<GLOBAL VARIABLES> +section further below. + +Also, you have the option of adding a C<print_me> argument, which is +simply printed before the prompt. It's printed to the same file handle +as the rest of the questions, so you can use this to keep track of a +full session of Q&A with the user, and retrieve it later using the +C<< Term::UI->history_as_string >> function. + + +See the C<EXAMPLES> section for samples of how to use this function. + +=cut + +sub ask_yn { + my $term = shift; + my %hash = @_; + + my $tmpl = { + default => { default => undef, allow => [qw|0 1 y n|], + strict_type => 1 }, + prompt => { default => '', required => 1, strict_type => 1 }, + print_me => { default => '', strict_type => 1 }, + multi => { default => 0, no_override => 1 }, + choices => { default => [qw|y n|], no_override => 1 }, + allow => { default => [qr/^y(?:es)?$/i, qr/^n(?:o)?$/i], + no_override => 1 + }, + }; + + my $args = check( $tmpl, \%hash, $VERBOSE ) or return undef; + + ### uppercase the default choice, if there is one, to be added + ### to the prompt in a 'foo? [Y/n]' type style. + my $prompt_add; + { my @list = @{$args->{choices}}; + if( defined $args->{default} ) { + + ### if you supplied the default as a boolean, rather than y/n + ### transform it to a y/n now + $args->{default} = $args->{default} =~ /\d/ + ? { 0 => 'n', 1 => 'y' }->{ $args->{default} } + : $args->{default}; + + @list = map { lc $args->{default} eq lc $_ + ? uc $args->{default} + : $_ + } @list; + } + + $prompt_add .= join("/", @list); + } + + my $rv = $term->_tt_readline( %$args, prompt_add => $prompt_add ); + + return $rv =~ /^y/i ? 1 : 0; +} + + + +sub _tt_readline { + my $term = shift; + my %hash = @_; + + local $Params::Check::VERBOSE = 0; # why is this? + local $| = 1; # print ASAP + + + my ($default, $prompt, $choices, $multi, $allow, $prompt_add, $print_me); + my $tmpl = { + default => { default => undef, strict_type => 1, + store => \$default }, + prompt => { default => '', strict_type => 1, required => 1, + store => \$prompt }, + choices => { default => [], strict_type => 1, + store => \$choices }, + multi => { default => 0, allow => [0, 1], store => \$multi }, + allow => { default => qr/.*/, store => \$allow, }, + prompt_add => { default => '', store => \$prompt_add }, + print_me => { default => '', store => \$print_me }, + }; + + check( $tmpl, \%hash, $VERBOSE ) or return; + + ### prompts for Term::ReadLine can't be longer than one line, or + ### it can display wonky on some terminals. + history( $print_me ) if $print_me; + + + ### we might have to add a default value to the prompt, to + ### show the user what will be picked by default: + $prompt .= " [$prompt_add]: " if $prompt_add; + + + ### are we in autoreply mode? + if ($AUTOREPLY) { + + ### you used autoreply, but didnt provide a default! + carp loc( + q[You have '%1' set to true, but did not provide a default!], + '$AUTOREPLY' + ) if( !defined $default && $VERBOSE); + + ### print it out for visual feedback + history( join ' ', grep { defined } $prompt, $default ); + + ### and return the default + return $default; + } + + + ### so, no AUTOREPLY, let's see what the user will answer + LOOP: { + + ### annoying bug in T::R::Perl that mucks up lines with a \n + ### in them; So split by \n, save the last line as the prompt + ### and just print the rest + { my @lines = split "\n", $prompt; + $prompt = pop @lines; + + history( "$_\n" ) for @lines; + } + + ### pose the question + my $answer = $term->readline($prompt); + $answer = $default unless length $answer; + + $term->addhistory( $answer ) if length $answer; + + ### add both prompt and answer to the history + history( "$prompt $answer", 0 ); + + ### if we're allowed to give multiple answers, split + ### the answer on whitespace + my @answers = $multi ? split(/\s+/, $answer) : $answer; + + ### the return value list + my @rv; + + if( @$choices ) { + + for my $answer (@answers) { + + ### a digit implies a multiple choice question, + ### a non-digit is an open answer + if( $answer =~ /\D/ ) { + push @rv, $answer if allow( $answer, $allow ); + } else { + + ### remember, the answer digits are +1 compared to + ### the choices, because humans want to start counting + ### at 1, not at 0 + push @rv, $choices->[ $answer - 1 ] + if $answer > 0 && defined $choices->[ $answer - 1]; + } + } + + ### no fixed list of choices.. just check if the answers + ### (or otherwise the default!) pass the allow handler + } else { + push @rv, grep { allow( $_, $allow ) } + scalar @answers ? @answers : ($default); + } + + ### if not all the answers made it to the return value list, + ### at least one of them was an invalid answer -- make the + ### user do it again + if( (@rv != @answers) or + (scalar(@$choices) and not scalar(@answers)) + ) { + $prompt = $INVALID; + $prompt .= "[$prompt_add] " if $prompt_add; + redo LOOP; + + ### otherwise just return the answer, or answers, depending + ### on the multi setting + } else { + return $multi ? @rv : $rv[0]; + } + } +} + +=head2 ($opts, $munged) = $term->parse_options( STRING ); + +C<parse_options> will convert all options given from an input string +to a hash reference. If called in list context it will also return +the part of the input string that it found no options in. + +Consider this example: + + my $str = q[command --no-foo --baz --bar=0 --quux=bleh ] . + q[--option="some'thing" -one-dash -single=blah' arg]; + + my ($options,$munged) = $term->parse_options($str); + + ### $options would contain: ### + $options = { + 'foo' => 0, + 'bar' => 0, + 'one-dash' => 1, + 'baz' => 1, + 'quux' => 'bleh', + 'single' => 'blah\'', + 'option' => 'some\'thing' + }; + + ### and this is the munged version of the input string, + ### ie what's left of the input minus the options + $munged = 'command arg'; + +As you can see, you can either use a single or a double C<-> to +indicate an option. +If you prefix an option with C<no-> and do not give it a value, it +will be set to 0. +If it has no prefix and no value, it will be set to 1. +Otherwise, it will be set to its value. Note also that it can deal +fine with single/double quoting issues. + +=cut + +sub parse_options { + my $term = shift; + my $input = shift; + + my $return = {}; + + ### there's probably a more elegant way to do this... ### + while ( $input =~ s/(?:^|\s+)--?([-\w]+=("|').+?\2)(?=\Z|\s+)// or + $input =~ s/(?:^|\s+)--?([-\w]+=\S+)(?=\Z|\s+)// or + $input =~ s/(?:^|\s+)--?([-\w]+)(?=\Z|\s+)// + ) { + my $match = $1; + + if( $match =~ /^([-\w]+)=("|')(.+?)\2$/ ) { + $return->{$1} = $3; + + } elsif( $match =~ /^([-\w]+)=(\S+)$/ ) { + $return->{$1} = $2; + + } elsif( $match =~ /^no-?([-\w]+)$/i ) { + $return->{$1} = 0; + + } elsif ( $match =~ /^([-\w]+)$/ ) { + $return->{$1} = 1; + + } else { + carp(loc(q[I do not understand option "%1"\n], $match)) if $VERBOSE; + } + } + + return wantarray ? ($return,$input) : $return; +} + +=head2 $str = $term->history_as_string + +Convenience wrapper around C<< Term::UI::History->history_as_string >>. + +Consult the C<Term::UI::History> man page for details. + +=cut + +sub history_as_string { return Term::UI::History->history_as_string }; + +1; + +=head1 GLOBAL VARIABLES + +The behaviour of Term::UI can be altered by changing the following +global variables: + +=head2 $Term::UI::VERBOSE + +This controls whether Term::UI will issue warnings and explanations +as to why certain things may have failed. If you set it to 0, +Term::UI will not output any warnings. +The default is 1; + +=head2 $Term::UI::AUTOREPLY + +This will make every question be answered by the default, and warn if +there was no default provided. This is particularly useful if your +program is run in non-interactive mode. +The default is 0; + +=head2 $Term::UI::INVALID + +This holds the string that will be printed when the user makes an +invalid choice. +You can override this string from your program if you, for example, +wish to do localization. +The default is C<Invalid selection, please try again: > + +=head2 $Term::UI::History::HISTORY_FH + +This is the filehandle all the print statements from this module +are being sent to. Please consult the C<Term::UI::History> manpage +for details. + +This defaults to C<*STDOUT>. + +=head1 EXAMPLES + +=head2 Basic get_reply sample + + ### ask a user (with an open question) for their favourite colour + $reply = $term->get_reply( prompt => 'Your favourite colour? ); + +which would look like: + + Your favourite colour? + +and C<$reply> would hold the text the user typed. + +=head2 get_reply with choices + + ### now provide a list of choices, so the user has to pick one + $reply = $term->get_reply( + prompt => 'Your favourite colour?', + choices => [qw|red green blue|] ); + +which would look like: + + 1> red + 2> green + 3> blue + + Your favourite colour? + +C<$reply> will hold one of the choices presented. C<Term::UI> will repose +the question if the user attempts to enter an answer that's not in the +list of choices. The string presented is held in the C<$Term::UI::INVALID> +variable (see the C<GLOBAL VARIABLES> section for details. + +=head2 get_reply with choices and default + + ### provide a sensible default option -- everyone loves blue! + $reply = $term->get_reply( + prompt => 'Your favourite colour?', + choices => [qw|red green blue|], + default => 'blue' ); + +which would look like: + + 1> red + 2> green + 3> blue + + Your favourite colour? [3]: + +Note the default answer after the prompt. A user can now just hit C<enter> +(or set C<$Term::UI::AUTOREPLY> -- see the C<GLOBAL VARIABLES> section) and +the sensible answer 'blue' will be returned. + +=head2 get_reply using print_me & multi + + ### allow the user to pick more than one colour and add an + ### introduction text + @reply = $term->get_reply( + print_me => 'Tell us what colours you like', + prompt => 'Your favourite colours?', + choices => [qw|red green blue|], + multi => 1 ); + +which would look like: + + Tell us what colours you like + 1> red + 2> green + 3> blue + + Your favourite colours? + +An answer of C<3 2 1> would fill C<@reply> with C<blue green red> + +=head2 get_reply & allow + + ### pose an open question, but do a custom verification on + ### the answer, which will only exit the question loop, if + ### the answer matches the allow handler. + $reply = $term->get_reply( + prompt => "What is the magic number?", + allow => 42 ); + +Unless the user now enters C<42>, the question will be reposed over +and over again. You can use more sophisticated C<allow> handlers (even +subroutines can be used). The C<allow> handler is implemented using +C<Params::Check>'s C<allow> function. Check its manpage for details. + +=head2 an elaborate ask_yn sample + + ### ask a user if he likes cookies. Default to a sensible 'yes' + ### and inform him first what cookies are. + $bool = $term->ask_yn( prompt => 'Do you like cookies?', + default => 'y', + print_me => 'Cookies are LOVELY!!!' ); + +would print: + + Cookies are LOVELY!!! + Do you like cookies? [Y/n]: + +If a user then simply hits C<enter>, agreeing with the default, +C<$bool> would be set to C<true>. (Simply hitting 'y' would also +return C<true>. Hitting 'n' would return C<false>) + +We could later retrieve this interaction by printing out the Q&A +history as follows: + + print $term->history_as_string; + +which would then print: + + Cookies are LOVELY!!! + Do you like cookies? [Y/n]: y + +There's a chance we're doing this non-interactively, because a console +is missing, the user indicated he just wanted the defaults, etc. + +In this case, simply setting C<$Term::UI::AUTOREPLY> to true, will +return from every question with the default answer set for the question. +Do note that if C<AUTOREPLY> is true, and no default is set, C<Term::UI> +will warn about this and return C<undef>. + +=head1 See Also + +C<Params::Check>, C<Term::ReadLine>, C<Term::UI::History> + +=head1 BUG REPORTS + +Please report bugs or other issues to E<lt>bug-term-ui@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/tlperl/lib/Term/UI/History.pm b/Master/tlpkg/tlperl/lib/Term/UI/History.pm new file mode 100644 index 00000000000..1d77c01c6f6 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Term/UI/History.pm @@ -0,0 +1,137 @@ +package Term::UI::History; + +use strict; +use base 'Exporter'; +use base 'Log::Message::Simple'; + +=pod + +=head1 NAME + +Term::UI::History + +=head1 SYNOPSIS + + use Term::UI::History qw[history]; + + history("Some message"); + + ### retrieve the history in printable form + $hist = Term::UI::History->history_as_string; + + ### redirect output + local $Term::UI::History::HISTORY_FH = \*STDERR; + +=head1 DESCRIPTION + +This module provides the C<history> function for C<Term::UI>, +printing and saving all the C<UI> interaction. + +Refer to the C<Term::UI> manpage for details on usage from +C<Term::UI>. + +This module subclasses C<Log::Message::Simple>. Refer to its +manpage for additional functionality available via this package. + +=head1 FUNCTIONS + +=head2 history("message string" [,VERBOSE]) + +Records a message on the stack, and prints it to C<STDOUT> +(or actually C<$HISTORY_FH>, see the C<GLOBAL VARIABLES> section +below), if the C<VERBOSE> option is true. + +The C<VERBOSE> option defaults to true. + +=cut + +BEGIN { + use Log::Message private => 0; + + use vars qw[ @EXPORT $HISTORY_FH ]; + @EXPORT = qw[ history ]; + my $log = new Log::Message; + $HISTORY_FH = \*STDOUT; + + for my $func ( @EXPORT ) { + no strict 'refs'; + + *$func = sub { my $msg = shift; + $log->store( + message => $msg, + tag => uc $func, + level => $func, + extra => [@_] + ); + }; + } + + sub history_as_string { + my $class = shift; + + return join $/, map { $_->message } __PACKAGE__->stack; + } +} + + +{ package Log::Message::Handlers; + + sub history { + my $self = shift; + my $verbose = shift; + $verbose = 1 unless defined $verbose; # default to true + + ### so you don't want us to print the msg? ### + return if defined $verbose && $verbose == 0; + + local $| = 1; + my $old_fh = select $Term::UI::History::HISTORY_FH; + + print $self->message . "\n"; + select $old_fh; + + return; + } +} + + +=head1 GLOBAL VARIABLES + +=over 4 + +=item $HISTORY_FH + +This is the filehandle all the messages sent to C<history()> are being +printed. This defaults to C<*STDOUT>. + +=back + +=head1 See Also + +C<Log::Message::Simple>, C<Term::UI> + +=head1 AUTHOR + +This module by +Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +This module is +copyright (c) 2005 Jos Boumans E<lt>kane@cpan.orgE<gt>. +All rights reserved. + +This library is free software; +you may redistribute and/or modify it under the same +terms as Perl itself. + +=cut + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: |