Initial Commit

database/perl/lib/Term/Cap.pm

@@ -0,0 +1,772 @@
+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.17';
+
+# 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
+
+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;
+}
+
+=over 4
+
+=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 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 'MSWin32' )
+          {
+             $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();
+
+    if ( !@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;
+                    }
+                };
+                warn "Can't run infocmp to get a termcap entry: $@" if $@;
+            }
+            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{2,})$/ )
+        {
+            $self->{ '_' . $field } = 1 unless defined $self->{ '_' . $1 };
+
+            # print STDERR "DEBUG: flag $1\n";
+        }
+        elsif ( defined $field && $field =~ /^(\w{2,})\@/ )
+        {
+            $self->{ '_' . $1 } = "";
+
+            # print STDERR "DEBUG: unset $1\n";
+        }
+        elsif ( defined $field && $field =~ /^(\w{2,})#(.*)/ )
+        {
+            $self->{ '_' . $1 } = $2 unless defined $self->{ '_' . $1 };
+
+            # print STDERR "DEBUG: numeric $1 = $2\n";
+        }
+        elsif ( defined $field && $field =~ /^(\w{2,})=(.*)/ )
+        {
+
+            # 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 be 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[0] > $code )
+            {
+                $tmp[0] += $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
+
+Copyright 1995-2015 (c) perl5 porters.
+
+This software is free software and can be modified and distributed under
+the same terms as Perl itself.
+
+Please see the file README in the Perl source distribution for details of
+the Perl license.
+
+=head1 AUTHOR
+
+This module is part of the core Perl distribution and is also maintained
+for CPAN by Jonathan Stowe <jns@gellyfish.co.uk>.
+
+The code is hosted on Github: https://github.com/jonathanstowe/Term-Cap
+please feel free to fork, submit patches etc, etc there.
+
+=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:
+

database/perl/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.403';
+
+#      @(#)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 >= ord(" ") && 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;

database/perl/lib/Term/ReadLine.pm

@@ -0,0 +1,487 @@
+=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">.
+
+The strings returned may not be useful for 3-argument open().
+
+=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<event_loop>
+
+Registers call-backs to wait for user input (i.e., during C<readline>
+method).  This supersedes tkRunning.
+
+The first call-back registered is the call back for waiting.  It is
+expected that the callback will call the current event loop until
+there is something waiting to get on the input filehandle.  The parameter
+passed in is the return value of the second call back.
+
+The second call-back registered is the call back for registration.  The
+input filehandle (often STDIN, but not necessarily) will be passed in.
+
+For example, with AnyEvent:
+
+  $term->event_loop(sub {
+    my $data = shift;
+    $data->[1] = AE::cv();
+    $data->[1]->recv();
+  }, sub {
+    my $fh = shift;
+    my $data = [];
+    $data->[0] = AE::io($fh, 0, sub { $data->[1]->send() });
+    $data;
+  });
+
+The second call-back is optional if the call back is registered prior to
+the call to $term-E<gt>readline.
+
+Deregistration is done in this case by calling event_loop with C<undef>
+as its parameter:
+
+    $term->event_loop(undef);
+
+This will cause the data array ref to be removed, allowing normal garbage
+collection to clean it up.  With AnyEvent, that will cause $data->[0] to
+be cleaned up, and AnyEvent will automatically cancel the watcher at that
+time.  If another loop requires more than that to clean up a file watcher,
+that will be up to the caller to handle.
+
+=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 sans ornaments
+  export "PERL_RL= o=0"     # Use best available ReadLine sans ornaments
+
+(Note that processing of C<PERL_RL> for ornaments is in the discretion of the 
+particular used C<Term::ReadLine::*> package).
+
+=cut
+
+use strict;
+
+package Term::ReadLine::Stub;
+our @ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap';
+
+$DB::emacs = $DB::emacs;	# To pacify -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;
+  #$str = scalar <$in>;
+  $str = $self->get_line;
+  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 creates length -1:
+  chomp $str if defined $str;
+  $str;
+}
+sub addhistory {}
+
+# used for testing purpose
+sub devtty { return '/dev/tty' }
+
+sub findConsole {
+    my $console;
+    my $consoleOUT;
+
+    my $devtty = devtty();
+
+    if ($^O ne 'MSWin32' and -e $devtty) {
+	$console = $devtty;
+    } elsif ($^O eq 'MSWin32' or $^O eq 'msys' or -e "con") {
+       $console = 'CONIN$';
+       $consoleOUT = 'CONOUT$';
+    } elsif ($^O eq 'VMS') {
+	$console = "sys\$command";
+    } elsif ($^O eq 'os2' && !$DB::emacs) {
+	$console = "/dev/con";
+    } else {
+	$console = undef;
+    }
+
+    $consoleOUT = $console unless defined $consoleOUT;
+    $console = "&STDIN" unless defined $console;
+    if ($console eq $devtty && !open(my $fh, "<", $console)) {
+      $console = "&STDIN";
+      undef($consoleOUT);
+    }
+    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;
+    # RT #132008:  Still need 2-arg open here
+    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.17';
+
+my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef;
+if ($which) {
+  if ($which =~ /\bgnu\b/i){
+    eval "use Term::ReadLine::Gnu;";
+  } elsif ($which =~ /\bperl\b/i) {
+    eval "use Term::ReadLine::Perl;";
+  } elsif ($which =~ /^(Stub|TermCap|Tk)$/) {
+    # it is already in memory to avoid false exception as seen in:
+    # PERL_RL=Stub perl -e'$SIG{__DIE__} = sub { print @_ }; require Term::ReadLine'
+  } else {
+    eval "use Term::ReadLine::$which;";
+  }
+} elsif (defined $which and $which ne '') {	# Defined but false
+  # Do nothing fancy
+} else {
+  eval "use Term::ReadLine::Gnu; 1" or eval "use Term::ReadLine::EditLine; 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::EditLine::readline) {
+  @ISA = qw(Term::ReadLine::EditLine 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;
+
+# This package inserts a Tk->fileevent() before the diamond operator.
+# The Tk watcher dispatches Tk events until the filehandle returned by
+# the$term->IN() accessor becomes ready for reading.  It's assumed
+# that the diamond operator will return a line of input immediately at
+# that point.
+
+my ($giveup);
+
+# maybe in the future the Tk-specific aspects will be removed.
+sub Tk_loop{
+    if (ref $Term::ReadLine::toloop)
+    {
+        $Term::ReadLine::toloop->[0]->($Term::ReadLine::toloop->[2]);
+    }
+    else
+    {
+        Tk::DoOneEvent(0) until $giveup;
+        $giveup = 0;
+    }
+};
+
+sub register_Tk {
+    my $self = shift;
+    unless ($Term::ReadLine::registered++)
+    {
+        if (ref $Term::ReadLine::toloop)
+        {
+            $Term::ReadLine::toloop->[2] = $Term::ReadLine::toloop->[1]->($self->IN) if $Term::ReadLine::toloop->[1];
+        }
+        else
+        {
+            Tk->fileevent($self->IN,'readable',sub { $giveup = 1});
+        }
+    }
+};
+
+sub tkRunning {
+  $Term::ReadLine::toloop = $_[1] if @_ > 1;
+  $Term::ReadLine::toloop;
+}
+
+sub event_loop {
+    shift;
+
+    # T::RL::Gnu and T::RL::Perl check that this exists, if not,
+    # it doesn't call the loop.  Those modules will need to be
+    # fixed before this can be removed.
+    if (not defined &Tk::DoOneEvent)
+    {
+        *Tk::DoOneEvent = sub {
+            die "what?"; # this shouldn't be called.
+        }
+    }
+
+    # store the callback in toloop, again so that other modules will
+    # recognise it and call us for the loop.
+    $Term::ReadLine::toloop = [ @_ ] if @_ > 0; # 0 because we shifted off $self.
+    $Term::ReadLine::toloop;
+}
+
+sub PERL_UNICODE_STDIN () { 0x0001 }
+
+sub get_line {
+  my $self = shift;
+  my ($in,$out,$str) = @$self;
+
+  if ($Term::ReadLine::toloop) {
+    $self->register_Tk if not $Term::ReadLine::registered;
+    $self->Tk_loop;
+  }
+
+  local ($/) = "\n";
+  $str = <$in>;
+
+  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 creates length -1:
+  chomp $str if defined $str;
+
+  $str;
+}
+
+1;
+