diff options
author | Norbert Preining <preining@logic.at> | 2010-05-12 16:54:37 +0000 |
---|---|---|
committer | Norbert Preining <preining@logic.at> | 2010-05-12 16:54:37 +0000 |
commit | 661c41a09e39a182865e0b51e34cc995a0dc96e8 (patch) | |
tree | 2f79bb1406e22fdcb2587be8ffda6c0c609d7932 /Master/tlpkg/tlperl/lib/Term | |
parent | b645030efc22e13c2498a1522083634ab91b2de1 (diff) |
move tlperl.straw to tlperl
git-svn-id: svn://tug.org/texlive/trunk@18210 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Term')
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Term/ANSIColor.pm | 725 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Term/Cap.pm | 799 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Term/Complete.pm | 188 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Term/ReadKey.pm | 572 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Term/ReadLine.pm | 413 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Term/ReadLine/Perl.pm | 153 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Term/ReadLine/readline.pm | 4615 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Term/UI.pm | 620 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Term/UI/History.pm | 137 |
9 files changed, 8222 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Term/ANSIColor.pm b/Master/tlpkg/tlperl/lib/Term/ANSIColor.pm new file mode 100755 index 00000000000..72b941f6211 --- /dev/null +++ b/Master/tlpkg/tlperl/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/tlperl/lib/Term/Cap.pm b/Master/tlpkg/tlperl/lib/Term/Cap.pm new file mode 100755 index 00000000000..004a03c4124 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Term/Cap.pm @@ -0,0 +1,799 @@ +package Term::Cap; + +# Since the debugger uses Term::ReadLine which uses Term::Cap, we want +# to load as few modules as possible. This includes Carp.pm. +sub carp +{ + require Carp; + goto &Carp::carp; +} + +sub croak +{ + require Carp; + goto &Carp::croak; +} + +use strict; + +use vars qw($VERSION $VMS_TERMCAP); +use vars qw($termpat $state $first $entry); + +$VERSION = '1.12'; + +# Version undef: Thu Dec 14 20:02:42 CST 1995 by sanders@bsdi.com +# Version 1.00: Thu Nov 30 23:34:29 EST 2000 by schwern@pobox.com +# [PATCH] $VERSION crusade, strict, tests, etc... all over lib/ +# Version 1.01: Wed May 23 00:00:00 CST 2001 by d-lewart@uiuc.edu +# Avoid warnings in Tgetent and Tputs +# Version 1.02: Sat Nov 17 13:50:39 GMT 2001 by jns@gellyfish.com +# Altered layout of the POD +# Added Test::More to PREREQ_PM in Makefile.PL +# Fixed no argument Tgetent() +# Version 1.03: Wed Nov 28 10:09:38 GMT 2001 +# VMS Support from Charles Lane <lane@DUPHY4.Physics.Drexel.Edu> +# Version 1.04: Thu Nov 29 16:22:03 GMT 2001 +# Fixed warnings in test +# Version 1.05: Mon Dec 3 15:33:49 GMT 2001 +# Don't try to fall back on infocmp if it's not there. From chromatic. +# Version 1.06: Thu Dec 6 18:43:22 GMT 2001 +# Preload the default VMS termcap from Charles Lane +# Don't carp at setting OSPEED unless warnings are on. +# Version 1.07: Wed Jan 2 21:35:09 GMT 2002 +# Sanity check on infocmp output from Norton Allen +# Repaired INSTALLDIRS thanks to Michael Schwern +# Version 1.08: Sat Sep 28 11:33:15 BST 2002 +# Late loading of 'Carp' as per Michael Schwern +# Version 1.09: Tue Apr 20 12:06:51 BST 2004 +# Merged in changes from and to Core +# Core (Fri Aug 30 14:15:55 CEST 2002): +# Cope with comments lines from 'infocmp' from Brendan O'Dea +# Allow for EBCDIC in Tgoto magic test. +# Version 1.10: Thu Oct 18 16:52:20 BST 2007 +# Don't use try to use $ENV{HOME} if it doesn't exist +# Give Win32 'dumb' if TERM isn't set +# Provide fallback 'dumb' termcap entry as last resort +# Version 1.11: Thu Oct 25 09:33:07 BST 2007 +# EBDIC fixes from Chun Bing Ge <gecb@cn.ibm.com> +# Version 1.12: Sat Dec 8 00:10:21 GMT 2007 +# QNX test fix from Matt Kraai <kraai@ftbfs.org> +# +# TODO: +# support Berkeley DB termcaps +# force $FH into callers package? +# keep $FH in object at Tgetent time? + +=head1 NAME + +Term::Cap - Perl termcap interface + +=head1 SYNOPSIS + + require Term::Cap; + $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed }; + $terminal->Trequire(qw/ce ku kd/); + $terminal->Tgoto('cm', $col, $row, $FH); + $terminal->Tputs('dl', $count, $FH); + $terminal->Tpad($string, $count, $FH); + +=head1 DESCRIPTION + +These are low-level functions to extract and use capabilities from +a terminal capability (termcap) database. + +More information on the terminal capabilities will be found in the +termcap manpage on most Unix-like systems. + +=head2 METHODS + +=over 4 + +The output strings for B<Tputs> are cached for counts of 1 for performance. +B<Tgoto> and B<Tpad> do not cache. C<$self-E<gt>{_xx}> is the raw termcap +data and C<$self-E<gt>{xx}> is the cached version. + + print $terminal->Tpad($self->{_xx}, 1); + +B<Tgoto>, B<Tputs>, and B<Tpad> return the string and will also +output the string to $FH if specified. + + +=cut + +# Preload the default VMS termcap. +# If a different termcap is required then the text of one can be supplied +# in $Term::Cap::VMS_TERMCAP before Tgetent is called. + +if ( $^O eq 'VMS' ) +{ + chomp( my @entry = <DATA> ); + $VMS_TERMCAP = join '', @entry; +} + +# Returns a list of termcap files to check. + +sub termcap_path +{ ## private + my @termcap_path; + + # $TERMCAP, if it's a filespec + push( @termcap_path, $ENV{TERMCAP} ) + if ( + ( exists $ENV{TERMCAP} ) + && ( + ( $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos' ) + ? $ENV{TERMCAP} =~ /^[a-z]:[\\\/]/is + : $ENV{TERMCAP} =~ /^\//s + ) + ); + if ( ( exists $ENV{TERMPATH} ) && ( $ENV{TERMPATH} ) ) + { + + # Add the users $TERMPATH + push( @termcap_path, split( /(:|\s+)/, $ENV{TERMPATH} ) ); + } + else + { + + # Defaults + push( @termcap_path, + exists $ENV{'HOME'} ? $ENV{'HOME'} . '/.termcap' : undef, + '/etc/termcap', '/usr/share/misc/termcap', ); + } + + # return the list of those termcaps that exist + return grep { defined $_ && -f $_ } @termcap_path; +} + +=item B<Tgetent> + +Returns a blessed object reference which the user can +then use to send the control strings to the terminal using B<Tputs> +and B<Tgoto>. + +The function extracts the entry of the specified terminal +type I<TERM> (defaults to the environment variable I<TERM>) from the +database. + +It will look in the environment for a I<TERMCAP> variable. If +found, and the value does not begin with a slash, and the terminal +type name is the same as the environment string I<TERM>, the +I<TERMCAP> string is used instead of reading a termcap file. If +it does begin with a slash, the string is used as a path name of +the termcap file to search. If I<TERMCAP> does not begin with a +slash and name is different from I<TERM>, B<Tgetent> searches the +files F<$HOME/.termcap>, F</etc/termcap>, and F</usr/share/misc/termcap>, +in that order, unless the environment variable I<TERMPATH> exists, +in which case it specifies a list of file pathnames (separated by +spaces or colons) to be searched B<instead>. Whenever multiple +files are searched and a tc field occurs in the requested entry, +the entry it names must be found in the same file or one of the +succeeding files. If there is a C<:tc=...:> in the I<TERMCAP> +environment variable string it will continue the search in the +files as above. + +The extracted termcap entry is available in the object +as C<$self-E<gt>{TERMCAP}>. + +It takes a hash reference as an argument with two optional keys: + +=over 2 + +=item OSPEED + +The terminal output bit rate (often mistakenly called the baud rate) +for this terminal - if not set a warning will be generated +and it will be defaulted to 9600. I<OSPEED> can be be specified as +either a POSIX termios/SYSV termio speeds (where 9600 equals 9600) or +an old DSD-style speed ( where 13 equals 9600). + + +=item TERM + +The terminal type whose termcap entry will be used - if not supplied it will +default to $ENV{TERM}: if that is not set then B<Tgetent> will croak. + +=back + +It calls C<croak> on failure. + +=cut + +sub Tgetent +{ ## public -- static method + my $class = shift; + my ($self) = @_; + + $self = {} unless defined $self; + bless $self, $class; + + my ( $term, $cap, $search, $field, $max, $tmp_term, $TERMCAP ); + local ( $termpat, $state, $first, $entry ); # used inside eval + local $_; + + # Compute PADDING factor from OSPEED (to be used by Tpad) + if ( !$self->{OSPEED} ) + { + if ($^W) + { + carp "OSPEED was not set, defaulting to 9600"; + } + $self->{OSPEED} = 9600; + } + if ( $self->{OSPEED} < 16 ) + { + + # delays for old style speeds + my @pad = ( + 0, 200, 133.3, 90.9, 74.3, 66.7, 50, 33.3, + 16.7, 8.3, 5.5, 4.1, 2, 1, .5, .2 + ); + $self->{PADDING} = $pad[ $self->{OSPEED} ]; + } + else + { + $self->{PADDING} = 10000 / $self->{OSPEED}; + } + + unless ( $self->{TERM} ) + { + if ( $ENV{TERM} ) + { + $self->{TERM} = $ENV{TERM} ; + } + else + { + if ( $^O eq 'Win32' ) + { + $self->{TERM} = 'dumb'; + } + else + { + croak "TERM not set"; + } + } + } + + $term = $self->{TERM}; # $term is the term type we are looking for + + # $tmp_term is always the next term (possibly :tc=...:) we are looking for + $tmp_term = $self->{TERM}; + + # protect any pattern metacharacters in $tmp_term + $termpat = $tmp_term; + $termpat =~ s/(\W)/\\$1/g; + + my $foo = ( exists $ENV{TERMCAP} ? $ENV{TERMCAP} : '' ); + + # $entry is the extracted termcap entry + if ( ( $foo !~ m:^/:s ) && ( $foo =~ m/(^|\|)${termpat}[:|]/s ) ) + { + $entry = $foo; + } + + my @termcap_path = termcap_path(); + + unless ( @termcap_path || $entry ) + { + + # last resort--fake up a termcap from terminfo + local $ENV{TERM} = $term; + + if ( $^O eq 'VMS' ) + { + $entry = $VMS_TERMCAP; + } + else + { + if ( grep { -x "$_/infocmp" } split /:/, $ENV{PATH} ) + { + eval { + my $tmp = `infocmp -C 2>/dev/null`; + $tmp =~ s/^#.*\n//gm; # remove comments + if ( ( $tmp !~ m%^/%s ) + && ( $tmp =~ /(^|\|)${termpat}[:|]/s ) ) + { + $entry = $tmp; + } + }; + } + else + { + # this is getting desperate now + if ( $self->{TERM} eq 'dumb' ) + { + $entry = 'dumb|80-column dumb tty::am::co#80::bl=^G:cr=^M:do=^J:sf=^J:'; + } + } + } + } + + croak "Can't find a valid termcap file" unless @termcap_path || $entry; + + $state = 1; # 0 == finished + # 1 == next file + # 2 == search again + + $first = 0; # first entry (keeps term name) + + $max = 32; # max :tc=...:'s + + if ($entry) + { + + # ok, we're starting with $TERMCAP + $first++; # we're the first entry + # do we need to continue? + if ( $entry =~ s/:tc=([^:]+):/:/ ) + { + $tmp_term = $1; + + # protect any pattern metacharacters in $tmp_term + $termpat = $tmp_term; + $termpat =~ s/(\W)/\\$1/g; + } + else + { + $state = 0; # we're already finished + } + } + + # This is eval'ed inside the while loop for each file + $search = q{ + while (<TERMCAP>) { + next if /^\\t/ || /^#/; + if ($_ =~ m/(^|\\|)${termpat}[:|]/o) { + chomp; + s/^[^:]*:// if $first++; + $state = 0; + while ($_ =~ s/\\\\$//) { + defined(my $x = <TERMCAP>) or last; + $_ .= $x; chomp; + } + last; + } + } + defined $entry or $entry = ''; + $entry .= $_ if $_; + }; + + while ( $state != 0 ) + { + if ( $state == 1 ) + { + + # get the next TERMCAP + $TERMCAP = shift @termcap_path + || croak "failed termcap lookup on $tmp_term"; + } + else + { + + # do the same file again + # prevent endless recursion + $max-- || croak "failed termcap loop at $tmp_term"; + $state = 1; # ok, maybe do a new file next time + } + + open( TERMCAP, "< $TERMCAP\0" ) || croak "open $TERMCAP: $!"; + eval $search; + die $@ if $@; + close TERMCAP; + + # If :tc=...: found then search this file again + $entry =~ s/:tc=([^:]+):/:/ && ( $tmp_term = $1, $state = 2 ); + + # protect any pattern metacharacters in $tmp_term + $termpat = $tmp_term; + $termpat =~ s/(\W)/\\$1/g; + } + + croak "Can't find $term" if $entry eq ''; + $entry =~ s/:+\s*:+/:/g; # cleanup $entry + $entry =~ s/:+/:/g; # cleanup $entry + $self->{TERMCAP} = $entry; # save it + # print STDERR "DEBUG: $entry = ", $entry, "\n"; + + # Precompile $entry into the object + $entry =~ s/^[^:]*://; + foreach $field ( split( /:[\s:\\]*/, $entry ) ) + { + if ( defined $field && $field =~ /^(\w\w)$/ ) + { + $self->{ '_' . $field } = 1 unless defined $self->{ '_' . $1 }; + + # print STDERR "DEBUG: flag $1\n"; + } + elsif ( defined $field && $field =~ /^(\w\w)\@/ ) + { + $self->{ '_' . $1 } = ""; + + # print STDERR "DEBUG: unset $1\n"; + } + elsif ( defined $field && $field =~ /^(\w\w)#(.*)/ ) + { + $self->{ '_' . $1 } = $2 unless defined $self->{ '_' . $1 }; + + # print STDERR "DEBUG: numeric $1 = $2\n"; + } + elsif ( defined $field && $field =~ /^(\w\w)=(.*)/ ) + { + + # print STDERR "DEBUG: string $1 = $2\n"; + next if defined $self->{ '_' . ( $cap = $1 ) }; + $_ = $2; + if ( ord('A') == 193 ) + { + s/\\E/\047/g; + s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg; + s/\\n/\n/g; + s/\\r/\r/g; + s/\\t/\t/g; + s/\\b/\b/g; + s/\\f/\f/g; + s/\\\^/\337/g; + s/\^\?/\007/g; + s/\^(.)/pack('c',ord($1) & 31)/eg; + s/\\(.)/$1/g; + s/\337/^/g; + } + else + { + s/\\E/\033/g; + s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg; + s/\\n/\n/g; + s/\\r/\r/g; + s/\\t/\t/g; + s/\\b/\b/g; + s/\\f/\f/g; + s/\\\^/\377/g; + s/\^\?/\177/g; + s/\^(.)/pack('c',ord($1) & 31)/eg; + s/\\(.)/$1/g; + s/\377/^/g; + } + $self->{ '_' . $cap } = $_; + } + + # else { carp "junk in $term ignored: $field"; } + } + $self->{'_pc'} = "\0" unless defined $self->{'_pc'}; + $self->{'_bc'} = "\b" unless defined $self->{'_bc'}; + $self; +} + +# $terminal->Tpad($string, $cnt, $FH); + +=item B<Tpad> + +Outputs a literal string with appropriate padding for the current terminal. + +It takes three arguments: + +=over 2 + +=item B<$string> + +The literal string to be output. If it starts with a number and an optional +'*' then the padding will be increased by an amount relative to this number, +if the '*' is present then this amount will me multiplied by $cnt. This part +of $string is removed before output/ + +=item B<$cnt> + +Will be used to modify the padding applied to string as described above. + +=item B<$FH> + +An optional filehandle (or IO::Handle ) that output will be printed to. + +=back + +The padded $string is returned. + +=cut + +sub Tpad +{ ## public + my $self = shift; + my ( $string, $cnt, $FH ) = @_; + my ( $decr, $ms ); + + if ( defined $string && $string =~ /(^[\d.]+)(\*?)(.*)$/ ) + { + $ms = $1; + $ms *= $cnt if $2; + $string = $3; + $decr = $self->{PADDING}; + if ( $decr > .1 ) + { + $ms += $decr / 2; + $string .= $self->{'_pc'} x ( $ms / $decr ); + } + } + print $FH $string if $FH; + $string; +} + +# $terminal->Tputs($cap, $cnt, $FH); + +=item B<Tputs> + +Output the string for the given capability padded as appropriate without +any parameter substitution. + +It takes three arguments: + +=over 2 + +=item B<$cap> + +The capability whose string is to be output. + +=item B<$cnt> + +A count passed to Tpad to modify the padding applied to the output string. +If $cnt is zero or one then the resulting string will be cached. + +=item B<$FH> + +An optional filehandle (or IO::Handle ) that output will be printed to. + +=back + +The appropriate string for the capability will be returned. + +=cut + +sub Tputs +{ ## public + my $self = shift; + my ( $cap, $cnt, $FH ) = @_; + my $string; + + $cnt = 0 unless $cnt; + + if ( $cnt > 1 ) + { + $string = Tpad( $self, $self->{ '_' . $cap }, $cnt ); + } + else + { + + # cache result because Tpad can be slow + unless ( exists $self->{$cap} ) + { + $self->{$cap} = + exists $self->{"_$cap"} + ? Tpad( $self, $self->{"_$cap"}, 1 ) + : undef; + } + $string = $self->{$cap}; + } + print $FH $string if $FH; + $string; +} + +# $terminal->Tgoto($cap, $col, $row, $FH); + +=item B<Tgoto> + +B<Tgoto> decodes a cursor addressing string with the given parameters. + +There are four arguments: + +=over 2 + +=item B<$cap> + +The name of the capability to be output. + +=item B<$col> + +The first value to be substituted in the output string ( usually the column +in a cursor addressing capability ) + +=item B<$row> + +The second value to be substituted in the output string (usually the row +in cursor addressing capabilities) + +=item B<$FH> + +An optional filehandle (or IO::Handle ) to which the output string will be +printed. + +=back + +Substitutions are made with $col and $row in the output string with the +following sprintf() line formats: + + %% output `%' + %d output value as in printf %d + %2 output value as in printf %2d + %3 output value as in printf %3d + %. output value as in printf %c + %+x add x to value, then do %. + + %>xy if value > x then add y, no output + %r reverse order of two parameters, no output + %i increment by one, no output + %B BCD (16*(value/10)) + (value%10), no output + + %n exclusive-or all parameters with 0140 (Datamedia 2500) + %D Reverse coding (value - 2*(value%16)), no output (Delta Data) + +The output string will be returned. + +=cut + +sub Tgoto +{ ## public + my $self = shift; + my ( $cap, $code, $tmp, $FH ) = @_; + my $string = $self->{ '_' . $cap }; + my $result = ''; + my $after = ''; + my $online = 0; + my @tmp = ( $tmp, $code ); + my $cnt = $code; + + while ( $string =~ /^([^%]*)%(.)(.*)/ ) + { + $result .= $1; + $code = $2; + $string = $3; + if ( $code eq 'd' ) + { + $result .= sprintf( "%d", shift(@tmp) ); + } + elsif ( $code eq '.' ) + { + $tmp = shift(@tmp); + if ( $tmp == 0 || $tmp == 4 || $tmp == 10 ) + { + if ($online) + { + ++$tmp, $after .= $self->{'_up'} if $self->{'_up'}; + } + else + { + ++$tmp, $after .= $self->{'_bc'}; + } + } + $result .= sprintf( "%c", $tmp ); + $online = !$online; + } + elsif ( $code eq '+' ) + { + $result .= sprintf( "%c", shift(@tmp) + ord($string) ); + $string = substr( $string, 1, 99 ); + $online = !$online; + } + elsif ( $code eq 'r' ) + { + ( $code, $tmp ) = @tmp; + @tmp = ( $tmp, $code ); + $online = !$online; + } + elsif ( $code eq '>' ) + { + ( $code, $tmp, $string ) = unpack( "CCa99", $string ); + if ( $tmp[$[] > $code ) + { + $tmp[$[] += $tmp; + } + } + elsif ( $code eq '2' ) + { + $result .= sprintf( "%02d", shift(@tmp) ); + $online = !$online; + } + elsif ( $code eq '3' ) + { + $result .= sprintf( "%03d", shift(@tmp) ); + $online = !$online; + } + elsif ( $code eq 'i' ) + { + ( $code, $tmp ) = @tmp; + @tmp = ( $code + 1, $tmp + 1 ); + } + else + { + return "OOPS"; + } + } + $string = Tpad( $self, $result . $string . $after, $cnt ); + print $FH $string if $FH; + $string; +} + +# $terminal->Trequire(qw/ce ku kd/); + +=item B<Trequire> + +Takes a list of capabilities as an argument and will croak if one is not +found. + +=cut + +sub Trequire +{ ## public + my $self = shift; + my ( $cap, @undefined ); + foreach $cap (@_) + { + push( @undefined, $cap ) + unless defined $self->{ '_' . $cap } && $self->{ '_' . $cap }; + } + croak "Terminal does not support: (@undefined)" if @undefined; +} + +=back + +=head1 EXAMPLES + + use Term::Cap; + + # Get terminal output speed + require POSIX; + my $termios = new POSIX::Termios; + $termios->getattr; + my $ospeed = $termios->getospeed; + + # Old-style ioctl code to get ospeed: + # require 'ioctl.pl'; + # ioctl(TTY,$TIOCGETP,$sgtty); + # ($ispeed,$ospeed) = unpack('cc',$sgtty); + + # allocate and initialize a terminal structure + $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed }; + + # require certain capabilities to be available + $terminal->Trequire(qw/ce ku kd/); + + # Output Routines, if $FH is undefined these just return the string + + # Tgoto does the % expansion stuff with the given args + $terminal->Tgoto('cm', $col, $row, $FH); + + # Tputs doesn't do any % expansion. + $terminal->Tputs('dl', $count = 1, $FH); + +=head1 COPYRIGHT AND LICENSE + +Please see the README file in distribution. + +=head1 AUTHOR + +This module is part of the core Perl distribution and is also maintained +for CPAN by Jonathan Stowe <jns@gellyfish.com>. + +=head1 SEE ALSO + +termcap(5) + +=cut + +# Below is a default entry for systems where there are terminals but no +# termcap +1; +__DATA__ +vt220|vt200|DEC VT220 in vt100 emulation mode: +am:mi:xn:xo: +co#80:li#24: +RA=\E[?7l:SA=\E[?7h: +ac=kkllmmjjnnwwqquuttvvxx:ae=\E(B:al=\E[L:as=\E(0: +bl=^G:cd=\E[J:ce=\E[K:cl=\E[H\E[2J:cm=\E[%i%d;%dH: +cr=^M:cs=\E[%i%d;%dr:dc=\E[P:dl=\E[M:do=\E[B: +ei=\E[4l:ho=\E[H:im=\E[4h: +is=\E[1;24r\E[24;1H: +nd=\E[C: +kd=\E[B::kl=\E[D:kr=\E[C:ku=\E[A:le=^H: +mb=\E[5m:md=\E[1m:me=\E[m:mr=\E[7m: +kb=\0177: +r2=\E>\E[24;1H\E[?3l\E[?4l\E[?5l\E[?7h\E[?8h\E=:rc=\E8: +sc=\E7:se=\E[27m:sf=\ED:so=\E[7m:sr=\EM:ta=^I: +ue=\E[24m:up=\E[A:us=\E[4m:ve=\E[?25h:vi=\E[?25l: + diff --git a/Master/tlpkg/tlperl/lib/Term/Complete.pm b/Master/tlpkg/tlperl/lib/Term/Complete.pm new file mode 100755 index 00000000000..601e4956430 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Term/Complete.pm @@ -0,0 +1,188 @@ +package Term::Complete; +require 5.000; +require Exporter; + +use strict; +our @ISA = qw(Exporter); +our @EXPORT = qw(Complete); +our $VERSION = '1.402'; + +# @(#)complete.pl,v1.2 (me@anywhere.EBay.Sun.COM) 09/23/91 + +=head1 NAME + +Term::Complete - Perl word completion module + +=head1 SYNOPSIS + + $input = Complete('prompt_string', \@completion_list); + $input = Complete('prompt_string', @completion_list); + +=head1 DESCRIPTION + +This routine provides word completion on the list of words in +the array (or array ref). + +The tty driver is put into raw mode and restored using an operating +system specific command, in UNIX-like environments C<stty>. + +The following command characters are defined: + +=over 4 + +=item E<lt>tabE<gt> + +Attempts word completion. +Cannot be changed. + +=item ^D + +Prints completion list. +Defined by I<$Term::Complete::complete>. + +=item ^U + +Erases the current input. +Defined by I<$Term::Complete::kill>. + +=item E<lt>delE<gt>, E<lt>bsE<gt> + +Erases one character. +Defined by I<$Term::Complete::erase1> and I<$Term::Complete::erase2>. + +=back + +=head1 DIAGNOSTICS + +Bell sounds when word completion fails. + +=head1 BUGS + +The completion character E<lt>tabE<gt> cannot be changed. + +=head1 AUTHOR + +Wayne Thompson + +=cut + +our($complete, $kill, $erase1, $erase2, $tty_raw_noecho, $tty_restore, $stty, $tty_safe_restore); +our($tty_saved_state) = ''; +CONFIG: { + $complete = "\004"; + $kill = "\025"; + $erase1 = "\177"; + $erase2 = "\010"; + foreach my $s (qw(/bin/stty /usr/bin/stty)) { + if (-x $s) { + $tty_raw_noecho = "$s raw -echo"; + $tty_restore = "$s -raw echo"; + $tty_safe_restore = $tty_restore; + $stty = $s; + last; + } + } +} + +sub Complete { + my($prompt, @cmp_lst, $cmp, $test, $l, @match); + my ($return, $r) = ("", 0); + + $return = ""; + $r = 0; + + $prompt = shift; + if (ref $_[0] || $_[0] =~ /^\*/) { + @cmp_lst = sort @{$_[0]}; + } + else { + @cmp_lst = sort(@_); + } + + # Attempt to save the current stty state, to be restored later + if (defined $stty && defined $tty_saved_state && $tty_saved_state eq '') { + $tty_saved_state = qx($stty -g 2>/dev/null); + if ($?) { + # stty -g not supported + $tty_saved_state = undef; + } + else { + $tty_saved_state =~ s/\s+$//g; + $tty_restore = qq($stty "$tty_saved_state" 2>/dev/null); + } + } + system $tty_raw_noecho if defined $tty_raw_noecho; + LOOP: { + local $_; + print($prompt, $return); + while (($_ = getc(STDIN)) ne "\r") { + CASE: { + # (TAB) attempt completion + $_ eq "\t" && do { + @match = grep(/^\Q$return/, @cmp_lst); + unless ($#match < 0) { + $l = length($test = shift(@match)); + foreach $cmp (@match) { + until (substr($cmp, 0, $l) eq substr($test, 0, $l)) { + $l--; + } + } + print("\a"); + print($test = substr($test, $r, $l - $r)); + $r = length($return .= $test); + } + last CASE; + }; + + # (^D) completion list + $_ eq $complete && do { + print(join("\r\n", '', grep(/^\Q$return/, @cmp_lst)), "\r\n"); + redo LOOP; + }; + + # (^U) kill + $_ eq $kill && do { + if ($r) { + $r = 0; + $return = ""; + print("\r\n"); + redo LOOP; + } + last CASE; + }; + + # (DEL) || (BS) erase + ($_ eq $erase1 || $_ eq $erase2) && do { + if($r) { + print("\b \b"); + chop($return); + $r--; + } + last CASE; + }; + + # printable char + ord >= 32 && do { + $return .= $_; + $r++; + print; + last CASE; + }; + } + } + } + + # system $tty_restore if defined $tty_restore; + if (defined $tty_saved_state && defined $tty_restore && defined $tty_safe_restore) + { + system $tty_restore; + if ($?) { + # tty_restore caused error + system $tty_safe_restore; + } + } + print("\n"); + $return; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Term/ReadKey.pm b/Master/tlpkg/tlperl/lib/Term/ReadKey.pm new file mode 100755 index 00000000000..92a2c22ec8f --- /dev/null +++ b/Master/tlpkg/tlperl/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/tlperl/lib/Term/ReadLine.pm b/Master/tlpkg/tlperl/lib/Term/ReadLine.pm new file mode 100755 index 00000000000..a8116af5e74 --- /dev/null +++ b/Master/tlpkg/tlperl/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/tlperl/lib/Term/ReadLine/Perl.pm b/Master/tlpkg/tlperl/lib/Term/ReadLine/Perl.pm new file mode 100755 index 00000000000..599b2c3769a --- /dev/null +++ b/Master/tlpkg/tlperl/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/tlperl/lib/Term/ReadLine/readline.pm b/Master/tlpkg/tlperl/lib/Term/ReadLine/readline.pm new file mode 100755 index 00000000000..a19ddb19a9a --- /dev/null +++ b/Master/tlpkg/tlperl/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/tlperl/lib/Term/UI.pm b/Master/tlpkg/tlperl/lib/Term/UI.pm new file mode 100755 index 00000000000..136f75bb6ad --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Term/UI.pm @@ -0,0 +1,620 @@ +package Term::UI; + +use Carp; +use Params::Check qw[check allow]; +use Term::ReadLine; +use Locale::Maketext::Simple Style => 'gettext'; +use Term::UI::History; + +use strict; + +BEGIN { + use vars qw[$VERSION $AUTOREPLY $VERBOSE $INVALID]; + $VERBOSE = 1; + $VERSION = '0.20'; + $INVALID = loc('Invalid selection, please try again: '); +} + +push @Term::ReadLine::Stub::ISA, __PACKAGE__ + unless grep { $_ eq __PACKAGE__ } @Term::ReadLine::Stub::ISA; + + +=pod + +=head1 NAME + +Term::UI - Term::ReadLine UI made easy + +=head1 SYNOPSIS + + use Term::UI; + use Term::ReadLine; + + my $term = Term::ReadLine->new('brand'); + + my $reply = $term->get_reply( + prompt => 'What is your favourite colour?', + choices => [qw|blue red green|], + default => blue, + ); + + my $bool = $term->ask_yn( + prompt => 'Do you like cookies?', + default => 'y', + ); + + + my $string = q[some_command -option --no-foo --quux='this thing']; + + my ($options,$munged_input) = $term->parse_options($string); + + + ### don't have Term::UI issue warnings -- default is '1' + $Term::UI::VERBOSE = 0; + + ### always pick the default (good for non-interactive terms) + ### -- default is '0' + $Term::UI::AUTOREPLY = 1; + + ### Retrieve the entire session as a printable string: + $hist = Term::UI::History->history_as_string; + $hist = $term->history_as_string; + +=head1 DESCRIPTION + +C<Term::UI> is a transparent way of eliminating the overhead of having +to format a question and then validate the reply, informing the user +if the answer was not proper and re-issuing the question. + +Simply give it the question you want to ask, optionally with choices +the user can pick from and a default and C<Term::UI> will DWYM. + +For asking a yes or no question, there's even a shortcut. + +=head1 HOW IT WORKS + +C<Term::UI> places itself at the back of the C<Term::ReadLine> +C<@ISA> array, so you can call its functions through your term object. + +C<Term::UI> uses C<Term::UI::History> to record all interactions +with the commandline. You can retrieve this history, or alter +the filehandle the interaction is printed to. See the +C<Term::UI::History> manpage or the C<SYNOPSIS> for details. + +=head1 METHODS + +=head2 $reply = $term->get_reply( prompt => 'question?', [choices => \@list, default => $list[0], multi => BOOL, print_me => "extra text to print & record", allow => $ref] ); + +C<get_reply> asks a user a question, and then returns the reply to the +caller. If the answer is invalid (more on that below), the question will +be reposed, until a satisfactory answer has been entered. + +You have the option of providing a list of choices the user can pick from +using the C<choices> argument. If the answer is not in the list of choices +presented, the question will be reposed. + +If you provide a C<default> answer, this will be returned when either +C<$AUTOREPLY> is set to true, (see the C<GLOBAL VARIABLES> section further +below), or when the user just hits C<enter>. + +You can indicate that the user is allowed to enter multiple answers by +toggling the C<multi> flag. Note that a list of answers will then be +returned to you, rather than a simple string. + +By specifying an C<allow> hander, you can yourself validate the answer +a user gives. This can be any of the types that the Params::Check C<allow> +function allows, so please refer to that manpage for details. + +Finally, you have the option of adding a C<print_me> argument, which is +simply printed before the prompt. It's printed to the same file handle +as the rest of the questions, so you can use this to keep track of a +full session of Q&A with the user, and retrieve it later using the +C<< Term::UI->history_as_string >> function. + +See the C<EXAMPLES> section for samples of how to use this function. + +=cut + +sub get_reply { + my $term = shift; + my %hash = @_; + + my $tmpl = { + default => { default => undef, strict_type => 1 }, + prompt => { default => '', strict_type => 1, required => 1 }, + choices => { default => [], strict_type => 1 }, + multi => { default => 0, allow => [0, 1] }, + allow => { default => qr/.*/ }, + print_me => { default => '', strict_type => 1 }, + }; + + my $args = check( $tmpl, \%hash, $VERBOSE ) + or ( carp( loc(q[Could not parse arguments]) ), return ); + + + ### add this to the prompt to indicate the default + ### answer to the question if there is one. + my $prompt_add; + + ### if you supplied several choices to pick from, + ### we'll print them seperately before the prompt + if( @{$args->{choices}} ) { + my $i; + + for my $choice ( @{$args->{choices}} ) { + $i++; # the answer counter -- but humans start counting + # at 1 :D + + ### so this choice is the default? add it to 'prompt_add' + ### so we can construct a "foo? [DIGIT]" type prompt + $prompt_add = $i if (defined $args->{default} and $choice eq $args->{default}); + + ### create a "DIGIT> choice" type line + $args->{print_me} .= sprintf "\n%3s> %-s", $i, $choice; + } + + ### we listed some choices -- add another newline for + ### pretty printing + $args->{print_me} .= "\n" if $i; + + ### allowable answers are now equal to the choices listed + $args->{allow} = $args->{choices}; + + ### no choices, but a default? set 'prompt_add' to the default + ### to construct a 'foo? [DEFAULT]' type prompt + } elsif ( defined $args->{default} ) { + $prompt_add = $args->{default}; + } + + ### we set up the defaults, prompts etc, dispatch to the readline call + return $term->_tt_readline( %$args, prompt_add => $prompt_add ); + +} + +=head2 $bool = $term->ask_yn( prompt => "your question", [default => (y|1,n|0), print_me => "extra text to print & record"] ) + +Asks a simple C<yes> or C<no> question to the user, returning a boolean +indicating C<true> or C<false> to the caller. + +The C<default> answer will automatically returned, if the user hits +C<enter> or if C<$AUTOREPLY> is set to true. See the C<GLOBAL VARIABLES> +section further below. + +Also, you have the option of adding a C<print_me> argument, which is +simply printed before the prompt. It's printed to the same file handle +as the rest of the questions, so you can use this to keep track of a +full session of Q&A with the user, and retrieve it later using the +C<< Term::UI->history_as_string >> function. + + +See the C<EXAMPLES> section for samples of how to use this function. + +=cut + +sub ask_yn { + my $term = shift; + my %hash = @_; + + my $tmpl = { + default => { default => undef, allow => [qw|0 1 y n|], + strict_type => 1 }, + prompt => { default => '', required => 1, strict_type => 1 }, + print_me => { default => '', strict_type => 1 }, + multi => { default => 0, no_override => 1 }, + choices => { default => [qw|y n|], no_override => 1 }, + allow => { default => [qr/^y(?:es)?$/i, qr/^n(?:o)?$/i], + no_override => 1 + }, + }; + + my $args = check( $tmpl, \%hash, $VERBOSE ) or return undef; + + ### uppercase the default choice, if there is one, to be added + ### to the prompt in a 'foo? [Y/n]' type style. + my $prompt_add; + { my @list = @{$args->{choices}}; + if( defined $args->{default} ) { + + ### if you supplied the default as a boolean, rather than y/n + ### transform it to a y/n now + $args->{default} = $args->{default} =~ /\d/ + ? { 0 => 'n', 1 => 'y' }->{ $args->{default} } + : $args->{default}; + + @list = map { lc $args->{default} eq lc $_ + ? uc $args->{default} + : $_ + } @list; + } + + $prompt_add .= join("/", @list); + } + + my $rv = $term->_tt_readline( %$args, prompt_add => $prompt_add ); + + return $rv =~ /^y/i ? 1 : 0; +} + + + +sub _tt_readline { + my $term = shift; + my %hash = @_; + + local $Params::Check::VERBOSE = 0; # why is this? + local $| = 1; # print ASAP + + + my ($default, $prompt, $choices, $multi, $allow, $prompt_add, $print_me); + my $tmpl = { + default => { default => undef, strict_type => 1, + store => \$default }, + prompt => { default => '', strict_type => 1, required => 1, + store => \$prompt }, + choices => { default => [], strict_type => 1, + store => \$choices }, + multi => { default => 0, allow => [0, 1], store => \$multi }, + allow => { default => qr/.*/, store => \$allow, }, + prompt_add => { default => '', store => \$prompt_add }, + print_me => { default => '', store => \$print_me }, + }; + + check( $tmpl, \%hash, $VERBOSE ) or return; + + ### prompts for Term::ReadLine can't be longer than one line, or + ### it can display wonky on some terminals. + history( $print_me ) if $print_me; + + + ### we might have to add a default value to the prompt, to + ### show the user what will be picked by default: + $prompt .= " [$prompt_add]: " if $prompt_add; + + + ### are we in autoreply mode? + if ($AUTOREPLY) { + + ### you used autoreply, but didnt provide a default! + carp loc( + q[You have '%1' set to true, but did not provide a default!], + '$AUTOREPLY' + ) if( !defined $default && $VERBOSE); + + ### print it out for visual feedback + history( join ' ', grep { defined } $prompt, $default ); + + ### and return the default + return $default; + } + + + ### so, no AUTOREPLY, let's see what the user will answer + LOOP: { + + ### annoying bug in T::R::Perl that mucks up lines with a \n + ### in them; So split by \n, save the last line as the prompt + ### and just print the rest + { my @lines = split "\n", $prompt; + $prompt = pop @lines; + + history( "$_\n" ) for @lines; + } + + ### pose the question + my $answer = $term->readline($prompt); + $answer = $default unless length $answer; + + $term->addhistory( $answer ) if length $answer; + + ### add both prompt and answer to the history + history( "$prompt $answer", 0 ); + + ### if we're allowed to give multiple answers, split + ### the answer on whitespace + my @answers = $multi ? split(/\s+/, $answer) : $answer; + + ### the return value list + my @rv; + + if( @$choices ) { + + for my $answer (@answers) { + + ### a digit implies a multiple choice question, + ### a non-digit is an open answer + if( $answer =~ /\D/ ) { + push @rv, $answer if allow( $answer, $allow ); + } else { + + ### remember, the answer digits are +1 compared to + ### the choices, because humans want to start counting + ### at 1, not at 0 + push @rv, $choices->[ $answer - 1 ] + if $answer > 0 && defined $choices->[ $answer - 1]; + } + } + + ### no fixed list of choices.. just check if the answers + ### (or otherwise the default!) pass the allow handler + } else { + push @rv, grep { allow( $_, $allow ) } + scalar @answers ? @answers : ($default); + } + + ### if not all the answers made it to the return value list, + ### at least one of them was an invalid answer -- make the + ### user do it again + if( (@rv != @answers) or + (scalar(@$choices) and not scalar(@answers)) + ) { + $prompt = $INVALID; + $prompt .= "[$prompt_add] " if $prompt_add; + redo LOOP; + + ### otherwise just return the answer, or answers, depending + ### on the multi setting + } else { + return $multi ? @rv : $rv[0]; + } + } +} + +=head2 ($opts, $munged) = $term->parse_options( STRING ); + +C<parse_options> will convert all options given from an input string +to a hash reference. If called in list context it will also return +the part of the input string that it found no options in. + +Consider this example: + + my $str = q[command --no-foo --baz --bar=0 --quux=bleh ] . + q[--option="some'thing" -one-dash -single=blah' arg]; + + my ($options,$munged) = $term->parse_options($str); + + ### $options would contain: ### + $options = { + 'foo' => 0, + 'bar' => 0, + 'one-dash' => 1, + 'baz' => 1, + 'quux' => 'bleh', + 'single' => 'blah\'', + 'option' => 'some\'thing' + }; + + ### and this is the munged version of the input string, + ### ie what's left of the input minus the options + $munged = 'command arg'; + +As you can see, you can either use a single or a double C<-> to +indicate an option. +If you prefix an option with C<no-> and do not give it a value, it +will be set to 0. +If it has no prefix and no value, it will be set to 1. +Otherwise, it will be set to its value. Note also that it can deal +fine with single/double quoting issues. + +=cut + +sub parse_options { + my $term = shift; + my $input = shift; + + my $return = {}; + + ### there's probably a more elegant way to do this... ### + while ( $input =~ s/(?:^|\s+)--?([-\w]+=("|').+?\2)(?=\Z|\s+)// or + $input =~ s/(?:^|\s+)--?([-\w]+=\S+)(?=\Z|\s+)// or + $input =~ s/(?:^|\s+)--?([-\w]+)(?=\Z|\s+)// + ) { + my $match = $1; + + if( $match =~ /^([-\w]+)=("|')(.+?)\2$/ ) { + $return->{$1} = $3; + + } elsif( $match =~ /^([-\w]+)=(\S+)$/ ) { + $return->{$1} = $2; + + } elsif( $match =~ /^no-?([-\w]+)$/i ) { + $return->{$1} = 0; + + } elsif ( $match =~ /^([-\w]+)$/ ) { + $return->{$1} = 1; + + } else { + carp(loc(q[I do not understand option "%1"\n], $match)) if $VERBOSE; + } + } + + return wantarray ? ($return,$input) : $return; +} + +=head2 $str = $term->history_as_string + +Convenience wrapper around C<< Term::UI::History->history_as_string >>. + +Consult the C<Term::UI::History> man page for details. + +=cut + +sub history_as_string { return Term::UI::History->history_as_string }; + +1; + +=head1 GLOBAL VARIABLES + +The behaviour of Term::UI can be altered by changing the following +global variables: + +=head2 $Term::UI::VERBOSE + +This controls whether Term::UI will issue warnings and explanations +as to why certain things may have failed. If you set it to 0, +Term::UI will not output any warnings. +The default is 1; + +=head2 $Term::UI::AUTOREPLY + +This will make every question be answered by the default, and warn if +there was no default provided. This is particularly useful if your +program is run in non-interactive mode. +The default is 0; + +=head2 $Term::UI::INVALID + +This holds the string that will be printed when the user makes an +invalid choice. +You can override this string from your program if you, for example, +wish to do localization. +The default is C<Invalid selection, please try again: > + +=head2 $Term::UI::History::HISTORY_FH + +This is the filehandle all the print statements from this module +are being sent to. Please consult the C<Term::UI::History> manpage +for details. + +This defaults to C<*STDOUT>. + +=head1 EXAMPLES + +=head2 Basic get_reply sample + + ### ask a user (with an open question) for their favourite colour + $reply = $term->get_reply( prompt => 'Your favourite colour? ); + +which would look like: + + Your favourite colour? + +and C<$reply> would hold the text the user typed. + +=head2 get_reply with choices + + ### now provide a list of choices, so the user has to pick one + $reply = $term->get_reply( + prompt => 'Your favourite colour?', + choices => [qw|red green blue|] ); + +which would look like: + + 1> red + 2> green + 3> blue + + Your favourite colour? + +C<$reply> will hold one of the choices presented. C<Term::UI> will repose +the question if the user attempts to enter an answer that's not in the +list of choices. The string presented is held in the C<$Term::UI::INVALID> +variable (see the C<GLOBAL VARIABLES> section for details. + +=head2 get_reply with choices and default + + ### provide a sensible default option -- everyone loves blue! + $reply = $term->get_reply( + prompt => 'Your favourite colour?', + choices => [qw|red green blue|], + default => 'blue' ); + +which would look like: + + 1> red + 2> green + 3> blue + + Your favourite colour? [3]: + +Note the default answer after the prompt. A user can now just hit C<enter> +(or set C<$Term::UI::AUTOREPLY> -- see the C<GLOBAL VARIABLES> section) and +the sensible answer 'blue' will be returned. + +=head2 get_reply using print_me & multi + + ### allow the user to pick more than one colour and add an + ### introduction text + @reply = $term->get_reply( + print_me => 'Tell us what colours you like', + prompt => 'Your favourite colours?', + choices => [qw|red green blue|], + multi => 1 ); + +which would look like: + + Tell us what colours you like + 1> red + 2> green + 3> blue + + Your favourite colours? + +An answer of C<3 2 1> would fill C<@reply> with C<blue green red> + +=head2 get_reply & allow + + ### pose an open question, but do a custom verification on + ### the answer, which will only exit the question loop, if + ### the answer matches the allow handler. + $reply = $term->get_reply( + prompt => "What is the magic number?", + allow => 42 ); + +Unless the user now enters C<42>, the question will be reposed over +and over again. You can use more sophisticated C<allow> handlers (even +subroutines can be used). The C<allow> handler is implemented using +C<Params::Check>'s C<allow> function. Check its manpage for details. + +=head2 an elaborate ask_yn sample + + ### ask a user if he likes cookies. Default to a sensible 'yes' + ### and inform him first what cookies are. + $bool = $term->ask_yn( prompt => 'Do you like cookies?', + default => 'y', + print_me => 'Cookies are LOVELY!!!' ); + +would print: + + Cookies are LOVELY!!! + Do you like cookies? [Y/n]: + +If a user then simply hits C<enter>, agreeing with the default, +C<$bool> would be set to C<true>. (Simply hitting 'y' would also +return C<true>. Hitting 'n' would return C<false>) + +We could later retrieve this interaction by printing out the Q&A +history as follows: + + print $term->history_as_string; + +which would then print: + + Cookies are LOVELY!!! + Do you like cookies? [Y/n]: y + +There's a chance we're doing this non-interactively, because a console +is missing, the user indicated he just wanted the defaults, etc. + +In this case, simply setting C<$Term::UI::AUTOREPLY> to true, will +return from every question with the default answer set for the question. +Do note that if C<AUTOREPLY> is true, and no default is set, C<Term::UI> +will warn about this and return C<undef>. + +=head1 See Also + +C<Params::Check>, C<Term::ReadLine>, C<Term::UI::History> + +=head1 BUG REPORTS + +Please report bugs or other issues to E<lt>bug-term-ui@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/tlperl/lib/Term/UI/History.pm b/Master/tlpkg/tlperl/lib/Term/UI/History.pm new file mode 100755 index 00000000000..1d77c01c6f6 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Term/UI/History.pm @@ -0,0 +1,137 @@ +package Term::UI::History; + +use strict; +use base 'Exporter'; +use base 'Log::Message::Simple'; + +=pod + +=head1 NAME + +Term::UI::History + +=head1 SYNOPSIS + + use Term::UI::History qw[history]; + + history("Some message"); + + ### retrieve the history in printable form + $hist = Term::UI::History->history_as_string; + + ### redirect output + local $Term::UI::History::HISTORY_FH = \*STDERR; + +=head1 DESCRIPTION + +This module provides the C<history> function for C<Term::UI>, +printing and saving all the C<UI> interaction. + +Refer to the C<Term::UI> manpage for details on usage from +C<Term::UI>. + +This module subclasses C<Log::Message::Simple>. Refer to its +manpage for additional functionality available via this package. + +=head1 FUNCTIONS + +=head2 history("message string" [,VERBOSE]) + +Records a message on the stack, and prints it to C<STDOUT> +(or actually C<$HISTORY_FH>, see the C<GLOBAL VARIABLES> section +below), if the C<VERBOSE> option is true. + +The C<VERBOSE> option defaults to true. + +=cut + +BEGIN { + use Log::Message private => 0; + + use vars qw[ @EXPORT $HISTORY_FH ]; + @EXPORT = qw[ history ]; + my $log = new Log::Message; + $HISTORY_FH = \*STDOUT; + + for my $func ( @EXPORT ) { + no strict 'refs'; + + *$func = sub { my $msg = shift; + $log->store( + message => $msg, + tag => uc $func, + level => $func, + extra => [@_] + ); + }; + } + + sub history_as_string { + my $class = shift; + + return join $/, map { $_->message } __PACKAGE__->stack; + } +} + + +{ package Log::Message::Handlers; + + sub history { + my $self = shift; + my $verbose = shift; + $verbose = 1 unless defined $verbose; # default to true + + ### so you don't want us to print the msg? ### + return if defined $verbose && $verbose == 0; + + local $| = 1; + my $old_fh = select $Term::UI::History::HISTORY_FH; + + print $self->message . "\n"; + select $old_fh; + + return; + } +} + + +=head1 GLOBAL VARIABLES + +=over 4 + +=item $HISTORY_FH + +This is the filehandle all the messages sent to C<history()> are being +printed. This defaults to C<*STDOUT>. + +=back + +=head1 See Also + +C<Log::Message::Simple>, C<Term::UI> + +=head1 AUTHOR + +This module by +Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +This module is +copyright (c) 2005 Jos Boumans E<lt>kane@cpan.orgE<gt>. +All rights reserved. + +This library is free software; +you may redistribute and/or modify it under the same +terms as Perl itself. + +=cut + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: |