perl 3.0: (no announcement message available)perl-3.000

A few of the new features: (18 Oct)

    * Perl can now handle binary data correctly and has functions to pack and unpack binary structures into arrays or lists. You can now do arbitrary ioctl functions.
    * You can now pass things to subroutines by reference.
    * Debugger enhancements.
    * An array or associative array may now appear in a local() list.
    * Array values may now be interpolated into strings.
    * Subroutine names are now distinguished by prefixing with &. You can call subroutines without using do, and without passing any argument list at all.
    * You can use the new -u switch to cause perl to dump core so that you can run undump and produce a binary executable image. Alternately you can use the "dump" operator after initializing any variables and such.
    * You can now chop lists.
    * Perl now uses /bin/csh to do filename globbing, if available. This means that filenames with spaces or other strangenesses work right.
    * New functions: mkdir and rmdir, getppid, getpgrp and setpgrp, getpriority and setpriority, chroot, ioctl and fcntl, flock, readlink, lstat, rindex, pack and unpack, read, warn, dbmopen and dbmclose, dump, reverse, defined, undef.

11 files changed, 947 insertions, 7 deletions

diff --git a/lib/abbrev.pl b/lib/abbrev.pl
new file mode 100644
index 0000000000..5859a7be48
--- /dev/null
+++ b/lib/abbrev.pl
@@ -0,0 +1,32 @@
+;# Usage:
+;#	%foo = ();
+;#	&abbrev(*foo,LIST);
+;#	...
+;#	$long = $foo{$short};
+
+package abbrev;
+
+sub main'abbrev {
+    local(*domain) = @_;
+    shift(@_);
+    @cmp = @_;
+    foreach $name (@_) {
+	@extra = split(//,$name);
+	$abbrev = shift(@extra);
+	$len = 1;
+	foreach $cmp (@cmp) {
+	    next if $cmp eq $name;
+	    while (substr($cmp,0,$len) eq $abbrev) {
+		$abbrev .= shift(@extra);
+		++$len;
+	    }
+	}
+	$domain{$abbrev} = $name;
+	while ($#extra >= 0) {
+	    $abbrev .= shift(@extra);
+	    $domain{$abbrev} = $name;
+	}
+    }
+}
+
+1;
diff --git a/lib/complete.pl b/lib/complete.pl
new file mode 100644
index 0000000000..fd50674086
--- /dev/null
+++ b/lib/complete.pl
@@ -0,0 +1,84 @@
+;#
+;#	@(#)complete.pl	1.0 (sun!waynet) 11/11/88
+;#
+;# Author: Wayne Thompson
+;#
+;# Description:
+;#     This routine provides word completion.
+;#     (TAB) attempts word completion.
+;#     (^D)  prints completion list.
+;#
+;# Diagnostics:
+;#     Bell when word completion fails.
+;#
+;# Dependencies:
+;#     The tty driver is put into raw mode.
+;#
+;# Bugs:
+;#     The erase and kill characters are hard coded.
+;#
+;# Usage:
+;#     $input = do Complete('prompt_string', @completion_list);
+;#
+
+sub Complete {
+    local ($prompt) = shift (@_);
+    local ($c, $cmp, $l, $r, $ret, $return, $test);
+    @_ = sort @_;
+    system 'stty raw -echo';
+    loop: {
+	print $prompt, $return;
+	while (($c = getc(stdin)) ne "\r") {
+	    if ($c eq "\t") {			# (TAB) attempt completion
+		@_match = ();
+		foreach $cmp (@_) {
+		    push (@_match, $cmp) if $cmp =~ /^$return/;
+		}
+    	    	$test = $_match[0];
+    	    	$l = length ($test);
+		unless ($#_match == 0) {
+    	    	    shift (@_match);
+    	    	    foreach $cmp (@_match) {
+    	    	    	until (substr ($cmp, 0, $l) eq substr ($test, 0, $l)) {
+    	    	    	    $l--;
+    	    	    	}
+    	    	    }
+    	    	    print "\007";
+    	    	}
+    	    	print $test = substr ($test, $r, $l - $r);
+    	    	$r = length ($return .= $test);
+	    }
+	    elsif ($c eq "\004") {		# (^D) completion list
+		print "\r\n";
+		foreach $cmp (@_) {
+		    print "$cmp\r\n" if $cmp =~ /^$return/;
+		}
+		redo loop;
+	    }
+    	    elsif ($c eq "\025" && $r) {	# (^U) kill
+    	    	$return = '';
+    	    	$r = 0;
+    	    	print "\r\n";
+    	    	redo loop;
+    	    }
+	    	    	    	    	    	# (DEL) || (BS) erase
+	    elsif ($c eq "\177" || $c eq "\010") {
+		if($r) {
+		    print "\b \b";
+		    chop ($return);
+		    $r--;
+		}
+	    }
+	    elsif ($c =~ /\S/) {    	    	# printable char
+		$return .= $c;
+		$r++;
+		print $c;
+	    }
+	}
+    }
+    system 'stty -raw echo';
+    print "\n";
+    $return;
+}
+
+1;
diff --git a/lib/dumpvar.pl b/lib/dumpvar.pl
new file mode 100644
index 0000000000..8a49ec09e7
--- /dev/null
+++ b/lib/dumpvar.pl
@@ -0,0 +1,28 @@
+package dumpvar;
+
+sub main'dumpvar {
+    ($package) = @_;
+    local(*stab) = eval("*_$package");
+    while (($key,$val) = each(%stab)) {
+	{
+	    local(*entry) = $val;
+	    if (defined $entry) {
+		print "\$$key = '$entry'\n";
+	    }
+	    if (defined @entry) {
+		print "\@$key = (\n";
+		foreach $num ($[ .. $#entry) {
+		    print "  $num\t'",$entry[$num],"'\n";
+		}
+		print ")\n";
+	    }
+	    if ($key ne "_$package" && defined %entry) {
+		print "\%$key = (\n";
+		foreach $key (sort keys(%entry)) {
+		    print "  $key\t'",$entry{$key},"'\n";
+		}
+		print ")\n";
+	    }
+	}
+    }
+}
diff --git a/lib/getopt.pl b/lib/getopt.pl
index 4832233ed2..b85b643e22 100644
--- a/lib/getopt.pl
+++ b/lib/getopt.pl
@@ -1,4 +1,4 @@
-;# $Header: getopt.pl,v 2.0 88/06/05 00:16:22 root Exp $
+;# $Header: getopt.pl,v 3.0 89/10/18 15:19:26 lwall Locked $
 
 ;# Process single-character switches with switch clustering.  Pass one argument
 ;# which is a string containing all switches that take an argument.  For each
@@ -17,11 +17,11 @@ sub Getopt {
 	($first,$rest) = ($1,$2);
 	if (index($argumentative,$first) >= $[) {
 	    if ($rest ne '') {
-		shift;
+		shift(@ARGV);
 	    }
 	    else {
-		shift;
-		$rest = shift;
+		shift(@ARGV);
+		$rest = shift(@ARGV);
 	    }
 	    eval "\$opt_$first = \$rest;";
 	}
@@ -31,8 +31,10 @@ sub Getopt {
 		$ARGV[0] = "-$rest";
 	    }
 	    else {
-		shift;
+		shift(@ARGV);
 	    }
 	}
     }
 }
+
+1;
diff --git a/lib/getopts.pl b/lib/getopts.pl
new file mode 100644
index 0000000000..926988516e
--- /dev/null
+++ b/lib/getopts.pl
@@ -0,0 +1,45 @@
+;# getopts.pl - a better getopt.pl
+
+;# Usage:
+;#      do Getopts('a:bc');  # -a takes arg. -b & -c not. Sets opt_* as a
+;#                           #  side effect.
+
+sub Getopts {
+    local($argumentative) = @_;
+    local(@args,$_,$first,$rest);
+
+    @args = split( / */, $argumentative );
+    while(($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
+	($first,$rest) = ($1,$2);
+	$pos = index($argumentative,$first);
+	if($pos >= $[) {
+	    if($args[$pos+1] eq ':') {
+		shift;
+		if($rest eq '') {
+		    $rest = shift;
+		}
+		eval "\$opt_$first = \$rest;";
+	    }
+	    else {
+		eval "\$opt_$first = 1";
+		if($rest eq '') {
+		    shift;
+		}
+		else {
+		    $ARGV[0] = "-$rest";
+		}
+	    }
+	}
+	else {
+	    print stderr "Unknown option: $first\n";
+	    if($rest ne '') {
+		$ARGV[0] = "-$rest";
+	    }
+	    else {
+		shift;
+	    }
+	}
+    }
+}
+
+1;
diff --git a/lib/importenv.pl b/lib/importenv.pl
index c0c2be088e..c321a20219 100644
--- a/lib/importenv.pl
+++ b/lib/importenv.pl
@@ -1,4 +1,4 @@
-;# $Header: importenv.pl,v 2.0 88/06/05 00:16:17 root Exp $
+;# $Header: importenv.pl,v 3.0 89/10/18 15:19:39 lwall Locked $
 
 ;# This file, when interpreted, pulls the environment into normal variables.
 ;# Usage:
@@ -12,3 +12,5 @@ foreach $key (keys(ENV)) {
     $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/;
 }
 eval $tmp;
+
+1;
diff --git a/lib/look.pl b/lib/look.pl
new file mode 100644
index 0000000000..ebbaa73a3d
--- /dev/null
+++ b/lib/look.pl
@@ -0,0 +1,44 @@
+;# Usage: &look(*FILEHANDLE,$key,$dict,$fold)
+
+;# Sets file position in FILEHANDLE to be first line greater than or equal
+;# (stringwise) to $key.  Pass flags for dictionary order and case folding.
+
+sub look {
+    local(*FH,$key,$fold) = @_;
+    local($max,$min,$mid,$_);
+    local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+       $blksize,$blocks) = stat(FH);
+    $blksize = 8192 unless $blksize;
+    $key =~ s/[^\w\s]//g if $dict;
+    $key =~ y/A-Z/a-z/ if $fold;
+    $max = $size + $blksize - 1;
+    $max -= $size % $blksize;
+    while ($max - $min > $blksize) {
+	$mid = ($max + $min) / 2;
+	die "look: internal error"  if $mid % $blksize;
+	seek(FH,$mid,0);
+	$_ = <FH>;		# probably a partial line
+	$_ = <FH>;
+	chop;
+	s/[^\w\s]//g if $dict;
+	y/A-Z/a-z/ if $fold;
+	if ($_ lt $key) {
+	    $min = $mid;
+	}
+	else {
+	    $max = $mid;
+	}
+    }
+    seek(FH,$min,0);
+    while (<FH>) {
+	chop;
+	s/[^\w\s]//g if $dict;
+	y/A-Z/a-z/ if $fold;
+	last if $_ ge $key;
+	$min = tell(FH);
+    }
+    seek(FH,$min,0);
+    $min;
+}
+
+1;
diff --git a/lib/perldb.pl b/lib/perldb.pl
new file mode 100644
index 0000000000..51f6c24e11
--- /dev/null
+++ b/lib/perldb.pl
@@ -0,0 +1,434 @@
+package DB;
+
+$header = '$Header: perldb.pl,v 3.0 89/10/18 15:19:46 lwall Locked $';
+#
+# This file is automatically included if you do perl -d.
+# It's probably not useful to include this yourself.
+#
+# Perl supplies the values for @line and %sub.  It effectively inserts
+# a do DB'DB(<linenum>); in front of every place that can
+# have a breakpoint.  It also inserts a do 'perldb.pl' before the first line.
+#
+# $Log:	perldb.pl,v $
+# Revision 3.0  89/10/18  15:19:46  lwall
+# 3.0 baseline
+# 
+# Revision 2.0  88/06/05  00:09:45  root
+# Baseline version 2.0.
+# 
+#
+
+open(IN,"/dev/tty");		# so we don't dingle stdin
+open(OUT,">/dev/tty");	# so we don't dongle stdout
+select(OUT);
+$| = 1;				# for DB'OUT
+select(STDOUT);
+$| = 1;				# for real STDOUT
+
+$header =~ s/\$Header: perldb.pl,v 3.0 89/10/18 15:19:46 lwall Locked $/$1$2/;
+print OUT "\nLoading DB from $header\n\n";
+
+sub DB {
+    local($. ,$@, $!, $[, $,, $/, $\);
+    $[ = 0; $, = ""; $/ = "\n"; $\ = "";
+    ($line) = @_;
+    if ($stop[$line]) {
+	if ($stop eq '1') {
+	    $signal |= 1;
+	}
+	else {
+	    package main;
+	    $DB'signal |= eval $DB'stop[$DB'line];  print DB'OUT $@;
+	    $DB'stop[$DB'line] =~ s/;9$//;
+	}
+    }
+    if ($single || $trace || $signal) {
+	print OUT "$sub($line):\t",$line[$line];
+	for ($i = $line + 1; $i <= $max && $line[$i] == 0; ++$i) {
+	    last if $line[$i] =~ /^\s*(}|#|\n)/;
+	    print OUT "$sub($i):\t",$line[$i];
+	}
+    }
+    if ($action[$line]) {
+	package main;
+	eval $DB'action[$DB'line];  print DB'OUT $@;
+    }
+    if ($single || $signal) {
+	if ($pre) {
+	    package main;
+	    eval $DB'pre;  print DB'OUT $@;
+	}
+	print OUT $#stack . " levels deep in subroutine calls!\n"
+	    if $single & 4;
+	$start = $line;
+	while ((print OUT "  DB<", $#hist+1, "> "), $cmd=<IN>) {
+	    $single = 0;
+	    $signal = 0;
+	    $cmd eq '' && exit 0;
+	    chop($cmd);
+	    $cmd =~ /^q$/ && exit 0;
+	    $cmd =~ /^$/ && ($cmd = $laststep);
+	    push(@hist,$cmd) if length($cmd) > 1;
+	    ($i) = split(/\s+/,$cmd);
+	    eval "\$cmd =~ $alias{$i}", print OUT $@ if $alias{$i};
+	    $cmd =~ /^h$/ && do {
+		print OUT "
+T		Stack trace.
+s		Single step.
+n		Next, steps over subroutine calls.
+f		Finish current subroutine.
+c [line]	Continue; optionally inserts a one-time-only breakpoint 
+		at the specified line.
+<CR>		Repeat last n or s.
+l min+incr	List incr+1 lines starting at min.
+l min-max	List lines.
+l line		List line;
+l		List next window.
+-		List previous window.
+w line		List window around line.
+l subname	List subroutine.
+/pattern/	Search forwards for pattern; final / is optional.
+?pattern?	Search backwards for pattern.
+L		List breakpoints and actions.
+S		List subroutine names.
+t		Toggle trace mode.
+b [line] [condition]
+		Set breakpoint; line defaults to the current execution line; 
+		condition breaks if it evaluates to true, defaults to \'1\'.
+b subname [condition]
+		Set breakpoint at first line of subroutine.
+d [line]	Delete breakpoint.
+D		Delete all breakpoints.
+a [line] command
+		Set an action to be done before the line is executed.
+		Sequence is: check for breakpoint, print line if necessary,
+		do action, prompt user if breakpoint or step, evaluate line.
+A		Delete all actions.
+V package	List all variables and values in package (default main).
+< command	Define command before prompt.
+> command	Define command after prompt.
+! number	Redo command (default previous command).
+! -number	Redo number\'th to last command.
+H -number	Display last number commands (default all).
+q or ^D		Quit.
+p expr		Same as \"package main; print DB'OUT expr\".
+command		Execute as a perl statement.
+
+";
+		next; };
+	    $cmd =~ /^t$/ && do {
+		$trace = !$trace;
+		print OUT "Trace = ".($trace?"on":"off")."\n";
+		next; };
+	    $cmd =~ /^S$/ && do {
+		foreach $subname (sort(keys %sub)) {
+		    if ($subname =~ /^main'(.*)/) {
+			print OUT $1,"\n";
+		    }
+		    else {
+			print OUT $subname,"\n";
+		    }
+		}
+		next; };
+	    $cmd =~ /^V$/ && do {
+		$cmd = 'V main'; };
+	    $cmd =~ /^V\s*(['A-Za-z_]['\w]*)$/ && do {
+		$packname = $1;
+		do 'dumpvar.pl' unless defined &main'dumpvar;
+		if (defined &main'dumpvar) {
+		    &main'dumpvar($packname);
+		}
+		else {
+		    print DB'OUT "dumpvar.pl not available.\n";
+		}
+		next; };
+	    $cmd =~ /^l\s*(['A-Za-z_]['\w]*)/ && do {
+		$subname = $1;
+		$subname = "main'" . $subname unless $subname =~ /'/;
+		$subrange = $sub{$subname};
+		if ($subrange) {
+		    if (eval($subrange) < -$window) {
+			$subrange =~ s/-.*/+/;
+		    }
+		    $cmd = "l $subrange";
+		} else {
+		    print OUT "Subroutine $1 not found.\n";
+		    next;
+		} };
+	    $cmd =~ /^w\s*(\d*)$/ && do {
+		$incr = $window - 1;
+		$start = $1 if $1;
+		$start -= $preview;
+		$cmd = 'l ' . $start . '-' . ($start + $incr); };
+	    $cmd =~ /^-$/ && do {
+		$incr = $window - 1;
+		$cmd = 'l ' . ($start-$window*2) . '+'; };
+	    $cmd =~ /^l$/ && do {
+		$incr = $window - 1;
+		$cmd = 'l ' . $start . '-' . ($start + $incr); };
+	    $cmd =~ /^l\s*(\d*)\+(\d*)$/ && do {
+		$start = $1 if $1;
+		$incr = $2;
+		$incr = $window - 1 unless $incr;
+		$cmd = 'l ' . $start . '-' . ($start + $incr); };
+	    $cmd =~ /^l\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
+		$end = (!$2) ? $max : ($4 ? $4 : $2);
+		$end = $max if $end > $max;
+		$i = $2;
+		$i = $line if $i eq '.';
+		$i = 1 if $i < 1;
+		for (; $i <= $end; $i++) {
+		    print OUT "$i:\t", $line[$i];
+		    last if $signal;
+		}
+		$start = $i;	# remember in case they want more
+		$start = $max if $start > $max;
+		next; };
+	    $cmd =~ /^D$/ && do {
+		print OUT "Deleting all breakpoints...\n";
+		for ($i = 1; $i <= $max ; $i++) {
+		    $stop[$i] = 0;
+		}
+		next; };
+	    $cmd =~ /^L$/ && do {
+		for ($i = 1; $i <= $max; $i++) {
+		    if ($stop[$i] || $action[$i]) {
+			print OUT "$i:\t", $line[$i];
+			print OUT "  break if (", $stop[$i], ")\n" 
+			    if $stop[$i];
+			print OUT "  action:  ", $action[$i], "\n" 
+			    if $action[$i];
+			last if $signal;
+		    }
+		}
+		next; };
+	    $cmd =~ /^b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do {
+		$subname = $1;
+		$subname = "main'" . $subname unless $subname =~ /'/;
+		($i) = split(/-/, $sub{$subname});
+		if ($i) {
+		    ++$i while $line[$i] == 0 && $i < $#line;
+		    $stop[$i] = $2 ? $2 : 1;
+		} else {
+		    print OUT "Subroutine $1 not found.\n";
+		}
+		next; };
+	    $cmd =~ /^b\s*(\d*)\s*(.*)/ && do {
+		$i = ($1?$1:$line);
+		if ($line[$i] == 0) {
+		    print OUT "Line $i not breakable.\n";
+		} else {
+		    $stop[$i] = $2 ? $2 : 1;
+		}
+		next; };
+	    $cmd =~ /^d\s*(\d+)?/ && do {
+		$i = ($1?$1:$line);
+		$stop[$i] = '';
+		next; };
+	    $cmd =~ /^A$/ && do {
+		for ($i = 1; $i <= $max ; $i++) {
+		    $action[$i] = '';
+		}
+		next; };
+	    $cmd =~ /^<\s*(.*)/ && do {
+		$pre = do action($1);
+		next; };
+	    $cmd =~ /^>\s*(.*)/ && do {
+		$post = do action($1);
+		next; };
+	    $cmd =~ /^a\s*(\d+)(\s+(.*))?/ && do {
+		$i = $1;
+		if ($line[$i] == 0) {
+		    print OUT "Line $i may not have an action.\n";
+		} else {
+		    $action[$i] = do action($3);
+		}
+		next; };
+	    $cmd =~ /^n$/ && do {
+		$single = 2;
+		$laststep = $cmd;
+		last; };
+	    $cmd =~ /^s$/ && do {
+		$single = 1;
+		$laststep = $cmd;
+		last; };
+	    $cmd =~ /^c\s*(\d*)\s*$/ && do {
+		$i = $1;
+		if ($i) {
+		    if ($line[$i] == 0) {
+		        print OUT "Line $i not breakable.\n";
+			next;
+		    }
+		    $stop[$i] .= ";9";	# add one-time-only b.p.
+		}
+		for ($i=0; $i <= $#stack; ) {
+		    $stack[$i++] &= ~1;
+		}
+		last; };
+	    $cmd =~ /^f$/ && do {
+		$stack[$#stack] |= 2;
+		last; };
+	    $cmd =~ /^T$/ && do {
+		for ($i=0; $i <= $#sub; ) {
+		    print OUT $sub[$i++], "\n";
+		    last if $signal;
+		}
+	        next; };
+	    $cmd =~ /^\/(.*)$/ && do {
+		$inpat = $1;
+		$inpat =~ s:([^\\])/$:$1:;
+		if ($inpat ne "") {
+		    eval '$inpat =~ m'."\n$inpat\n";	
+		    if ($@ ne "") {
+		    	print OUT "$@";
+		    	next;
+		    }
+		    $pat = $inpat;
+		}
+		$end = $start;
+		eval '
+		for (;;) {
+		    ++$start;
+		    $start = 1 if ($start > $max);
+		    last if ($start == $end);
+		    if ($line[$start] =~ m'."\n$pat\n".'i) {
+			print OUT "$start:\t", $line[$start], "\n";
+			last;
+		    }
+		} ';
+		print OUT "/$pat/: not found\n" if ($start == $end);
+		next; };
+	    $cmd =~ /^\?(.*)$/ && do {
+		$inpat = $1;
+		$inpat =~ s:([^\\])\?$:$1:;
+		if ($inpat ne "") {
+		    eval '$inpat =~ m'."\n$inpat\n";	
+		    if ($@ ne "") {
+		    	print OUT "$@";
+		    	next;
+		    }
+		    $pat = $inpat;
+		}
+		$end = $start;
+		eval '
+		for (;;) {
+		    --$start;
+		    $start = $max if ($start <= 0);
+		    last if ($start == $end);
+		    if ($line[$start] =~ m'."\n$pat\n".'i) {
+			print OUT "$start:\t", $line[$start], "\n";
+			last;
+		    }
+		} ';
+		print OUT "?$pat?: not found\n" if ($start == $end);
+		next; };
+	    $cmd =~ /^!+\s*(-)?(\d+)?$/ && do {
+		pop(@hist) if length($cmd) > 1;
+		$i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist));
+		$cmd = $hist[$i] . "\n";
+		print OUT $cmd;
+		redo; };
+	    $cmd =~ /^!(.+)$/ && do {
+		$pat = "^$1";
+		pop(@hist) if length($cmd) > 1;
+		for ($i = $#hist; $i; --$i) {
+		    last if $hist[$i] =~ $pat;
+		}
+		if (!$i) {
+		    print OUT "No such command!\n\n";
+		    next;
+		}
+		$cmd = $hist[$i] . "\n";
+		print OUT $cmd;
+		redo; };
+	    $cmd =~ /^H\s*(-(\d+))?/ && do {
+		$end = $2?($#hist-$2):0;
+		$hist = 0 if $hist < 0;
+		for ($i=$#hist; $i>$end; $i--) {
+		    print OUT "$i: ",$hist[$i],"\n"
+			unless $hist[$i] =~ /^.?$/;
+		};
+		next; };
+	    $cmd =~ s/^p( .*)?$/print DB'OUT$1/;
+	    {
+		package main;
+		eval $DB'cmd;
+	    }
+	    print OUT $@,"\n";
+	}
+	if ($post) {
+	    package main;
+	    eval $DB'post;  print DB'OUT $@;
+	}
+    }
+}
+
+sub action {
+    local($action) = @_;
+    while ($action =~ s/\\$//) {
+	print OUT "+ ";
+	$action .= <IN>;
+    }
+    $action;
+}
+
+sub catch {
+    $signal = 1;
+}
+
+sub sub {
+    push(@stack, $single);
+    $single &= 1;
+    $single |= 4 if $#stack == $deep;
+    local(@args) = @_;
+    for (@args) {
+	if (/^Stab/ && length($_) == length($_main{'_main'})) {
+	    $_ = sprintf("%s",$_);
+	    print "ARG: $_\n";
+	}
+	else {
+	    s/'/\\'/g;
+	    s/(.*)/'$1'/ unless /^-?[\d.]+$/;
+	}
+    }
+    push(@sub, $sub . '(' . join(', ', @args) . ') from ' . $line);
+    if (wantarray) {
+	@i = &$sub;
+    }
+    else {
+	$i = &$sub;
+	@i = $i;
+    }
+    --$#sub;
+    $single |= pop(@stack);
+    @i;
+}
+
+$single = 1;			# so it stops on first executable statement
+$max = $#line;
+@hist = ('?');
+$SIG{'INT'} = "DB'catch";
+$deep = 100;		# warning if stack gets this deep
+$window = 10;
+$preview = 3;
+
+@stack = (0);
+@args = @ARGV;
+for (@args) {
+    s/'/\\'/g;
+    s/(.*)/'$1'/ unless /^-?[\d.]+$/;
+}
+push(@sub, 'main(' . join(', ', @args) . ")" );
+$sub = 'main';
+
+if (-f '.perldb') {
+    do './.perldb';
+}
+elsif (-f "$ENV{'LOGDIR'}/.perldb") {
+    do "$ENV{'LOGDIR'}/.perldb";
+}
+elsif (-f "$ENV{'HOME'}/.perldb") {
+    do "$ENV{'HOME'}/.perldb";
+}
+
+1;
diff --git a/lib/stat.pl b/lib/stat.pl
index 1895c58c19..8cf0bde193 100644
--- a/lib/stat.pl
+++ b/lib/stat.pl
@@ -1,4 +1,4 @@
-;# $Header: stat.pl,v 2.0 88/06/05 00:16:29 root Exp $
+;# $Header: stat.pl,v 3.0 89/10/18 15:19:53 lwall Locked $
 
 ;# Usage:
 ;#	@ary = stat(foo);
@@ -25,3 +25,5 @@ sub Stat {
     ($st_dev,$st_ino,$st_mode,$st_nlink,$st_uid,$st_gid,$st_rdev,$st_size,
 	$st_atime,$st_mtime,$st_ctime,$st_blksize,$st_blocks) = stat(shift(@_));
 }
+
+1;
diff --git a/lib/termcap.pl b/lib/termcap.pl
new file mode 100644
index 0000000000..ab693f28d7
--- /dev/null
+++ b/lib/termcap.pl
@@ -0,0 +1,164 @@
+;# $Header: termcap.pl,v 3.0 89/10/18 15:19:58 lwall Locked $
+;#
+;# Usage:
+;#	do 'ioctl.pl';
+;#	ioctl(TTY,$TIOCGETP,$foo);
+;#	($ispeed,$ospeed) = unpack('cc',$foo);
+;#	do 'termcap.pl';
+;#	do Tgetent('vt100');	# sets $TC{'cm'}, etc.
+;#	do Tgoto($TC{'cm'},$row,$col);
+;#	do 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;
+    $TERMCAP = $ENV{'TERMCAP'};
+    $TERMCAP = '/etc/termcap' unless $TERMCAP;
+    if ($TERMCAP !~ m:^/:) {
+	if (index($TERMCAP,"|$TERM|") < $[) {
+	    $TERMCAP = '/etc/termcap';
+	}
+    }
+    if ($TERMCAP =~ m:^/:) {
+	$entry = '';
+	do {
+	    $loop = "
+	    open(TERMCAP,'<$TERMCAP') || die \"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 if $TC{$1} eq '';
+	}
+	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',$1 & 031)/eg;
+	    s/\\(.)/$1/g;
+	    s/\377/^/g;
+	    $TC{$entry} = $_ if $TC{$entry} eq '';
+	}
+    }
+    $TC{'pc'} = "\0" if $TC{'pc'} eq '';
+    $TC{'bc'} = "\b" if $TC{'bc'} eq '';
+}
+
+@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) = @_;
+    @_ = ($tmp,$code);
+    local($online) = 0;
+    while ($string =~ /^([^%]*)%(.)(.*)/) {
+	$result .= $1;
+	$code = $2;
+	$string = $3;
+	if ($code eq 'd') {
+	    $result .= sprintf("%d",shift(@_));
+	}
+	elsif ($code eq '.') {
+	    $tmp = shift(@_);
+	    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(@_)+ord($string));
+	    $string = substr($string,1,99);
+	    $online = !$online;
+	}
+	elsif ($code eq 'r') {
+	    ($code,$tmp) = @_;
+	    @_ = ($tmp,$code);
+	    $online = !$online;
+	}
+	elsif ($code eq '>') {
+	    ($code,$tmp,$string) = unpack("CCa99",$string);
+	    if ($_[$[] > $code) {
+		$_[$[] += $tmp;
+	    }
+	}
+	elsif ($code eq '2') {
+	    $result .= sprintf("%02d",shift(@_));
+	    $online = !$online;
+	}
+	elsif ($code eq '3') {
+	    $result .= sprintf("%03d",shift(@_));
+	    $online = !$online;
+	}
+	elsif ($code eq 'i') {
+	    ($code,$tmp) = @_;
+	    @_ = ($code+1,$tmp+1);
+	}
+	else {
+	    return "OOPS";
+	}
+    }
+    $result . $string . $after;
+}
+
+1;
diff --git a/lib/validate.pl b/lib/validate.pl
new file mode 100644
index 0000000000..bee7bbaddf
--- /dev/null
+++ b/lib/validate.pl
@@ -0,0 +1,103 @@
+;# $Header: validate.pl,v 3.0 89/10/18 15:20:04 lwall Locked $
+
+;# The validate routine takes a single multiline string consisting of
+;# lines containing a filename plus a file test to try on it.  (The
+;# file test may also be a 'cd', causing subsequent relative filenames
+;# to be interpreted relative to that directory.)  After the file test
+;# you may put '|| die' to make it a fatal error if the file test fails.
+;# The default is '|| warn'.  The file test may optionally have a ! prepended
+;# to test for the opposite condition.  If you do a cd and then list some
+;# relative filenames, you may want to indent them slightly for readability.
+;# If you supply your own "die" or "warn" message, you can use $file to
+;# interpolate the filename.
+
+;# Filetests may be bunched:  -rwx tests for all of -r, -w and -x.
+;# Only the first failed test of the bunch will produce a warning.
+
+;# The routine returns the number of warnings issued.
+
+;# Usage:
+;#	$warnings += do validate('
+;#	/vmunix			-e || die
+;#	/boot			-e || die
+;#	/bin			cd
+;#	    csh			-ex
+;#	    csh			!-ug
+;#	    sh			-ex
+;#	    sh			!-ug
+;#	/usr			-d || warn "What happened to $file?\n"
+;#	');
+
+sub validate {
+    local($file,$test,$warnings,$oldwarnings);
+    foreach $check (split(/\n/,$_[0])) {
+	next if $check =~ /^#/;
+	next if $check =~ /^$/;
+	($file,$test) = split(' ',$check,2);
+	if ($test =~ s/^(!?-)(\w{2,}\b)/$1Z/) {
+	    $testlist = $2;
+	    @testlist = split(//,$testlist);
+	}
+	else {
+	    @testlist = ('Z');
+	}
+	$oldwarnings = $warnings;
+	foreach $one (@testlist) {
+	    $this = $test;
+	    $this =~ s/(-\w\b)/$1 \$file/g;
+	    $this =~ s/-Z/-$one/;
+	    $this .= ' || warn' unless $this =~ /\|\|/;
+	    $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || do valmess('$2','$1')/;
+	    $this =~ s/\bcd\b/chdir (\$cwd = \$file)/g;
+	    eval $this;
+	    last if $warnings > $oldwarnings;
+	}
+    }
+    $warnings;
+}
+
+sub valmess {
+    local($disposition,$this) = @_;
+    $file = $cwd . '/' . $file unless $file =~ m|^/|;
+    if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) {
+	$neg = $1;
+	$tmp = $2;
+	$tmp eq 'r' && ($mess = "$file is not readable by uid $>.");
+	$tmp eq 'w' && ($mess = "$file is not writable by uid $>.");
+	$tmp eq 'x' && ($mess = "$file is not executable by uid $>.");
+	$tmp eq 'o' && ($mess = "$file is not owned by uid $>.");
+	$tmp eq 'R' && ($mess = "$file is not readable by you.");
+	$tmp eq 'W' && ($mess = "$file is not writable by you.");
+	$tmp eq 'X' && ($mess = "$file is not executable by you.");
+	$tmp eq 'O' && ($mess = "$file is not owned by you.");
+	$tmp eq 'e' && ($mess = "$file does not exist.");
+	$tmp eq 'z' && ($mess = "$file does not have zero size.");
+	$tmp eq 's' && ($mess = "$file does not have non-zero size.");
+	$tmp eq 'f' && ($mess = "$file is not a plain file.");
+	$tmp eq 'd' && ($mess = "$file is not a directory.");
+	$tmp eq 'l' && ($mess = "$file is not a symbolic link.");
+	$tmp eq 'p' && ($mess = "$file is not a named pipe (FIFO).");
+	$tmp eq 'S' && ($mess = "$file is not a socket.");
+	$tmp eq 'b' && ($mess = "$file is not a block special file.");
+	$tmp eq 'c' && ($mess = "$file is not a character special file.");
+	$tmp eq 'u' && ($mess = "$file does not have the setuid bit set.");
+	$tmp eq 'g' && ($mess = "$file does not have the setgid bit set.");
+	$tmp eq 'k' && ($mess = "$file does not have the sticky bit set.");
+	$tmp eq 'T' && ($mess = "$file is not a text file.");
+	$tmp eq 'B' && ($mess = "$file is not a binary file.");
+	if ($neg eq '!') {
+	    $mess =~ s/ is not / should not be / ||
+	    $mess =~ s/ does not / should not / ||
+	    $mess =~ s/ not / /;
+	}
+	print stderr $mess,"\n";
+    }
+    else {
+	$this =~ s/\$file/'$file'/g;
+	print stderr "Can't do $this.\n";
+    }
+    if ($disposition eq 'die') { exit 1; }
+    ++$warnings;
+}
+
+1;