perl 5.000perl-5.000

[editor's note: this commit combines approximate 4 months of furious
releases of Andy Dougherty and Larry Wall - see pod/perlhist.pod for
details.  Andy notes that;
 
Alas neither my "Irwin AccuTrack" nor my DC 600A quarter-inch cartridge 
backup tapes from that era seem to be readable anymore.  I guess 13 years 
exceeds the shelf life for that backup technology :-(.
]

2 files changed, 287 insertions, 0 deletions

diff --git a/lib/Term/Cap.pm b/lib/Term/Cap.pm
new file mode 100644
index 0000000000..30389bb37c
--- /dev/null
+++ b/lib/Term/Cap.pm
@@ -0,0 +1,174 @@
+package Term::Cap;
+require 5.000;
+require Exporter;
+use Carp;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(&Tgetent &Tputs &Tgoto $ispeed $ospeed %TC);
+
+# $RCSfile: termcap.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:16 $
+#
+# Usage:
+#	require 'ioctl.pl';
+#	ioctl(TTY,$TIOCGETP,$foo);
+#	($ispeed,$ospeed) = unpack('cc',$foo);
+#	use Termcap;
+#	&Tgetent('vt100');	# sets $TC{'cm'}, etc.
+#	&Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE');
+#	&Tputs($TC{'dl'},$affcnt,'FILEHANDLE');
+#
+sub Tgetent {
+    local($TERM) = @_;
+    local($TERMCAP,$_,$entry,$loop,$field);
+
+    warn "Tgetent: no ospeed set" unless $ospeed;
+    foreach $key (keys(%TC)) {
+	delete $TC{$key};
+    }
+    $TERM = $ENV{'TERM'} unless $TERM;
+    $TERM =~ s/(\W)/\\$1/g;
+    $TERMCAP = $ENV{'TERMCAP'};
+    $TERMCAP = '/etc/termcap' unless $TERMCAP;
+    if ($TERMCAP !~ m:^/:) {
+	if ($TERMCAP !~ /(^|\|)$TERM[:\|]/) {
+	    $TERMCAP = '/etc/termcap';
+	}
+    }
+    if ($TERMCAP =~ m:^/:) {
+	$entry = '';
+	do {
+	    $loop = "
+	    open(TERMCAP,'<$TERMCAP') || croak \"Can't open $TERMCAP\";
+	    while (<TERMCAP>) {
+		next if /^#/;
+		next if /^\t/;
+		if (/(^|\\|)${TERM}[:\\|]/) {
+		    chop;
+		    while (chop eq '\\\\') {
+			\$_ .= <TERMCAP>;
+			chop;
+		    }
+		    \$_ .= ':';
+		    last;
+		}
+	    }
+	    close TERMCAP;
+	    \$entry .= \$_;
+	    ";
+	    eval $loop;
+	} while s/:tc=([^:]+):/:/ && ($TERM = $1);
+	$TERMCAP = $entry;
+    }
+
+    foreach $field (split(/:[\s:\\]*/,$TERMCAP)) {
+	if ($field =~ /^\w\w$/) {
+	    $TC{$field} = 1;
+	}
+	elsif ($field =~ /^(\w\w)#(.*)/) {
+	    $TC{$1} = $2 unless defined $TC{$1};
+	}
+	elsif ($field =~ /^(\w\w)=(.*)/) {
+	    $entry = $1;
+	    $_ = $2;
+	    s/\\E/\033/g;
+	    s/\\(\d\d\d)/pack('c',$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;
+	    $TC{$entry} = $_ unless defined $TC{$entry};
+	}
+    }
+    $TC{'pc'} = "\0" unless defined $TC{'pc'};
+    $TC{'bc'} = "\b" unless defined $TC{'bc'};
+}
+
+@Tputs = (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);
+
+sub Tputs {
+    local($string,$affcnt,$FH) = @_;
+    local($ms);
+    if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
+	$ms = $1;
+	$ms *= $affcnt if $2;
+	$string = $3;
+	$decr = $Tputs[$ospeed];
+	if ($decr > .1) {
+	    $ms += $decr / 2;
+	    $string .= $TC{'pc'} x ($ms / $decr);
+	}
+    }
+    print $FH $string if $FH;
+    $string;
+}
+
+sub Tgoto {
+    local($string) = shift(@_);
+    local($result) = '';
+    local($after) = '';
+    local($code,$tmp) = @_;
+    local(@tmp);
+    @tmp = ($tmp,$code);
+    local($online) = 0;
+    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 .= $TC{'up'} if $TC{'up'};
+		}
+		else {
+		    ++$tmp, $after .= $TC{'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";
+	}
+    }
+    $result . $string . $after;
+}
+
+1;
diff --git a/lib/Term/Complete.pm b/lib/Term/Complete.pm
new file mode 100644
index 0000000000..10b12a2b5c
--- /dev/null
+++ b/lib/Term/Complete.pm
@@ -0,0 +1,113 @@
+package Term::Complete;
+require 5.000;
+require Exporter;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(Complete);
+
+#
+#      @(#)complete.pl,v1.1            (me@anywhere.EBay.Sun.COM) 09/23/91
+#
+# Author: Wayne Thompson
+#
+# Description:
+#     This routine provides word completion.
+#     (TAB) attempts word completion.
+#     (^D)  prints completion list.
+#      (These may be changed by setting $Complete::complete, etc.)
+#
+# Diagnostics:
+#     Bell when word completion fails.
+#
+# Dependencies:
+#     The tty driver is put into raw mode.
+#
+# Bugs:
+#
+# Usage:
+#     $input = complete('prompt_string', \@completion_list);
+#         or
+#     $input = complete('prompt_string', @completion_list);
+#
+
+CONFIG: {
+    $complete = "\004";
+    $kill     = "\025";
+    $erase1 =   "\177";
+    $erase2 =   "\010";
+}
+
+sub complete {
+    $prompt = shift;
+    if (ref $_[0] || $_[0] =~ /^\*/) {
+	@cmp_lst = sort @{$_[0]};
+    }
+    else {
+	@cmp_lst = sort(@_);
+    }
+
+    system('stty raw -echo');
+    LOOP: {
+        print($prompt, $return);
+        while (($_ = getc(STDIN)) ne "\r") {
+            CASE: {
+                # (TAB) attempt completion
+                $_ eq "\t" && do {
+                    @match = grep(/^$return/, @cmp_lst);
+                    $l = length($test = shift(@match));
+                    unless ($#match < 0) {
+                        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(/^$return/, @cmp_lst)), "\r\n");
+                    redo LOOP;
+                };
+
+                # (^U) kill
+                $_ eq $kill && do {
+                    if ($r) {
+                        undef($r, $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('stty -raw echo');
+    print("\n");
+    $return;
+}
+
+1;
+