perl 4.0 patch 18: patch #11, continued

See patch #11.

5 files changed, 145 insertions, 70 deletions

diff --git a/lib/cacheout.pl b/lib/cacheout.pl
index 106014cc5d..bec40bde62 100644
--- a/lib/cacheout.pl
+++ b/lib/cacheout.pl
@@ -12,11 +12,9 @@ sub cacheout {
     package cacheout;
 
     ($file) = @_;
-    ($package) = caller;
     if (!$isopen{$file}) {
 	if (++$numopen > $maxopen) {
-	    sub byseq {$isopen{$a} != $isopen{$b};}
-	    local(@lru) = sort byseq keys(%isopen);
+	    local(@lru) = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen);
 	    splice(@lru, $maxopen / 3);
 	    $numopen -= @lru;
 	    for (@lru) { close $_; delete $isopen{$_}; }
@@ -35,7 +33,7 @@ $numopen = 0;
 if (open(PARAM,'/usr/include/sys/param.h')) {
     local($.);
     while (<PARAM>) {
-	$maxopen = $1 - 4 if /^#define NOFILE\s+(\d+)/;
+	$maxopen = $1 - 4 if /^\s*#\s*define\s+NOFILE\s+(\d+)/;
     }
     close PARAM;
 }
diff --git a/lib/complete.pl b/lib/complete.pl
index 73d3649f8d..dabf8f66ad 100644
--- a/lib/complete.pl
+++ b/lib/complete.pl
@@ -1,5 +1,5 @@
 ;#
-;#	@(#)complete.pl	1.0 (sun!waynet) 11/11/88
+;#      @(#)complete.pl,v1.1            (me@anywhere.EBay.Sun.COM) 09/23/91
 ;#
 ;# Author: Wayne Thompson
 ;#
@@ -7,7 +7,7 @@
 ;#     This routine provides word completion.
 ;#     (TAB) attempts word completion.
 ;#     (^D)  prints completion list.
-;#	(These may be changed by setting $Complete'complete, etc.)
+;#      (These may be changed by setting $Complete'complete, etc.)
 ;#
 ;# Diagnostics:
 ;#     Bell when word completion fails.
@@ -18,78 +18,92 @@
 ;# Bugs:
 ;#
 ;# Usage:
-;#     $input = do Complete('prompt_string', @completion_list);
+;#     $input = &Complete('prompt_string', *completion_list);
+;#         or
+;#     $input = &Complete('prompt_string', @completion_list);
 ;#
 
 CONFIG: {
     package Complete;
 
-    $complete =	"\004";
-    $kill =	"\025";
-    $erase1 =	"\177";
-    $erase2 =	"\010";
+    $complete = "\004";
+    $kill     = "\025";
+    $erase1 =   "\177";
+    $erase2 =   "\010";
 }
 
 sub Complete {
     package Complete;
 
-    local ($prompt) = shift (@_);
-    local ($c, $cmp, $l, $r, $ret, $return, $test);
-    @_cmp_lst = sort @_;
     local($[) = 0;
-    system 'stty raw -echo';
-    loop: {
-	print $prompt, $return;
-	while (($c = getc(stdin)) ne "\r") {
-	    if ($c eq "\t") {			# (TAB) attempt completion
-		@_match = ();
-		foreach $cmp (@_cmp_lst) {
-		    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 $complete) {		# (^D) completion list
-		print "\r\n";
-		foreach $cmp (@_cmp_lst) {
-		    print "$cmp\r\n" if $cmp =~ /^$return/;
-		}
-		redo loop;
-	    }
-    	    elsif ($c eq $kill && $r) {	# (^U) kill
-    	    	$return = '';
-    	    	$r = 0;
-    	    	print "\r\n";
-    	    	redo loop;
-    	    }
-	    	    	    	    	    	# (DEL) || (BS) erase
-	    elsif ($c eq $erase1 || $c eq $erase2) {
-		if($r) {
-		    print "\b \b";
-		    chop ($return);
-		    $r--;
-		}
-	    }
-	    elsif ($c =~ /\S/) {    	    	# printable char
-		$return .= $c;
-		$r++;
-		print $c;
-	    }
-	}
+    if ($_[1] =~ /^StB\0/) {
+        ($prompt, *_) = @_;
     }
-    system 'stty -raw echo';
-    print "\n";
+    else {
+        $prompt = shift(@_);
+    }
+    @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;
 }
 
diff --git a/lib/getcwd.pl b/lib/getcwd.pl
new file mode 100644
index 0000000000..114e8905c6
--- /dev/null
+++ b/lib/getcwd.pl
@@ -0,0 +1,62 @@
+# By Brandon S. Allbery
+#
+# Usage: $cwd = &getcwd;
+
+sub getcwd
+{
+    local($dotdots, $cwd, @pst, @cst, $dir, @tst);
+
+    unless (@cst = stat('.'))
+    {
+	warn "stat(.): $!";
+	return '';
+    }
+    $cwd = '';
+    do
+    {
+	$dotdots .= '/' if $dotdots;
+	$dotdots .= '..';
+	@pst = @cst;
+	unless (opendir(getcwd'PARENT, $dotdots))			#'))
+	{
+	    warn "opendir($dotdots): $!";
+	    return '';
+	}
+	unless (@cst = stat($dotdots))
+	{
+	    warn "stat($dotdots): $!";
+	    closedir(getcwd'PARENT);					#');
+	    return '';
+	}
+	if ($pst[$[] == $cst[$[] && $pst[$[ + 1] == $cst[$[ + 1])
+	{
+	    $dir = '';
+	}
+	else
+	{
+	    do
+	    {
+		unless ($dir = readdir(getcwd'PARENT))			#'))
+		{
+		    warn "readdir($dotdots): $!";
+		    closedir(getcwd'PARENT);				#');
+		    return '';
+		}
+		unless (@tst = stat("$dotdots/$dir"))
+		{
+		    warn "stat($dotdots/$dir): $!";
+		    closedir(getcwd'PARENT);				#');
+		    return '';
+		}
+	    }
+	    while ($dir eq '.' || $dir eq '..' || $tst[$[] != $pst[$[] ||
+		   $tst[$[ + 1] != $pst[$[ + 1]);
+	}
+	$cwd = "$dir/$cwd";
+	closedir(getcwd'PARENT);					#');
+    } while ($dir);
+    chop($cwd);
+    $cwd;
+}
+
+1;
diff --git a/lib/getopt.pl b/lib/getopt.pl
index da39d3b29d..b9d7b5b75b 100644
--- a/lib/getopt.pl
+++ b/lib/getopt.pl
@@ -1,4 +1,4 @@
-;# $Header: getopt.pl,v 4.0 91/03/20 01:25:11 lwall Locked $
+;# $RCSfile: getopt.pl,v $$Revision: 4.0.1.1 $$Date: 91/11/05 17:53:01 $
 
 ;# Process single-character switches with switch clustering.  Pass one argument
 ;# which is a string containing all switches that take an argument.  For each
@@ -14,7 +14,7 @@ sub Getopt {
     local($_,$first,$rest);
     local($[) = 0;
 
-    while (($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
+    while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
 	($first,$rest) = ($1,$2);
 	if (index($argumentative,$first) >= $[) {
 	    if ($rest ne '') {
diff --git a/lib/getopts.pl b/lib/getopts.pl
index 4ed3a053f9..6590918016 100644
--- a/lib/getopts.pl
+++ b/lib/getopts.pl
@@ -6,11 +6,12 @@
 
 sub Getopts {
     local($argumentative) = @_;
-    local(@args,$_,$first,$rest,$errs);
+    local(@args,$_,$first,$rest);
+    local($errs) = 0;
     local($[) = 0;
 
     @args = split( / */, $argumentative );
-    while(($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
+    while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
 	($first,$rest) = ($1,$2);
 	$pos = index($argumentative,$first);
 	if($pos >= $[) {