summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl0/lib/Term
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl0/lib/Term')
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Term/ANSIColor.pm725
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Term/Cap.pm799
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Term/Complete.pm188
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Term/ReadKey.pm572
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Term/ReadLine.pm413
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Term/ReadLine/Perl.pm153
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Term/ReadLine/readline.pm4615
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Term/UI.pm620
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Term/UI/History.pm137
9 files changed, 8222 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl0/lib/Term/ANSIColor.pm b/Master/tlpkg/tlperl0/lib/Term/ANSIColor.pm
new file mode 100755
index 00000000000..72b941f6211
--- /dev/null
+++ b/Master/tlpkg/tlperl0/lib/Term/ANSIColor.pm
@@ -0,0 +1,725 @@
+# Term::ANSIColor -- Color screen output using ANSI escape sequences.
+#
+# Copyright 1996, 1997, 1998, 2000, 2001, 2002, 2005, 2006, 2008, 2009, 2010
+# 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 = '3.00';
+
+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
+
+ BRIGHT_BLACK BRIGHT_RED BRIGHT_GREEN BRIGHT_YELLOW
+ BRIGHT_BLUE BRIGHT_MAGENTA BRIGHT_CYAN BRIGHT_WHITE
+ ON_BRIGHT_BLACK ON_BRIGHT_RED ON_BRIGHT_GREEN ON_BRIGHT_YELLOW
+ ON_BRIGHT_BLUE ON_BRIGHT_MAGENTA ON_BRIGHT_CYAN ON_BRIGHT_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,
+
+ 'bright_black' => 90, 'on_bright_black' => 100,
+ 'bright_red' => 91, 'on_bright_red' => 101,
+ 'bright_green' => 92, 'on_bright_green' => 102,
+ 'bright_yellow' => 93, 'on_bright_yellow' => 103,
+ 'bright_blue' => 94, 'on_bright_blue' => 104,
+ 'bright_magenta' => 95, 'on_bright_magenta' => 105,
+ 'bright_cyan' => 96, 'on_bright_cyan' => 106,
+ 'bright_white' => 97, 'on_bright_white' => 107,
+ );
+
+# 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
+grey ATTR
+
+=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.', "\n";
+ print colored ['red on_bright_yellow'] 'Red on bright yellow.', "\n";
+ print colored ['bright_red on_black], 'Bright red on black.', "\n";
+ 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 BRIGHT_BLUE "This text is bright blue on green.\n";
+ print RESET BRIGHT_BLUE "This text is just bright 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 Supported Colors
+
+Terminal emulators that support color divide into two types: ones that
+support only eight colors, and ones that support sixteen. This module
+provides both the ANSI escape codes for the "normal" colors, supported by
+both types, as well as the additional colors supported by sixteen-color
+emulators. These colors are referred to as ANSI colors 0 through 7
+(normal) and 8 through 15.
+
+Unfortunately, interpretation of colors 0 through 7 often depends on
+whether the emulator supports eight colors or sixteen colors. Emulators
+that only support eight colors (such as the Linux console) will display
+colors 0 through 7 with normal brightness and ignore colors 8 through 15,
+treating them the same as white. Emulators that support 16 colors, such
+as gnome-terminal, normally display colors 0 through 7 as dim or darker
+versions and colors 8 through 15 as normal brightness. On such emulators,
+the "normal" white (color 7) usually is shown as pale grey, requiring
+bright white (15) to be used to get a real white color. Bright black
+usually is a dark grey color, although some terminals display it as pure
+black. Some sixteen-color terminal emulators also treat normal yellow
+(color 3) as orange or brown, and bright yellow (color 11) as yellow.
+
+Following the normal convention of sixteen-color emulators, this module
+provides a pair of attributes for each color. For every normal color (0
+through 7), the corresponding bright color (8 through 15) is obtained by
+prepending the string C<bright_> to the normal color name. For example,
+C<red> is color 1 and C<bright_red> is color 9. The same applies for
+background colors: C<on_red> is the normal color and C<on_bright_red> is
+the bright color. Capitalize these strings for the constant interface.
+
+There is unfortunately no way to know whether the current emulator
+supports sixteen colors or not, which makes the choice of colors
+difficult. The most conservative choice is to use only the regular
+colors, which are at least displayed on all emulators. However, they will
+appear dark in sixteen-color terminal emulators, including most common
+emulators in UNIX X environments. If you know the display is one of those
+emulators, you may wish to use the bright variants instead. Even better,
+offer the user a way to configure the colors for a given application to
+fit their terminal emulator.
+
+Support for colors 8 through 15 (the C<bright_> variants) was added in
+Term::ANSIColor 3.0.
+
+=head2 Function Interface
+
+The function interface uses attribute strings to describe the colors and
+text attributes to assign to text. 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.
+
+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.
+
+The recognized normal foreground color attributes (colors 0 to 7) are:
+
+ black red green yellow blue magenta cyan white
+
+The corresponding bright foreground color attributes (colors 8 to 15) are:
+
+ bright_black bright_red bright_green bright_yellow
+ bright_blue bright_magenta bright_cyan bright_white
+
+The recognized normal background color attributes (colors 0 to 7) are:
+
+ on_black on_red on_green on yellow
+ on_blue on_magenta on_cyan on_white
+
+The recognized bright background color attributes (colors 8 to 15) are:
+
+ on_bright_black on_bright_red on_bright_green on_bright_yellow
+ on_bright_blue on_bright_magenta on_bright_cyan on_bright_white
+
+For any of the above listed attributes, case is not significant.
+
+Attributes, once set, last until they are unset (by printing 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.
+
+=over 4
+
+=item color(ATTR[, ATTR ...])
+
+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.
+
+=item colored(STRING, ATTRIBUTES)
+
+=item colored(ATTR-REF, STRING[, STRING...])
+
+As an aid in resetting colors, 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.
+
+=item uncolor(ESCAPE)
+
+uncolor() performs the opposite translation as color(), turning escape
+sequences into a list of strings corresponding to the attributes being set
+by those sequences.
+
+=item colorstrip(STRING[, STRING ...])
+
+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.
+
+=item colorvalid(ATTR[, ATTR ...])
+
+colorvalid() takes attribute strings the same as color() and returns true
+if all attributes are known and false otherwise.
+
+=back
+
+=head2 Constant Interface
+
+Alternately, if you import C<:constants>, you can use the following
+constants directly:
+
+ CLEAR RESET BOLD DARK
+ FAINT UNDERLINE UNDERSCORE BLINK
+ REVERSE CONCEALED
+
+ BLACK RED GREEN YELLOW
+ BLUE MAGENTA CYAN WHITE
+ BRIGHT_BLACK BRIGHT_RED BRIGHT_GREEN BRIGHT_YELLOW
+ BRIGHT_BLUE BRIGHT_MAGENTA BRIGHT_CYAN BRIGHT_WHITE
+
+ ON_BLACK ON_RED ON_GREEN ON_YELLOW
+ ON_BLUE ON_MAGENTA ON_CYAN ON_WHITE
+ ON_BRIGHT_BLACK ON_BRIGHT_RED ON_BRIGHT_GREEN ON_BRIGHT_YELLOW
+ ON_BRIGHT_BLUE ON_BRIGHT_MAGENTA ON_BRIGHT_CYAN ON_BRIGHT_WHITE
+
+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
+thirty-eight 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, 2010
+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/tlperl0/lib/Term/Cap.pm b/Master/tlpkg/tlperl0/lib/Term/Cap.pm
new file mode 100755
index 00000000000..004a03c4124
--- /dev/null
+++ b/Master/tlpkg/tlperl0/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/tlperl0/lib/Term/Complete.pm b/Master/tlpkg/tlperl0/lib/Term/Complete.pm
new file mode 100755
index 00000000000..601e4956430
--- /dev/null
+++ b/Master/tlpkg/tlperl0/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/tlperl0/lib/Term/ReadKey.pm b/Master/tlpkg/tlperl0/lib/Term/ReadKey.pm
new file mode 100755
index 00000000000..92a2c22ec8f
--- /dev/null
+++ b/Master/tlpkg/tlperl0/lib/Term/ReadKey.pm
@@ -0,0 +1,572 @@
+#
+# $Id: ReadKey.pm,v 2.23 2005/01/11 21:16:31 jonathan Exp $
+#
+
+=head1 NAME
+
+Term::ReadKey - A perl module for simple terminal control
+
+=head1 SYNOPSIS
+
+ use Term::ReadKey;
+ ReadMode 4; # Turn off controls keys
+ while (not defined ($key = ReadKey(-1))) {
+ # No key yet
+ }
+ print "Get key $key\n";
+ ReadMode 0; # Reset tty mode before exiting
+
+=head1 DESCRIPTION
+
+Term::ReadKey is a compiled perl module dedicated to providing simple
+control over terminal driver modes (cbreak, raw, cooked, etc.,) support for
+non-blocking reads, if the architecture allows, and some generalized handy
+functions for working with terminals. One of the main goals is to have the
+functions as portable as possible, so you can just plug in "use
+Term::ReadKey" on any architecture and have a good likelyhood of it working.
+
+Version 2.30.01:
+Added handling of arrows, page up/down, home/end, insert/delete keys
+under Win32. These keys emit xterm-compatible sequences.
+Works with Term::ReadLine::Perl.
+
+=over 8
+
+=item ReadMode MODE [, Filehandle]
+
+Takes an integer argument, which can currently be one of the following
+values:
+
+ 0 Restore original settings.
+ 1 Change to cooked mode.
+ 2 Change to cooked mode with echo off.
+ (Good for passwords)
+ 3 Change to cbreak mode.
+ 4 Change to raw mode.
+ 5 Change to ultra-raw mode.
+ (LF to CR/LF translation turned off)
+
+ Or, you may use the synonyms:
+
+ restore
+ normal
+ noecho
+ cbreak
+ raw
+ ultra-raw
+
+These functions are automatically applied to the STDIN handle if no
+other handle is supplied. Modes 0 and 5 have some special properties
+worth mentioning: not only will mode 0 restore original settings, but it
+cause the next ReadMode call to save a new set of default settings. Mode
+5 is similar to mode 4, except no CR/LF translation is performed, and if
+possible, parity will be disabled (only if not being used by the terminal,
+however. It is no different from mode 4 under Windows.)
+
+If you are executing another program that may be changing the terminal mode,
+you will either want to say
+
+ ReadMode 1
+ system('someprogram');
+ ReadMode 1;
+
+which resets the settings after the program has run, or:
+
+ $somemode=1;
+ ReadMode 0;
+ system('someprogram');
+ ReadMode 1;
+
+which records any changes the program may have made, before resetting the
+mode.
+
+=item ReadKey MODE [, Filehandle]
+
+Takes an integer argument, which can currently be one of the following
+values:
+
+ 0 Perform a normal read using getc
+ -1 Perform a non-blocked read
+ >0 Perform a timed read
+
+(If the filehandle is not supplied, it will default to STDIN.) If there is
+nothing waiting in the buffer during a non-blocked read, then undef will be
+returned. Note that if the OS does not provide any known mechanism for
+non-blocking reads, then a C<ReadKey -1> can die with a fatal error. This
+will hopefully not be common.
+
+If MODE is greater then zero, then ReadKey will use it as a timeout value in
+seconds (fractional seconds are allowed), and won't return C<undef> until
+that time expires. (Note, again, that some OS's may not support this timeout
+behaviour.) If MODE is less then zero, then this is treated as a timeout
+of zero, and thus will return immediately if no character is waiting. A MODE
+of zero, however, will act like a normal getc.
+
+There are currently some limitations with this call under Windows. It may be
+possible that non-blocking reads will fail when reading repeating keys from
+more then one console.
+
+=item ReadLine MODE [, Filehandle]
+
+Takes an integer argument, which can currently be one of the following
+values:
+
+ 0 Perform a normal read using scalar(<FileHandle>)
+ -1 Perform a non-blocked read
+ >0 Perform a timed read
+
+If there is nothing waiting in the buffer during a non-blocked read, then
+undef will be returned. Note that if the OS does not provide any known
+mechanism for non-blocking reads, then a C<ReadLine 1> can die with a fatal
+error. This will hopefully not be common. Note that a non-blocking test is
+only performed for the first character in the line, not the entire line.
+This call will probably B<not> do what you assume, especially with
+ReadMode's higher then 1. For example, pressing Space and then Backspace
+would appear to leave you where you started, but any timeouts would now
+be suspended.
+
+This call is currently not available under Windows.
+
+=item GetTerminalSize [Filehandle]
+
+Returns either an empty array if this operation is unsupported, or a four
+element array containing: the width of the terminal in characters, the
+height of the terminal in character, the width in pixels, and the height in
+pixels. (The pixel size will only be valid in some environments.)
+
+Under Windows, this function must be called with an "output" filehandle,
+such as STDOUT, or a handle opened to CONOUT$.
+
+=item SetTerminalSize WIDTH,HEIGHT,XPIX,YPIX [, Filehandle]
+
+Return -1 on failure, 0 otherwise. Note that this terminal size is only for
+B<informative> value, and changing the size via this mechanism will B<not>
+change the size of the screen. For example, XTerm uses a call like this when
+it resizes the screen. If any of the new measurements vary from the old, the
+OS will probably send a SIGWINCH signal to anything reading that tty or pty.
+
+This call does not work under Windows.
+
+=item GetSpeeds [, Filehandle]
+
+Returns either an empty array if the operation is unsupported, or a two
+value array containing the terminal in and out speeds, in B<decimal>. E.g,
+an in speed of 9600 baud and an out speed of 4800 baud would be returned as
+(9600,4800). Note that currently the in and out speeds will always be
+identical in some OS's. No speeds are reported under Windows.
+
+=item GetControlChars [, Filehandle]
+
+Returns an array containing key/value pairs suitable for a hash. The pairs
+consist of a key, the name of the control character/signal, and the value
+of that character, as a single character. This call does nothing under Windows.
+
+Each key will be an entry from the following list:
+
+ DISCARD
+ DSUSPEND
+ EOF
+ EOL
+ EOL2
+ ERASE
+ ERASEWORD
+ INTERRUPT
+ KILL
+ MIN
+ QUIT
+ QUOTENEXT
+ REPRINT
+ START
+ STATUS
+ STOP
+ SUSPEND
+ SWITCH
+ TIME
+
+Thus, the following will always return the current interrupt character,
+regardless of platform.
+
+ %keys = GetControlChars;
+ $int = $keys{INTERRUPT};
+
+=item SetControlChars [, Filehandle]
+
+Takes an array containing key/value pairs, as a hash will produce. The pairs
+should consist of a key that is the name of a legal control
+character/signal, and the value should be either a single character, or a
+number in the range 0-255. SetControlChars will die with a runtime error if
+an invalid character name is passed or there is an error changing the
+settings. The list of valid names is easily available via
+
+ %cchars = GetControlChars();
+ @cnames = keys %cchars;
+
+This call does nothing under Windows.
+
+=back
+
+=head1 AUTHOR
+
+Kenneth Albanowski <kjahds@kjahds.com>
+
+Currently maintained by Jonathan Stowe <jns@gellyfish.com>
+
+=cut
+
+package Term::ReadKey;
+
+$VERSION = '2.30.01';
+
+require Exporter;
+require AutoLoader;
+require DynaLoader;
+use Carp;
+
+@ISA = qw(Exporter AutoLoader DynaLoader);
+
+# Items to export into callers namespace by default
+# (move infrequently used names to @EXPORT_OK below)
+
+@EXPORT = qw(
+ ReadKey
+ ReadMode
+ ReadLine
+ GetTerminalSize
+ SetTerminalSize
+ GetSpeed
+ GetControlChars
+ SetControlChars
+);
+
+@EXPORT_OK = qw();
+
+bootstrap Term::ReadKey;
+
+# Preloaded methods go here. Autoload methods go after __END__, and are
+# processed by the autosplit program.
+
+# Should we use LINES and COLUMNS to try and get the terminal size?
+# Change this to zero if you have systems where these are commonly
+# set to erroneous values. (But if either are nero zero, they won't be
+# used anyhow.)
+
+$UseEnv = 1;
+
+$CurrentMode = 0;
+
+%modes = (
+ original => 0,
+ restore => 0,
+ normal => 1,
+ noecho => 2,
+ cbreak => 3,
+ raw => 4,
+ 'ultra-raw' => 5
+);
+
+sub ReadMode
+{
+ my ($mode) = $modes{ $_[0] };
+ my ($fh) = normalizehandle( ( @_ > 1 ? $_[1] : \*STDIN ) );
+ if ( defined($mode) ) { $CurrentMode = $mode }
+ elsif ( $_[0] =~ /^\d/ ) { $CurrentMode = $_[0] }
+ else { croak("Unknown terminal mode `$_[0]'"); }
+ SetReadMode($CurrentMode, $fh);
+}
+
+sub normalizehandle
+{
+ my ($file) = @_;
+
+ # print "Handle = $file\n";
+ if ( ref($file) ) { return $file; } # Reference is fine
+
+ # if($file =~ /^\*/) { return $file; } # Type glob is good
+ if ( ref( \$file ) eq 'GLOB' ) { return $file; } # Glob is good
+
+ # print "Caller = ",(caller(1))[0],"\n";
+ return \*{ ( ( caller(1) )[0] ) . "::$file" };
+}
+
+sub GetTerminalSize
+{
+ my ($file) = normalizehandle( ( @_ > 1 ? $_[1] : \*STDOUT ) );
+ my (@results) = ();
+ my (@fail);
+
+ if ( &termsizeoptions() & 1 ) # VIO
+ {
+ @results = GetTermSizeVIO($file);
+ push( @fail, "VIOGetMode call" );
+ }
+ elsif ( &termsizeoptions() & 2 ) # GWINSZ
+ {
+ @results = GetTermSizeGWINSZ($file);
+ push( @fail, "TIOCGWINSZ ioctl" );
+ }
+ elsif ( &termsizeoptions() & 4 ) # GSIZE
+ {
+ @results = GetTermSizeGSIZE($file);
+ push( @fail, "TIOCGSIZE ioctl" );
+ }
+ elsif ( &termsizeoptions() & 8 ) # WIN32
+ {
+ @results = GetTermSizeWin32($file);
+ push( @fail, "Win32 GetConsoleScreenBufferInfo call" );
+ }
+ else
+ {
+ @results = ();
+ }
+
+ if ( @results < 4 and $UseEnv )
+ {
+ my ($C) = defined( $ENV{COLUMNS} ) ? $ENV{COLUMNS} : 0;
+ my ($L) = defined( $ENV{LINES} ) ? $ENV{LINES} : 0;
+ if ( ( $C >= 2 ) and ( $L >= 2 ) )
+ {
+ @results = ( $C + 0, $L + 0, 0, 0 );
+ }
+ push( @fail, "COLUMNS and LINES environment variables" );
+ }
+
+ if ( @results < 4 )
+ {
+ my ($prog) = "resize";
+
+ # Workaround for Solaris path sillyness
+ if ( -f "/usr/openwin/bin/resize" ) {
+ $prog = "/usr/openwin/bin/resize";
+ }
+
+ my ($resize) = scalar(`$prog 2>/dev/null`);
+ if (
+ defined $resize
+ and ( $resize =~ /COLUMNS\s*=\s*(\d+)/
+ or $resize =~ /setenv\s+COLUMNS\s+'?(\d+)/ )
+ )
+ {
+ $results[0] = $1;
+ if ( $resize =~ /LINES\s*=\s*(\d+)/
+ or $resize =~ /setenv\s+LINES\s+'?(\d+)/ )
+ {
+ $results[1] = $1;
+ @results[ 2, 3 ] = ( 0, 0 );
+ }
+ else
+ {
+ @results = ();
+ }
+ }
+ else
+ {
+ @results = ();
+ }
+ push( @fail, "resize program" );
+ }
+
+ if ( @results < 4 )
+ {
+ die "Unable to get Terminal Size."
+ . join( "", map( " The $_ didn't work.", @fail ) );
+ }
+
+ @results;
+}
+
+if ( &blockoptions() & 1 ) # Use nodelay
+{
+ if ( &blockoptions() & 2 ) #poll
+ {
+ eval <<'DONE';
+ sub ReadKey {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if (defined $_[0] && $_[0] > 0) {
+ if ($_[0]) {
+ return undef if &pollfile($File,$_[0]) == 0;
+ }
+ }
+ if (defined $_[0] && $_[0] < 0) {
+ &setnodelay($File,1);
+ }
+ my ($value) = getc $File;
+ if (defined $_[0] && $_[0] < 0) {
+ &setnodelay($File,0);
+ }
+ $value;
+ }
+ sub ReadLine {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+
+ if (defined $_[0] && $_[0] > 0) {
+ if ($_[0]) {
+ return undef if &pollfile($File,$_[0]) == 0;
+ }
+ }
+ if (defined $_[0] && $_[0] < 0) {
+ &setnodelay($File,1)
+ };
+ my ($value) = scalar(<$File>);
+ if ( defined $_[0] && $_[0]<0 ) {
+ &setnodelay($File,0)
+ };
+ $value;
+ }
+DONE
+ }
+ elsif ( &blockoptions() & 4 ) #select
+ {
+ eval <<'DONE';
+ sub ReadKey {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if(defined $_[0] && $_[0]>0) {
+ if($_[0]) {return undef if &selectfile($File,$_[0])==0}
+ }
+ if(defined $_[0] && $_[0]<0) {&setnodelay($File,1);}
+ my($value) = getc $File;
+ if(defined $_[0] && $_[0]<0) {&setnodelay($File,0);}
+ $value;
+ }
+ sub ReadLine {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if(defined $_[0] && $_[0]>0) {
+ if($_[0]) {return undef if &selectfile($File,$_[0])==0}
+ }
+ if(defined $_[0] && $_[0]<0) {&setnodelay($File,1)};
+ my($value)=scalar(<$File>);
+ if(defined $_[0] && $_[0]<0) {&setnodelay($File,0)};
+ $value;
+ }
+DONE
+ }
+ else
+ { #nothing
+ eval <<'DONE';
+ sub ReadKey {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if(defined $_[0] && $_[0]>0) {
+ # Nothing better seems to exist, so I just use time-of-day
+ # to timeout the read. This isn't very exact, though.
+ $starttime=time;
+ $endtime=$starttime+$_[0];
+ &setnodelay($File,1);
+ my($value)=undef;
+ while(time<$endtime) { # This won't catch wraparound!
+ $value = getc $File;
+ last if defined($value);
+ }
+ &setnodelay($File,0);
+ return $value;
+ }
+ if(defined $_[0] && $_[0]<0) {&setnodelay($File,1);}
+ my($value) = getc $File;
+ if(defined $_[0] && $_[0]<0) {&setnodelay($File,0);}
+ $value;
+ }
+ sub ReadLine {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if(defined $_[0] && $_[0]>0) {
+ # Nothing better seems to exist, so I just use time-of-day
+ # to timeout the read. This isn't very exact, though.
+ $starttime=time;
+ $endtime=$starttime+$_[0];
+ &setnodelay($File,1);
+ my($value)=undef;
+ while(time<$endtime) { # This won't catch wraparound!
+ $value = scalar(<$File>);
+ last if defined($value);
+ }
+ &setnodelay($File,0);
+ return $value;
+ }
+ if(defined $_[0] && $_[0]<0) {&setnodelay($File,1)};
+ my($value)=scalar(<$File>);
+ if(defined $_[0] && $_[0]<0) {&setnodelay($File,0)};
+ $value;
+ }
+DONE
+ }
+}
+elsif ( &blockoptions() & 2 ) # Use poll
+{
+ eval <<'DONE';
+ sub ReadKey {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if(defined $_[0] && $_[0] != 0) {
+ return undef if &pollfile($File,$_[0]) == 0
+ }
+ getc $File;
+ }
+ sub ReadLine {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if(defined $_[0] && $_[0]!=0) {
+ return undef if &pollfile($File,$_[0]) == 0;
+ }
+ scalar(<$File>);
+ }
+DONE
+}
+elsif ( &blockoptions() & 4 ) # Use select
+{
+ eval <<'DONE';
+ sub ReadKey {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if(defined $_[0] && $_[0] !=0 ) {
+ return undef if &selectfile($File,$_[0])==0
+ }
+ getc $File;
+ }
+ sub ReadLine {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if(defined $_[0] && $_[0] != 0) {
+ return undef if &selectfile($File,$_[0]) == 0;
+ }
+ scalar(<$File>);
+ }
+DONE
+}
+elsif ( &blockoptions() & 8 ) # Use Win32
+{
+ eval <<'DONE';
+ sub ReadKey {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if ($_[0] || $CurrentMode >= 3) {
+ Win32PeekChar($File, $_[0]);
+ } else {
+ getc $File;
+ }
+ #if ($_[0]!=0) {return undef if !Win32PeekChar($File, $_[0])};
+ #getc $File;
+ }
+ sub ReadLine {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ #if ($_[0]!=0) {return undef if !Win32PeekChar($File, $_[0])};
+ #scalar(<$File>);
+ if($_[0])
+ {croak("Non-blocking ReadLine is not supported on this architecture")}
+ scalar(<$File>);
+ }
+DONE
+}
+else
+{
+ eval <<'DONE';
+ sub ReadKey {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if($_[0])
+ {croak("Non-blocking ReadKey is not supported on this architecture")}
+ getc $File;
+ }
+ sub ReadLine {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if($_[0])
+ {croak("Non-blocking ReadLine is not supported on this architecture")}
+ scalar(<$File>);
+ }
+DONE
+}
+
+package Term::ReadKey; # return to package ReadKey so AutoSplit is happy
+1;
+
+__END__;
diff --git a/Master/tlpkg/tlperl0/lib/Term/ReadLine.pm b/Master/tlpkg/tlperl0/lib/Term/ReadLine.pm
new file mode 100755
index 00000000000..a8116af5e74
--- /dev/null
+++ b/Master/tlpkg/tlperl0/lib/Term/ReadLine.pm
@@ -0,0 +1,413 @@
+=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.04';
+
+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;
+
diff --git a/Master/tlpkg/tlperl0/lib/Term/ReadLine/Perl.pm b/Master/tlpkg/tlperl0/lib/Term/ReadLine/Perl.pm
new file mode 100755
index 00000000000..599b2c3769a
--- /dev/null
+++ b/Master/tlpkg/tlperl0/lib/Term/ReadLine/Perl.pm
@@ -0,0 +1,153 @@
+package Term::ReadLine::Perl;
+use Carp;
+@ISA = qw(Term::ReadLine::Stub Term::ReadLine::Compa Term::ReadLine::Perl::AU);
+#require 'readline.pl';
+
+$VERSION = $VERSION = 1.0303;
+
+sub readline {
+ shift;
+ #my $in =
+ &readline::readline(@_);
+ #$loaded = defined &Term::ReadKey::ReadKey;
+ #print STDOUT "\nrl=`$in', loaded = `$loaded'\n";
+ #if (ref \$in eq 'GLOB') { # Bug under debugger
+ # ($in = "$in") =~ s/^\*(\w+::)+//;
+ #}
+ #print STDOUT "rl=`$in'\n";
+ #$in;
+}
+
+#sub addhistory {}
+*addhistory = \&AddHistory;
+
+#$term;
+$readline::minlength = 1; # To peacify -w
+$readline::rl_readline_name = undef; # To peacify -w
+$readline::rl_basic_word_break_characters = undef; # To peacify -w
+
+sub new {
+ if (defined $term) {
+ warn "Cannot create second readline interface, falling back to dumb.\n";
+ return Term::ReadLine::Stub::new(@_);
+ }
+ shift; # Package
+ if (@_) {
+ if ($term) {
+ warn "Ignoring name of second readline interface.\n" if defined $term;
+ shift;
+ } else {
+ $readline::rl_readline_name = shift; # Name
+ }
+ }
+ if (!@_) {
+ if (!defined $term) {
+ ($IN,$OUT) = Term::ReadLine->findConsole();
+ # Old Term::ReadLine did not have a workaround for a bug in Win devdriver
+ $IN = 'CONIN$' if $^O eq 'MSWin32' and "\U$IN" eq 'CON';
+ open IN,
+ # A workaround for another bug in Win device driver
+ (($IN eq 'CONIN$' and $^O eq 'MSWin32') ? "+< $IN" : "< $IN")
+ or croak "Cannot open $IN for read";
+ open(OUT,">$OUT") || croak "Cannot open $OUT for write";
+ $readline::term_IN = \*IN;
+ $readline::term_OUT = \*OUT;
+ }
+ } else {
+ if (defined $term and ($term->IN ne $_[0] or $term->OUT ne $_[1]) ) {
+ croak "Request for a second readline interface with different terminal";
+ }
+ $readline::term_IN = shift;
+ $readline::term_OUT = shift;
+ }
+ eval {require Term::ReadLine::readline}; die $@ if $@;
+ # The following is here since it is mostly used for perl input:
+ # $readline::rl_basic_word_break_characters .= '-:+/*,[])}';
+ $term = bless [$readline::term_IN,$readline::term_OUT];
+ unless ($ENV{PERL_RL} and $ENV{PERL_RL} =~ /\bo\w*=0/) {
+ local $Term::ReadLine::termcap_nowarn = 1; # With newer Perls
+ local $SIG{__WARN__} = sub {}; # With older Perls
+ $term->ornaments(1);
+ }
+ return $term;
+}
+sub newTTY {
+ my ($self, $in, $out) = @_;
+ $readline::term_IN = $self->[0] = $in;
+ $readline::term_OUT = $self->[1] = $out;
+ my $sel = select($out);
+ $| = 1; # for DB::OUT
+ select($sel);
+}
+sub ReadLine {'Term::ReadLine::Perl'}
+sub MinLine {
+ my $old = $readline::minlength;
+ $readline::minlength = $_[1] if @_ == 2;
+ return $old;
+}
+sub SetHistory {
+ shift;
+ @readline::rl_History = @_;
+ $readline::rl_HistoryIndex = @readline::rl_History;
+}
+sub GetHistory {
+ @readline::rl_History;
+}
+sub AddHistory {
+ shift;
+ push @readline::rl_History, @_;
+ $readline::rl_HistoryIndex = @readline::rl_History + @_;
+}
+%features = (appname => 1, minline => 1, autohistory => 1, getHistory => 1,
+ setHistory => 1, addHistory => 1, preput => 1,
+ attribs => 1, 'newTTY' => 1,
+ tkRunning => Term::ReadLine::Stub->Features->{'tkRunning'},
+ ornaments => Term::ReadLine::Stub->Features->{'ornaments'},
+ );
+sub Features { \%features; }
+# my %attribs;
+tie %attribs, 'Term::ReadLine::Perl::Tie' or die ;
+sub Attribs {
+ \%attribs;
+}
+sub DESTROY {}
+
+package Term::ReadLine::Perl::AU;
+
+sub AUTOLOAD {
+ { $AUTOLOAD =~ s/.*:://; } # preserve match data
+ my $name = "readline::rl_$AUTOLOAD";
+ die "Unknown method `$AUTOLOAD' in Term::ReadLine::Perl"
+ unless exists $readline::{"rl_$AUTOLOAD"};
+ *$AUTOLOAD = sub { shift; &$name };
+ goto &$AUTOLOAD;
+}
+
+package Term::ReadLine::Perl::Tie;
+
+sub TIEHASH { bless {} }
+sub DESTROY {}
+
+sub STORE {
+ my ($self, $name) = (shift, shift);
+ $ {'readline::rl_' . $name} = shift;
+}
+sub FETCH {
+ my ($self, $name) = (shift, shift);
+ $ {'readline::rl_' . $name};
+}
+
+package Term::ReadLine::Compa;
+
+sub get_c {
+ my $self = shift;
+ getc($self->[0]);
+}
+
+sub get_line {
+ my $self = shift;
+ my $fh = $self->[0];
+ scalar <$fh>;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl0/lib/Term/ReadLine/readline.pm b/Master/tlpkg/tlperl0/lib/Term/ReadLine/readline.pm
new file mode 100755
index 00000000000..a19ddb19a9a
--- /dev/null
+++ b/Master/tlpkg/tlperl0/lib/Term/ReadLine/readline.pm
@@ -0,0 +1,4615 @@
+##
+## Perl Readline -- The Quick Help
+## (see the manual for complete info)
+##
+## Once this package is included (require'd), you can then call
+## $text = &readline'readline($input);
+## to get lines of input from the user.
+##
+## Normally, it reads ~/.inputrc when loaded... to suppress this, set
+## $readline'rl_NoInitFromFile = 1;
+## before requiring the package.
+##
+## Call rl_bind to add your own key bindings, as in
+## &readline'rl_bind('C-L', 'possible-completions');
+##
+## Call rl_set to set mode variables yourself, as in
+## &readline'rl_set('TcshCompleteMode', 'On');
+##
+## To change the input mode (emacs or vi) use ~/.inputrc or call
+## &readline::rl_set('EditingMode', 'vi');
+## or &readline::rl_set('EditingMode', 'emacs');
+##
+## Call rl_basic_commands to set your own command completion, as in
+## &readline'rl_basic_commands('print', 'list', 'quit', 'run', 'status');
+##
+##
+
+# Wrap the code below (initially Perl4, now partially Perl4) into a fake
+# Perl5 pseudo-module; mismatch of package and file name is intentional
+# to make is harder to abuse this (very fragile) code...
+package readline;
+
+my $autoload_broken = 1; # currently: defined does not work with a-l
+my $useioctl = 1;
+my $usestty = 1;
+my $max_include_depth = 10; # follow $include's in init files this deep
+
+BEGIN { # Some old systems have ioctl "unsupported"
+ *ioctl = sub ($$$) { eval { ioctl $_[0], $_[1], $_[2] } };
+}
+
+##
+## BLURB:
+## A pretty full-function package similar to GNU's readline.
+## Includes support for EUC-encoded Japanese text.
+##
+## Written by Jeffrey Friedl, Omron Corporation (jfriedl@omron.co.jp)
+##
+## Comments, corrections welcome.
+##
+## Thanks to the people at FSF for readline (and the code I referenced
+## while writing this), and for Roland Schemers whose line_edit.pl I used
+## as an early basis for this.
+##
+$VERSION = $VERSION = '1.0303';
+
+## - Changes from Slaven Rezic (slaven@rezic.de):
+## * reverted the usage of $ENV{EDITOR} to set startup mode
+## only ~/.inputrc or an explicit call to rl_set should
+## be used to set startup mode
+##
+# 1011109.011 - Changes from Russ Southern (russ@dvns.com):
+## * Added $rl_vi_replace_default_on_insert
+# 1000510.010 - Changes from Joe Petolino (petolino@eng.sun.com), requested
+## by Ilya:
+##
+## * Make it compatible with perl 5.003.
+## * Rename getc() to getc_with_pending().
+## * Change unshift(@Pending) to push(@Pending).
+##
+## 991109.009 - Changes from Joe Petolino (petolino@eng.sun.com):
+## Added vi mode. Also added a way to set the keymap default
+## action for multi-character keymaps, so that a 2-character
+## sequence (e.g. <esc>A) can be treated as two one-character
+## commands (<esc>, then A) if the sequence is not explicitly
+## mapped.
+##
+## Changed subs:
+##
+## * preinit(): Initialize new keymaps and other data structures.
+## Use $ENV{EDITOR} to set startup mode.
+##
+## * init(): Sets the global *KeyMap, since &F_ReReadInitFile
+## may have changed the key map.
+##
+## * InitKeymap(): $KeyMap{default} is now optional - don't
+## set it if $_[1] eq '';
+##
+## * actually_do_binding(): Set $KeyMap{default} for '\*' key;
+## warning if double-defined.
+##
+## * rl_bind(): Implement \* to set the keymap default. Also fix
+## some existing regex bugs that I happened to notice.
+##
+## * readline(): No longer takes input from $pending before
+## calling &$rl_getc(); instead, it calls getc_with_pending(),
+## which takes input from the new array @Pending
+## before calling &$rl_getc(). Sets the global
+## *KeyMap after do_command(), since do_command()
+## may change the keymap now. Does some cursor
+## manipulation after do_command() when at the end
+## of the line in vi command mode, to match the
+## behavior of vi.
+##
+## * rl_getc(): Added a my declaration for $key, which was
+## apparently omitted by the author. rl_getc() is
+## no longer called directly; instead, getc_with_pending() calls
+## it only after exhausting any requeued characters
+## in @Pending. @Pending is used to implement the
+## vi '.' command, as well as the emacs DoSearch
+## functionality.
+##
+## * do_command(): Now defaults the command to 'F_Ding' if
+## $KeyMap{default} is undefined. This is part
+## of the new \* feature.
+##
+## * savestate()/getstate(): Now use an anonymous array instead
+## of packing the fields into a string.
+##
+## * F_AcceptLine(): Code moved to new sub add_line_to_history(),
+## so that it may be called by F_SaveLine()
+## as well as by F_AcceptLine().
+##
+## * F_QuotedInsert(): Calls getc_with_pending() instead of &$rl_getc().
+##
+## * F_UnixWordRubout(): Fixed bug: changed 'my' declaration of
+## global $rl_basic_word_break_characters to 'local'.
+##
+## * DoSearch(): Calls getc_with_pending() instead of &$rl_getc(). Ungets
+## character onto @Pending instead of $pending.
+##
+## * F_EmacsEditingMode(): Resets global $Vi_mode;
+##
+## * F_ToggleEditingMode(): Deleted. We use F_ViInput() and
+## F_EmacsEditingMode() instead.
+##
+## * F_PrefixMeta(): Calls getc_with_pending() instead of &$rl_getc().
+##
+## * F_DigitArgument(): Calls getc_with_pending() instead of &$rl_getc().
+##
+## * F_Ding(): Returns undef, for testing by vi commands.
+##
+## * F_Complete(): Returns true if a completion was done, false
+## otherwise, so vi completion routines can test it.
+##
+## * complete_internal(): Returns true if a completion was done,
+## false otherwise, so vi completion routines can
+## test it. Does a little cursor massaging in vi
+## mode, to match the behavior of ksh vi mode.
+##
+## Disclaimer: the original code dates from the perl 4 days, and
+## isn't very pretty by today's standards (for example,
+## extensive use of typeglobs and localized globals). In the
+## interests of not breaking anything, I've tried to preserve
+## the old code as much as possible, and I've avoided making
+## major stylistic changes. Since I'm not a regular emacs user,
+## I haven't done much testing to see that all the emacs-mode
+## features still work.
+##
+## 940817.008 - Added $var_CompleteAddsuffix.
+## Now recognizes window-change signals (at least on BSD).
+## Various typos and bug fixes.
+## Changes from Chris Arthur (csa@halcyon.com):
+## Added a few new keybindings.
+## Various typos and bug fixes.
+## Support for use from a dumb terminal.
+## Pretty-printing of filename-completion matches.
+##
+## 930306.007 - Added rl_start_default_at_beginning.
+## Added optional message arg to &redisplay.
+## Added explicit numeric argument var to functions that use it.
+## Redid many commands to simplify.
+## Added TransposeChars, UpcaseWord, CapitalizeWord, DownCaseWord.
+## Redid key binding specs to better match GNU.. added
+## undocumented "new-style" bindings.... can now bind
+## arrow keys and other arbitrairly long key sequences.
+## Added if/else/then to .inputrc.
+##
+## 930305.006 - optional "default" added (from mmuegel@cssmp.corp.mot.com).
+##
+## 930211.005 - fixed strange problem with eval while keybinding
+##
+
+##
+## Ilya:
+##
+## Added support for ReadKey,
+##
+## Added customization variable $minlength
+## to denote minimal lenth of a string to be put into history buffer.
+##
+## Added support for a bug in debugger: preinit cannot be a subroutine ?!!!
+## (See immendiately below)
+##
+## Added support for WINCH hooks. The subroutine references should be put into
+## @winchhooks.
+##
+## Added F_ToggleInsertMode, F_HistorySearchBackward,
+## F_HistorySearchForward, PC keyboard bindings.
+## 0.93: Updates to Operate, couple of keybindings added.
+## $rl_completer_terminator_character, $rl_correct_sw added.
+## Reload-init-file moved to C-x C-x.
+## C-x ? and C-x * list/insert possible completions.
+
+$rl_getc = \&rl_getc;
+
+&preinit;
+&init;
+
+# # # # use strict 'vars';
+
+# # # # # Separation into my and vars needs some thought...
+
+# # # # use vars qw(@KeyMap %KeyMap $rl_screen_width $rl_start_default_at_beginning
+# # # # $rl_completion_function $rl_basic_word_break_characters
+# # # # $rl_completer_word_break_characters $rl_special_prefixes
+# # # # $rl_readline_name @rl_History $rl_MaxHistorySize
+# # # # $rl_max_numeric_arg $rl_OperateCount
+# # # # $KillBuffer $dumb_term $stdin_not_tty $InsertMode
+# # # # $rl_NoInitFromFile);
+
+# # # # my ($InputLocMsg, $term_OUT, $term_IN);
+# # # # my ($winsz_t, $TIOCGWINSZ, $winsz, $rl_margin, $hooj, $force_redraw);
+# # # # my ($hook, %var_HorizontalScrollMode, %var_EditingMode, %var_OutputMeta);
+# # # # my ($var_HorizontalScrollMode, $var_EditingMode, $var_OutputMeta);
+# # # # my (%var_ConvertMeta, $var_ConvertMeta, %var_MarkModifiedLines, $var_MarkModifiedLines);
+# # # # my ($term_readkey, $inDOS);
+# # # # my (%var_PreferVisibleBell, $var_PreferVisibleBell);
+# # # # my (%var_TcshCompleteMode, $var_TcshCompleteMode);
+# # # # my (%var_CompleteAddsuffix, $var_CompleteAddsuffix);
+# # # # my ($minlength, @winchhooks);
+# # # # my ($BRKINT, $ECHO, $FIONREAD, $ICANON, $ICRNL, $IGNBRK, $IGNCR, $INLCR,
+# # # # $ISIG, $ISTRIP, $NCCS, $OPOST, $RAW, $TCGETS, $TCOON, $TCSETS, $TCXONC,
+# # # # $TERMIOS_CFLAG, $TERMIOS_IFLAG, $TERMIOS_LFLAG, $TERMIOS_NORMAL_IOFF,
+# # # # $TERMIOS_NORMAL_ION, $TERMIOS_NORMAL_LOFF, $TERMIOS_NORMAL_LON,
+# # # # $TERMIOS_NORMAL_OOFF, $TERMIOS_NORMAL_OON, $TERMIOS_OFLAG,
+# # # # $TERMIOS_READLINE_IOFF, $TERMIOS_READLINE_ION, $TERMIOS_READLINE_LOFF,
+# # # # $TERMIOS_READLINE_LON, $TERMIOS_READLINE_OOFF, $TERMIOS_READLINE_OON,
+# # # # $TERMIOS_VMIN, $TERMIOS_VTIME, $TIOCGETP, $TIOCGWINSZ, $TIOCSETP,
+# # # # $fion, $fionread_t, $mode, $sgttyb_t,
+# # # # $termios, $termios_t, $winsz, $winsz_t);
+# # # # my ($line, $initialized, $term_readkey);
+
+
+# # # # # Global variables added for vi mode (I'm leaving them all commented
+# # # # # out, like the declarations above, until SelfLoader issues
+# # # # # are resolved).
+
+# # # # # True when we're in one of the vi modes.
+# # # # my $Vi_mode;
+
+# # # # # Array refs: saves keystrokes for '.' command. Undefined when we're
+# # # # # not doing a '.'-able command.
+# # # # my $Dot_buf; # Working buffer
+# # # # my $Last_vi_command; # Gets $Dot_buf when a command is parsed
+
+# # # # # These hold state for vi 'u' and 'U'.
+# # # # my($Dot_state, $Vi_undo_state, $Vi_undo_all_state);
+
+# # # # # Refs to hashes used for cursor movement
+# # # # my($Vi_delete_patterns, $Vi_move_patterns,
+# # # # $Vi_change_patterns, $Vi_yank_patterns);
+
+# # # # # Array ref: holds parameters from the last [fFtT] command, for ';'
+# # # # # and ','.
+# # # # my $Last_findchar;
+
+# # # # # Globals for history search commands (/, ?, n, N)
+# # # # my $Vi_search_re; # Regular expression (compiled by qr{})
+# # # # my $Vi_search_reverse; # True for '?' search, false for '/'
+
+
+##
+## What's Cool
+## ----------------------------------------------------------------------
+## * hey, it's in perl.
+## * Pretty full GNU readline like library...
+## * support for ~/.inputrc
+## * horizontal scrolling
+## * command/file completion
+## * rebinding
+## * history (with search)
+## * undo
+## * numeric prefixes
+## * supports multi-byte characters (at least for the Japanese I use).
+## * Has a tcsh-like completion-function mode.
+## call &readline'rl_set('tcsh-complete-mode', 'On') to turn on.
+##
+
+##
+## What's not Cool
+## ----------------------------------------------------------------------
+## Can you say HUGE?
+## I can't spell, so comments riddled with misspellings.
+## Written by someone that has never really used readline.
+## History mechanism is slightly different than GNU... may get fixed
+## someday, but I like it as it is now...
+## Killbuffer not a ring.. just one level.
+## Obviously not well tested yet.
+## Written by someone that doesn't have a bell on his terminal, so
+## proper readline use of the bell may not be here.
+##
+
+
+##
+## Functions beginning with F_ are functions that are mapped to keys.
+## Variables and functions beginning rl_ may be accessed/set/called/read
+## from outside the package. Other things are internal.
+##
+## Some notable internal-only variables of global proportions:
+## $prompt -- line prompt (passed from user)
+## $line -- the line being input
+## $D -- ``Dot'' -- index into $line of the cursor's location.
+## $InsertMode -- usually true. False means overwrite mode.
+## $InputLocMsg -- string for error messages, such as "[~/.inputrc line 2]"
+## *emacs_keymap -- keymap for emacs-mode bindings:
+## @emacs_keymap - bindings indexed by ASCII ordinal
+## $emacs_keymap{'name'} = "emacs_keymap"
+## $emacs_keymap{'default'} = "SelfInsert" (default binding)
+## *vi_keymap -- keymap for vi input mode bindings
+## *vicmd_keymap -- keymap for vi command mode bindings
+## *vipos_keymap -- keymap for vi positioning command bindings
+## *visearch_keymap -- keymap for vi search pattern input mode bindings
+## *KeyMap -- current keymap in effect.
+## $LastCommandKilledText -- needed so that subsequent kills accumulate
+## $lastcommand -- name of command previously run
+## $lastredisplay -- text placed upon screen during previous &redisplay
+## $si -- ``screen index''; index into $line of leftmost char &redisplay'ed
+## $force_redraw -- if set to true, causes &redisplay to be verbose.
+## $AcceptLine -- when set, its value is returned from &readline.
+## $ReturnEOF -- unless this also set, in which case undef is returned.
+## @Pending -- characters to be used as input.
+## @undo -- array holding all states of current line, for undoing.
+## $KillBuffer -- top of kill ring (well, don't have a kill ring yet)
+## @tcsh_complete_selections -- for tcsh mode, possible selections
+##
+## Some internal variables modified by &rl_set (see comment at &rl_set for
+## info about how these set'able variables work)
+## $var_EditingMode -- a keymap typeglob like *emacs_keymap or *vi_keymap
+## $var_TcshCompleteMode -- if true, the completion function works like
+## in tcsh. That is, the first time you try to complete something,
+## the common prefix is completed for you. Subsequent completion tries
+## (without other commands in between) cycles the command line through
+## the various possibilities. If/when you get the one you want, just
+## continue typing.
+## Other $var_ things not supported yet.
+##
+## Some variables used internally, but may be accessed from outside...
+## $VERSION -- just for good looks.
+## $rl_readline_name = name of program -- for .initrc if/endif stuff.
+## $rl_NoInitFromFile -- if defined when package is require'd, ~/.inputrc
+## will not be read.
+## @rl_History -- array of previous lines input
+## $rl_HistoryIndex -- history pointer (for moving about history array)
+## $rl_completion_function -- see "How Command Completion Works" (way) below.
+## $rl_basic_word_break_characters -- string of characters that can cause
+## a word break for forward-word, etc.
+## $rl_start_default_at_beginning --
+## Normally, the user's cursor starts at the end of any default text
+## passed to readline. If this variable is true, it starts at the
+## beginning.
+## $rl_completer_word_break_characters --
+## like $rl_basic_word_break_characters (and in fact defaults to it),
+## but for the completion function.
+## $rl_completer_terminator_character -- what to insert to separate
+## a completed token from the rest. Reset at beginning of
+## completion to ' ' so completion function can change it.
+## $rl_special_prefixes -- characters that are part of this string as well
+## as of $rl_completer_word_break_characters cause a word break for the
+## completer function, but remain part of the word. An example: consider
+## when the input might be perl code, and one wants to be able to
+## complete on variable and function names, yet still have the '$',
+## '&', '@',etc. part of the $text to be completed. Then set this var
+## to '&@$%' and make sure each of these characters is in
+## $rl_completer_word_break_characters as well....
+## $rl_MaxHistorySize -- maximum size that the history array may grow.
+## $rl_screen_width -- width readline thinks it can use on the screen.
+## $rl_correct_sw -- is substructed from the real width of the terminal
+## $rl_margin -- scroll by moving to within this far from a margin.
+## $rl_CLEAR -- what to output to clear the screen.
+## $rl_max_numeric_arg -- maximum numeric arg allowed.
+## $rl_vi_replace_default_on_insert
+## Normally, the text you enter is added to any default text passed to
+## readline. If this variable is true, default text will start out
+## highlighted (if supported by your terminal) and text entered while the
+## default is highlighted (during the _first_ insert mode only) will
+## replace the entire default line. Once you have left insert mode (hit
+## escape), everything works as normal.
+## - This is similar to many GUI controls' behavior, which select the
+## default text so that new text replaces the old.
+## - Use with $rl_start_default_at_beginning for normal-looking behavior
+## (though it works just fine without it).
+## Notes/Bugs:
+## - Control characters (like C-w) do not actually terminate this replace
+## mode, for the same reason it does not work in emacs mode.
+## - Spine-crawlingly scary subroutine redefinitions
+## $rl_mark - start of the region
+## $line_rl_mark - the line on which $rl_mark is active
+## $_rl_japanese_mb - For character movement suppose Japanese (which?!)
+## multi-byte encoding. (How to make a sane default?)
+##
+
+sub get_window_size
+{
+ my $sig = shift;
+ local($., $@, $!, $^E, $?); # Preserve $! etc; the rest for hooks
+ my ($num_cols,$num_rows);
+
+ if (defined $term_readkey) {
+ ($num_cols,$num_rows) = Term::ReadKey::GetTerminalSize($term_OUT);
+ $rl_screen_width = $num_cols - $rl_correct_sw
+ if defined($num_cols) && $num_cols;
+ } elsif (defined $TIOCGWINSZ and &ioctl($term_IN,$TIOCGWINSZ,$winsz)) {
+ ($num_rows,$num_cols) = unpack($winsz_t,$winsz);
+ $rl_screen_width = $num_cols - $rl_correct_sw
+ if defined($num_cols) && $num_cols;
+ }
+ $rl_margin = int($rl_screen_width/3);
+ if (defined $sig) {
+ $force_redraw = 1;
+ &redisplay();
+ }
+
+ for $hook (@winchhooks) {
+ eval {&$hook()}; warn $@ if $@ and $^W;
+ }
+ local $^W = 0; # WINCH may be illegal...
+ $SIG{'WINCH'} = "readline::get_window_size";
+}
+
+# Fix: case-sensitivity of inputrc on/off keywords in
+# `set' commands. readline lib doesn't care about case.
+# changed case of keys 'On' and 'Off' to 'on' and 'off'
+# &rl_set changed so that it converts the value to
+# lower case before hash lookup.
+sub preinit
+{
+ ## Set up the input and output handles
+
+ $term_IN = \*STDIN unless defined $term_IN;
+ $term_OUT = \*STDOUT unless defined $term_OUT;
+ ## not yet supported... always on.
+ $var_HorizontalScrollMode = 1;
+ $var_HorizontalScrollMode{'On'} = 1;
+ $var_HorizontalScrollMode{'Off'} = 0;
+
+ $var_EditingMode{'emacs'} = *emacs_keymap;
+ $var_EditingMode{'vi'} = *vi_keymap;
+ $var_EditingMode{'vicmd'} = *vicmd_keymap;
+ $var_EditingMode{'vipos'} = *vipos_keymap;
+ $var_EditingMode{'visearch'} = *visearch_keymap;
+
+ ## this is an addition. Very nice.
+ $var_TcshCompleteMode = 0;
+ $var_TcshCompleteMode{'On'} = 1;
+ $var_TcshCompleteMode{'Off'} = 0;
+
+ $var_CompleteAddsuffix = 1;
+ $var_CompleteAddsuffix{'On'} = 1;
+ $var_CompleteAddsuffix{'Off'} = 0;
+
+ $var_DeleteSelection = $var_DeleteSelection{'On'} = 1;
+ $var_DeleteSelection{'Off'} = 0;
+ *rl_delete_selection = \$var_DeleteSelection; # Alias
+
+ ## not yet supported... always on
+ for ('InputMeta', 'OutputMeta') {
+ ${"var_$_"} = 1;
+ ${"var_$_"}{'Off'} = 0;
+ ${"var_$_"}{'On'} = 1;
+ }
+
+ ## not yet supported... always off
+ for ('ConvertMeta', 'MetaFlag', 'MarkModifiedLines', 'PreferVisibleBell',
+ 'BlinkMatchingParen', 'VisibleStats', 'ShowAllIfAmbiguous',
+ 'PrintCompletionsHorizontally', 'MarkDirectories', 'ExpandTilde',
+ 'EnableKeypad', 'DisableCompletion', 'CompletionIgnoreCase') {
+ ${"var_$_"} = 0;
+ ${"var_$_"}{'Off'} = 0;
+ ${"var_$_"}{'On'} = 1;
+ }
+
+ # To conform to interface
+ $minlength = 1 unless defined $minlength;
+
+ # WINCH hooks
+ @winchhooks = ();
+
+ $inDOS = $^O eq 'os2' || defined $ENV{OS2_SHELL} unless defined $inDOS;
+ eval {
+ require Term::ReadKey; $term_readkey++;
+ } unless defined $ENV{PERL_RL_USE_TRK}
+ and not $ENV{PERL_RL_USE_TRK};
+ unless ($term_readkey) {
+ eval {require "ioctl.pl"}; ## try to get, don't die if not found.
+ eval {require "sys/ioctl.ph"}; ## try to get, don't die if not found.
+ eval {require "sgtty.ph"}; ## try to get, don't die if not found.
+ if ($inDOS and !defined $TIOCGWINSZ) {
+ $TIOCGWINSZ=0;
+ $TIOCGETP=1;
+ $TIOCSETP=2;
+ $sgttyb_t="I5 C8";
+ $winsz_t="";
+ $RAW=0xf002;
+ $ECHO=0x0008;
+ }
+ $TIOCGETP = &TIOCGETP if defined(&TIOCGETP);
+ $TIOCSETP = &TIOCSETP if defined(&TIOCSETP);
+ $TIOCGWINSZ = &TIOCGWINSZ if defined(&TIOCGWINSZ);
+ $FIONREAD = &FIONREAD if defined(&FIONREAD);
+ $TCGETS = &TCGETS if defined(&TCGETS);
+ $TCSETS = &TCSETS if defined(&TCSETS);
+ $TCXONC = &TCXONC if defined(&TCXONC);
+ $TIOCGETP = 0x40067408 if !defined($TIOCGETP);
+ $TIOCSETP = 0x80067409 if !defined($TIOCSETP);
+ $TIOCGWINSZ = 0x40087468 if !defined($TIOCGWINSZ);
+ $FIONREAD = 0x4004667f if !defined($FIONREAD);
+ $TCGETS = 0x40245408 if !defined($TCGETS);
+ $TCSETS = 0x80245409 if !defined($TCSETS);
+ $TCXONC = 0x20005406 if !defined($TCXONC);
+
+ ## TTY modes
+ $ECHO = &ECHO if defined(&ECHO);
+ $RAW = &RAW if defined(&RAW);
+ $RAW = 040 if !defined($RAW);
+ $ECHO = 010 if !defined($ECHO);
+ #$CBREAK = 002 if !defined($CBREAK);
+ $mode = $RAW; ## could choose CBREAK for testing....
+
+ $IGNBRK = 1 if !defined($IGNBRK);
+ $BRKINT = 2 if !defined($BRKINT);
+ $ISTRIP = 040 if !defined($ISTRIP);
+ $INLCR = 0100 if !defined($INLCR);
+ $IGNCR = 0200 if !defined($IGNCR);
+ $ICRNL = 0400 if !defined($ICRNL);
+ $OPOST = 1 if !defined($OPOST);
+ $ISIG = 1 if !defined($ISIG);
+ $ICANON = 2 if !defined($ICANON);
+ $TCOON = 1 if !defined($TCOON);
+ $TERMIOS_READLINE_ION = $BRKINT;
+ $TERMIOS_READLINE_IOFF = $IGNBRK | $ISTRIP | $INLCR | $IGNCR | $ICRNL;
+ $TERMIOS_READLINE_OON = 0;
+ $TERMIOS_READLINE_OOFF = $OPOST;
+ $TERMIOS_READLINE_LON = 0;
+ $TERMIOS_READLINE_LOFF = $ISIG | $ICANON | $ECHO;
+ $TERMIOS_NORMAL_ION = $BRKINT;
+ $TERMIOS_NORMAL_IOFF = $IGNBRK;
+ $TERMIOS_NORMAL_OON = $OPOST;
+ $TERMIOS_NORMAL_OOFF = 0;
+ $TERMIOS_NORMAL_LON = $ISIG | $ICANON | $ECHO;
+ $TERMIOS_NORMAL_LOFF = 0;
+
+ #$sgttyb_t = 'C4 S';
+ #$winsz_t = "S S S S"; # rows,cols, xpixel, ypixel
+ $sgttyb_t = 'C4 S' if !defined($sgttyb_t);
+ $winsz_t = "S S S S" if !defined($winsz_t);
+ # rows,cols, xpixel, ypixel
+ $winsz = pack($winsz_t,0,0,0,0);
+ $fionread_t = "L";
+ $fion = pack($fionread_t, 0);
+ $NCCS = 17;
+ $termios_t = "LLLLc" . ("c" x $NCCS); # true for SunOS 4.1.3, at least...
+ $termios = ''; ## just to shut up "perl -w".
+ $termios = pack($termios, 0); # who cares, just make it long enough
+ $TERMIOS_IFLAG = 0;
+ $TERMIOS_OFLAG = 1;
+ $TERMIOS_CFLAG = 2;
+ $TERMIOS_LFLAG = 3;
+ $TERMIOS_VMIN = 5 + 4;
+ $TERMIOS_VTIME = 5 + 5;
+ }
+ $rl_delete_selection = 1;
+ $rl_correct_sw = ($inDOS ? 1 : 0);
+ $rl_scroll_nextline = 1 unless defined $rl_scroll_nextline;
+ $rl_last_pos_can_backspace = ($inDOS ? 0 : 1) # Can backspace when the
+ unless defined $rl_last_pos_can_backspace; # whole line is filled?
+
+ $rl_start_default_at_beginning = 0;
+ $rl_vi_replace_default_on_insert = 0;
+ $rl_screen_width = 79; ## default
+
+ $rl_completion_function = "rl_filename_list"
+ unless defined($rl_completion_function);
+ $rl_basic_word_break_characters = "\\\t\n' \"`\@\$><=;|&{(";
+ $rl_completer_word_break_characters = $rl_basic_word_break_characters;
+ $rl_special_prefixes = '';
+ ($rl_readline_name = $0) =~ s#.*[/\\]## if !defined($rl_readline_name);
+
+ @rl_History=() if !(@rl_History);
+ $rl_MaxHistorySize = 100 if !defined($rl_MaxHistorySize);
+ $rl_max_numeric_arg = 200 if !defined($rl_max_numeric_arg);
+ $rl_OperateCount = 0 if !defined($rl_OperateCount);
+
+ $rl_term_set = \@Term::ReadLine::TermCap::rl_term_set;
+ @$rl_term_set or $rl_term_set = ["","","",""];
+
+ $InsertMode=1;
+ $KillBuffer='';
+ $line='';
+ $D = 0;
+ $InputLocMsg = ' [initialization]';
+
+ &InitKeymap(*emacs_keymap, 'SelfInsert', 'emacs_keymap',
+ ($inDOS ? () : ('C-@', 'SetMark') ),
+ 'C-a', 'BeginningOfLine',
+ 'C-b', 'BackwardChar',
+ 'C-c', 'Interrupt',
+ 'C-d', 'DeleteChar',
+ 'C-e', 'EndOfLine',
+ 'C-f', 'ForwardChar',
+ 'C-g', 'Abort',
+ 'M-C-g', 'Abort',
+ 'C-h', 'BackwardDeleteChar',
+ "TAB" , 'Complete',
+ "C-j" , 'AcceptLine',
+ 'C-k', 'KillLine',
+ 'C-l', 'ClearScreen',
+ "C-m" , 'AcceptLine',
+ 'C-n', 'NextHistory',
+ 'C-o', 'OperateAndGetNext',
+ 'C-p', 'PreviousHistory',
+ 'C-q', 'QuotedInsert',
+ 'C-r', 'ReverseSearchHistory',
+ 'C-s', 'ForwardSearchHistory',
+ 'C-t', 'TransposeChars',
+ 'C-u', 'UnixLineDiscard',
+ ##'C-v', 'QuotedInsert',
+ 'C-v', 'HistorySearchForward',
+ 'C-w', 'UnixWordRubout',
+ qq/"\cX\cX"/, 'ExchangePointAndMark',
+ qq/"\cX\cR"/, 'ReReadInitFile',
+ qq/"\cX?"/, 'PossibleCompletions',
+ qq/"\cX*"/, 'InsertPossibleCompletions',
+ qq/"\cX\cU"/, 'Undo',
+ qq/"\cXu"/, 'Undo',
+ qq/"\cX\cW"/, 'KillRegion',
+ qq/"\cXw"/, 'CopyRegionAsKill',
+ qq/"\cX\ec\\*"/, 'DoControlVersion',
+ qq/"\cX\ec\0"/, 'SetMark',
+ qq/"\cX\ec\@"/, 'SetMark',
+ qq/"\cX\ec "/, 'SetMark',
+ qq/"\cX\em\\*"/, 'DoMetaVersion',
+ qq/"\cX\@c\\*"/, 'DoControlVersion',
+ qq/"\cX\@c\0"/, 'SetMark',
+ qq/"\cX\@c\@"/, 'SetMark',
+ qq/"\cX\@c "/, 'SetMark',
+ qq/"\cX\@m\\*"/, 'DoMetaVersion',
+ 'C-y', 'Yank',
+ 'C-z', 'Suspend',
+ 'C-\\', 'Ding',
+ 'C-^', 'Ding',
+ 'C-_', 'Undo',
+ 'DEL', ($inDOS ?
+ 'BackwardKillWord' : # <Control>+<Backspace>
+ 'BackwardDeleteChar'
+ ),
+ 'M-<', 'BeginningOfHistory',
+ 'M->', 'EndOfHistory',
+ 'M-DEL', 'BackwardKillWord',
+ 'M-C-h', 'BackwardKillWord',
+ 'M-C-j', 'ViInput',
+ 'M-C-v', 'QuotedInsert',
+ 'M-b', 'BackwardWord',
+ 'M-c', 'CapitalizeWord',
+ 'M-d', 'KillWord',
+ 'M-f', 'ForwardWord',
+ 'M-h', 'PrintHistory',
+ 'M-l', 'DownCaseWord',
+ 'M-r', 'RevertLine',
+ 'M-t', 'TransposeWords',
+ 'M-u', 'UpcaseWord',
+ 'M-v', 'HistorySearchBackward',
+ 'M-y', 'YankPop',
+ "M-?", 'PossibleCompletions',
+ "M-TAB", 'TabInsert',
+ 'M-#', 'SaveLine',
+ qq/"\e[A"/, 'previous-history',
+ qq/"\e[B"/, 'next-history',
+ qq/"\e[C"/, 'forward-char',
+ qq/"\e[D"/, 'backward-char',
+ qq/"\eOA"/, 'previous-history',
+ qq/"\eOB"/, 'next-history',
+ qq/"\eOC"/, 'forward-char',
+ qq/"\eOD"/, 'backward-char',
+ qq/"\eOy"/, 'HistorySearchBackward', # vt: PageUp
+ qq/"\eOs"/, 'HistorySearchForward', # vt: PageDown
+ qq/"\e[[A"/, 'previous-history',
+ qq/"\e[[B"/, 'next-history',
+ qq/"\e[[C"/, 'forward-char',
+ qq/"\e[[D"/, 'backward-char',
+ qq/"\e[2~"/, 'ToggleInsertMode', # X: <Insert>
+ # Mods: 1 + bitmask: 1 Shift, 2 Alt, 4 Control, 8 (sometimes) Meta
+ qq/"\e[2;2~"/, 'YankClipboard', # <Shift>+<Insert>
+ qq/"\e[3;2~"/, 'KillRegionClipboard', # <Shift>+<Delete>
+ #qq/"\0\16"/, 'Undo', # <Alt>+<Backspace>
+ qq/"\eO5D"/, 'BackwardWord', # <Ctrl>+<Left arrow>
+ qq/"\eO5C"/, 'ForwardWord', # <Ctrl>+<Right arrow>
+ qq/"\e[5D"/, 'BackwardWord', # <Ctrl>+<Left arrow>
+ qq/"\e[5C"/, 'ForwardWord', # <Ctrl>+<Right arrow>
+ qq/"\eO5F"/, 'KillLine', # <Ctrl>+<End>
+ qq/"\e[5F"/, 'KillLine', # <Ctrl>+<End>
+ qq/"\e[4;5~"/, 'KillLine', # <Ctrl>+<End>
+ qq/"\eO5s"/, 'EndOfHistory', # <Ctrl>+<Page Down>
+ qq/"\e[6;5~"/, 'EndOfHistory', # <Ctrl>+<Page Down>
+ qq/"\e[5H"/, 'BackwardKillLine', # <Ctrl>+<Home>
+ qq/"\eO5H"/, 'BackwardKillLine', # <Ctrl>+<Home>
+ qq/"\e[1;5~"/, 'BackwardKillLine', # <Ctrl>+<Home>
+ qq/"\eO5y"/, 'BeginningOfHistory', # <Ctrl>+<Page Up>
+ qq/"\e[5;5y"/, 'BeginningOfHistory', # <Ctrl>+<Page Up>
+ qq/"\e[2;5~"/, 'CopyRegionAsKillClipboard', # <Ctrl>+<Insert>
+ qq/"\e[3;5~"/, 'KillWord', # <Ctrl>+<Delete>
+
+ # XTerm mouse editing (f202/f203 not in mainstream yet):
+ # Paste may be: move f200 STRING f201
+ # or f202 move f200 STRING f201 f203;
+ # and Cut may be f202 move delete f203
+ qq/"\e[200~"/, 'BeginPasteGroup', # Pre-paste
+ qq/"\e[201~"/, 'EndPasteGroup', # Post-paste
+ qq/"\e[202~"/, 'BeginEditGroup', # Pre-edit
+ qq/"\e[203~"/, 'EndEditGroup', # Post-edit
+
+ # OSX xterm:
+ # OSX xterm: home \eOH end \eOF delete \e[3~ help \e[28~ f13 \e[25~
+ # gray- \eOm gray+ \eOk gray-enter \eOM gray* \eOj gray/ \eOo gray= \eO
+ # grayClear \e\e.
+
+ qq/"\eOH"/, 'BeginningOfLine', # home
+ qq/"\eOF"/, 'EndOfLine', # end
+
+ # HP xterm
+ #qq/"\e[A"/, 'PreviousHistory', # up arrow
+ #qq/"\e[B"/, 'NextHistory', # down arrow
+ #qq/"\e[C"/, 'ForwardChar', # right arrow
+ #qq/"\e[D"/, 'BackwardChar', # left arrow
+ qq/"\e[H"/, 'BeginningOfLine', # home
+ #'C-k', 'KillLine', # clear display
+ qq/"\e[5~"/, 'HistorySearchBackward', # prev
+ qq/"\e[6~"/, 'HistorySearchForward', # next
+ qq/"\e[\0"/, 'BeginningOfLine', # home
+
+ # These contradict:
+ ($^O =~ /^hp\W?ux/i ? (
+ qq/"\e[1~"/, 'HistorySearchForward', # find
+ qq/"\e[3~"/, 'ToggleInsertMode', # insert char
+ qq/"\e[4~"/, 'ToggleInsertMode', # select
+ ) : ( # "Normal" xterm
+ qq/"\e[1~"/, 'BeginningOfLine', # home
+ qq/"\e[3~"/, 'DeleteChar', # delete
+ qq/"\e[4~"/, 'EndOfLine', # end
+ )),
+
+ # hpterm
+
+ (($ENV{'TERM'} and $ENV{'TERM'} eq 'hpterm') ?
+ (
+ qq/"\eA"/, 'PreviousHistory', # up arrow
+ qq/"\eB"/, 'NextHistory', # down arrow
+ qq/"\eC"/, 'ForwardChar', # right arrow
+ qq/"\eD"/, 'BackwardChar', # left arrow
+ qq/"\eS"/, 'BeginningOfHistory', # shift up arrow
+ qq/"\eT"/, 'EndOfHistory', # shift down arrow
+ qq/"\e&r1R"/, 'EndOfLine', # shift right arrow
+ qq/"\e&r1L"/, 'BeginningOfLine', # shift left arrow
+ qq/"\eJ"/, 'ClearScreen', # clear display
+ qq/"\eM"/, 'UnixLineDiscard', # delete line
+ qq/"\eK"/, 'KillLine', # clear line
+ qq/"\eG\eK"/, 'BackwardKillLine', # shift clear line
+ qq/"\eP"/, 'DeleteChar', # delete char
+ qq/"\eL"/, 'Yank', # insert line
+ qq/"\eQ"/, 'ToggleInsertMode', # insert char
+ qq/"\eV"/, 'HistorySearchBackward',# prev
+ qq/"\eU"/, 'HistorySearchForward',# next
+ qq/"\eh"/, 'BeginningOfLine', # home
+ qq/"\eF"/, 'EndOfLine', # shift home
+ qq/"\ei"/, 'Suspend', # shift tab
+ ) :
+ ()
+ ),
+ ($inDOS ?
+ (
+ qq/"\0\2"/, 'SetMark', # 2: <Control>+<Space>
+ qq/"\0\3"/, 'SetMark', # 3: <Control>+<@>
+ qq/"\0\4"/, 'YankClipboard', # 4: <Shift>+<Insert>
+ qq/"\0\5"/, 'KillRegionClipboard', # 5: <Shift>+<Delete>
+ qq/"\0\16"/, 'Undo', # 14: <Alt>+<Backspace>
+# qq/"\0\23"/, 'RevertLine', # 19: <Alt>+<R>
+# qq/"\0\24"/, 'TransposeWords', # 20: <Alt>+<T>
+# qq/"\0\25"/, 'YankPop', # 21: <Alt>+<Y>
+# qq/"\0\26"/, 'UpcaseWord', # 22: <Alt>+<U>
+# qq/"\0\31"/, 'ReverseSearchHistory', # 25: <Alt>+<P>
+# qq/"\0\40"/, 'KillWord', # 32: <Alt>+<D>
+# qq/"\0\41"/, 'ForwardWord', # 33: <Alt>+<F>
+# qq/"\0\46"/, 'DownCaseWord', # 38: <Alt>+<L>
+ #qq/"\0\51"/, 'TildeExpand', # 41: <Alt>+<\'>
+# qq/"\0\56"/, 'CapitalizeWord', # 46: <Alt>+<C>
+# qq/"\0\60"/, 'BackwardWord', # 48: <Alt>+<B>
+# qq/"\0\61"/, 'ForwardSearchHistory', # 49: <Alt>+<N>
+ #qq/"\0\64"/, 'YankLastArg', # 52: <Alt>+<.>
+ qq/"\0\65"/, 'PossibleCompletions', # 53: <Alt>+</>
+ qq/"\0\107"/, 'BeginningOfLine', # 71: <Home>
+ qq/"\0\110"/, 'previous-history', # 72: <Up arrow>
+ qq/"\0\111"/, 'HistorySearchBackward', # 73: <Page Up>
+ qq/"\0\113"/, 'backward-char', # 75: <Left arrow>
+ qq/"\0\115"/, 'forward-char', # 77: <Right arrow>
+ qq/"\0\117"/, 'EndOfLine', # 79: <End>
+ qq/"\0\120"/, 'next-history', # 80: <Down arrow>
+ qq/"\0\121"/, 'HistorySearchForward', # 81: <Page Down>
+ qq/"\0\122"/, 'ToggleInsertMode', # 82: <Insert>
+ qq/"\0\123"/, 'DeleteChar', # 83: <Delete>
+ qq/"\0\163"/, 'BackwardWord', # 115: <Ctrl>+<Left arrow>
+ qq/"\0\164"/, 'ForwardWord', # 116: <Ctrl>+<Right arrow>
+ qq/"\0\165"/, 'KillLine', # 117: <Ctrl>+<End>
+ qq/"\0\166"/, 'EndOfHistory', # 118: <Ctrl>+<Page Down>
+ qq/"\0\167"/, 'BackwardKillLine', # 119: <Ctrl>+<Home>
+ qq/"\0\204"/, 'BeginningOfHistory', # 132: <Ctrl>+<Page Up>
+ qq/"\0\x92"/, 'CopyRegionAsKillClipboard', # 146: <Ctrl>+<Insert>
+ qq/"\0\223"/, 'KillWord', # 147: <Ctrl>+<Delete>
+ qq/"\0#"/, 'PrintHistory', # Alt-H
+ )
+ : ( 'C-@', 'Ding')
+ )
+ );
+
+ *KeyMap = *emacs_keymap;
+ my @add_bindings = ();
+ foreach ('-', '0' .. '9') { push(@add_bindings, "M-$_", 'DigitArgument'); }
+ foreach ("A" .. "Z") {
+ next if # defined($KeyMap[27]) && defined (%{"$KeyMap{name}_27"}) &&
+ defined $ {"$KeyMap{name}_27"}[ord $_];
+ push(@add_bindings, "M-$_", 'DoLowercaseVersion');
+ }
+ if ($inDOS) {
+ # Default translation of Alt-char
+ $ {"$KeyMap{name}_0"}{'Esc'} = *{"$KeyMap{name}_27"};
+ $ {"$KeyMap{name}_0"}{'default'} = 'F_DoEscVersion';
+ }
+ &rl_bind(@add_bindings);
+
+ # Vi input mode.
+ &InitKeymap(*vi_keymap, 'SelfInsert', 'vi_keymap',
+
+ "\e", 'ViEndInsert',
+ 'C-c', 'Interrupt',
+ 'C-h', 'BackwardDeleteChar',
+ 'C-w', 'UnixWordRubout',
+ 'C-u', 'UnixLineDiscard',
+ 'C-v', 'QuotedInsert',
+ 'DEL', 'BackwardDeleteChar',
+ "\n", 'ViAcceptInsert',
+ "\r", 'ViAcceptInsert',
+ );
+
+ # Vi command mode.
+ &InitKeymap(*vicmd_keymap, 'Ding', 'vicmd_keymap',
+
+ 'C-c', 'Interrupt',
+ 'C-e', 'EmacsEditingMode',
+ 'C-h', 'ViMoveCursor',
+ 'C-l', 'ClearScreen',
+ "\n", 'ViAcceptLine',
+ "\r", 'ViAcceptLine',
+
+ ' ', 'ViMoveCursor',
+ '#', 'SaveLine',
+ '$', 'ViMoveCursor',
+ '%', 'ViMoveCursor',
+ '*', 'ViInsertPossibleCompletions',
+ '+', 'NextHistory',
+ ',', 'ViMoveCursor',
+ '-', 'PreviousHistory',
+ '.', 'ViRepeatLastCommand',
+ '/', 'ViSearch',
+
+ '0', 'ViMoveCursor',
+ '1', 'ViDigit',
+ '2', 'ViDigit',
+ '3', 'ViDigit',
+ '4', 'ViDigit',
+ '5', 'ViDigit',
+ '6', 'ViDigit',
+ '7', 'ViDigit',
+ '8', 'ViDigit',
+ '9', 'ViDigit',
+
+ ';', 'ViMoveCursor',
+ '=', 'ViPossibleCompletions',
+ '?', 'ViSearch',
+
+ 'A', 'ViAppendLine',
+ 'B', 'ViMoveCursor',
+ 'C', 'ViChangeLine',
+ 'D', 'ViDeleteLine',
+ 'E', 'ViMoveCursor',
+ 'F', 'ViMoveCursor',
+ 'G', 'ViHistoryLine',
+ 'H', 'PrintHistory',
+ 'I', 'ViBeginInput',
+ 'N', 'ViRepeatSearch',
+ 'P', 'ViPutBefore',
+ 'R', 'ViReplaceMode',
+ 'S', 'ViChangeEntireLine',
+ 'T', 'ViMoveCursor',
+ 'U', 'ViUndoAll',
+ 'W', 'ViMoveCursor',
+ 'X', 'ViBackwardDeleteChar',
+ 'Y', 'ViYankLine',
+
+ '\\', 'ViComplete',
+ '^', 'ViMoveCursor',
+
+ 'a', 'ViAppend',
+ 'b', 'ViMoveCursor',
+ 'c', 'ViChange',
+ 'd', 'ViDelete',
+ 'e', 'ViMoveCursor',
+ 'f', 'ViMoveCursorFind',
+ 'h', 'ViMoveCursor',
+ 'i', 'ViInput',
+ 'j', 'NextHistory',
+ 'k', 'PreviousHistory',
+ 'l', 'ViMoveCursor',
+ 'n', 'ViRepeatSearch',
+ 'p', 'ViPut',
+ 'r', 'ViReplaceChar',
+ 's', 'ViChangeChar',
+ 't', 'ViMoveCursorTo',
+ 'u', 'ViUndo',
+ 'w', 'ViMoveCursor',
+ 'x', 'ViDeleteChar',
+ 'y', 'ViYank',
+
+ '|', 'ViMoveCursor',
+ '~', 'ViToggleCase',
+
+ (($inDOS
+ and (not $ENV{'TERM'} or $ENV{'TERM'} !~ /^(vt|xterm)/i)) ?
+ (
+ qq/"\0\110"/, 'PreviousHistory', # 72: <Up arrow>
+ qq/"\0\120"/, 'NextHistory', # 80: <Down arrow>
+ qq/"\0\113"/, 'BackwardChar', # 75: <Left arrow>
+ qq/"\0\115"/, 'ForwardChar', # 77: <Right arrow>
+ "\e", 'ViCommandMode',
+ ) :
+
+ (('M-C-j','EmacsEditingMode'), # Conflicts with \e otherwise
+ (($ENV{'TERM'} and $ENV{'TERM'} eq 'hpterm') ?
+ (
+ qq/"\eA"/, 'PreviousHistory', # up arrow
+ qq/"\eB"/, 'NextHistory', # down arrow
+ qq/"\eC"/, 'ForwardChar', # right arrow
+ qq/"\eD"/, 'BackwardChar', # left arrow
+ qq/"\e\\*"/, 'ViAfterEsc',
+ ) :
+
+ # Default
+ (
+ qq/"\e[A"/, 'PreviousHistory', # up arrow
+ qq/"\e[B"/, 'NextHistory', # down arrow
+ qq/"\e[C"/, 'ForwardChar', # right arrow
+ qq/"\e[D"/, 'BackwardChar', # left arrow
+ qq/"\e\\*"/, 'ViAfterEsc',
+ qq/"\e[\\*"/, 'ViAfterEsc',
+ )
+ ))),
+ );
+
+ # Vi positioning commands (suffixed to vi commands like 'd').
+ &InitKeymap(*vipos_keymap, 'ViNonPosition', 'vipos_keymap',
+
+ '^', 'ViFirstWord',
+ '0', 'BeginningOfLine',
+ '1', 'ViDigit',
+ '2', 'ViDigit',
+ '3', 'ViDigit',
+ '4', 'ViDigit',
+ '5', 'ViDigit',
+ '6', 'ViDigit',
+ '7', 'ViDigit',
+ '8', 'ViDigit',
+ '9', 'ViDigit',
+ '$', 'EndOfLine',
+ 'h', 'BackwardChar',
+ 'l', 'ForwardChar',
+ ' ', 'ForwardChar',
+ 'C-h', 'BackwardChar',
+ 'f', 'ViForwardFindChar',
+ 'F', 'ViBackwardFindChar',
+ 't', 'ViForwardToChar',
+ 'T', 'ViBackwardToChar',
+ ';', 'ViRepeatFindChar',
+ ',', 'ViInverseRepeatFindChar',
+ '%', 'ViFindMatchingParens',
+ '|', 'ViMoveToColumn',
+
+ # Arrow keys
+ ($inDOS ?
+ (
+ qq/"\0\115"/, 'ForwardChar', # 77: <Right arrow>
+ qq/"\0\113"/, 'BackwardChar', # 75: <Left arrow>
+ "\e", 'ViPositionEsc',
+ ) :
+
+ ($ENV{'TERM'} and $ENV{'TERM'} eq 'hpterm') ?
+ (
+ qq/"\eC"/, 'ForwardChar', # right arrow
+ qq/"\eD"/, 'BackwardChar', # left arrow
+ qq/"\e\\*"/, 'ViPositionEsc',
+ ) :
+
+ # Default
+ (
+ qq/"\e[C"/, 'ForwardChar', # right arrow
+ qq/"\e[D"/, 'BackwardChar', # left arrow
+ qq/"\e\\*"/, 'ViPositionEsc',
+ qq/"\e[\\*"/, 'ViPositionEsc',
+ )
+ ),
+ );
+
+ # Vi search string input mode for '/' and '?'.
+ &InitKeymap(*visearch_keymap, 'SelfInsert', 'visearch_keymap',
+
+ "\e", 'Ding',
+ 'C-c', 'Interrupt',
+ 'C-h', 'ViSearchBackwardDeleteChar',
+ 'C-w', 'UnixWordRubout',
+ 'C-u', 'UnixLineDiscard',
+ 'C-v', 'QuotedInsert',
+ 'DEL', 'ViSearchBackwardDeleteChar',
+ "\n", 'ViEndSearch',
+ "\r", 'ViEndSearch',
+ );
+
+ # These constant hashes hold the arguments to &forward_scan() or
+ # &backward_scan() for vi positioning commands, which all
+ # behave a little differently for delete, move, change, and yank.
+ #
+ # Note: I originally coded these as qr{}, but changed them to q{} for
+ # compatibility with older perls at the expense of some performance.
+ #
+ # Note: Some of the more obscure key combinations behave slightly
+ # differently in different vi implementation. This module matches
+ # the behavior of /usr/ucb/vi, which is different from the
+ # behavior of vim, nvi, and the ksh command line. One example is
+ # the command '2de', when applied to the string ('^' represents the
+ # cursor, not a character of the string):
+ #
+ # ^5.6 7...88888888
+ #
+ # With /usr/ucb/vi and with this module, the result is
+ #
+ # ^...88888888
+ #
+ # but with the other three vi implementations, the result is
+ #
+ # ^ 7...88888888
+
+ $Vi_delete_patterns = {
+ ord('w') => q{(?:\w+|[^\w\s]+|)\s*},
+ ord('W') => q{\S*\s*},
+ ord('b') => q{\w+\s*|[^\w\s]+\s*|^\s+},
+ ord('B') => q{\S+\s*|^\s+},
+ ord('e') => q{.\s*\w+|.\s*[^\w\s]+|.\s*$},
+ ord('E') => q{.\s*\S+|.\s*$},
+ };
+
+ $Vi_move_patterns = {
+ ord('w') => q{(?:\w+|[^\w\s]+|)\s*},
+ ord('W') => q{\S*\s*},
+ ord('b') => q{\w+\s*|[^\w\s]+\s*|^\s+},
+ ord('B') => q{\S+\s*|^\s+},
+ ord('e') => q{.\s*\w*(?=\w)|.\s*[^\w\s]*(?=[^\w\s])|.?\s*(?=\s$)},
+ ord('E') => q{.\s*\S*(?=\S)|.?\s*(?=\s$)},
+ };
+
+ $Vi_change_patterns = {
+ ord('w') => q{\w+|[^\w\s]+|\s},
+ ord('W') => q{\S+|\s},
+ ord('b') => q{\w+\s*|[^\w\s]+\s*|^\s+},
+ ord('B') => q{\S+\s*|^\s+},
+ ord('e') => q{.\s*\w+|.\s*[^\w\s]+|.\s*$},
+ ord('E') => q{.\s*\S+|.\s*$},
+ };
+
+ $Vi_yank_patterns = {
+ ord('w') => q{(?:\w+|[^\w\s]+|)\s*},
+ ord('W') => q{\S*\s*},
+ ord('b') => q{\w+\s*|[^\w\s]+\s*|^\s+},
+ ord('B') => q{\S+\s*|^\s+},
+ ord('e') => q{.\s*\w*(?=\w)|.\s*[^\w\s]*(?=[^\w\s])|.?\s*(?=\s$)},
+ ord('E') => q{.\s*\S*(?=\S)|.?\s*(?=\s$)},
+ };
+
+ my $default_mode = 'emacs';
+
+ *KeyMap = $var_EditingMode = $var_EditingMode{$default_mode};
+
+## my $name;
+## for $name ( keys %{'readline::'} ) {
+## # Create aliases accessible via tied interface
+## *{"rl_$1"} = \$ {"var_$1"} if $name =~ /$var_(.*)/;
+## }
+
+ 1; # Returning a glob causes a bug in db5.001m
+}
+
+sub init
+{
+ if ($ENV{'TERM'} and ($ENV{'TERM'} eq 'emacs' || $ENV{'TERM'} eq 'dumb')) {
+ $dumb_term = 1;
+ } elsif (! -c $term_IN && $term_IN eq \*STDIN) { # Believe if it is given
+ $stdin_not_tty = 1;
+ } else {
+ &get_window_size;
+ &F_ReReadInitFile if !defined($rl_NoInitFromFile);
+ $InputLocMsg = '';
+ *KeyMap = $var_EditingMode;
+ }
+
+ $initialized = 1;
+}
+
+
+##
+## InitKeymap(*keymap, 'default', 'name', bindings.....)
+##
+sub InitKeymap
+{
+ local(*KeyMap) = shift(@_);
+ my $default = shift(@_);
+ my $name = $KeyMap{'name'} = shift(@_);
+
+ # 'default' is now optional - if '', &do_command() defaults it to
+ # 'F_Ding'. Meta-maps now don't set a default - this lets
+ # us detect multiple '\*' default declarations. JP
+ if ($default ne '') {
+ my $func = $KeyMap{'default'} = "F_$default";
+ ### Temporarily disabled
+ die qq/Bad default function [$func] for keymap "$name"/
+ if !$autoload_broken and !defined(&$func);
+ }
+
+ &rl_bind if @_ > 0; ## The rest of @_ gets passed silently.
+}
+
+##
+## Accepts an array as pairs ($keyspec, $function, [$keyspec, $function]...).
+## and maps the associated bindings to the current KeyMap.
+##
+## keyspec should be the name of key sequence in one of two forms:
+##
+## Old (GNU readline documented) form:
+## M-x to indicate Meta-x
+## C-x to indicate Ctrl-x
+## M-C-x to indicate Meta-Ctrl-x
+## x simple char x
+## where 'x' above can be a single character, or the special:
+## special means
+## -------- -----
+## space space ( )
+## spc space ( )
+## tab tab (\t)
+## del delete (0x7f)
+## rubout delete (0x7f)
+## newline newline (\n)
+## lfd newline (\n)
+## ret return (\r)
+## return return (\r)
+## escape escape (\e)
+## esc escape (\e)
+##
+## New form:
+## "chars" (note the required double-quotes)
+## where each char in the list represents a character in the sequence, except
+## for the special sequences:
+## \\C-x Ctrl-x
+## \\M-x Meta-x
+## \\M-C-x Meta-Ctrl-x
+## \\e escape.
+## \\x x (if not one of the above)
+##
+##
+## FUNCTION should be in the form 'BeginningOfLine' or 'beginning-of-line'.
+## It is an error for the function to not be known....
+##
+## As an example, the following lines in .inputrc will bind one's xterm
+## arrow keys:
+## "\e[[A": previous-history
+## "\e[[B": next-history
+## "\e[[C": forward-char
+## "\e[[D": backward-char
+##
+
+sub filler_Pending ($) {
+ my $keys = shift;
+ sub {
+ my $c = shift;
+ push @Pending, map chr, @$keys;
+ return if not @$keys or $c == 1 or not defined(my $in = &getc_with_pending);
+ # provide the numeric argument
+ local(*KeyMap) = $var_EditingMode;
+ $doingNumArg = 1; # Allow NumArg inside NumArg
+ &do_command(*KeyMap, $c, ord $in);
+ return;
+ }
+}
+
+sub _unescape ($) {
+ my($key, @keys) = shift;
+ ## New-style bindings are enclosed in double-quotes.
+ ## Characters are taken verbatim except the special cases:
+ ## \C-x Control x (for any x)
+ ## \M-x Meta x (for any x)
+ ## \e Escape
+ ## \* Set the keymap default (JP: added this)
+ ## (must be the last character of the sequence)
+ ##
+ ## \x x (unless it fits the above pattern)
+ ##
+ ## Look for special case of "\C-\M-x", which should be treated
+ ## like "\M-\C-x".
+
+ while (length($key) > 0) {
+
+ # JP: fixed regex bugs below: changed all 's#' to 's#^'
+
+ if ($key =~ s#^\\C-\\M-(.)##) {
+ push(@keys, ord("\e"), &ctrl(ord($1)));
+ } elsif ($key =~ s#^\\(M-|e)##) {
+ push(@keys, ord("\e"));
+ } elsif ($key =~ s#^\\C-(.)##) {
+ push(@keys, &ctrl(ord($1)));
+ } elsif ($key =~ s#^\\x([0-9a-fA-F]{2})##) {
+ push(@keys, eval('0x'.$1));
+ } elsif ($key =~ s#^\\([0-7]{3})##) {
+ push(@keys, eval('0'.$1));
+ } elsif ($key =~ s#^\\\*$##) { # JP: added
+ push(@keys, 'default');
+ } elsif ($key =~ s#^\\([afnrtv])##) {
+ push(@keys, ord(eval(qq("\\$1"))));
+ } elsif ($key =~ s#^\\d##) {
+ push(@keys, 4); # C-d
+ } elsif ($key =~ s#^\\b##) {
+ push(@keys, 0x7f); # Backspace
+ } elsif ($key =~ s#^\\(.)##) {
+ push(@keys, ord($1));
+ } else {
+ push(@keys, ord($key));
+ substr($key,0,1) = '';
+ }
+ }
+ @keys
+}
+
+sub RL_func ($) {
+ my $name_or_macro = shift;
+ if ($name_or_macro =~ /^"((?:\\.|[^\\\"])*)"|^'((?:\\.|[^\\\'])*)'/s) {
+ filler_Pending [_unescape "$+"];
+ } else {
+ "F_$name_or_macro";
+ }
+}
+
+sub actually_do_binding
+{
+ ##
+ ## actually_do_binding($function1, \@sequence1, ...)
+ ##
+ ## Actually inserts the binding for @sequence to $function into the
+ ## current map. @sequence is an array of character ordinals.
+ ##
+ ## If @sequence is more than one element long, all but the last will
+ ## cause meta maps to be created.
+ ##
+ ## $Function will have an implicit "F_" prepended to it.
+ ##
+ while (@_) {
+ my $func = shift;
+ my ($key, @keys) = @{shift()};
+ $key += 0;
+ local(*KeyMap) = *KeyMap;
+ my $map;
+ while (@keys) {
+ if (defined($KeyMap[$key]) && ($KeyMap[$key] ne 'F_PrefixMeta')) {
+ warn "Warning$InputLocMsg: ".
+ "Re-binding char #$key from [$KeyMap[$key]] to meta for [@keys] => $func.\n" if $^W;
+ }
+ $KeyMap[$key] = 'F_PrefixMeta';
+ $map = "$KeyMap{'name'}_$key";
+ InitKeymap(*$map, '', $map) if !(%$map);
+ *KeyMap = *$map;
+ $key = shift @keys;
+ #&actually_do_binding($func, \@keys);
+ }
+
+ my $name = $KeyMap{'name'};
+ if ($key eq 'default') { # JP: added
+ warn "Warning$InputLocMsg: ".
+ " changing default action to $func in $name key map\n"
+ if $^W && defined $KeyMap{'default'};
+
+ $KeyMap{'default'} = RL_func $func;
+ }
+ else {
+ if (defined($KeyMap[$key]) && $KeyMap[$key] eq 'F_PrefixMeta'
+ && $func ne 'PrefixMeta')
+ {
+ warn "Warning$InputLocMsg: ".
+ " Re-binding char #$key to non-meta ($func) in $name key map\n"
+ if $^W;
+ }
+ $KeyMap[$key] = RL_func $func;
+ }
+ }
+}
+
+sub rl_bind
+{
+ my (@keys, $key, $func, $ord, @arr);
+
+ while (defined($key = shift(@_)) && defined($func = shift(@_)))
+ {
+ ##
+ ## Change the function name from something like
+ ## backward-kill-line
+ ## to
+ ## BackwardKillLine
+ ## if not already there.
+ ##
+ unless ($func =~ /^[\"\']/) {
+ $func = "\u$func";
+ $func =~ s/-(.)/\u$1/g;
+
+ # Temporary disabled
+ if (!$autoload_broken and !defined($ {'readline::'}{"F_$func"})) {
+ warn "Warning$InputLocMsg: bad bind function [$func]\n" if $^W;
+ next;
+ }
+ }
+
+ ## print "sequence [$key] func [$func]\n"; ##DEBUG
+
+ @keys = ();
+ ## See if it's a new-style binding.
+ if ($key =~ m/"((?:\\.|[^\\])*)"/s) {
+ @keys = _unescape "$1";
+ } else {
+ ## ol-dstyle binding... only one key (or Meta+key)
+ my ($isctrl, $orig) = (0, $key);
+ $isctrl = $key =~ s/\b(C|Control|CTRL)-//i;
+ push(@keys, ord("\e")) if $key =~ s/\b(M|Meta)-//i; ## is meta?
+ ## Isolate key part. This matches GNU's implementation.
+ ## If the key is '-', be careful not to delete it!
+ $key =~ s/.*-(.)/$1/;
+ if ($key =~ /^(space|spc)$/i) { $key = ' '; }
+ elsif ($key =~ /^(rubout|del)$/i) { $key = "\x7f"; }
+ elsif ($key =~ /^tab$/i) { $key = "\t"; }
+ elsif ($key =~ /^(return|ret)$/i) { $key = "\r"; }
+ elsif ($key =~ /^(newline|lfd)$/i) { $key = "\n"; }
+ elsif ($key =~ /^(escape|esc)$/i) { $key = "\e"; }
+ elsif (length($key) > 1) {
+ warn "Warning$InputLocMsg: strange binding [$orig]\n" if $^W;
+ }
+ $key = ord($key);
+ $key = &ctrl($key) if $isctrl;
+ push(@keys, $key);
+ }
+
+ #
+ ## Now do the mapping of the sequence represented in @keys
+ #
+ # print "&actually_do_binding($func, @keys)\n"; ##DEBUG
+ push @arr, $func, [@keys];
+ #&actually_do_binding($func, \@keys);
+ }
+ &actually_do_binding(@arr);
+}
+
+sub read_an_init_file {
+ my $file = shift;
+ my $include_depth = shift;
+ local *RC;
+ $file =~ s/^~([\\\/])/$ENV{HOME}$1/ if not -f $file and exists $ENV{HOME};
+ return unless open RC, "< $file";
+ my (@action) = ('exec'); ## exec, skip, ignore (until appropriate endif)
+ my (@level) = (); ## if, else
+
+ local $/ = "\n";
+ while (<RC>) {
+ s/^\s+//;
+ next if m/^\s*(#|$)/;
+ $InputLocMsg = " [$file line $.]";
+ if (/^\$if\s+(.*)/) {
+ my($test) = $1;
+ push(@level, 'if');
+ if ($action[$#action] ne 'exec') {
+ ## We're supposed to be skipping or ignoring this level,
+ ## so for subsequent levels we really ignore completely.
+ push(@action, 'ignore');
+ } else {
+ ## We're executing this IF... do the test.
+ ## The test is either "term=xxxx", or just a string that
+ ## we compare to $rl_readline_name;
+ if ($test =~ /term=([a-z0-9]+)/) {
+ $test = ($ENV{'TERM'} && $1 eq $ENV{'TERM'});
+ } else {
+ $test = $test =~ /^(perl|$rl_readline_name)\s*$/i;
+ }
+ push(@action, $test ? 'exec' : 'skip');
+ }
+ next;
+ } elsif (/^\$endif\b/) {
+ die qq/\rWarning$InputLocMsg: unmatched endif\n/ if @level == 0;
+ pop(@level);
+ pop(@action);
+ next;
+ } elsif (/^\$else\b/) {
+ die qq/\rWarning$InputLocMsg: unmatched else\n/ if
+ @level == 0 || $level[$#level] ne 'if';
+ $level[$#level] = 'else'; ## an IF turns into an ELSE
+ if ($action[$#action] eq 'skip') {
+ $action[$#action] = 'exec'; ## if were SKIPing, now EXEC
+ } else {
+ $action[$#action] = 'ignore'; ## otherwise, just IGNORE.
+ }
+ next;
+ } elsif (/^\$include\s+(\S+)/) {
+ if ($include_depth > $max_include_depth) {
+ warn "Deep recursion in \$include directives in $file.\n";
+ } else {
+ read_an_init_file($1, $include_depth + 1);
+ }
+ } elsif ($action[$#action] ne 'exec') {
+ ## skipping this one....
+ # readline permits trailing comments in inputrc
+ # this seems to solve the warnings caused by trailing comments in the
+ # default /etc/inputrc on Mandrake Linux boxes.
+ } elsif (m/\s*set\s+(\S+)\s+(\S*)/) { # Allow trailing comment
+ &rl_set($1, $2, $file);
+ } elsif (m/^\s*(\S+):\s+("(?:\\.|[^\\\"])*"|'(\\.|[^\\\'])*')/) { # Allow trailing comment
+ &rl_bind($1, $2);
+ } elsif (m/^\s*(\S+|"[^\"]+"):\s+(\S+)/) { # Allow trailing comment
+ &rl_bind($1, $2);
+ } else {
+ chomp;
+ warn "\rWarning$InputLocMsg: Bad line [$_]\n" if $^W;
+ }
+ }
+ close(RC);
+}
+
+sub F_ReReadInitFile
+{
+ my ($file) = $ENV{'TRP_INPUTRC'};
+ $file = $ENV{'INPUTRC'} unless defined $file;
+ unless (defined $file) {
+ return unless defined $ENV{'HOME'};
+ $file = "$ENV{'HOME'}/.inputrc";
+ }
+ read_an_init_file($file, 0);
+}
+
+sub get_ornaments_selected {
+ return if @$rl_term_set >= 6;
+ local $^W=0;
+ my $Orig = $Term::ReadLine::Perl::term->ornaments();
+ eval {
+ # Term::ReadLine does not expose its $terminal, so make another
+ require Term::Cap;
+ my $terminal = Tgetent Term::Cap ({OSPEED=>9600});
+ # and be sure the terminal supports highlighting
+ $terminal->Trequire('mr');
+ };
+ if (!$@ and $Orig ne ',,,'){
+ my @set = @$rl_term_set;
+
+ $Term::ReadLine::Perl::term->ornaments
+ (join(',', (split(/,/, $Orig))[0,1]) . ',mr,me') ;
+ @set[4,5] = @$rl_term_set[2,3];
+ $Term::ReadLine::Perl::term->ornaments($Orig);
+ @$rl_term_set = @set;
+ } else {
+ @$rl_term_set[4,5] = @$rl_term_set[2,3];
+ }
+}
+
+sub readline_dumb {
+ local $\ = '';
+ print $term_OUT $prompt;
+ local $/ = "\n";
+ return undef
+ if !defined($line = $Term::ReadLine::Perl::term->get_line);
+ chomp($line);
+ $| = $oldbar;
+ select $old;
+ return $line;
+}
+
+##
+## This is it. Called as &readline'readline($prompt, $default),
+## (DEFAULT can be omitted) the next input line is returned (undef on EOF).
+##
+sub readline
+{
+ $Term::ReadLine::Perl::term->register_Tk
+ if not $Term::ReadLine::registered and $Term::ReadLine::toloop
+ and defined &Tk::DoOneEvent;
+ if ($stdin_not_tty) {
+ local $/ = "\n";
+ return undef if !defined($line = <$term_IN>);
+ chomp($line);
+ return $line;
+ }
+
+ $old = select $term_OUT;
+ $oldbar = $|;
+ local($|) = 1;
+ local($input);
+
+ ## prompt should be given to us....
+ $prompt = defined($_[0]) ? $_[0] : 'INPUT> ';
+
+ # Try to move cursor to the beginning of the next line if this line
+ # contains anything.
+
+ # On DOSish 80-wide console
+ # perl -we "print 1 x shift, qq(\b2\r3); sleep 2" 79
+ # prints 3 on the same line,
+ # perl -we "print 1 x shift, qq(\b2\r3); sleep 2" 80
+ # on the next; $rl_screen_width is 79.
+
+ # on XTerm one needs to increase the number by 1.
+
+ print $term_OUT ' ' x ($rl_screen_width - !$rl_last_pos_can_backspace) . "\b \r"
+ if $rl_scroll_nextline;
+
+ if ($dumb_term) {
+ return readline_dumb;
+ }
+
+ # test if we resume an 'Operate' command
+ if ($rl_OperateCount > 0 && (!defined $_[1] || $_[1] eq '')) {
+ ## it's from a valid previous 'Operate' command and
+ ## user didn't give a default line
+ ## we leave $rl_HistoryIndex untouched
+ $line = $rl_History[$rl_HistoryIndex];
+ } else {
+ ## set history pointer at the end of history
+ $rl_HistoryIndex = $#rl_History + 1;
+ $rl_OperateCount = 0;
+ $line = defined $_[1] ? $_[1] : '';
+ }
+ $rl_OperateCount-- if $rl_OperateCount > 0;
+
+ $line_for_revert = $line;
+
+# I don't think we need to do this, actually...
+# while (&ioctl(STDIN,$FIONREAD,$fion))
+# {
+# local($n_chars_available) = unpack ($fionread_t, $fion);
+# ## print "n_chars = $n_chars_available\n";
+# last if $n_chars_available == 0;
+# $line .= getc_with_pending; # should we prepend if $rl_start_default_at_beginning?
+# }
+
+ $D = $rl_start_default_at_beginning ? 0 : length($line); ## set dot.
+ $LastCommandKilledText = 0; ## heck, was no last command.
+ $lastcommand = ''; ## Well, there you go.
+ $line_rl_mark = -1;
+
+ ##
+ ## some stuff for &redisplay.
+ ##
+ $lastredisplay = ''; ## Was no last redisplay for this time.
+ $lastlen = length($lastredisplay);
+ $lastpromptlen = 0;
+ $lastdelta = 0; ## Cursor was nowhere
+ $si = 0; ## Want line to start left-justified
+ $force_redraw = 1; ## Want to display with brute force.
+ if (!eval {SetTTY()}) { ## Put into raw mode.
+ warn $@ if $@;
+ $dumb_term = 1;
+ return readline_dumb;
+ }
+
+ *KeyMap = $var_EditingMode;
+ undef($AcceptLine); ## When set, will return its value.
+ undef($ReturnEOF); ## ...unless this on, then return undef.
+ @Pending = (); ## Contains characters to use as input.
+ @undo = (); ## Undo history starts empty for each line.
+ @undoGroupS = (); ## Undo groups start empty for each line.
+ undef $memorizedArg; ## No digitArgument memorized
+ undef $memorizedPos; ## No position memorized
+
+ undef $Vi_undo_state;
+ undef $Vi_undo_all_state;
+
+ # We need to do some additional initialization for vi mode.
+ # RS: bug reports/platform issues are welcome: russ@dvns.com
+ if ($KeyMap{'name'} eq 'vi_keymap'){
+ &F_ViInput();
+ if ($rl_vi_replace_default_on_insert){
+ local $^W=0;
+ my $Orig = $Term::ReadLine::Perl::term->ornaments();
+ eval {
+ # Term::ReadLine does not expose its $terminal, so make another
+ require Term::Cap;
+ my $terminal = Tgetent Term::Cap ({OSPEED=>9600});
+ # and be sure the terminal supports highlighting
+ $terminal->Trequire('mr');
+ };
+ if (!$@ and $Orig ne ',,,'){
+ $Term::ReadLine::Perl::term->ornaments
+ (join(',', (split(/,/, $Orig))[0,1]) . ',mr,me')
+ }
+ my $F_SelfInsert_Real = \&F_SelfInsert;
+ *F_SelfInsert = sub {
+ $Term::ReadLine::Perl::term->ornaments($Orig);
+ &F_ViChangeEntireLine;
+ local $^W=0;
+ *F_SelfInsert = $F_SelfInsert_Real;
+ &F_SelfInsert;
+ };
+ my $F_ViEndInsert_Real = \&F_ViEndInsert;
+ *F_ViEndInsert = sub {
+ $Term::ReadLine::Perl::term->ornaments($Orig);
+ local $^W=0;
+ *F_SelfInsert = $F_SelfInsert_Real;
+ *F_ViEndInsert = $F_ViEndInsert_Real;
+ &F_ViEndInsert;
+ $force_redraw = 1;
+ redisplay();
+ };
+ }
+ }
+
+ if ($rl_default_selected) {
+ redisplay_high();
+ } else {
+ &redisplay(); ## Show the line (prompt+default at this point).
+ }
+
+ # pretend input if we 'Operate' on more than one line
+ &F_OperateAndGetNext($rl_OperateCount) if $rl_OperateCount > 0;
+
+ $rl_first_char = 1;
+ while (!defined($AcceptLine)) {
+ ## get a character of input
+ $input = &getc_with_pending(); # bug in debugger, returns 42. - No more!
+
+ unless (defined $input) {
+ # XXX What to do??? Until this is clear, just pretend we got EOF
+ $AcceptLine = $ReturnEOF = 1;
+ last;
+ }
+ preserve_state();
+
+ $ThisCommandKilledText = 0;
+ ##print "\n\rline is @$D:[$line]\n\r"; ##DEBUG
+ my $cmd = get_command($var_EditingMode, ord($input));
+ if ( $rl_first_char && $cmd =~ /^F_(SelfInsert$|Yank)/
+ && length $line && $rl_default_selected ) {
+ # (Backward)?DeleteChar specialcased in the code
+ $line = '';
+ $D = 0;
+ $cmd = 'F_BackwardDeleteChar' if $cmd eq 'F_DeleteChar';
+ }
+ undef $doingNumArg;
+ &$cmd(1, ord($input)); ## actually execute input
+ $rl_first_char = 0;
+ $lastcommand = $cmd;
+ *KeyMap = $var_EditingMode; # JP: added
+
+ # In Vi command mode, don't position the cursor beyond the last
+ # character of the line buffer.
+ &F_BackwardChar(1) if $Vi_mode and $line ne ''
+ and &at_end_of_line and $KeyMap{'name'} eq 'vicmd_keymap';
+
+ &redisplay();
+ $LastCommandKilledText = $ThisCommandKilledText;
+ }
+
+ undef @undo; ## Release the memory.
+ undef @undoGroupS; ## Release the memory.
+ &ResetTTY; ## Restore the tty state.
+ $| = $oldbar;
+ select $old;
+ return undef if defined($ReturnEOF);
+ #print STDOUT "|al=`$AcceptLine'";
+ $AcceptLine; ## return the line accepted.
+}
+
+## ctrl(ord('a')) will return the ordinal for Ctrl-A.
+sub ctrl {
+ $_[0] ^ (($_[0]>=ord('a') && $_[0]<=ord('z')) ? 0x60 : 0x40);
+}
+
+
+
+sub SetTTY {
+ return if $dumb_term || $stdin_not_tty;
+ #return system 'stty raw -echo' if defined &DB::DB;
+ if (defined $term_readkey) {
+ Term::ReadKey::ReadMode(4, $term_IN);
+ if ($^O eq 'MSWin32') {
+ # If we reached this, Perl isn't cygwin; Enter sends \r; thus we need binmode
+ # XXXX Do we need to undo??? $term_IN is most probably private now...
+ binmode $term_IN;
+ }
+ return 1;
+ }
+# system 'stty raw -echo';
+
+ $sgttyb = ''; ## just to quiet "perl -w";
+ if ($useioctl && $^O ne 'solaris' && defined $TIOCGETP
+ && &ioctl($term_IN,$TIOCGETP,$sgttyb)) {
+ @tty_buf = unpack($sgttyb_t,$sgttyb);
+ if (defined $ENV{OS2_SHELL}) {
+ $tty_buf[3] &= ~$mode;
+ $tty_buf[3] &= ~$ECHO;
+ } else {
+ $tty_buf[4] |= $mode;
+ $tty_buf[4] &= ~$ECHO;
+ }
+ $sgttyb = pack($sgttyb_t,@tty_buf);
+ &ioctl($term_IN,$TIOCSETP,$sgttyb) || die "Can't ioctl TIOCSETP: $!";
+ } elsif (!$usestty) {
+ return 0;
+ } else {
+ warn <<EOW if $useioctl and not defined $ENV{PERL_READLINE_NOWARN};
+Can't ioctl TIOCGETP: $!
+Consider installing Term::ReadKey from CPAN site nearby
+ at http://www.perl.com/CPAN
+Or use
+ perl -MCPAN -e shell
+to reach CPAN. Falling back to 'stty'.
+ If you do not want to see this warning, set PERL_READLINE_NOWARN
+in your environment.
+EOW
+ # '; # For Emacs.
+ $useioctl = 0;
+ system 'stty raw -echo' and ($usestty = 0, die "Cannot call `stty': $!");
+ if ($^O eq 'MSWin32') {
+ # If we reached this, Perl isn't cygwin, but STTY is present ==> cygwin
+ # The symptoms: now Enter sends \r; thus we need binmode
+ # XXXX Do we need to undo??? $term_IN is most probably private now...
+ binmode $term_IN;
+ }
+ }
+ return 1;
+}
+
+sub ResetTTY {
+ return if $dumb_term || $stdin_not_tty;
+ #return system 'stty -raw echo' if defined &DB::DB;
+ if (defined $term_readkey) {
+ return Term::ReadKey::ReadMode(0, $term_IN);
+ }
+
+# system 'stty -raw echo';
+ if ($useioctl) {
+ &ioctl($term_IN,$TIOCGETP,$sgttyb) || die "Can't ioctl TIOCGETP: $!";
+ @tty_buf = unpack($sgttyb_t,$sgttyb);
+ if (defined $ENV{OS2_SHELL}) {
+ $tty_buf[3] |= $mode;
+ $tty_buf[3] |= $ECHO;
+ } else {
+ $tty_buf[4] &= ~$mode;
+ $tty_buf[4] |= $ECHO;
+ }
+ $sgttyb = pack($sgttyb_t,@tty_buf);
+ &ioctl($term_IN,$TIOCSETP,$sgttyb) || die "Can't ioctl TIOCSETP: $!";
+ } elsif ($usestty) {
+ system 'stty -raw echo' and die "Cannot call `stty': $!";
+ }
+}
+
+# Substr_with_props: gives the substr of prompt+string with embedded
+# face-change commands
+
+sub substr_with_props {
+ my ($p, $s, $from, $len, $ket, $bsel, $esel) = @_;
+ my $lp = length $p;
+
+ defined $from or $from = 0;
+ defined $len or $len = length($p) + length($s) - $from;
+ unless (defined $ket) {
+ warn 'bug in Term::ReadLine::Perl, please report to its author cpan@ilyaz.org';
+ $ket = '';
+ }
+ # We may draw over to put cursor in a correct position:
+ $ket = '' if $len < length($p) + length($s) - $from; # Not redrawn
+
+ if ($from >= $lp) {
+ $p = '';
+ $s = substr $s, $from - $lp;
+ $lp = 0;
+ } else {
+ $p = substr $p, $from;
+ $lp -= $from;
+ $from = 0;
+ }
+ $s = substr $s, 0, $len - $lp;
+ $p =~ s/^(\s*)//; my $bs = $1;
+ $p =~ s/(\s*)$//; my $as = $1;
+ $p = $rl_term_set->[0] . $p . $rl_term_set->[1] if length $p;
+ $p = "$bs$p$as";
+ $ket = chop $s if $ket;
+ if (defined $bsel and $bsel != $esel) {
+ $bsel = $len if $bsel > $len;
+ $esel = $len if $esel > $len;
+ }
+ if (defined $bsel and $bsel != $esel) {
+ get_ornaments_selected;
+ $bsel -= $lp; $esel -= $lp;
+ my ($pre, $sel, $post) =
+ (substr($s, 0, $bsel),
+ substr($s, $bsel, $esel-$bsel),
+ substr($s, $esel));
+ $pre = $rl_term_set->[2] . $pre . $rl_term_set->[3] if length $pre;
+ $sel = $rl_term_set->[4] . $sel . $rl_term_set->[5] if length $sel;
+ $post = $rl_term_set->[2] . $post . $rl_term_set->[3] if length $post;
+ $s = "$pre$sel$post"
+ } else {
+ $s = $rl_term_set->[2] . $s . $rl_term_set->[3] if length $s;
+ }
+
+ if (!$lp) { # Should not happen...
+ return $s;
+ } elsif (!length $s) { # Should not happen
+ return $p;
+ } else { # Do not underline spaces in the prompt
+ return "$p$s"
+ . (length $ket ? ($rl_term_set->[0] . $ket . $rl_term_set->[1]) : '');
+ }
+}
+
+sub redisplay_high {
+ get_ornaments_selected();
+ @$rl_term_set[2,3,4,5] = @$rl_term_set[4,5,2,3];
+ &redisplay(); ## Show the line, default inverted.
+ @$rl_term_set[2,3,4,5] = @$rl_term_set[4,5,2,3];
+ $force_redraw = 1;
+}
+
+##
+## redisplay()
+##
+## Updates the screen to reflect the current $line.
+##
+## For the purposes of this routine, we prepend the prompt to a local copy of
+## $line so that we display the prompt as well. We then modify it to reflect
+## that some characters have different sizes (i.e. control-C is represented
+## as ^C, tabs are expanded, etc.)
+##
+## This routine is somewhat complicated by two-byte characters.... must
+## make sure never to try do display just half of one.
+##
+## NOTE: If an argument is given, it is used instead of the prompt.
+##
+## This is some nasty code.
+##
+sub redisplay
+{
+ ## local $line has prompt also; take that into account with $D.
+ local($prompt) = defined($_[0]) ? $_[0] : $prompt;
+ my ($thislen, $have_bra);
+ my($dline) = $prompt . $line;
+ local($D) = $D + length($prompt);
+ my ($bsel, $esel);
+ if (defined pos $line) {
+ $bsel = (pos $line) + length $prompt;
+ }
+ my ($have_ket) = '';
+
+ ##
+ ## If the line contains anything that might require special processing
+ ## for displaying (such as tabs, control characters, etc.), we will
+ ## take care of that now....
+ ##
+ if ($dline =~ m/[^\x20-\x7e]/)
+ {
+ local($new, $Dinc, $c) = ('', 0);
+
+ ## Look at each character of $dline in turn.....
+ for ($i = 0; $i < length($dline); $i++) {
+ $c = substr($dline, $i, 1);
+
+ ## A tab to expand...
+ if ($c eq "\t") {
+ $c = ' ' x (8 - (($i-length($prompt)) % 8));
+
+ ## A control character....
+ } elsif ($c =~ tr/\000-\037//) {
+ $c = sprintf("^%c", ord($c)+ord('@'));
+
+ ## the delete character....
+ } elsif (ord($c) == 127) {
+ $c = '^?';
+ }
+ $new .= $c;
+
+ ## Bump over $D if this char is expanded and left of $D.
+ $Dinc += length($c) - 1 if (length($c) > 1 && $i < $D);
+ ## Bump over $bsel if this char is expanded and left of $bsel.
+ $bsel += length($c) - 1 if (defined $bsel && length($c) > 1 && $i < $bsel);
+ }
+ $dline = $new;
+ $D += $Dinc;
+ }
+
+ ##
+ ## Now $dline is what we'd like to display (with a prepended prompt)
+ ## $D is the position of the cursor on it.
+ ##
+ ## If it's too long to fit on the line, we must decide what we can fit.
+ ##
+ ## If we end up moving the screen index ($si) [index of the leftmost
+ ## character on the screen], to some place other than the front of the
+ ## the line, we'll have to make sure that it's not on the first byte of
+ ## a 2-byte character, 'cause we'll be placing a '<' marker there, and
+ ## that would screw up the 2-byte character.
+ ##
+ ## $si is preserved between several displays (if possible).
+ ##
+ ## Similarly, if the line needs chopped off, we make sure that the
+ ## placement of the tailing '>' won't screw up any 2-byte character in
+ ## the vicinity.
+
+ # Now $si keeps the value from previous display
+ if ($D == length($prompt) # If prompts fits exactly, show only if need not show trailing '>'
+ and length($prompt) < $rl_screen_width - (0 != length $dline)) {
+ $si = 0; ## prefer displaying the whole prompt
+ } elsif ($si >= $D) { # point to the left of what was displayed
+ $si = &max(0, $D - $rl_margin);
+ $si-- if $si > 0 && $si != length($prompt) && !&OnSecondByte($si);
+ } elsif ($si + $rl_screen_width <= $D) { # Point to the right of ...
+ $si = &min(length($dline), ($D - $rl_screen_width) + $rl_margin);
+ $si-- if $si > 0 && $si != length($prompt) && !&OnSecondByte($si);
+ } elsif (length($dline) - $si < $rl_screen_width - $rl_margin and $si) {
+ # Too little of the line shown
+ $si = &max(0, length($dline) - $rl_screen_width + 3);
+ $si-- if $si > 0 && $si != length($prompt) && !&OnSecondByte($si);
+ } else {
+ ## Fine as-is.... don't need to change $si.
+ }
+ $have_bra = 1 if $si != 0; # Need the "chopped-off" marker
+
+ $thislen = &min(length($dline) - $si, $rl_screen_width);
+ if ($si + $thislen < length($dline)) {
+ ## need to place a '>'... make sure to place on first byte.
+ $thislen-- if &OnSecondByte($si+$thislen-1);
+ substr($dline, $si+$thislen-1,1) = '>';
+ $have_ket = 1;
+ }
+
+ ##
+ ## Now know what to display.
+ ## Must get substr($dline, $si, $thislen) on the screen,
+ ## with the cursor at $D-$si characters from the left edge.
+ ##
+ $dline = substr($dline, $si, $thislen);
+ $delta = $D - $si; ## delta is cursor distance from beginning of $dline.
+ if (defined $bsel) { # Highlight the selected part
+ $bsel -= $si;
+ $esel = $delta;
+ ($bsel, $esel) = ($esel, $bsel) if $bsel > $esel;
+ $bsel = 0 if $bsel < 0;
+ if ($have_ket) {
+ $esel = $thislen - 1 if $esel > $thislen - 1;
+ } else {
+ $esel = $thislen if $esel > $thislen;
+ }
+ }
+ if ($si >= length($prompt)) { # Keep $dline for $lastredisplay...
+ $prompt = ($have_bra ? "<" : "");
+ $dline = substr $dline, 1; # After prompt
+ $bsel = 1 if defined $bsel and $bsel == 0;
+ } else {
+ $dline = substr($dline, (length $prompt) - $si);
+ $prompt = substr($prompt,$si);
+ substr($prompt, 0, 1) = '<' if $si > 0;
+ }
+ # Now $dline is the part after the prompt...
+
+ ##
+ ## Now must output $dline, with cursor $delta spaces from left of TTY
+ ##
+
+ local ($\, $,) = ('','');
+
+ ##
+ ## If $force_redraw is not set, we can attempt to optimize the redisplay
+ ## However, if we don't happen to find an easy way to optimize, we just
+ ## fall through to the brute-force method of re-drawing the whole line.
+ ##
+ if (not $force_redraw and not defined $bsel)
+ {
+ ## can try to optimize here a bit.
+
+ ## For when we only need to move the cursor
+ if ($lastredisplay eq $dline and $lastpromptlen == length $prompt) {
+ ## If we need to move forward, just overwrite as far as we need.
+ if ($lastdelta < $delta) {
+ print $term_OUT
+ substr_with_props($prompt, $dline,
+ $lastdelta, $delta-$lastdelta, $have_ket);
+ ## Need to move back.
+ } elsif($lastdelta > $delta) {
+ ## Two ways to move back... use the fastest. One is to just
+ ## backspace the proper amount. The other is to jump to the
+ ## the beginning of the line and overwrite from there....
+ my $out = substr_with_props($prompt, $dline, 0, $delta, $have_ket);
+ if ($lastdelta - $delta <= length $out) {
+ print $term_OUT "\b" x ($lastdelta - $delta);
+ } else {
+ print $term_OUT "\r", $out;
+ }
+ }
+ ($lastlen, $lastredisplay, $lastdelta, $lastpromptlen)
+ = ($thislen, $dline, $delta, length $prompt);
+ # print $term_OUT "\a"; # Debugging
+ return;
+ }
+
+ ## for when we've just added stuff to the end
+ if ($thislen > $lastlen &&
+ $lastdelta == $lastlen &&
+ $delta == $thislen &&
+ $lastpromptlen == length($prompt) &&
+ substr($dline, 0, $lastlen - $lastpromptlen) eq $lastredisplay)
+ {
+ print $term_OUT substr_with_props($prompt, $dline,
+ $lastdelta, undef, $have_ket);
+ # print $term_OUT "\a"; # Debugging
+ ($lastlen, $lastredisplay, $lastdelta, $lastpromptlen)
+ = ($thislen, $dline, $delta, length $prompt);
+ return;
+ }
+
+ ## There is much more opportunity for optimizing.....
+ ## something to work on later.....
+ }
+
+ ##
+ ## Brute force method of redisplaying... redraw the whole thing.
+ ##
+
+ print $term_OUT "\r", substr_with_props($prompt, $dline, 0, undef, $have_ket, $bsel, $esel);
+ my $back = length ($dline) + length ($prompt) - $delta;
+ $back += $lastlen - $thislen,
+ print $term_OUT ' ' x ($lastlen - $thislen) if $lastlen > $thislen;
+
+ if ($back) {
+ my $out = substr_with_props($prompt, $dline, 0, $delta, $have_ket, $bsel, $esel);
+ if ($back <= length $out and not defined $bsel) {
+ print $term_OUT "\b" x $back;
+ } else {
+ print $term_OUT "\r", $out;
+ }
+ }
+
+ ($lastlen, $lastredisplay, $lastdelta, $lastpromptlen)
+ = ($thislen, $dline, $delta, length $prompt);
+
+ $force_redraw = 0;
+}
+
+sub min { $_[0] < $_[1] ? $_[0] : $_[1]; }
+
+sub getc_with_pending {
+
+ my $key = @Pending ? shift(@Pending) : &$rl_getc;
+
+ # Save keystrokes for vi '.' command
+ push(@$Dot_buf, $key) if $Dot_buf;
+
+ $key;
+}
+
+sub rl_getc {
+ my $key; # JP: Added missing declaration
+ if (defined $term_readkey) { # XXXX ???
+ $Term::ReadLine::Perl::term->Tk_loop
+ if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
+ $key = Term::ReadKey::ReadKey(0, $term_IN);
+ } else {
+ $key = $Term::ReadLine::Perl::term->get_c;
+ }
+}
+
+##
+## get_command(keymap, ord_command_char)
+##
+## If the KEYMAP has an entry for COMMAND, it is returned.
+## Otherwise, the default command is returned.
+##
+sub get_command
+{
+ local *KeyMap = shift;
+ my ($key) = @_;
+ my $cmd = defined($KeyMap[$key]) ? $KeyMap[$key]
+ : ($KeyMap{'default'} || 'F_Ding');
+ if (!defined($cmd) || $cmd eq ''){
+ warn "internal error (key=$key)";
+ $cmd = 'F_Ding';
+ }
+ $cmd
+}
+
+##
+## do_command(keymap, numericarg, command)
+##
+## If the KEYMAP has an entry for COMMAND, it is executed.
+## Otherwise, the default command for the keymap is executed.
+##
+sub do_command
+{
+ my ($keymap, $count, $key) = @_;
+ my $cmd = get_command($keymap, $key);
+
+ local *KeyMap = $keymap; # &$cmd may expect it...
+ &$cmd($count, $key);
+ $lastcommand = $cmd;
+}
+
+##
+## Save whatever state we wish to save as an anonymous array.
+## The only other function that needs to know about its encoding is getstate/preserve_state.
+##
+sub savestate
+{
+ [$D, $si, $LastCommandKilledText, $KillBuffer, $line, @_];
+}
+
+# consolidate only-movement changes together...
+sub preserve_state {
+ return if $Vi_mode;
+ push(@undo, savestate()), return unless @undo;
+ my $last = $undo[-1];
+ my @only_movement;
+ if ( #$last->[1] == $si and $last->[2] eq $LastCommandKilledText
+ # and $last->[3] eq $KillBuffer and
+ $last->[4] eq $line ) {
+ # Only position changed; remove old only-position-changed records
+ pop @undo if $undo[-1]->[5];
+ @only_movement = 1;
+ }
+ push(@undo, savestate(@only_movement));
+}
+
+##
+## $_[1] is an ASCII ordinal; inserts as per $count.
+##
+sub F_SelfInsert
+{
+ remove_selection();
+ my ($count, $ord) = @_;
+ my $text2add = pack('C', $ord) x $count;
+ if ($InsertMode) {
+ substr($line,$D,0) .= $text2add;
+ } else {
+ ## note: this can screw up with 2-byte characters.
+ substr($line,$D,length($text2add)) = $text2add;
+ }
+ $D += length($text2add);
+}
+
+##
+## Return the line as-is to the user.
+##
+sub F_AcceptLine
+{
+ &add_line_to_history;
+ $AcceptLine = $line;
+ local $\ = '';
+ print $term_OUT "\r\n";
+ $force_redraw = 0;
+ (pos $line) = undef; # Another way to force redraw...
+}
+
+sub add_line_to_history
+{
+ ## Insert into history list if:
+ ## * bigger than the minimal length
+ ## * not same as last entry
+ ##
+ if (length($line) >= $minlength
+ && (!@rl_History || $rl_History[$#rl_History] ne $line)
+ ) {
+ ## if the history list is full, shift out an old one first....
+ while (@rl_History >= $rl_MaxHistorySize) {
+ shift(@rl_History);
+ $rl_HistoryIndex--;
+ }
+
+ push(@rl_History, $line); ## tack new one on the end
+ }
+}
+
+
+sub remove_selection {
+ if ( $rl_first_char && length $line && $rl_default_selected ) {
+ $line = '';
+ $D = 0;
+ return 1;
+ }
+ if ($rl_delete_selection and defined pos $line and $D != pos $line) {
+ kill_text(pos $line, $D);
+ return 1;
+ }
+ return;
+}
+
+#sub F_ReReadInitFile;
+#sub rl_getc;
+sub F_ForwardChar;
+sub F_BackwardChar;
+sub F_BeginningOfLine;
+sub F_EndOfLine;
+sub F_ForwardWord;
+sub F_BackwardWord;
+sub F_RedrawCurrentLine;
+sub F_ClearScreen;
+# sub F_SelfInsert;
+sub F_QuotedInsert;
+sub F_TabInsert;
+#sub F_AcceptLine;
+sub F_OperateAndGetNext;
+sub F_BackwardDeleteChar;
+sub F_DeleteChar;
+sub F_UnixWordRubout;
+sub F_UnixLineDiscard;
+sub F_UpcaseWord;
+sub F_DownCaseWord;
+sub F_CapitalizeWord;
+sub F_TransposeWords;
+sub F_TransposeChars;
+sub F_PreviousHistory;
+sub F_NextHistory;
+sub F_BeginningOfHistory;
+sub F_EndOfHistory;
+sub F_ReverseSearchHistory;
+sub F_ForwardSearchHistory;
+sub F_HistorySearchBackward;
+sub F_HistorySearchForward;
+sub F_KillLine;
+sub F_BackwardKillLine;
+sub F_Yank;
+sub F_YankPop;
+sub F_YankNthArg;
+sub F_KillWord;
+sub F_BackwardKillWord;
+sub F_Abort;
+sub F_DoLowercaseVersion;
+sub F_DoMetaVersion;
+sub F_DoControlVersion;
+sub F_Undo;
+sub F_RevertLine;
+sub F_EmacsEditingMode;
+sub F_Interrupt;
+sub F_PrefixMeta;
+sub F_UniversalArgument;
+sub F_DigitArgument;
+sub F_OverwriteMode;
+sub F_InsertMode;
+sub F_ToggleInsertMode;
+sub F_Suspend;
+sub F_Ding;
+sub F_PossibleCompletions;
+sub F_Complete;
+sub F_YankClipboard;
+sub F_CopyRegionAsKillClipboard;
+sub F_KillRegionClipboard;
+sub clipboard_set;
+sub F_BeginUndoGroup;
+sub F_EndUndoGroup;
+sub F_DoNothing;
+sub F_ForceMemorizeDigitArgument;
+sub F_MemorizeDigitArgument;
+sub F_UnmemorizeDigitArgument;
+sub F_ResetDigitArgument;
+sub F_MergeInserts;
+sub F_MemorizePos;
+sub F_BeginPasteGroup;
+sub F_EndPasteGroup;
+sub F_BeginEditGroup;
+sub F_EndEditGroup;
+
+# Comment next line and __DATA__ line below to disable the selfloader.
+
+use SelfLoader;
+
+1;
+
+__DATA__
+
+# From here on anything may be autoloaded
+
+sub max { $_[0] > $_[1] ? $_[0] : $_[1]; }
+sub isupper { ord($_[0]) >= ord('A') && ord($_[0]) <= ord('Z'); }
+sub islower { ord($_[0]) >= ord('a') && ord($_[0]) <= ord('z'); }
+sub toupper { &islower ? pack('c', ord($_[0])-ord('a')+ord('A')) : $_[0];}
+sub tolower { &isupper ? pack('c', ord($_[0])-ord('A')+ord('a')) : $_[0];}
+
+##
+## rl_set(var_name, value_string)
+##
+## Sets the named variable as per the given value, if both are appropriate.
+## Allows the user of the package to set such things as HorizontalScrollMode
+## and EditingMode. Value_string may be of the form
+## HorizontalScrollMode
+## horizontal-scroll-mode
+##
+## Also called during the parsing of ~/.inputrc for "set var value" lines.
+##
+## The previous value is returned, or undef on error.
+###########################################################################
+## Consider the following example for how to add additional variables
+## accessible via rl_set (and hence via ~/.inputrc).
+##
+## Want:
+## We want an external variable called "FooTime" (or "foo-time").
+## It may have values "January", "Monday", or "Noon".
+## Internally, we'll want those values to translate to 1, 2, and 12.
+##
+## How:
+## Have an internal variable $var_FooTime that will represent the current
+## internal value, and initialize it to the default value.
+## Make an array %var_FooTime whose keys and values are are the external
+## (January, Monday, Noon) and internal (1, 2, 12) values:
+##
+## $var_FooTime = $var_FooTime{'January'} = 1; #default
+## $var_FooTime{'Monday'} = 2;
+## $var_FooTime{'Noon'} = 12;
+##
+sub rl_set
+{
+ local($var, $val) = @_;
+
+ # &preinit's keys are all Capitalized
+ $val = ucfirst lc $val if $val =~ /^(on|off)$/i;
+
+ $var = 'CompleteAddsuffix' if $var eq 'visible-stats';
+
+ ## if the variable is in the form "some-name", change to "SomeName"
+ local($_) = "\u$var";
+ local($return) = undef;
+ s/-(.)/\u$1/g;
+
+ # Skip unknown variables:
+ return unless defined $ {'readline::'}{"var_$_"};
+ local(*V); # avoid <Undefined value assign to typeglob> warning
+ { local $^W; *V = $ {'readline::'}{"var_$_"}; }
+ if (!defined($V)) { # XXX Duplicate check?
+ warn("Warning$InputLocMsg:\n".
+ " Invalid variable `$var'\n") if $^W;
+ } elsif (!defined($V{$val})) {
+ local(@selections) = keys(%V);
+ warn("Warning$InputLocMsg:\n".
+ " Invalid value `$val' for variable `$var'.\n".
+ " Choose from [@selections].\n") if $^W;
+ } else {
+ $return = $V;
+ $V = $V{$val}; ## make the setting
+ }
+ $return;
+}
+
+##
+## OnSecondByte($index)
+##
+## Returns true if the byte at $index into $line is the second byte
+## of a two-byte character.
+##
+sub OnSecondByte
+{
+ return 0 if !$_rl_japanese_mb || $_[0] == 0 || $_[0] == length($line);
+
+ die 'internal error' if $_[0] > length($line);
+
+ ##
+ ## must start looking from the beginning of the line .... can
+ ## have one- and two-byte characters interspersed, so can't tell
+ ## without starting from some know location.....
+ ##
+ local($i);
+ for ($i = 0; $i < $_[0]; $i++) {
+ next if ord(substr($line, $i, 1)) < 0x80;
+ ## We have the first byte... must bump up $i to skip past the 2nd.
+ ## If that one we're skipping past is the index, it should be changed
+ ## to point to the first byte of the pair (therefore, decremented).
+ return 1 if ++$i == $_[0];
+ }
+ 0; ## seemed to be OK.
+}
+
+##
+## CharSize(index)
+##
+## Returns the size of the character at the given INDEX in the
+## current line. Most characters are just one byte in length,
+## but if the byte at the index and the one after has the high
+## bit set those two bytes are one character of size=2.
+##
+## Assumes that index points to the first of a 2-byte char if not
+## pointing to a 2-byte char.
+##
+sub CharSize
+{
+ return 2 if $_rl_japanese_mb &&
+ ord(substr($line, $_[0], 1)) >= 0x80 &&
+ ord(substr($line, $_[0]+1, 1)) >= 0x80;
+ 1;
+}
+
+sub GetTTY
+{
+ $base_termios = $termios; # make it long enough
+ &ioctl($term_IN,$TCGETS,$base_termios) || die "Can't ioctl TCGETS: $!";
+}
+
+sub XonTTY
+{
+ # I don't know which of these I actually need to do this to, so we'll
+ # just cover all bases.
+
+ &ioctl($term_IN,$TCXONC,$TCOON); # || die "Can't ioctl TCXONC STDIN: $!";
+ &ioctl($term_OUT,$TCXONC,$TCOON); # || die "Can't ioctl TCXONC STDOUT: $!";
+}
+
+sub ___SetTTY
+{
+# print "before SetTTY\n\r";
+# system 'stty -a';
+
+ &XonTTY;
+
+ &GetTTY
+ if !defined($base_termios);
+
+ @termios = unpack($termios_t,$base_termios);
+ $termios[$TERMIOS_IFLAG] |= $TERMIOS_READLINE_ION;
+ $termios[$TERMIOS_IFLAG] &= ~$TERMIOS_READLINE_IOFF;
+ $termios[$TERMIOS_OFLAG] |= $TERMIOS_READLINE_OON;
+ $termios[$TERMIOS_OFLAG] &= ~$TERMIOS_READLINE_OOFF;
+ $termios[$TERMIOS_LFLAG] |= $TERMIOS_READLINE_LON;
+ $termios[$TERMIOS_LFLAG] &= ~$TERMIOS_READLINE_LOFF;
+ $termios[$TERMIOS_VMIN] = 1;
+ $termios[$TERMIOS_VTIME] = 0;
+ $termios = pack($termios_t,@termios);
+ &ioctl($term_IN,$TCSETS,$termios) || die "Can't ioctl TCSETS: $!";
+
+# print "after SetTTY\n\r";
+# system 'stty -a';
+}
+
+sub normal_tty_mode
+{
+ return if $stdin_not_tty || $dumb_term || !$initialized;
+ &XonTTY;
+ &GetTTY if !defined($base_termios);
+ &ResetTTY;
+}
+
+sub ___ResetTTY
+{
+# print "before ResetTTY\n\r";
+# system 'stty -a';
+
+ @termios = unpack($termios_t,$base_termios);
+ $termios[$TERMIOS_IFLAG] |= $TERMIOS_NORMAL_ION;
+ $termios[$TERMIOS_IFLAG] &= ~$TERMIOS_NORMAL_IOFF;
+ $termios[$TERMIOS_OFLAG] |= $TERMIOS_NORMAL_OON;
+ $termios[$TERMIOS_OFLAG] &= ~$TERMIOS_NORMAL_OOFF;
+ $termios[$TERMIOS_LFLAG] |= $TERMIOS_NORMAL_LON;
+ $termios[$TERMIOS_LFLAG] &= ~$TERMIOS_NORMAL_LOFF;
+ $termios = pack($termios_t,@termios);
+ &ioctl($term_IN,$TCSETS,$termios) || die "Can't ioctl TCSETS: $!";
+
+# print "after ResetTTY\n\r";
+# system 'stty -a';
+}
+
+##
+## WordBreak(index)
+##
+## Returns true if the character at INDEX into $line is a basic word break
+## character, false otherwise.
+##
+sub WordBreak
+{
+ index($rl_basic_word_break_characters, substr($line,$_[0],1)) != -1;
+}
+
+sub getstate
+{
+ ($D, $si, $LastCommandKilledText, $KillBuffer, $line) = @{$_[0]};
+ $ThisCommandKilledText = $LastCommandKilledText;
+}
+
+##
+## kills from D=$_[0] to $_[1] (to the killbuffer if $_[2] is true)
+##
+sub kill_text
+{
+ my($from, $to, $save) = (&min($_[0], $_[1]), &max($_[0], $_[1]), $_[2]);
+ my $len = $to - $from;
+ if ($save) {
+ $KillBuffer = '' if !$LastCommandKilledText;
+ if ($from < $LastCommandKilledText - 1) {
+ $KillBuffer = substr($line, $from, $len) . $KillBuffer;
+ } else {
+ $KillBuffer .= substr($line, $from, $len);
+ }
+ $ThisCommandKilledText = 1 + $from;
+ }
+ substr($line, $from, $len) = '';
+
+ ## adjust $D
+ if ($D > $from) {
+ $D -= $len;
+ $D = $from if $D < $from;
+ }
+}
+
+
+###########################################################################
+## Bindable functions... pretty much in the same order as in readline.c ###
+###########################################################################
+
+##
+## Returns true if $D at the end of the line.
+##
+sub at_end_of_line
+{
+ ($D + &CharSize($D)) == (length($line) + 1);
+}
+
+
+##
+## Move forward (right) $count characters.
+##
+sub F_ForwardChar
+{
+ my $count = shift;
+ return &F_BackwardChar(-$count) if $count < 0;
+
+ while (!&at_end_of_line && $count-- > 0) {
+ $D += &CharSize($D);
+ }
+}
+
+##
+## Move backward (left) $count characters.
+##
+sub F_BackwardChar
+{
+ my $count = shift;
+ return &F_ForwardChar(-$count) if $count < 0;
+
+ while (($D > 0) && ($count-- > 0)) {
+ $D--; ## Move back one regardless,
+ $D-- if &OnSecondByte($D); ## another if over a big char.
+ }
+}
+
+##
+## Go to beginning of line.
+##
+sub F_BeginningOfLine
+{
+ $D = 0;
+}
+
+##
+## Move to the end of the line.
+##
+sub F_EndOfLine
+{
+ &F_ForwardChar(100) while !&at_end_of_line;
+}
+
+##
+## Move to the end of this/next word.
+## Done as many times as $count says.
+##
+sub F_ForwardWord
+{
+ my $count = shift;
+ return &F_BackwardWord(-$count) if $count < 0;
+
+ while (!&at_end_of_line && $count-- > 0)
+ {
+ ## skip forward to the next word (if not already on one)
+ &F_ForwardChar(1) while !&at_end_of_line && &WordBreak($D);
+ ## skip forward to end of word
+ &F_ForwardChar(1) while !&at_end_of_line && !&WordBreak($D);
+ }
+}
+
+##
+##
+## Move to the beginning of this/next word.
+## Done as many times as $count says.
+##
+sub F_BackwardWord
+{
+ my $count = shift;
+ return &F_ForwardWord(-$count) if $count < 0;
+
+ while ($D > 0 && $count-- > 0) {
+ ## skip backward to the next word (if not already on one)
+ &F_BackwardChar(1) while (($D > 0) && &WordBreak($D-1));
+ ## skip backward to start of word
+ &F_BackwardChar(1) while (($D > 0) && !&WordBreak($D-1));
+ }
+}
+
+##
+## Refresh the input line.
+##
+sub F_RedrawCurrentLine
+{
+ $force_redraw = 1;
+}
+
+##
+## Clear the screen and refresh the line.
+## If given a numeric arg other than 1, simply refreshes the line.
+##
+sub F_ClearScreen
+{
+ my $count = shift;
+ return &F_RedrawCurrentLine if $count != 1;
+
+ $rl_CLEAR = `clear` if !defined($rl_CLEAR);
+ local $\ = '';
+ print $term_OUT $rl_CLEAR;
+ $force_redraw = 1;
+}
+
+##
+## Insert the next character read verbatim.
+##
+sub F_QuotedInsert
+{
+ my $count = shift;
+ &F_SelfInsert($count, ord(&getc_with_pending));
+}
+
+##
+## Insert a tab.
+##
+sub F_TabInsert
+{
+ my $count = shift;
+ &F_SelfInsert($count, ord("\t"));
+}
+
+## Operate - accept the current line and fetch from the
+## history the next line relative to current line for default.
+sub F_OperateAndGetNext
+{
+ my $count = shift;
+
+ &F_AcceptLine;
+
+ my $remainingEntries = $#rl_History - $rl_HistoryIndex;
+ if ($count > 0 && $remainingEntries >= 0) { # there is something to repeat
+ if ($remainingEntries > 0) { # if we are not on last line
+ $rl_HistoryIndex++; # fetch next one
+ $count = $remainingEntries if $count > $remainingEntries;
+ }
+ $rl_OperateCount = $count;
+ }
+}
+
+##
+## Removes $count chars to left of cursor (if not at beginning of line).
+## If $count > 1, deleted chars saved to kill buffer.
+##
+sub F_BackwardDeleteChar
+{
+ return if remove_selection();
+
+ my $count = shift;
+ return F_DeleteChar(-$count) if $count < 0;
+ my $oldD = $D;
+ &F_BackwardChar($count);
+ return if $D == $oldD;
+ &kill_text($oldD, $D, $count > 1);
+}
+
+##
+## Removes the $count chars from under the cursor.
+## If there is no line and the last command was different, tells
+## readline to return EOF.
+## If there is a line, and the cursor is at the end of it, and we're in
+## tcsh completion mode, then list possible completions.
+## If $count > 1, deleted chars saved to kill buffer.
+##
+sub F_DeleteChar
+{
+ return if remove_selection();
+
+ my $count = shift;
+ return F_DeleteBackwardChar(-$count) if $count < 0;
+ if (length($line) == 0) { # EOF sent (probably OK in DOS too)
+ $AcceptLine = $ReturnEOF = 1 if $lastcommand ne 'F_DeleteChar';
+ return;
+ }
+ if ($D == length ($line))
+ {
+ &complete_internal('?') if $var_TcshCompleteMode;
+ return;
+ }
+ my $oldD = $D;
+ &F_ForwardChar($count);
+ return if $D == $oldD;
+ &kill_text($oldD, $D, $count > 1);
+}
+
+##
+## Kill to previous whitespace.
+##
+sub F_UnixWordRubout
+{
+ return &F_Ding if $D == 0;
+ (my $oldD, local $rl_basic_word_break_characters) = ($D, "\t ");
+ # JP: Fixed a bug here - both were 'my'
+ F_BackwardWord(1);
+ kill_text($D, $oldD, 1);
+}
+
+##
+## Kill line from cursor to beginning of line.
+##
+sub F_UnixLineDiscard
+{
+ return &F_Ding if $D == 0;
+ kill_text(0, $D, 1);
+}
+
+sub F_UpcaseWord { &changecase($_[0], 'up'); }
+sub F_DownCaseWord { &changecase($_[0], 'down'); }
+sub F_CapitalizeWord { &changecase($_[0], 'cap'); }
+
+##
+## Translated from GNUs readline.c
+## One arg is 'up' to upcase $_[0] words,
+## 'down' to downcase them,
+## or something else to capitolize them.
+## If $_[0] is negative, the dot is not moved.
+##
+sub changecase
+{
+ my $op = $_[1];
+
+ my ($start, $state, $c, $olddot) = ($D, 0);
+ if ($_[0] < 0)
+ {
+ $olddot = $D;
+ $_[0] = -$_[0];
+ }
+
+ &F_ForwardWord; ## goes forward $_[0] words.
+
+ while ($start < $D) {
+ $c = substr($line, $start, 1);
+
+ if ($op eq 'up') {
+ $c = &toupper($c);
+ } elsif ($op eq 'down') {
+ $c = &tolower($c);
+ } else { ## must be 'cap'
+ if ($state == 1) {
+ $c = &tolower($c);
+ } else {
+ $c = &toupper($c);
+ $state = 1;
+ }
+ $state = 0 if $c !~ tr/a-zA-Z//;
+ }
+
+ substr($line, $start, 1) = $c;
+ $start++;
+ }
+ $D = $olddot if defined($olddot);
+}
+
+sub F_TransposeWords {
+ my $c = shift;
+ return F_Ding() unless $c;
+ # Find "this" word
+ F_BackwardWord(1);
+ my $p0 = $D;
+ F_ForwardWord(1);
+ my $p1 = $D;
+ return F_Ding() if $p1 == $p0;
+ my ($p2, $p3) = ($p0, $p1);
+ if ($c > 0) {
+ F_ForwardWord($c);
+ $p3 = $D;
+ F_BackwardWord(1);
+ $p2 = $D;
+ } else {
+ F_BackwardWord(1 - $c);
+ $p0 = $D;
+ F_ForwardWord(1);
+ $p1 = $D;
+ }
+ return F_Ding() if $p3 == $p2 or $p2 < $p1;
+ my $r = substr $line, $p2, $p3 - $p2;
+ substr($line, $p2, $p3 - $p2) = substr $line, $p0, $p1 - $p0;
+ substr($line, $p0, $p1 - $p0) = $r;
+ $D = $c > 0 ? $p3 : $p0 + $p3 - $p2; # End of "this" word after edit
+ return 1;
+## Exchange words: C-Left, C-right, C-right, C-left. If positions do
+## not overlap, we get two things to transpose. Repeat count?
+}
+
+##
+## Switch char at dot with char before it.
+## If at the end of the line, switch the previous two...
+## (NOTE: this could screw up multibyte characters.. should do correctly)
+sub F_TransposeChars
+{
+ if ($D == length($line) && $D >= 2) {
+ substr($line,$D-2,2) = substr($line,$D-1,1).substr($line,$D-2,1);
+ } elsif ($D >= 1) {
+ substr($line,$D-1,2) = substr($line,$D,1) .substr($line,$D-1,1);
+ } else {
+ &F_Ding;
+ }
+}
+
+sub F_PreviousHistory {
+ &get_line_from_history($rl_HistoryIndex - shift);
+}
+
+sub F_NextHistory {
+ &get_line_from_history($rl_HistoryIndex + shift);
+}
+
+
+
+sub F_BeginningOfHistory
+{
+ &get_line_from_history(0);
+}
+
+sub F_EndOfHistory
+{
+ &get_line_from_history(@rl_History);
+}
+
+sub F_ReverseSearchHistory
+{
+ &DoSearch($_[0] >= 0 ? 1 : 0);
+}
+
+sub F_ForwardSearchHistory
+{
+ &DoSearch($_[0] >= 0 ? 0 : 1);
+}
+
+sub F_HistorySearchBackward
+{
+ &DoSearchStart(($_[0] >= 0 ? 1 : 0),substr($line,0,$D));
+}
+
+sub F_HistorySearchForward
+{
+ &DoSearchStart(($_[0] >= 0 ? 0 : 1),substr($line,0,$D));
+}
+
+## returns a new $i or -1 if not found.
+sub search {
+ my ($i, $str) = @_;
+ return -1 if $i < 0 || $i > $#rl_History; ## for safety
+ while (1) {
+ return $i if rindex($rl_History[$i], $str) >= 0;
+ if ($reverse) {
+ return -1 if $i-- == 0;
+ } else {
+ return -1 if $i++ == $#rl_History;
+ }
+ }
+}
+
+sub DoSearch
+{
+ local $reverse = shift; # Used in search()
+ my $oldline = $line;
+ my $oldD = $D;
+
+ my $searchstr = ''; ## string we're searching for
+ my $I = -1; ## which history line
+
+ $si = 0;
+
+ while (1)
+ {
+ if ($I != -1) {
+ $line = $rl_History[$I];
+ $D += index($rl_History[$I], $searchstr);
+ }
+ &redisplay( '('.($reverse?'reverse-':'') ."i-search) `$searchstr': ");
+
+ $c = &getc_with_pending;
+ if (($KeyMap[ord($c)] || 0) eq 'F_ReverseSearchHistory') {
+ if ($reverse && $I != -1) {
+ if ($tmp = &search($I-1,$searchstr), $tmp >= 0) {
+ $I = $tmp;
+ } else {
+ &F_Ding;
+ }
+ }
+ $reverse = 1;
+ } elsif (($KeyMap[ord($c)] || 0) eq 'F_ForwardSearchHistory') {
+ if (!$reverse && $I != -1) {
+ if ($tmp = &search($I+1,$searchstr), $tmp >= 0) {
+ $I = $tmp;
+ } else {
+ &F_Ding;
+ }
+ }
+ $reverse = 0;
+ } elsif ($c eq "\007") { ## abort search... restore line and return
+ $line = $oldline;
+ $D = $oldD;
+ return;
+ } elsif (ord($c) < 32 || ord($c) > 126) {
+ push(@Pending, $c) if $c ne "\e";
+ if ($I < 0) {
+ ## just restore
+ $line = $oldline;
+ $D = $oldD;
+ } else {
+ #chose this line
+ $line = $rl_History[$I];
+ $D = index($rl_History[$I], $searchstr);
+ }
+ &redisplay();
+ last;
+ } else {
+ ## Add this character to the end of the search string and
+ ## see if that'll match anything.
+ $tmp = &search($I < 0 ? $rl_HistoryIndex-$reverse: $I, $searchstr.$c);
+ if ($tmp == -1) {
+ &F_Ding;
+ } else {
+ $searchstr .= $c;
+ $I = $tmp;
+ }
+ }
+ }
+}
+
+## returns a new $i or -1 if not found.
+sub searchStart {
+ my ($i, $reverse, $str) = @_;
+ $i += $reverse ? - 1: +1;
+ return -1 if $i < 0 || $i > $#rl_History; ## for safety
+ while (1) {
+ return $i if index($rl_History[$i], $str) == 0;
+ if ($reverse) {
+ return -1 if $i-- == 0;
+ } else {
+ return -1 if $i++ == $#rl_History;
+ }
+ }
+}
+
+sub DoSearchStart
+{
+ my ($reverse,$what) = @_;
+ my $i = searchStart($rl_HistoryIndex, $reverse, $what);
+ return if $i == -1;
+ $rl_HistoryIndex = $i;
+ ($D, $line) = (0, $rl_History[$rl_HistoryIndex]);
+ F_BeginningOfLine();
+ F_ForwardChar(length($what));
+
+}
+
+###########################################################################
+###########################################################################
+
+##
+## Kill from cursor to end of line.
+##
+sub F_KillLine
+{
+ my $count = shift;
+ return F_BackwardKillLine(-$count) if $count < 0;
+ kill_text($D, length($line), 1);
+}
+
+##
+## Delete from cursor to beginning of line.
+##
+sub F_BackwardKillLine
+{
+ my $count = shift;
+ return F_KillLine(-$count) if $count < 0;
+ return F_Ding if $D == 0;
+ kill_text(0, $D, 1);
+}
+
+##
+## TextInsert(count, string)
+##
+sub TextInsert {
+ my $count = shift;
+ my $text2add = shift(@_) x $count;
+ if ($InsertMode) {
+ substr($line,$D,0) .= $text2add;
+ } else {
+ substr($line,$D,length($text2add)) = $text2add;
+ }
+ $D += length($text2add);
+}
+
+sub F_Yank
+{
+ remove_selection();
+ &TextInsert($_[0], $KillBuffer);
+}
+
+sub F_YankPop {
+ 1;
+ ## not implemented yet
+}
+
+sub F_YankNthArg {
+ 1;
+ ## not implemented yet
+}
+
+##
+## Kill to the end of the current word. If not on a word, kill to
+## the end of the next word.
+##
+sub F_KillWord
+{
+ my $count = shift;
+ return &F_BackwardKillWord(-$count) if $count < 0;
+ my $oldD = $D;
+ &F_ForwardWord($count); ## moves forward $count words.
+ kill_text($oldD, $D, 1);
+}
+
+##
+## Kill backward to the start of the current word, or, if currently
+## not on a word (or just at the start of a word), to the start of the
+## previous word.
+##
+sub F_BackwardKillWord
+{
+ my $count = shift;
+ return F_KillWord(-$count) if $count < 0;
+ my $oldD = $D;
+ &F_BackwardWord($count); ## moves backward $count words.
+ kill_text($D, $oldD, 1);
+}
+
+###########################################################################
+###########################################################################
+
+
+##
+## Abort the current input.
+##
+sub F_Abort
+{
+ &F_Ding;
+}
+
+
+##
+## If the character that got us here is upper case,
+## do the lower-case equiv...
+##
+sub F_DoLowercaseVersion
+{
+ if ($_[1] >= ord('A') && $_[1] <= ord('Z')) {
+ &do_command(*KeyMap, $_[0], $_[1] - ord('A') + ord('a'));
+ } else {
+ &F_Ding;
+ }
+}
+
+##
+## do the equiv with control key...
+##
+sub F_DoControlVersion
+{
+ local *KeyMap = $var_EditingMode;
+ my $key = $_[1];
+
+ if ($key == ord('?')) {
+ $key = 0x7F;
+ } else {
+ $key &= ~(0x80 | 0x60);
+ }
+ &do_command(*KeyMap, $_[0], $key);
+}
+
+##
+## do the equiv with meta key...
+##
+sub F_DoMetaVersion
+{
+ local *KeyMap = $var_EditingMode;
+ unshift @Pending, chr $_[1];
+
+ &do_command(*KeyMap, $_[0], ord "\e");
+}
+
+##
+## If the character that got us here is Alt-Char,
+## do the Esc Char equiv...
+##
+sub F_DoEscVersion
+{
+ my ($ord, $t) = $_[1];
+ &F_Ding unless $KeyMap{'Esc'};
+ for $t (([ord 'w', '`1234567890-='],
+ [ord ',', 'zxcvbnm,./\\'],
+ [16, 'qwertyuiop[]'],
+ [ord(' ') - 2, 'asdfghjkl;\''])) {
+ next unless $ord >= $t->[0] and $ord < $t->[0] + length($t->[1]);
+ $ord = ord substr $t->[1], $ord - $t->[0], 1;
+ return &do_command($KeyMap{'Esc'}, $_[0], $ord);
+ }
+ &F_Ding;
+}
+
+##
+## Undo one level.
+##
+sub F_Undo
+{
+ pop(@undo); # unless $undo[-1]->[5]; ## get rid of the state we just put on, so we can go back one.
+ if (@undo) {
+ &getstate(pop(@undo));
+ } else {
+ &F_Ding;
+ }
+}
+
+##
+## Replace the current line to some "before" state.
+##
+sub F_RevertLine
+{
+ if ($rl_HistoryIndex >= $#rl_History+1) {
+ $line = $line_for_revert;
+ } else {
+ $line = $rl_History[$rl_HistoryIndex];
+ }
+ $D = length($line);
+}
+
+sub F_EmacsEditingMode
+{
+ $var_EditingMode = $var_EditingMode{'emacs'};
+ $Vi_mode = 0;
+}
+
+###########################################################################
+###########################################################################
+
+
+##
+## (Attempt to) interrupt the current program.
+##
+sub F_Interrupt
+{
+ local $\ = '';
+ print $term_OUT "\r\n";
+ &ResetTTY;
+ kill ("INT", 0);
+
+ ## We're back.... must not have died.
+ $force_redraw = 1;
+}
+
+##
+## Execute the next character input as a command in a meta keymap.
+##
+sub F_PrefixMeta
+{
+ my($count, $keymap) = ($_[0], "$KeyMap{'name'}_$_[1]");
+ ##print "F_PrefixMeta [$keymap]\n\r";
+ die "<internal error, $_[1]>" unless %$keymap;
+ do_command(*$keymap, $count, ord(&getc_with_pending));
+}
+
+sub F_UniversalArgument
+{
+ &F_DigitArgument;
+}
+
+##
+## For typing a numeric prefix to a command....
+##
+sub F_DigitArgument
+{
+ my $in = chr $_[1];
+ my ($NumericArg, $sawDigit) = (1, 0);
+ my ($increment, $ord);
+ ($NumericArg, $sawDigit) = ($_[0], $_[0] !~ /e0$/i)
+ if $doingNumArg; # XXX What if Esc-- 1 ?
+
+ do
+ {
+ $ord = ord $in;
+ if (defined($KeyMap[$ord]) && $KeyMap[$ord] eq 'F_UniversalArgument') {
+ $NumericArg *= 4;
+ } elsif ($ord == ord('-') && !$sawDigit) {
+ $NumericArg = -$NumericArg;
+ } elsif ($ord >= ord('0') && $ord <= ord('9')) {
+ $increment = ($ord - ord('0')) * ($NumericArg < 0 ? -1 : 1);
+ if ($sawDigit) {
+ $NumericArg = $NumericArg * 10 + $increment;
+ } else {
+ $NumericArg = $increment;
+ $sawDigit = 1;
+ }
+ } else {
+ local(*KeyMap) = $var_EditingMode;
+ &redisplay();
+ $doingNumArg = 1; # Allow NumArg inside NumArg
+ &do_command(*KeyMap, $NumericArg . ($sawDigit ? '': 'e0'), $ord);
+ return;
+ }
+ ## make sure it's not toooo big.
+ if ($NumericArg > $rl_max_numeric_arg) {
+ $NumericArg = $rl_max_numeric_arg;
+ } elsif ($NumericArg < -$rl_max_numeric_arg) {
+ $NumericArg = -$rl_max_numeric_arg;
+ }
+ &redisplay(sprintf("(arg %d) ", $NumericArg));
+ } while defined($in = &getc_with_pending);
+}
+
+sub F_OverwriteMode
+{
+ $InsertMode = 0;
+}
+
+sub F_InsertMode
+{
+ $InsertMode = 1;
+}
+
+sub F_ToggleInsertMode
+{
+ $InsertMode = !$InsertMode;
+}
+
+##
+## (Attempt to) suspend the program.
+##
+sub F_Suspend
+{
+ if ($inDOS && length($line)==0) { # EOF sent
+ $AcceptLine = $ReturnEOF = 1 if $lastcommand ne 'F_DeleteChar';
+ return;
+ }
+ local $\ = '';
+ print $term_OUT "\r\n";
+ &ResetTTY;
+ eval { kill ("TSTP", 0) };
+ ## We're back....
+ &SetTTY;
+ $force_redraw = 1;
+}
+
+##
+## Ring the bell.
+## Should do something with $var_PreferVisibleBell here, but what?
+##
+sub F_Ding {
+ local $\ = '';
+ print $term_OUT "\007";
+ return; # Undefined return value
+}
+
+##########################################################################
+#### command/file completion ############################################
+##########################################################################
+
+##
+## How Command Completion Works
+##
+## When asked to do a completion operation, readline isolates the word
+## to the immediate left of the cursor (i.e. what's just been typed).
+## This information is then passed to some function (which may be supplied
+## by the user of this package) which will return an array of possible
+## completions.
+##
+## If there is just one, that one is used. Otherwise, they are listed
+## in some way (depends upon $var_TcshCompleteMode).
+##
+## The default is to do filename completion. The function that performs
+## this task is readline'rl_filename_list.
+##
+## A minimal-trouble way to have command-completion is to call
+## readline'rl_basic_commands with an array of command names, such as
+## &readline'rl_basic_commands('quit', 'run', 'set', 'list')
+## Those command names will then be used for completion if the word being
+## completed begins the line. Otherwise, completion is disallowed.
+##
+## The way to have the most power is to provide a function to readline
+## which will accept information about a partial word that needs completed,
+## and will return the appropriate list of possibilities.
+## This is done by setting $readline'rl_completion_function to the name of
+## the function to run.
+##
+## That function will be called with three args ($text, $line, $start).
+## TEXT is the partial word that should be completed. LINE is the entire
+## input line as it stands, and START is the index of the TEXT in LINE
+## (i.e. zero if TEXT is at the beginning of LINE).
+##
+## A cool completion function will look at LINE and START and give context-
+## sensitive completion lists. Consider something that will do completion
+## for two commands
+## cat FILENAME
+## finger USERNAME
+## status [this|that|other]
+##
+## It (untested) might look like:
+##
+## $readline'rl_completion_function = "main'complete";
+## sub complete { local($text, $_, $start) = @_;
+## ## return commands which may match if at the beginning....
+## return grep(/^$text/, 'cat', 'finger') if $start == 0;
+## return &rl_filename_list($text) if /^cat\b/;
+## return &my_namelist($text) if /^finger\b/;
+## return grep(/^text/, 'this', 'that','other') if /^status\b/;
+## ();
+## }
+## Of course, a real completion function would be more robust, but you
+## get the idea (I hope).
+##
+
+##
+## List possible completions
+##
+sub F_PossibleCompletions
+{
+ &complete_internal('?');
+}
+
+##
+## List possible completions
+##
+sub F_InsertPossibleCompletions
+{
+ &complete_internal('*');
+}
+
+##
+## Do a completion operation.
+## If the last thing we did was a completion operation, we'll
+## now list the options available (under normal emacs mode).
+##
+## Under TcshCompleteMode, each contiguous subsequent completion operation
+## lists another of the possible options.
+##
+## Returns true if a completion was done, false otherwise, so vi completion
+## routines can test it.
+##
+sub F_Complete
+{
+ if ($lastcommand eq 'F_Complete') {
+ if ($var_TcshCompleteMode && @tcsh_complete_selections > 0) {
+ substr($line, $tcsh_complete_start, $tcsh_complete_len)
+ = $tcsh_complete_selections[0];
+ $D -= $tcsh_complete_len;
+ $tcsh_complete_len = length($tcsh_complete_selections[0]);
+ $D += $tcsh_complete_len;
+ push(@tcsh_complete_selections, shift(@tcsh_complete_selections));
+ } else {
+ &complete_internal('?') or return;
+ }
+ } else {
+ @tcsh_complete_selections = ();
+ &complete_internal("\t") or return;
+ }
+
+ 1;
+}
+
+##
+## The meat of command completion. Patterned closely after GNU's.
+##
+## The supposedly partial word at the cursor is "completed" as per the
+## single argument:
+## "\t" complete as much of the word as is unambiguous
+## "?" list possibilities.
+## "*" replace word with all possibilities. (who would use this?)
+##
+## A few notable variables used:
+## $rl_completer_word_break_characters
+## -- characters in this string break a word.
+## $rl_special_prefixes
+## -- but if in this string as well, remain part of that word.
+##
+## Returns true if a completion was done, false otherwise, so vi completion
+## routines can test it.
+##
+sub complete_internal
+{
+ my $what_to_do = shift;
+ my ($point, $end) = ($D, $D);
+
+ # In vi mode, complete if the cursor is at the *end* of a word, not
+ # after it.
+ ($point++, $end++) if $Vi_mode;
+
+ if ($point)
+ {
+ ## Not at the beginning of the line; Isolate the word to be completed.
+ 1 while (--$point && (-1 == index($rl_completer_word_break_characters,
+ substr($line, $point, 1))));
+
+ # Either at beginning of line or at a word break.
+ # If at a word break (that we don't want to save), skip it.
+ $point++ if (
+ (index($rl_completer_word_break_characters,
+ substr($line, $point, 1)) != -1) &&
+ (index($rl_special_prefixes, substr($line, $point, 1)) == -1)
+ );
+ }
+
+ my $text = substr($line, $point, $end - $point);
+ $rl_completer_terminator_character = ' ';
+ @matches = &completion_matches($rl_completion_function,$text,$line,$point);
+
+ if (@matches == 0) {
+ return &F_Ding;
+ } elsif ($what_to_do eq "\t") {
+ my $replacement = shift(@matches);
+ $replacement .= $rl_completer_terminator_character if @matches == 1;
+ &F_Ding if @matches != 1;
+ if ($var_TcshCompleteMode) {
+ @tcsh_complete_selections = (@matches, $text);
+ $tcsh_complete_start = $point;
+ $tcsh_complete_len = length($replacement);
+ }
+ if ($replacement ne '') {
+ substr($line, $point, $end-$point) = $replacement;
+ $D = $D - ($end - $point) + length($replacement);
+ }
+ } elsif ($what_to_do eq '?') {
+ shift(@matches); ## remove prepended common prefix
+ local $\ = '';
+ print $term_OUT "\n\r";
+ # print "@matches\n\r";
+ &pretty_print_list (@matches);
+ $force_redraw = 1;
+ } elsif ($what_to_do eq '*') {
+ shift(@matches); ## remove common prefix.
+ local $" = $rl_completer_terminator_character;
+ my $replacement = "@matches$rl_completer_terminator_character";
+ substr($line, $point, $end-$point) = $replacement; ## insert all.
+ $D = $D - ($end - $point) + length($replacement);
+ } else {
+ warn "\r\n[Internal error]";
+ return &F_Ding;
+ }
+
+ 1;
+}
+
+##
+## completion_matches(func, text, line, start)
+##
+## FUNC is a function to call as FUNC(TEXT, LINE, START)
+## where TEXT is the item to be completed
+## LINE is the whole command line, and
+## START is the starting index of TEXT in LINE.
+## The FUNC should return a list of items that might match.
+##
+## completion_matches will return that list, with the longest common
+## prefix prepended as the first item of the list. Therefor, the list
+## will either be of zero length (meaning no matches) or of 2 or more.....
+##
+
+## Works with &rl_basic_commands. Return items from @rl_basic_commands
+## that start with the pattern in $text.
+sub use_basic_commands {
+ my ($text, $line, $start) = @_;
+ return () if $start != 0;
+ grep(/^$text/, @rl_basic_commands);
+}
+
+sub completion_matches
+{
+ my ($func, $text, $line, $start) = @_;
+
+ ## get the raw list
+ my @matches;
+
+ #print qq/\r\neval("\@matches = &$func(\$text, \$line, \$start)\n\r/;#DEBUG
+ #eval("\@matches = &$func(\$text, \$line, \$start);1") || warn "$@ ";
+ @matches = &$func($text, $line, $start);
+
+ ## if anything returned , find the common prefix among them
+ if (@matches) {
+ my $prefix = $matches[0];
+ my $len = length($prefix);
+ for ($i = 1; $i < @matches; $i++) {
+ next if substr($matches[$i], 0, $len) eq $prefix;
+ $prefix = substr($prefix, 0, --$len);
+ last if $len == 0;
+ $i--; ## retry this one to see if the shorter one matches.
+ }
+ unshift(@matches, $prefix); ## make common prefix the first thing.
+ }
+ @matches;
+}
+
+##
+## For use in passing to completion_matches(), returns a list of
+## filenames that begin with the given pattern. The user of this package
+## can set $rl_completion_function to 'rl_filename_list' to restore the
+## default of filename matching if they'd changed it earlier, either
+## directly or via &rl_basic_commands.
+##
+sub rl_filename_list
+{
+ my $pattern = $_[0];
+ my @files = (<$pattern*>);
+ if ($var_CompleteAddsuffix) {
+ foreach (@files) {
+ if (-l $_) {
+ $_ .= '@';
+ } elsif (-d _) {
+ $_ .= '/';
+ } elsif (-x _) {
+ $_ .= '*';
+ } elsif (-S _ || -p _) {
+ $_ .= '=';
+ }
+ }
+ }
+ return @files;
+}
+
+##
+## For use by the user of the package. Called with a list of possible
+## commands, will allow command completion on those commands, but only
+## for the first word on a line.
+## For example: &rl_basic_commands('set', 'quit', 'type', 'run');
+##
+## This is for people that want quick and simple command completion.
+## A more thoughtful implementation would set $rl_completion_function
+## to a routine that would look at the context of the word being completed
+## and return the appropriate possibilities.
+##
+sub rl_basic_commands
+{
+ @rl_basic_commands = @_;
+ $rl_completion_function = 'use_basic_commands';
+}
+
+##
+## Print an array in columns like ls -C. Originally based on stuff
+## (lsC2.pl) by utashiro@sran230.sra.co.jp (Kazumasa Utashiro).
+##
+sub pretty_print_list
+{
+ my @list = @_;
+ return unless @list;
+ my ($lines, $columns, $mark, $index);
+
+ ## find width of widest entry
+ my $maxwidth = 0;
+ grep(length > $maxwidth && ($maxwidth = length), @list);
+ $maxwidth++;
+
+ $columns = $maxwidth >= $rl_screen_width
+ ? 1 : int($rl_screen_width / $maxwidth);
+
+ ## if there's enough margin to interspurse among the columns, do so.
+ $maxwidth += int(($rl_screen_width % $maxwidth) / $columns);
+
+ $lines = int((@list + $columns - 1) / $columns);
+ $columns-- while ((($lines * $columns) - @list + 1) > $lines);
+
+ $mark = $#list - $lines;
+ local $\ = '';
+ for ($l = 0; $l < $lines; $l++) {
+ for ($index = $l; $index <= $mark; $index += $lines) {
+ printf("%-$ {maxwidth}s", $list[$index]);
+ }
+ print $term_OUT $list[$index] if $index <= $#list;
+ print $term_OUT "\n\r";
+ }
+}
+
+##----------------- Vi Routines --------------------------------
+
+sub F_ViAcceptLine
+{
+ &F_AcceptLine();
+ &F_ViInput();
+}
+
+# Repeat the most recent one of these vi commands:
+#
+# a A c C d D i I p P r R s S x X ~
+#
+sub F_ViRepeatLastCommand {
+ my($count) = @_;
+ return &F_Ding if !$Last_vi_command;
+
+ my @lastcmd = @$Last_vi_command;
+
+ # Multiply @lastcmd's numeric arg by $count.
+ unless ($count == 1) {
+
+ my $n = '';
+ while (@lastcmd and $lastcmd[0] =~ /^\d$/) {
+ $n *= 10;
+ $n += shift(@lastcmd);
+ }
+ $count *= $n unless $n eq '';
+ unshift(@lastcmd, split(//, $count));
+ }
+
+ push(@Pending, @lastcmd);
+}
+
+sub F_ViMoveCursor
+{
+ my($count, $ord) = @_;
+
+ my $new_cursor = &get_position($count, $ord, undef, $Vi_move_patterns);
+ return &F_Ding if !defined $new_cursor;
+
+ $D = $new_cursor;
+}
+
+sub F_ViFindMatchingParens {
+
+ # Move to the first parens at or after $D
+ my $old_d = $D;
+ &forward_scan(1, q/[^[\](){}]*/);
+ my $parens = substr($line, $D, 1);
+
+ my $mate_direction = {
+ '(' => [ ')', 1 ],
+ '[' => [ ']', 1 ],
+ '{' => [ '}', 1 ],
+ ')' => [ '(', -1 ],
+ ']' => [ '[', -1 ],
+ '}' => [ '{', -1 ],
+
+ }->{$parens};
+
+ return &F_Ding() unless $mate_direction;
+
+ my($mate, $direction) = @$mate_direction;
+
+ my $lvl = 1;
+ while ($lvl) {
+ last if !$D && ($direction < 0);
+ &F_ForwardChar($direction);
+ last if &at_end_of_line;
+ my $c = substr($line, $D, 1);
+ if ($c eq $parens) {
+ $lvl++;
+ }
+ elsif ($c eq $mate) {
+ $lvl--;
+ }
+ }
+
+ if ($lvl) {
+ # We didn't find a match
+ $D = $old_d;
+ return &F_Ding();
+ }
+}
+
+sub F_ViForwardFindChar {
+ &do_findchar(1, 1, @_);
+}
+
+sub F_ViBackwardFindChar {
+ &do_findchar(-1, 0, @_);
+}
+
+sub F_ViForwardToChar {
+ &do_findchar(1, 0, @_);
+}
+
+sub F_ViBackwardToChar {
+ &do_findchar(-1, 1, @_);
+}
+
+sub F_ViMoveCursorTo
+{
+ &do_findchar(1, -1, @_);
+}
+
+sub F_ViMoveCursorFind
+{
+ &do_findchar(1, 0, @_);
+}
+
+
+sub F_ViRepeatFindChar {
+ my($n) = @_;
+ return &F_Ding if !defined $Last_findchar;
+ &findchar(@$Last_findchar, $n);
+}
+
+sub F_ViInverseRepeatFindChar {
+ my($n) = @_;
+ return &F_Ding if !defined $Last_findchar;
+ my($c, $direction, $offset) = @$Last_findchar;
+ &findchar($c, -$direction, $offset, $n);
+}
+
+sub do_findchar {
+ my($direction, $offset, $n) = @_;
+ my $c = &getc_with_pending;
+ $c = &getc_with_pending if $c eq "\cV";
+ return &F_ViCommandMode if $c eq "\e";
+ $Last_findchar = [$c, $direction, $offset];
+ &findchar($c, $direction, $offset, $n);
+}
+
+sub findchar {
+ my($c, $direction, $offset, $n) = @_;
+ my $old_d = $D;
+ while ($n) {
+ last if !$D && ($direction < 0);
+ &F_ForwardChar($direction);
+ last if &at_end_of_line;
+ my $char = substr($line, $D, 1);
+ $n-- if substr($line, $D, 1) eq $c;
+ }
+ if ($n) {
+ # Not found
+ $D = $old_d;
+ return &F_Ding;
+ }
+ &F_ForwardChar($offset);
+}
+
+sub F_ViMoveToColumn {
+ my($n) = @_;
+ $D = 0;
+ my $col = 1;
+ while (!&at_end_of_line and $col < $n) {
+ my $c = substr($line, $D, 1);
+ if ($c eq "\t") {
+ $col += 7;
+ $col -= ($col % 8) - 1;
+ }
+ else {
+ $col++;
+ }
+ $D += &CharSize($D);
+ }
+}
+
+sub start_dot_buf {
+ my($count, $ord) = @_;
+ $Dot_buf = [pack('c', $ord)];
+ unshift(@$Dot_buf, split(//, $count)) if $count > 1;
+ $Dot_state = savestate();
+}
+
+sub end_dot_buf {
+ # We've recognized an editing command
+
+ # Save the command keystrokes for use by '.'
+ $Last_vi_command = $Dot_buf;
+ undef $Dot_buf;
+
+ # Save the pre-command state for use by 'u' and 'U';
+ $Vi_undo_state = $Dot_state;
+ $Vi_undo_all_state = $Dot_state if !$Vi_undo_all_state;
+
+ # Make sure the current line is treated as new line for history purposes.
+ $rl_HistoryIndex = $#rl_History + 1;
+}
+
+sub save_dot_buf {
+ &start_dot_buf(@_);
+ &end_dot_buf;
+}
+
+sub F_ViUndo {
+ return &F_Ding unless defined $Vi_undo_state;
+ my $state = savestate();
+ &getstate($Vi_undo_state);
+ $Vi_undo_state = $state;
+}
+
+sub F_ViUndoAll {
+ $Vi_undo_state = $Vi_undo_all_state;
+ &F_ViUndo;
+}
+
+sub F_ViChange
+{
+ my($count, $ord) = @_;
+ &start_dot_buf(@_);
+ &do_delete($count, $ord, $Vi_change_patterns) || return();
+ &vi_input_mode;
+}
+
+sub F_ViDelete
+{
+ my($count, $ord) = @_;
+ &start_dot_buf(@_);
+ &do_delete($count, $ord, $Vi_delete_patterns);
+ &end_dot_buf;
+}
+
+sub do_delete {
+
+ my($count, $ord, $poshash) = @_;
+
+ my $other_end = &get_position($count, undef, $ord, $poshash);
+ return &F_Ding if !defined $other_end;
+
+ if ($other_end < 0) {
+ # dd - delete entire line
+ &kill_text(0, length($line), 1);
+ }
+ else {
+ &kill_text($D, $other_end, 1);
+ }
+
+ 1; # True return value
+}
+
+sub F_ViDeleteChar {
+ my($count) = @_;
+ &save_dot_buf(@_);
+ my $other_end = $D + $count;
+ $other_end = length($line) if $other_end > length($line);
+ &kill_text($D, $other_end, 1);
+}
+
+sub F_ViBackwardDeleteChar {
+ my($count) = @_;
+ &save_dot_buf(@_);
+ my $other_end = $D - $count;
+ $other_end = 0 if $other_end < 0;
+ &kill_text($other_end, $D, 1);
+ $D = $other_end;
+}
+
+##
+## Prepend line with '#', add to history, and clear the input buffer
+## (this feature was borrowed from ksh).
+##
+sub F_SaveLine
+{
+ local $\ = '';
+ $line = '#'.$line;
+ &redisplay();
+ print $term_OUT "\r\n";
+ &add_line_to_history;
+ $line_for_revert = '';
+ &get_line_from_history(scalar @rl_History);
+ &F_ViInput() if $Vi_mode;
+}
+
+#
+# Come here if we see a non-positioning keystroke when a positioning
+# keystroke is expected.
+#
+sub F_ViNonPosition {
+ # Not a positioning command - undefine the cursor to indicate the error
+ # to get_position().
+ undef $D;
+}
+
+#
+# Come here if we see <esc><char>, but *not* an arrow key or other
+# mapped sequence, when a positioning keystroke is expected.
+#
+sub F_ViPositionEsc {
+ my($count, $ord) = @_;
+
+ # We got <esc><char> in vipos mode. Put <char> back onto the
+ # input stream and terminate the positioning command.
+ unshift(@Pending, pack('c', $ord));
+ &F_ViNonPosition;
+}
+
+# Interpret vi positioning commands
+sub get_position {
+ my ($count, $ord, $fullline_ord, $poshash) = @_;
+
+ # Manipulate a copy of the cursor, not the real thing
+ local $D = $D;
+
+ # $ord (first character of positioning command) is an optional argument.
+ $ord = ord(&getc_with_pending) if !defined $ord;
+
+ # Detect double character (for full-line operation, e.g. dd)
+ return -1 if defined $fullline_ord and $ord == $fullline_ord;
+
+ my $re = $poshash->{$ord};
+
+ if ($re) {
+ my $c = pack('c', $ord);
+ if (lc($c) eq 'b') {
+ &backward_scan($count, $re);
+ }
+ else {
+ &forward_scan($count, $re);
+ }
+ }
+ else {
+ # Move the local copy of the cursor
+ &do_command($var_EditingMode{'vipos'}, $count, $ord);
+ }
+
+ # Return the new cursor (undef if illegal command)
+ $D;
+}
+
+##
+## Go to first non-space character of line.
+##
+sub F_ViFirstWord
+{
+ $D = 0;
+ &forward_scan(1, q{\s+});
+}
+
+sub forward_scan {
+ my($count, $re) = @_;
+ while ($count--) {
+ last unless substr($line, $D) =~ m{^($re)};
+ $D += length($1);
+ }
+}
+
+sub backward_scan {
+ my($count, $re) = @_;
+ while ($count--) {
+ last unless substr($line, 0, $D) =~ m{($re)$};
+ $D -= length($1);
+ }
+}
+
+# Note: like the emacs case transforms, this doesn't work for
+# two-byte characters.
+sub F_ViToggleCase {
+ my($count) = @_;
+ &save_dot_buf(@_);
+ while ($count-- > 0) {
+ substr($line, $D, 1) =~ tr/A-Za-z/a-zA-Z/;
+ &F_ForwardChar(1);
+ if (&at_end_of_line) {
+ &F_BackwardChar(1);
+ last;
+ }
+ }
+}
+
+# Go to the numbered history line, as listed by the 'H' command, i.e. the
+# current $line is line 1, the youngest line in @rl_History is 2, etc.
+sub F_ViHistoryLine {
+ my($n) = @_;
+ &get_line_from_history(@rl_History - $n + 1);
+}
+
+sub get_line_from_history {
+ my($n) = @_;
+ return &F_Ding if $n < 0 or $n > @rl_History;
+ return if $n == $rl_HistoryIndex;
+
+ # If we're moving from the currently-edited line, save it for later.
+ $line_for_revert = $line if $rl_HistoryIndex == @rl_History;
+
+ # Get line from history buffer (or from saved edit line).
+ $line = ($n == @rl_History) ? $line_for_revert : $rl_History[$n];
+ $D = $Vi_mode ? 0 : length $line;
+
+ # Subsequent 'U' will bring us back to this point.
+ $Vi_undo_all_state = savestate() if $Vi_mode;
+
+ $rl_HistoryIndex = $n;
+}
+
+sub F_PrintHistory {
+ my($count) = @_;
+
+ $count = 20 if $count == 1; # Default - assume 'H', not '1H'
+ my $end = $rl_HistoryIndex + $count/2;
+ $end = @rl_History if $end > @rl_History;
+ my $start = $end - $count + 1;
+ $start = 0 if $start < 0;
+
+ my $lmh = length $rl_MaxHistorySize;
+
+ my $lspace = ' ' x ($lmh+3);
+ my $hdr = "$lspace-----";
+ $hdr .= " (Use ESC <num> UP to retrieve command <num>) -----" unless $Vi_mode;
+ $hdr .= " (Use '<num>G' to retrieve command <num>) -----" if $Vi_mode;
+
+ local ($\, $,) = ('','');
+ print "\n$hdr\n";
+ print $lspace, ". . .\n" if $start > 0;
+ my $i;
+ my $shift = ($Vi_mode != 0);
+ for $i ($start .. $end) {
+ print + ($i == $rl_HistoryIndex) ? '>' : ' ',
+
+ sprintf("%${lmh}d: ", @rl_History - $i + $shift),
+
+ ($i < @rl_History) ? $rl_History[$i] :
+ ($i == $rl_HistoryIndex) ? $line :
+ $line_for_revert,
+
+ "\n";
+ }
+ print $lspace, ". . .\n" if $end < @rl_History;
+ print "$hdr\n";
+
+ &force_redisplay();
+
+ &F_ViInput() if $line eq '' && $Vi_mode;
+}
+
+# Redisplay the line, without attempting any optimization
+sub force_redisplay {
+ local $force_redraw = 1;
+ &redisplay(@_);
+}
+
+# Search history for matching string. As with vi in nomagic mode, the
+# ^, $, \<, and \> positional assertions, the \* quantifier, the \.
+# character class, and the \[ character class delimiter all have special
+# meaning here.
+sub F_ViSearch {
+ my($n, $ord) = @_;
+
+ my $c = pack('c', $ord);
+
+ my $str = &get_vi_search_str($c);
+ if (!defined $str) {
+ # Search aborted by deleting the '/' at the beginning of the line
+ return &F_ViInput() if $line eq '';
+ return();
+ }
+
+ # Null string repeats last search
+ if ($str eq '') {
+ return &F_Ding unless defined $Vi_search_re;
+ }
+ else {
+ # Convert to a regular expression. Interpret $str Like vi in nomagic
+ # mode: '^', '$', '\<', and '\>' positional assertions, '\*'
+ # quantifier, '\.' and '\[]' character classes.
+
+ my @chars = ($str =~ m{(\\?.)}g);
+ my(@re, @tail);
+ unshift(@re, shift(@chars)) if @chars and $chars[0] eq '^';
+ push (@tail, pop(@chars)) if @chars and $chars[-1] eq '$';
+ my $in_chclass;
+ my %chmap = (
+ '\<' => '\b(?=\w)',
+ '\>' => '(?<=\w)\b',
+ '\*' => '*',
+ '\[' => '[',
+ '\.' => '.',
+ );
+ my $ch;
+ foreach $ch (@chars) {
+ if ($in_chclass) {
+ # Any backslashes in vi char classes are literal
+ push(@re, "\\") if length($ch) > 1;
+ push(@re, $ch);
+ $in_chclass = 0 if $ch =~ /\]$/;
+ }
+ else {
+ push(@re, (length $ch == 2) ? ($chmap{$ch} || $ch) :
+ ($ch =~ /^\w$/) ? $ch :
+ ("\\", $ch));
+ $in_chclass = 1 if $ch eq '\[';
+ }
+ }
+ my $re = join('', @re, @tail);
+ $Vi_search_re = q{$re};
+ }
+
+ local $reverse = $Vi_search_reverse = ($c eq '/') ? 1 : 0;
+ &do_vi_search();
+}
+
+sub F_ViRepeatSearch {
+ my($n, $ord) = @_;
+ my $c = pack('c', $ord);
+ return &F_Ding unless defined $Vi_search_re;
+ local $reverse = $Vi_search_reverse;
+ $reverse ^= 1 if $c eq 'N';
+ &do_vi_search();
+}
+
+## returns a new $i or -1 if not found.
+sub vi_search {
+ my ($i) = @_;
+ return -1 if $i < 0 || $i > $#rl_History; ## for safety
+ while (1) {
+ return $i if $rl_History[$i] =~ /$Vi_search_re/;
+ if ($reverse) {
+ return -1 if $i-- == 0;
+ } else {
+ return -1 if $i++ == $#rl_History;
+ }
+ }
+}
+
+sub do_vi_search {
+ my $incr = $reverse ? -1 : 1;
+
+ my $i = &vi_search($rl_HistoryIndex + $incr);
+ return &F_Ding if $i < 0; # Not found.
+
+ $rl_HistoryIndex = $i;
+ ($D, $line) = (0, $rl_History[$rl_HistoryIndex]);
+}
+
+# Using local $line, $D, and $prompt, get and return the string to search for.
+sub get_vi_search_str {
+ my($c) = @_;
+
+ local $prompt = $prompt . $c;
+ local ($line, $D) = ('', 0);
+ &redisplay();
+
+ # Gather a search string in our local $line.
+ while ($lastcommand ne 'F_ViEndSearch') {
+ &do_command($var_EditingMode{'visearch'}, 1, ord(&getc_with_pending));
+ &redisplay();
+
+ # We've backspaced past beginning of line
+ return undef if !defined $line;
+ }
+ $line;
+}
+
+sub F_ViEndSearch {}
+
+sub F_ViSearchBackwardDeleteChar {
+ if ($line eq '') {
+ # Backspaced past beginning of line - terminate search mode
+ undef $line;
+ }
+ else {
+ &F_BackwardDeleteChar(@_);
+ }
+}
+
+##
+## Kill entire line and enter input mode
+##
+sub F_ViChangeEntireLine
+{
+ &start_dot_buf(@_);
+ kill_text(0, length($line), 1);
+ &vi_input_mode;
+}
+
+##
+## Kill characters and enter input mode
+##
+sub F_ViChangeChar
+{
+ &start_dot_buf(@_);
+ &F_DeleteChar(@_);
+ &vi_input_mode;
+}
+
+sub F_ViReplaceChar
+{
+ &start_dot_buf(@_);
+ my $c = &getc_with_pending;
+ $c = &getc_with_pending if $c eq "\cV"; # ctrl-V
+ return &F_ViCommandMode if $c eq "\e";
+ &end_dot_buf;
+
+ local $InsertMode = 0;
+ local $D = $D; # Preserve cursor position
+ &F_SelfInsert(1, ord($c));
+}
+
+##
+## Kill from cursor to end of line and enter input mode
+##
+sub F_ViChangeLine
+{
+ &start_dot_buf(@_);
+ &F_KillLine(@_);
+ &vi_input_mode;
+}
+
+sub F_ViDeleteLine
+{
+ &save_dot_buf(@_);
+ &F_KillLine(@_);
+}
+
+sub F_ViPut
+{
+ my($count) = @_;
+ &save_dot_buf(@_);
+ my $text2add = $KillBuffer x $count;
+ my $ll = length($line);
+ $D++;
+ $D = $ll if $D > $ll;
+ substr($line, $D, 0) = $KillBuffer x $count;
+ $D += length($text2add) - 1;
+}
+
+sub F_ViPutBefore
+{
+ &save_dot_buf(@_);
+ &TextInsert($_[0], $KillBuffer);
+}
+
+sub F_ViYank
+{
+ my($count, $ord) = @_;
+ my $pos = &get_position($count, undef, $ord, $Vi_yank_patterns);
+ &F_Ding if !defined $pos;
+ if ($pos < 0) {
+ # yy
+ &F_ViYankLine;
+ }
+ else {
+ my($from, $to) = ($pos > $D) ? ($D, $pos) : ($pos, $D);
+ $KillBuffer = substr($line, $from, $to-$from);
+ }
+}
+
+sub F_ViYankLine
+{
+ $KillBuffer = $line;
+}
+
+sub F_ViInput
+{
+ @_ = (1, ord('i')) if !@_;
+ &start_dot_buf(@_);
+ &vi_input_mode;
+}
+
+sub F_ViBeginInput
+{
+ &start_dot_buf(@_);
+ &F_BeginningOfLine;
+ &vi_input_mode;
+}
+
+sub F_ViReplaceMode
+{
+ &start_dot_buf(@_);
+ $InsertMode = 0;
+ $var_EditingMode = $var_EditingMode{'vi'};
+ $Vi_mode = 1;
+}
+
+sub vi_input_mode
+{
+ $InsertMode = 1;
+ $var_EditingMode = $var_EditingMode{'vi'};
+ $Vi_mode = 1;
+}
+
+# The previous keystroke was an escape, but the sequence was not recognized
+# as a mapped sequence (like an arrow key). Enter vi comand mode and
+# process this keystroke.
+sub F_ViAfterEsc {
+ my($n, $ord) = @_;
+ &F_ViCommandMode;
+ &do_command($var_EditingMode, 1, $ord);
+}
+
+sub F_ViAppend
+{
+ &start_dot_buf(@_);
+ &vi_input_mode;
+ &F_ForwardChar;
+}
+
+sub F_ViAppendLine
+{
+ &start_dot_buf(@_);
+ &vi_input_mode;
+ &F_EndOfLine;
+}
+
+sub F_ViCommandMode
+{
+ $var_EditingMode = $var_EditingMode{'vicmd'};
+ $Vi_mode = 1;
+}
+
+sub F_ViAcceptInsert {
+ local $in_accept_line = 1;
+ &F_ViEndInsert;
+ &F_ViAcceptLine;
+}
+
+sub F_ViEndInsert
+{
+ if ($Dot_buf) {
+ if ($line eq '' and $Dot_buf->[0] eq 'i') {
+ # We inserted nothing into an empty $line - assume it was a
+ # &F_ViInput() call with no arguments, and don't save command.
+ undef $Dot_buf;
+ }
+ else {
+ # Regardless of which keystroke actually terminated this insert
+ # command, replace it with an <esc> in the dot buffer.
+ @{$Dot_buf}[-1] = "\e";
+ &end_dot_buf;
+ }
+ }
+ &F_ViCommandMode;
+ # Move cursor back to the last inserted character, but not when
+ # we're about to accept a line of input
+ &F_BackwardChar(1) unless $in_accept_line;
+}
+
+sub F_ViDigit {
+ my($count, $ord) = @_;
+
+ my $n = 0;
+ my $ord0 = ord('0');
+ while (1) {
+
+ $n *= 10;
+ $n += $ord - $ord0;
+
+ my $c = &getc_with_pending;
+ return unless defined $c;
+ $ord = ord($c);
+ last unless $c =~ /^\d$/;
+ }
+
+ $n *= $count; # So 2d3w deletes six words
+ $n = $rl_max_numeric_arg if $n > $rl_max_numeric_arg;
+
+ &do_command($var_EditingMode, $n, $ord);
+}
+
+sub F_ViComplete {
+ my($n, $ord) = @_;
+
+ $Dot_state = savestate(); # Completion is undo-able
+ undef $Dot_buf; # but not redo-able
+
+ my $ch;
+ while (1) {
+
+ &F_Complete() or return;
+
+ # Vi likes the cursor one character right of where emacs like it.
+ &F_ForwardChar(1);
+ &force_redisplay();
+
+ # Look ahead to the next input keystroke.
+ $ch = &getc_with_pending();
+ last unless ord($ch) == $ord; # Not a '\' - quit.
+
+ # Another '\' was typed - put the cursor back where &F_Complete left
+ # it, and try again.
+ &F_BackwardChar(1);
+ $lastcommand = 'F_Complete'; # Play along with &F_Complete's kludge
+ }
+ unshift(@Pending, $ch); # Unget the lookahead keystroke
+
+ # Successful completion - enter input mode with cursor beyond end of word.
+ &vi_input_mode;
+}
+
+sub F_ViInsertPossibleCompletions {
+ $Dot_state = savestate(); # Completion is undo-able
+ undef $Dot_buf; # but not redo-able
+
+ &complete_internal('*') or return;
+
+ # Successful completion - enter input mode with cursor beyond end of word.
+ &F_ForwardChar(1);
+ &vi_input_mode;
+}
+
+sub F_ViPossibleCompletions {
+
+ # List possible completions
+ &complete_internal('?');
+
+ # Enter input mode with cursor where we left off.
+ &F_ForwardChar(1);
+ &vi_input_mode;
+}
+
+sub F_SetMark {
+ $rl_mark = $D;
+ pos $line = $rl_mark;
+ $line_rl_mark = $rl_HistoryIndex;
+ $force_redraw = 1;
+}
+
+sub F_ExchangePointAndMark {
+ return F_Ding unless $line_rl_mark == $rl_HistoryIndex;
+ ($rl_mark, $D) = ($D, $rl_mark);
+ pos $line = $rl_mark;
+ $D = length $line if $D > length $line;
+ $force_redraw = 1;
+}
+
+sub F_KillRegion {
+ return F_Ding unless $line_rl_mark == $rl_HistoryIndex;
+ $rl_mark = length $line if $rl_mark > length $line;
+ kill_text($rl_mark, $D, 1);
+ $line_rl_mark = -1; # Disable mark
+}
+
+sub F_CopyRegionAsKill {
+ return F_Ding unless $line_rl_mark == $rl_HistoryIndex;
+ $rl_mark = length $line if $rl_mark > length $line;
+ my ($s, $e) = ($rl_mark, $D);
+ ($s, $e) = ($e, $s) if $s > $e;
+ $ThisCommandKilledText = 1 + $s;
+ $KillBuffer = '' if !$LastCommandKilledText;
+ $KillBuffer .= substr($line, $s, $e - $s);
+}
+
+sub clipboard_set {
+ my $in = shift;
+ if ($^O eq 'os2') {
+ eval {
+ require OS2::Process;
+ OS2::Process::ClipbrdText_set($in); # Do not disable \r\n-conversion
+ 1
+ } and return;
+ } elsif ($^O eq 'MSWin32') {
+ eval {
+ require Win32::Clipboard;
+ Win32::Clipboard::Set($in);
+ 1
+ } and return;
+ }
+ my $mess;
+ if ($ENV{RL_CLCOPY_CMD}) {
+ $mess = "Writing to pipe `$ENV{RL_CLCOPY_CMD}'";
+ open COPY, "| $ENV{RL_CLCOPY_CMD}" or warn("$mess: $!"), return;
+ } elsif (defined $ENV{HOME}) {
+ $mess = "Writing to file `$ENV{HOME}/.rl_cutandpaste'";
+ open COPY, "> $ENV{HOME}/.rl_cutandpaste" or warn("$mess: $!"), return;
+ } else {
+ return;
+ }
+ print COPY $in;
+ close COPY or warn("$mess: closing $!");
+}
+
+sub F_CopyRegionAsKillClipboard {
+ return clipboard_set($line) unless $line_rl_mark == $rl_HistoryIndex;
+ &F_CopyRegionAsKill;
+ clipboard_set($KillBuffer);
+}
+
+sub F_KillRegionClipboard {
+ &F_KillRegion;
+ clipboard_set($KillBuffer);
+}
+
+sub F_YankClipboard
+{
+ remove_selection();
+ my $in;
+ if ($^O eq 'os2') {
+ eval {
+ require OS2::Process;
+ $in = OS2::Process::ClipbrdText();
+ $in =~ s/\r\n/\n/g; # With old versions, or what?
+ }
+ } elsif ($^O eq 'MSWin32') {
+ eval {
+ require Win32::Clipboard;
+ $in = Win32::Clipboard::GetText();
+ $in =~ s/\r\n/\n/g; # is this needed?
+ }
+ } else {
+ my $mess;
+ if ($ENV{RL_PASTE_CMD}) {
+ $mess = "Reading from pipe `$ENV{RL_PASTE_CMD}'";
+ open PASTE, "$ENV{RL_PASTE_CMD} |" or warn("$mess: $!"), return;
+ } elsif (defined $ENV{HOME}) {
+ $mess = "Reading from file `$ENV{HOME}/.rl_cutandpaste'";
+ open PASTE, "< $ENV{HOME}/.rl_cutandpaste" or warn("$mess: $!"), return;
+ }
+ if ($mess) {
+ local $/;
+ $in = <PASTE>;
+ close PASTE or warn("$mess, closing: $!");
+ }
+ }
+ if (defined $in) {
+ $in =~ s/\n+$//;
+ return &TextInsert($_[0], $in);
+ }
+ &TextInsert($_[0], $KillBuffer);
+}
+
+sub F_BeginUndoGroup {
+ push @undoGroupS, $#undo;
+}
+
+sub F_EndUndoGroup {
+ return F_Ding unless @undoGroupS;
+ my $last = pop @undoGroupS;
+ return unless $#undo > $last + 1;
+ my $now = pop @undo;
+ $#undo = $last;
+ push @undo, $now;
+}
+
+sub F_DoNothing { # E.g., reset digit-argument
+ 1;
+}
+
+sub F_ForceMemorizeDigitArgument {
+ $memorizedArg = shift;
+}
+
+sub F_MemorizeDigitArgument {
+ return if defined $memorizedArg;
+ $memorizedArg = shift;
+}
+
+sub F_UnmemorizeDigitArgument {
+ $memorizedArg = undef;
+}
+
+sub F_MemorizePos {
+ $memorizedPos = $D;
+}
+
+# It is assumed that F_MemorizePos was called, then something was inserted,
+# then F_MergeInserts is called with a prefix argument to multiply
+# insertion by
+
+sub F_MergeInserts {
+ my $n = shift;
+ return F_Ding unless defined $memorizedPos and $n > 0;
+ my ($b, $e) = ($memorizedPos, $D);
+ ($b, $e) = ($e, $b) if $e < $b;
+ if ($n) {
+ substr($line, $e, 0) = substr($line, $b, $e - $b) x ($n - 1);
+ } else {
+ substr($line, $b, $e - $b) = '';
+ }
+ $D = $b + ($e - $b) * $n;
+}
+
+sub F_ResetDigitArgument {
+ return F_Ding unless defined $memorizedArg;
+ my $in = &getc_with_pending;
+ return unless defined $in;
+ my $ord = ord $in;
+ local(*KeyMap) = $var_EditingMode;
+ &do_command(*KeyMap, $memorizedArg, $ord);
+}
+
+sub F_BeginPasteGroup {
+ my $c = shift;
+ $memorizedArg = $c unless defined $memorizedArg;
+ F_BeginUndoGroup(1);
+ $memorizedPos = $D;
+}
+
+sub F_EndPasteGroup {
+ my $c = $memorizedArg;
+ undef $memorizedArg;
+ $c = 1 unless defined $c;
+ F_MergeInserts($c);
+ F_EndUndoGroup(1);
+}
+
+sub F_BeginEditGroup {
+ $memorizedArg = shift;
+ F_BeginUndoGroup(1);
+}
+
+sub F_EndEditGroup {
+ undef $memorizedArg;
+ F_EndUndoGroup(1);
+}
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl0/lib/Term/UI.pm b/Master/tlpkg/tlperl0/lib/Term/UI.pm
new file mode 100755
index 00000000000..136f75bb6ad
--- /dev/null
+++ b/Master/tlpkg/tlperl0/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/tlperl0/lib/Term/UI/History.pm b/Master/tlpkg/tlperl0/lib/Term/UI/History.pm
new file mode 100755
index 00000000000..1d77c01c6f6
--- /dev/null
+++ b/Master/tlpkg/tlperl0/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: