summaryrefslogtreecommitdiffstats
path: root/gnu/usr.bin/perl/lib
diff options
context:
space:
mode:
authorgclarkii <gclarkii@FreeBSD.org>1994-09-10 06:27:55 +0000
committergclarkii <gclarkii@FreeBSD.org>1994-09-10 06:27:55 +0000
commitbd9f08584221a6bacbfeaebf19d4c3e21fa94a83 (patch)
tree8e0cf41774fd52d25f63363297782b383c4ad1f7 /gnu/usr.bin/perl/lib
downloadFreeBSD-src-bd9f08584221a6bacbfeaebf19d4c3e21fa94a83.zip
FreeBSD-src-bd9f08584221a6bacbfeaebf19d4c3e21fa94a83.tar.gz
Initial import of Perl 4.046 bmaked
Diffstat (limited to 'gnu/usr.bin/perl/lib')
-rw-r--r--gnu/usr.bin/perl/lib/Makefile19
-rw-r--r--gnu/usr.bin/perl/lib/abbrev.pl33
-rw-r--r--gnu/usr.bin/perl/lib/assert.pl52
-rw-r--r--gnu/usr.bin/perl/lib/bigfloat.pl233
-rw-r--r--gnu/usr.bin/perl/lib/bigint.pl271
-rw-r--r--gnu/usr.bin/perl/lib/bigrat.pl148
-rw-r--r--gnu/usr.bin/perl/lib/cacheout.pl40
-rw-r--r--gnu/usr.bin/perl/lib/chat2.pl339
-rw-r--r--gnu/usr.bin/perl/lib/complete.pl110
-rw-r--r--gnu/usr.bin/perl/lib/ctime.pl51
-rw-r--r--gnu/usr.bin/perl/lib/dumpvar.pl37
-rw-r--r--gnu/usr.bin/perl/lib/exceptions.pl54
-rw-r--r--gnu/usr.bin/perl/lib/fastcwd.pl35
-rw-r--r--gnu/usr.bin/perl/lib/find.pl106
-rw-r--r--gnu/usr.bin/perl/lib/finddepth.pl105
-rw-r--r--gnu/usr.bin/perl/lib/flush.pl23
-rw-r--r--gnu/usr.bin/perl/lib/getcwd.pl62
-rw-r--r--gnu/usr.bin/perl/lib/getopt.pl41
-rw-r--r--gnu/usr.bin/perl/lib/getopts.pl50
-rw-r--r--gnu/usr.bin/perl/lib/importenv.pl16
-rw-r--r--gnu/usr.bin/perl/lib/look.pl44
-rw-r--r--gnu/usr.bin/perl/lib/newgetopt.pl271
-rw-r--r--gnu/usr.bin/perl/lib/open2.pl54
-rw-r--r--gnu/usr.bin/perl/lib/perldb.pl598
-rw-r--r--gnu/usr.bin/perl/lib/pwd.pl72
-rw-r--r--gnu/usr.bin/perl/lib/shellwords.pl48
-rw-r--r--gnu/usr.bin/perl/lib/stat.pl31
-rw-r--r--gnu/usr.bin/perl/lib/syslog.pl224
-rw-r--r--gnu/usr.bin/perl/lib/termcap.pl165
-rw-r--r--gnu/usr.bin/perl/lib/timelocal.pl82
-rw-r--r--gnu/usr.bin/perl/lib/validate.pl104
31 files changed, 3518 insertions, 0 deletions
diff --git a/gnu/usr.bin/perl/lib/Makefile b/gnu/usr.bin/perl/lib/Makefile
new file mode 100644
index 0000000..375720d
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/Makefile
@@ -0,0 +1,19 @@
+PLIBDIR= /usr/local/lib/perl
+
+PLIB+= abbrev.pl assert.pl bigfloat.pl bigint.pl bigrat.pl cacheout.pl
+PLIB+= chat2.pl complete.pl ctime.pl dumpvar.pl exceptions.pl fastcwd.pl
+PLIB+= find.pl finddepth.pl flush.pl getcwd.pl getopts.pl importenv.pl
+PLIB+= look.pl newgetopt.pl open2.pl perldb.pl pwd.pl shellwords.pl
+PLIB+= stat.pl syslog.pl termcap.pl timelocal.pl validate.pl
+
+install:
+ mkdir -p ${PLIBDIR}
+ install -c -o ${BINOWN} -g ${BINGRP} -m 444 ${PLIB} ${PLIBDIR}
+
+clean:
+cleandir:
+obj:
+
+.include <bsd.prog.mk>
+
+
diff --git a/gnu/usr.bin/perl/lib/abbrev.pl b/gnu/usr.bin/perl/lib/abbrev.pl
new file mode 100644
index 0000000..c233d4a
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/abbrev.pl
@@ -0,0 +1,33 @@
+;# Usage:
+;# %foo = ();
+;# &abbrev(*foo,LIST);
+;# ...
+;# $long = $foo{$short};
+
+package abbrev;
+
+sub main'abbrev {
+ local(*domain) = @_;
+ shift(@_);
+ @cmp = @_;
+ local($[) = 0;
+ 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/gnu/usr.bin/perl/lib/assert.pl b/gnu/usr.bin/perl/lib/assert.pl
new file mode 100644
index 0000000..cfda70c
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/assert.pl
@@ -0,0 +1,52 @@
+# assert.pl
+# tchrist@convex.com (Tom Christiansen)
+#
+# Usage:
+#
+# &assert('@x > @y');
+# &assert('$var > 10', $var, $othervar, @various_info);
+#
+# That is, if the first expression evals false, we blow up. The
+# rest of the args, if any, are nice to know because they will
+# be printed out by &panic, which is just the stack-backtrace
+# routine shamelessly borrowed from the perl debugger.
+
+sub assert {
+ &panic("ASSERTION BOTCHED: $_[0]",$@) unless eval $_[0];
+}
+
+sub panic {
+ select(STDERR);
+
+ print "\npanic: @_\n";
+
+ exit 1 if $] <= 4.003; # caller broken
+
+ # stack traceback gratefully borrowed from perl debugger
+
+ local($i,$_);
+ local($p,$f,$l,$s,$h,$a,@a,@sub);
+ for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
+ @a = @DB'args;
+ for (@a) {
+ if (/^StB\000/ && length($_) == length($_main{'_main'})) {
+ $_ = sprintf("%s",$_);
+ }
+ else {
+ s/'/\\'/g;
+ s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
+ s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+ s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
+ }
+ }
+ $w = $w ? '@ = ' : '$ = ';
+ $a = $h ? '(' . join(', ', @a) . ')' : '';
+ push(@sub, "$w&$s$a from file $f line $l\n");
+ }
+ for ($i=0; $i <= $#sub; $i++) {
+ print $sub[$i];
+ }
+ exit 1;
+}
+
+1;
diff --git a/gnu/usr.bin/perl/lib/bigfloat.pl b/gnu/usr.bin/perl/lib/bigfloat.pl
new file mode 100644
index 0000000..278f11d
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/bigfloat.pl
@@ -0,0 +1,233 @@
+package bigfloat;
+require "bigint.pl";
+# Arbitrary length float math package
+#
+# by Mark Biggar
+#
+# number format
+# canonical strings have the form /[+-]\d+E[+-]\d+/
+# Input values can have inbedded whitespace
+# Error returns
+# 'NaN' An input parameter was "Not a Number" or
+# divide by zero or sqrt of negative number
+# Division is computed to
+# max($div_scale,length(dividend).length(divisor))
+# digits by default.
+# Also used for default sqrt scale
+
+$div_scale = 40;
+
+# Rounding modes one of 'even', 'odd', '+inf', '-inf', 'zero' or 'trunc'.
+
+$rnd_mode = 'even';
+
+# bigfloat routines
+#
+# fadd(NSTR, NSTR) return NSTR addition
+# fsub(NSTR, NSTR) return NSTR subtraction
+# fmul(NSTR, NSTR) return NSTR multiplication
+# fdiv(NSTR, NSTR[,SCALE]) returns NSTR division to SCALE places
+# fneg(NSTR) return NSTR negation
+# fabs(NSTR) return NSTR absolute value
+# fcmp(NSTR,NSTR) return CODE compare undef,<0,=0,>0
+# fround(NSTR, SCALE) return NSTR round to SCALE digits
+# ffround(NSTR, SCALE) return NSTR round at SCALEth place
+# fnorm(NSTR) return (NSTR) normalize
+# fsqrt(NSTR[, SCALE]) return NSTR sqrt to SCALE places
+
+# Convert a number to canonical string form.
+# Takes something that looks like a number and converts it to
+# the form /^[+-]\d+E[+-]\d+$/.
+sub main'fnorm { #(string) return fnum_str
+ local($_) = @_;
+ s/\s+//g; # strip white space
+ if (/^([+-]?)(\d*)(\.(\d*))?([Ee]([+-]?\d+))?$/ && "$2$4" ne '') {
+ &norm(($1 ? "$1$2$4" : "+$2$4"),(($4 ne '') ? $6-length($4) : $6));
+ } else {
+ 'NaN';
+ }
+}
+
+# normalize number -- for internal use
+sub norm { #(mantissa, exponent) return fnum_str
+ local($_, $exp) = @_;
+ if ($_ eq 'NaN') {
+ 'NaN';
+ } else {
+ s/^([+-])0+/$1/; # strip leading zeros
+ if (length($_) == 1) {
+ '+0E+0';
+ } else {
+ $exp += length($1) if (s/(0+)$//); # strip trailing zeros
+ sprintf("%sE%+ld", $_, $exp);
+ }
+ }
+}
+
+# negation
+sub main'fneg { #(fnum_str) return fnum_str
+ local($_) = &'fnorm($_[0]);
+ vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0E+0'; # flip sign
+ s/^H/N/;
+ $_;
+}
+
+# absolute value
+sub main'fabs { #(fnum_str) return fnum_str
+ local($_) = &'fnorm($_[0]);
+ s/^-/+/; # mash sign
+ $_;
+}
+
+# multiplication
+sub main'fmul { #(fnum_str, fnum_str) return fnum_str
+ local($x,$y) = (&'fnorm($_[0]),&'fnorm($_[1]));
+ if ($x eq 'NaN' || $y eq 'NaN') {
+ 'NaN';
+ } else {
+ local($xm,$xe) = split('E',$x);
+ local($ym,$ye) = split('E',$y);
+ &norm(&'bmul($xm,$ym),$xe+$ye);
+ }
+}
+
+# addition
+sub main'fadd { #(fnum_str, fnum_str) return fnum_str
+ local($x,$y) = (&'fnorm($_[0]),&'fnorm($_[1]));
+ if ($x eq 'NaN' || $y eq 'NaN') {
+ 'NaN';
+ } else {
+ local($xm,$xe) = split('E',$x);
+ local($ym,$ye) = split('E',$y);
+ ($xm,$xe,$ym,$ye) = ($ym,$ye,$xm,$xe) if ($xe < $ye);
+ &norm(&'badd($ym,$xm.('0' x ($xe-$ye))),$ye);
+ }
+}
+
+# subtraction
+sub main'fsub { #(fnum_str, fnum_str) return fnum_str
+ &'fadd($_[0],&'fneg($_[1]));
+}
+
+# division
+# args are dividend, divisor, scale (optional)
+# result has at most max(scale, length(dividend), length(divisor)) digits
+sub main'fdiv #(fnum_str, fnum_str[,scale]) return fnum_str
+{
+ local($x,$y,$scale) = (&'fnorm($_[0]),&'fnorm($_[1]),$_[2]);
+ if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0E+0') {
+ 'NaN';
+ } else {
+ local($xm,$xe) = split('E',$x);
+ local($ym,$ye) = split('E',$y);
+ $scale = $div_scale if (!$scale);
+ $scale = length($xm)-1 if (length($xm)-1 > $scale);
+ $scale = length($ym)-1 if (length($ym)-1 > $scale);
+ $scale = $scale + length($ym) - length($xm);
+ &norm(&round(&'bdiv($xm.('0' x $scale),$ym),$ym),
+ $xe-$ye-$scale);
+ }
+}
+
+# round int $q based on fraction $r/$base using $rnd_mode
+sub round { #(int_str, int_str, int_str) return int_str
+ local($q,$r,$base) = @_;
+ if ($q eq 'NaN' || $r eq 'NaN') {
+ 'NaN';
+ } elsif ($rnd_mode eq 'trunc') {
+ $q; # just truncate
+ } else {
+ local($cmp) = &'bcmp(&'bmul($r,'+2'),$base);
+ if ( $cmp < 0 ||
+ ($cmp == 0 &&
+ ( $rnd_mode eq 'zero' ||
+ ($rnd_mode eq '-inf' && (substr($q,0,1) eq '+')) ||
+ ($rnd_mode eq '+inf' && (substr($q,0,1) eq '-')) ||
+ ($rnd_mode eq 'even' && $q =~ /[24680]$/) ||
+ ($rnd_mode eq 'odd' && $q =~ /[13579]$/) )) ) {
+ $q; # round down
+ } else {
+ &'badd($q, ((substr($q,0,1) eq '-') ? '-1' : '+1'));
+ # round up
+ }
+ }
+}
+
+# round the mantissa of $x to $scale digits
+sub main'fround { #(fnum_str, scale) return fnum_str
+ local($x,$scale) = (&'fnorm($_[0]),$_[1]);
+ if ($x eq 'NaN' || $scale <= 0) {
+ $x;
+ } else {
+ local($xm,$xe) = split('E',$x);
+ if (length($xm)-1 <= $scale) {
+ $x;
+ } else {
+ &norm(&round(substr($xm,0,$scale+1),
+ "+0".substr($xm,$scale+1,1),"+10"),
+ $xe+length($xm)-$scale-1);
+ }
+ }
+}
+
+# round $x at the 10 to the $scale digit place
+sub main'ffround { #(fnum_str, scale) return fnum_str
+ local($x,$scale) = (&'fnorm($_[0]),$_[1]);
+ if ($x eq 'NaN') {
+ 'NaN';
+ } else {
+ local($xm,$xe) = split('E',$x);
+ if ($xe >= $scale) {
+ $x;
+ } else {
+ $xe = length($xm)+$xe-$scale;
+ if ($xe < 1) {
+ '+0E+0';
+ } elsif ($xe == 1) {
+ &norm(&round('+0',"+0".substr($xm,1,1),"+10"), $scale);
+ } else {
+ &norm(&round(substr($xm,0,$trunc),
+ "+0".substr($xm,$trunc,1),"+10"), $scale);
+ }
+ }
+ }
+}
+
+# compare 2 values returns one of undef, <0, =0, >0
+# returns undef if either or both input value are not numbers
+sub main'fcmp #(fnum_str, fnum_str) return cond_code
+{
+ local($x, $y) = (&'fnorm($_[0]),&'fnorm($_[1]));
+ if ($x eq "NaN" || $y eq "NaN") {
+ undef;
+ } else {
+ ord($y) <=> ord($x)
+ ||
+ ( local($xm,$xe,$ym,$ye) = split('E', $x."E$y"),
+ (($xe <=> $ye) * (substr($x,0,1).'1')
+ || &bigint'cmp($xm,$ym))
+ );
+ }
+}
+
+# square root by Newtons method.
+sub main'fsqrt { #(fnum_str[, scale]) return fnum_str
+ local($x, $scale) = (&'fnorm($_[0]), $_[1]);
+ if ($x eq 'NaN' || $x =~ /^-/) {
+ 'NaN';
+ } elsif ($x eq '+0E+0') {
+ '+0E+0';
+ } else {
+ local($xm, $xe) = split('E',$x);
+ $scale = $div_scale if (!$scale);
+ $scale = length($xm)-1 if ($scale < length($xm)-1);
+ local($gs, $guess) = (1, sprintf("1E%+d", (length($xm)+$xe-1)/2));
+ while ($gs < 2*$scale) {
+ $guess = &'fmul(&'fadd($guess,&'fdiv($x,$guess,$gs*2)),".5");
+ $gs *= 2;
+ }
+ &'fround($guess, $scale);
+ }
+}
+
+1;
diff --git a/gnu/usr.bin/perl/lib/bigint.pl b/gnu/usr.bin/perl/lib/bigint.pl
new file mode 100644
index 0000000..5c79da9
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/bigint.pl
@@ -0,0 +1,271 @@
+package bigint;
+
+# arbitrary size integer math package
+#
+# by Mark Biggar
+#
+# Canonical Big integer value are strings of the form
+# /^[+-]\d+$/ with leading zeros suppressed
+# Input values to these routines may be strings of the form
+# /^\s*[+-]?[\d\s]+$/.
+# Examples:
+# '+0' canonical zero value
+# ' -123 123 123' canonical value '-123123123'
+# '1 23 456 7890' canonical value '+1234567890'
+# Output values always always in canonical form
+#
+# Actual math is done in an internal format consisting of an array
+# whose first element is the sign (/^[+-]$/) and whose remaining
+# elements are base 100000 digits with the least significant digit first.
+# The string 'NaN' is used to represent the result when input arguments
+# are not numbers, as well as the result of dividing by zero
+#
+# routines provided are:
+#
+# bneg(BINT) return BINT negation
+# babs(BINT) return BINT absolute value
+# bcmp(BINT,BINT) return CODE compare numbers (undef,<0,=0,>0)
+# badd(BINT,BINT) return BINT addition
+# bsub(BINT,BINT) return BINT subtraction
+# bmul(BINT,BINT) return BINT multiplication
+# bdiv(BINT,BINT) return (BINT,BINT) division (quo,rem) just quo if scalar
+# bmod(BINT,BINT) return BINT modulus
+# bgcd(BINT,BINT) return BINT greatest common divisor
+# bnorm(BINT) return BINT normalization
+#
+
+# normalize string form of number. Strip leading zeros. Strip any
+# white space and add a sign, if missing.
+# Strings that are not numbers result the value 'NaN'.
+sub main'bnorm { #(num_str) return num_str
+ local($_) = @_;
+ s/\s+//g; # strip white space
+ if (s/^([+-]?)0*(\d+)$/$1$2/) { # test if number
+ substr($_,0,0) = '+' unless $1; # Add missing sign
+ s/^-0/+0/;
+ $_;
+ } else {
+ 'NaN';
+ }
+}
+
+# Convert a number from string format to internal base 100000 format.
+# Assumes normalized value as input.
+sub internal { #(num_str) return int_num_array
+ local($d) = @_;
+ ($is,$il) = (substr($d,0,1),length($d)-2);
+ substr($d,0,1) = '';
+ ($is, reverse(unpack("a" . ($il%5+1) . ("a5" x ($il/5)), $d)));
+}
+
+# Convert a number from internal base 100000 format to string format.
+# This routine scribbles all over input array.
+sub external { #(int_num_array) return num_str
+ $es = shift;
+ grep($_ > 9999 || ($_ = substr('0000'.$_,-5)), @_); # zero pad
+ &'bnorm(join('', $es, reverse(@_))); # reverse concat and normalize
+}
+
+# Negate input value.
+sub main'bneg { #(num_str) return num_str
+ local($_) = &'bnorm(@_);
+ vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0';
+ s/^H/N/;
+ $_;
+}
+
+# Returns the absolute value of the input.
+sub main'babs { #(num_str) return num_str
+ &abs(&'bnorm(@_));
+}
+
+sub abs { # post-normalized abs for internal use
+ local($_) = @_;
+ s/^-/+/;
+ $_;
+}
+
+# Compares 2 values. Returns one of undef, <0, =0, >0. (suitable for sort)
+sub main'bcmp { #(num_str, num_str) return cond_code
+ local($x,$y) = (&'bnorm($_[0]),&'bnorm($_[1]));
+ if ($x eq 'NaN') {
+ undef;
+ } elsif ($y eq 'NaN') {
+ undef;
+ } else {
+ &cmp($x,$y);
+ }
+}
+
+sub cmp { # post-normalized compare for internal use
+ local($cx, $cy) = @_;
+ $cx cmp $cy
+ &&
+ (
+ ord($cy) <=> ord($cx)
+ ||
+ ($cx cmp ',') * (length($cy) <=> length($cx) || $cy cmp $cx)
+ );
+}
+
+sub main'badd { #(num_str, num_str) return num_str
+ local(*x, *y); ($x, $y) = (&'bnorm($_[0]),&'bnorm($_[1]));
+ if ($x eq 'NaN') {
+ 'NaN';
+ } elsif ($y eq 'NaN') {
+ 'NaN';
+ } else {
+ @x = &internal($x); # convert to internal form
+ @y = &internal($y);
+ local($sx, $sy) = (shift @x, shift @y); # get signs
+ if ($sx eq $sy) {
+ &external($sx, &add(*x, *y)); # if same sign add
+ } else {
+ ($x, $y) = (&abs($x),&abs($y)); # make abs
+ if (&cmp($y,$x) > 0) {
+ &external($sy, &sub(*y, *x));
+ } else {
+ &external($sx, &sub(*x, *y));
+ }
+ }
+ }
+}
+
+sub main'bsub { #(num_str, num_str) return num_str
+ &'badd($_[0],&'bneg($_[1]));
+}
+
+# GCD -- Euclids algorithm Knuth Vol 2 pg 296
+sub main'bgcd { #(num_str, num_str) return num_str
+ local($x,$y) = (&'bnorm($_[0]),&'bnorm($_[1]));
+ if ($x eq 'NaN' || $y eq 'NaN') {
+ 'NaN';
+ } else {
+ ($x, $y) = ($y,&'bmod($x,$y)) while $y ne '+0';
+ $x;
+ }
+}
+
+# routine to add two base 1e5 numbers
+# stolen from Knuth Vol 2 Algorithm A pg 231
+# there are separate routines to add and sub as per Kunth pg 233
+sub add { #(int_num_array, int_num_array) return int_num_array
+ local(*x, *y) = @_;
+ $car = 0;
+ for $x (@x) {
+ last unless @y || $car;
+ $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5);
+ }
+ for $y (@y) {
+ last unless $car;
+ $y -= 1e5 if $car = (($y += $car) >= 1e5);
+ }
+ (@x, @y, $car);
+}
+
+# subtract base 1e5 numbers -- stolen from Knuth Vol 2 pg 232, $x > $y
+sub sub { #(int_num_array, int_num_array) return int_num_array
+ local(*sx, *sy) = @_;
+ $bar = 0;
+ for $sx (@sx) {
+ last unless @y || $bar;
+ $sx += 1e5 if $bar = (($sx -= shift(@sy) + $bar) < 0);
+ }
+ @sx;
+}
+
+# multiply two numbers -- stolen from Knuth Vol 2 pg 233
+sub main'bmul { #(num_str, num_str) return num_str
+ local(*x, *y); ($x, $y) = (&'bnorm($_[0]), &'bnorm($_[1]));
+ if ($x eq 'NaN') {
+ 'NaN';
+ } elsif ($y eq 'NaN') {
+ 'NaN';
+ } else {
+ @x = &internal($x);
+ @y = &internal($y);
+ local($signr) = (shift @x ne shift @y) ? '-' : '+';
+ @prod = ();
+ for $x (@x) {
+ ($car, $cty) = (0, 0);
+ for $y (@y) {
+ $prod = $x * $y + $prod[$cty] + $car;
+ $prod[$cty++] =
+ $prod - ($car = int($prod * 1e-5)) * 1e5;
+ }
+ $prod[$cty] += $car if $car;
+ $x = shift @prod;
+ }
+ &external($signr, @x, @prod);
+ }
+}
+
+# modulus
+sub main'bmod { #(num_str, num_str) return num_str
+ (&'bdiv(@_))[1];
+}
+
+sub main'bdiv { #(dividend: num_str, divisor: num_str) return num_str
+ local (*x, *y); ($x, $y) = (&'bnorm($_[0]), &'bnorm($_[1]));
+ return wantarray ? ('NaN','NaN') : 'NaN'
+ if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0');
+ return wantarray ? ('+0',$x) : '+0' if (&cmp(&abs($x),&abs($y)) < 0);
+ @x = &internal($x); @y = &internal($y);
+ $srem = $y[0];
+ $sr = (shift @x ne shift @y) ? '-' : '+';
+ $car = $bar = $prd = 0;
+ if (($dd = int(1e5/($y[$#y]+1))) != 1) {
+ for $x (@x) {
+ $x = $x * $dd + $car;
+ $x -= ($car = int($x * 1e-5)) * 1e5;
+ }
+ push(@x, $car); $car = 0;
+ for $y (@y) {
+ $y = $y * $dd + $car;
+ $y -= ($car = int($y * 1e-5)) * 1e5;
+ }
+ }
+ else {
+ push(@x, 0);
+ }
+ @q = (); ($v2,$v1) = @y[$#y-1,$#y];
+ while ($#x > $#y) {
+ ($u2,$u1,$u0) = @x[($#x-2)..$#x];
+ $q = (($u0 == $v1) ? 99999 : int(($u0*1e5+$u1)/$v1));
+ --$q while ($v2*$q > ($u0*1e5+$u1-$q*$v1)*1e5+$u2);
+ if ($q) {
+ ($car, $bar) = (0,0);
+ for ($y = 0, $x = $#x-$#y-1; $y <= $#y; ++$y,++$x) {
+ $prd = $q * $y[$y] + $car;
+ $prd -= ($car = int($prd * 1e-5)) * 1e5;
+ $x[$x] += 1e5 if ($bar = (($x[$x] -= $prd + $bar) < 0));
+ }
+ if ($x[$#x] < $car + $bar) {
+ $car = 0; --$q;
+ for ($y = 0, $x = $#x-$#y-1; $y <= $#y; ++$y,++$x) {
+ $x[$x] -= 1e5
+ if ($car = (($x[$x] += $y[$y] + $car) > 1e5));
+ }
+ }
+ }
+ pop(@x); unshift(@q, $q);
+ }
+ if (wantarray) {
+ @d = ();
+ if ($dd != 1) {
+ $car = 0;
+ for $x (reverse @x) {
+ $prd = $car * 1e5 + $x;
+ $car = $prd - ($tmp = int($prd / $dd)) * $dd;
+ unshift(@d, $tmp);
+ }
+ }
+ else {
+ @d = @x;
+ }
+ (&external($sr, @q), &external($srem, @d, 0));
+ } else {
+ &external($sr, @q);
+ }
+}
+1;
diff --git a/gnu/usr.bin/perl/lib/bigrat.pl b/gnu/usr.bin/perl/lib/bigrat.pl
new file mode 100644
index 0000000..fb10cf3
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/bigrat.pl
@@ -0,0 +1,148 @@
+package bigrat;
+require "bigint.pl";
+
+# Arbitrary size rational math package
+#
+# by Mark Biggar
+#
+# Input values to these routines consist of strings of the form
+# m|^\s*[+-]?[\d\s]+(/[\d\s]+)?$|.
+# Examples:
+# "+0/1" canonical zero value
+# "3" canonical value "+3/1"
+# " -123/123 123" canonical value "-1/1001"
+# "123 456/7890" canonical value "+20576/1315"
+# Output values always include a sign and no leading zeros or
+# white space.
+# This package makes use of the bigint package.
+# The string 'NaN' is used to represent the result when input arguments
+# that are not numbers, as well as the result of dividing by zero and
+# the sqrt of a negative number.
+# Extreamly naive algorthims are used.
+#
+# Routines provided are:
+#
+# rneg(RAT) return RAT negation
+# rabs(RAT) return RAT absolute value
+# rcmp(RAT,RAT) return CODE compare numbers (undef,<0,=0,>0)
+# radd(RAT,RAT) return RAT addition
+# rsub(RAT,RAT) return RAT subtraction
+# rmul(RAT,RAT) return RAT multiplication
+# rdiv(RAT,RAT) return RAT division
+# rmod(RAT) return (RAT,RAT) integer and fractional parts
+# rnorm(RAT) return RAT normalization
+# rsqrt(RAT, cycles) return RAT square root
+
+# Convert a number to the canonical string form m|^[+-]\d+/\d+|.
+sub main'rnorm { #(string) return rat_num
+ local($_) = @_;
+ s/\s+//g;
+ if (m#^([+-]?\d+)(/(\d*[1-9]0*))?$#) {
+ &norm($1, $3 ? $3 : '+1');
+ } else {
+ 'NaN';
+ }
+}
+
+# Normalize by reducing to lowest terms
+sub norm { #(bint, bint) return rat_num
+ local($num,$dom) = @_;
+ if ($num eq 'NaN') {
+ 'NaN';
+ } elsif ($dom eq 'NaN') {
+ 'NaN';
+ } elsif ($dom =~ /^[+-]?0+$/) {
+ 'NaN';
+ } else {
+ local($gcd) = &'bgcd($num,$dom);
+ if ($gcd ne '+1') {
+ $num = &'bdiv($num,$gcd);
+ $dom = &'bdiv($dom,$gcd);
+ } else {
+ $num = &'bnorm($num);
+ $dom = &'bnorm($dom);
+ }
+ substr($dom,0,1) = '';
+ "$num/$dom";
+ }
+}
+
+# negation
+sub main'rneg { #(rat_num) return rat_num
+ local($_) = &'rnorm($_[0]);
+ tr/-+/+-/ if ($_ ne '+0/1');
+ $_;
+}
+
+# absolute value
+sub main'rabs { #(rat_num) return $rat_num
+ local($_) = &'rnorm($_[0]);
+ substr($_,0,1) = '+' unless $_ eq 'NaN';
+ $_;
+}
+
+# multipication
+sub main'rmul { #(rat_num, rat_num) return rat_num
+ local($xn,$xd) = split('/',&'rnorm($_[0]));
+ local($yn,$yd) = split('/',&'rnorm($_[1]));
+ &norm(&'bmul($xn,$yn),&'bmul($xd,$yd));
+}
+
+# division
+sub main'rdiv { #(rat_num, rat_num) return rat_num
+ local($xn,$xd) = split('/',&'rnorm($_[0]));
+ local($yn,$yd) = split('/',&'rnorm($_[1]));
+ &norm(&'bmul($xn,$yd),&'bmul($xd,$yn));
+}
+
+# addition
+sub main'radd { #(rat_num, rat_num) return rat_num
+ local($xn,$xd) = split('/',&'rnorm($_[0]));
+ local($yn,$yd) = split('/',&'rnorm($_[1]));
+ &norm(&'badd(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd));
+}
+
+# subtraction
+sub main'rsub { #(rat_num, rat_num) return rat_num
+ local($xn,$xd) = split('/',&'rnorm($_[0]));
+ local($yn,$yd) = split('/',&'rnorm($_[1]));
+ &norm(&'bsub(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd));
+}
+
+# comparison
+sub main'rcmp { #(rat_num, rat_num) return cond_code
+ local($xn,$xd) = split('/',&'rnorm($_[0]));
+ local($yn,$yd) = split('/',&'rnorm($_[1]));
+ &bigint'cmp(&'bmul($xn,$yd),&'bmul($yn,$xd));
+}
+
+# int and frac parts
+sub main'rmod { #(rat_num) return (rat_num,rat_num)
+ local($xn,$xd) = split('/',&'rnorm($_[0]));
+ local($i,$f) = &'bdiv($xn,$xd);
+ if (wantarray) {
+ ("$i/1", "$f/$xd");
+ } else {
+ "$i/1";
+ }
+}
+
+# square root by Newtons method.
+# cycles specifies the number of iterations default: 5
+sub main'rsqrt { #(fnum_str[, cycles]) return fnum_str
+ local($x, $scale) = (&'rnorm($_[0]), $_[1]);
+ if ($x eq 'NaN') {
+ 'NaN';
+ } elsif ($x =~ /^-/) {
+ 'NaN';
+ } else {
+ local($gscale, $guess) = (0, '+1/1');
+ $scale = 5 if (!$scale);
+ while ($gscale++ < $scale) {
+ $guess = &'rmul(&'radd($guess,&'rdiv($x,$guess)),"+1/2");
+ }
+ "$guess"; # quotes necessary due to perl bug
+ }
+}
+
+1;
diff --git a/gnu/usr.bin/perl/lib/cacheout.pl b/gnu/usr.bin/perl/lib/cacheout.pl
new file mode 100644
index 0000000..513c25b
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/cacheout.pl
@@ -0,0 +1,40 @@
+# Open in their package.
+
+sub cacheout'open {
+ open($_[0], $_[1]);
+}
+
+# But only this sub name is visible to them.
+
+sub cacheout {
+ package cacheout;
+
+ ($file) = @_;
+ if (!$isopen{$file}) {
+ if (++$numopen > $maxopen) {
+ local(@lru) = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen);
+ splice(@lru, $maxopen / 3);
+ $numopen -= @lru;
+ for (@lru) { close $_; delete $isopen{$_}; }
+ }
+ &open($file, ($saw{$file}++ ? '>>' : '>') . $file)
+ || die "Can't create $file: $!\n";
+ }
+ $isopen{$file} = ++$seq;
+}
+
+package cacheout;
+
+$seq = 0;
+$numopen = 0;
+
+if (open(PARAM,'/usr/include/sys/param.h')) {
+ local($.);
+ while (<PARAM>) {
+ $maxopen = $1 - 4 if /^\s*#\s*define\s+NOFILE\s+(\d+)/;
+ }
+ close PARAM;
+}
+$maxopen = 16 unless $maxopen;
+
+1;
diff --git a/gnu/usr.bin/perl/lib/chat2.pl b/gnu/usr.bin/perl/lib/chat2.pl
new file mode 100644
index 0000000..662872c
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/chat2.pl
@@ -0,0 +1,339 @@
+## chat.pl: chat with a server
+## V2.01.alpha.7 91/06/16
+## Randal L. Schwartz
+
+package chat;
+
+$sockaddr = 'S n a4 x8';
+chop($thishost = `hostname`); $thisaddr = (gethostbyname($thishost))[4];
+$thisproc = pack($sockaddr, 2, 0, $thisaddr);
+
+# *S = symbol for current I/O, gets assigned *chatsymbol....
+$next = "chatsymbol000000"; # next one
+$nextpat = "^chatsymbol"; # patterns that match next++, ++, ++, ++
+
+
+## $handle = &chat'open_port("server.address",$port_number);
+## opens a named or numbered TCP server
+
+sub open_port { ## public
+ local($server, $port) = @_;
+
+ local($serveraddr,$serverproc);
+
+ *S = ++$next;
+ if ($server =~ /^(\d+)+\.(\d+)\.(\d+)\.(\d+)$/) {
+ $serveraddr = pack('C4', $1, $2, $3, $4);
+ } else {
+ local(@x) = gethostbyname($server);
+ return undef unless @x;
+ $serveraddr = $x[4];
+ }
+ $serverproc = pack($sockaddr, 2, $port, $serveraddr);
+ unless (socket(S, 2, 1, 6)) {
+ # XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp'
+ # but who the heck would change these anyway? (:-)
+ ($!) = ($!, close(S)); # close S while saving $!
+ return undef;
+ }
+ unless (bind(S, $thisproc)) {
+ ($!) = ($!, close(S)); # close S while saving $!
+ return undef;
+ }
+ unless (connect(S, $serverproc)) {
+ ($!) = ($!, close(S)); # close S while saving $!
+ return undef;
+ }
+ select((select(S), $| = 1)[0]);
+ $next; # return symbol for switcharound
+}
+
+## ($host, $port, $handle) = &chat'open_listen([$port_number]);
+## opens a TCP port on the current machine, ready to be listened to
+## if $port_number is absent or zero, pick a default port number
+## process must be uid 0 to listen to a low port number
+
+sub open_listen { ## public
+
+ *S = ++$next;
+ local($thisport) = shift || 0;
+ local($thisproc_local) = pack($sockaddr, 2, $thisport, $thisaddr);
+ local(*NS) = "__" . time;
+ unless (socket(NS, 2, 1, 6)) {
+ # XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp'
+ # but who the heck would change these anyway? (:-)
+ ($!) = ($!, close(NS));
+ return undef;
+ }
+ unless (bind(NS, $thisproc_local)) {
+ ($!) = ($!, close(NS));
+ return undef;
+ }
+ unless (listen(NS, 1)) {
+ ($!) = ($!, close(NS));
+ return undef;
+ }
+ select((select(NS), $| = 1)[0]);
+ local($family, $port, @myaddr) =
+ unpack("S n C C C C x8", getsockname(NS));
+ $S{"needs_accept"} = *NS; # so expect will open it
+ (@myaddr, $port, $next); # returning this
+}
+
+## $handle = &chat'open_proc("command","arg1","arg2",...);
+## opens a /bin/sh on a pseudo-tty
+
+sub open_proc { ## public
+ local(@cmd) = @_;
+
+ *S = ++$next;
+ local(*TTY) = "__TTY" . time;
+ local($pty,$tty) = &_getpty(S,TTY);
+ die "Cannot find a new pty" unless defined $pty;
+ local($pid) = fork;
+ die "Cannot fork: $!" unless defined $pid;
+ unless ($pid) {
+ close STDIN; close STDOUT; close STDERR;
+ setpgrp(0,$$);
+ if (open(DEVTTY, "/dev/tty")) {
+ ioctl(DEVTTY,0x20007471,0); # XXX s/b &TIOCNOTTY
+ close DEVTTY;
+ }
+ open(STDIN,"<&TTY");
+ open(STDOUT,">&TTY");
+ open(STDERR,">&STDOUT");
+ die "Oops" unless fileno(STDERR) == 2; # sanity
+ close(S);
+ exec @cmd;
+ die "Cannot exec @cmd: $!";
+ }
+ close(TTY);
+ $PID{$next} = $pid;
+ $next; # return symbol for switcharound
+}
+
+# $S is the read-ahead buffer
+
+## $return = &chat'expect([$handle,] $timeout_time,
+## $pat1, $body1, $pat2, $body2, ... )
+## $handle is from previous &chat'open_*().
+## $timeout_time is the time (either relative to the current time, or
+## absolute, ala time(2)) at which a timeout event occurs.
+## $pat1, $pat2, and so on are regexs which are matched against the input
+## stream. If a match is found, the entire matched string is consumed,
+## and the corresponding body eval string is evaled.
+##
+## Each pat is a regular-expression (probably enclosed in single-quotes
+## in the invocation). ^ and $ will work, respecting the current value of $*.
+## If pat is 'TIMEOUT', the body is executed if the timeout is exceeded.
+## If pat is 'EOF', the body is executed if the process exits before
+## the other patterns are seen.
+##
+## Pats are scanned in the order given, so later pats can contain
+## general defaults that won't be examined unless the earlier pats
+## have failed.
+##
+## The result of eval'ing body is returned as the result of
+## the invocation. Recursive invocations are not thought
+## through, and may work only accidentally. :-)
+##
+## undef is returned if either a timeout or an eof occurs and no
+## corresponding body has been defined.
+## I/O errors of any sort are treated as eof.
+
+$nextsubname = "expectloop000000"; # used for subroutines
+
+sub expect { ## public
+ if ($_[0] =~ /$nextpat/) {
+ *S = shift;
+ }
+ local($endtime) = shift;
+
+ local($timeout,$eof) = (1,1);
+ local($caller) = caller;
+ local($rmask, $nfound, $timeleft, $thisbuf);
+ local($cases, $pattern, $action, $subname);
+ $endtime += time if $endtime < 600_000_000;
+
+ if (defined $S{"needs_accept"}) { # is it a listen socket?
+ local(*NS) = $S{"needs_accept"};
+ delete $S{"needs_accept"};
+ $S{"needs_close"} = *NS;
+ unless(accept(S,NS)) {
+ ($!) = ($!, close(S), close(NS));
+ return undef;
+ }
+ select((select(S), $| = 1)[0]);
+ }
+
+ # now see whether we need to create a new sub:
+
+ unless ($subname = $expect_subname{$caller,@_}) {
+ # nope. make a new one:
+ $expect_subname{$caller,@_} = $subname = $nextsubname++;
+
+ $cases .= <<"EDQ"; # header is funny to make everything elsif's
+sub $subname {
+ LOOP: {
+ if (0) { ; }
+EDQ
+ while (@_) {
+ ($pattern,$action) = splice(@_,0,2);
+ if ($pattern =~ /^eof$/i) {
+ $cases .= <<"EDQ";
+ elsif (\$eof) {
+ package $caller;
+ $action;
+ }
+EDQ
+ $eof = 0;
+ } elsif ($pattern =~ /^timeout$/i) {
+ $cases .= <<"EDQ";
+ elsif (\$timeout) {
+ package $caller;
+ $action;
+ }
+EDQ
+ $timeout = 0;
+ } else {
+ $pattern =~ s#/#\\/#g;
+ $cases .= <<"EDQ";
+ elsif (\$S =~ /$pattern/) {
+ \$S = \$';
+ package $caller;
+ $action;
+ }
+EDQ
+ }
+ }
+ $cases .= <<"EDQ" if $eof;
+ elsif (\$eof) {
+ undef;
+ }
+EDQ
+ $cases .= <<"EDQ" if $timeout;
+ elsif (\$timeout) {
+ undef;
+ }
+EDQ
+ $cases .= <<'ESQ';
+ else {
+ $rmask = "";
+ vec($rmask,fileno(S),1) = 1;
+ ($nfound, $rmask) =
+ select($rmask, undef, undef, $endtime - time);
+ if ($nfound) {
+ $nread = sysread(S, $thisbuf, 1024);
+ if ($nread > 0) {
+ $S .= $thisbuf;
+ } else {
+ $eof++, redo LOOP; # any error is also eof
+ }
+ } else {
+ $timeout++, redo LOOP; # timeout
+ }
+ redo LOOP;
+ }
+ }
+}
+ESQ
+ eval $cases; die "$cases:\n$@" if $@;
+ }
+ $eof = $timeout = 0;
+ do $subname();
+}
+
+## &chat'print([$handle,] @data)
+## $handle is from previous &chat'open().
+## like print $handle @data
+
+sub print { ## public
+ if ($_[0] =~ /$nextpat/) {
+ *S = shift;
+ }
+ print S @_;
+}
+
+## &chat'close([$handle,])
+## $handle is from previous &chat'open().
+## like close $handle
+
+sub close { ## public
+ local($pid);
+ if ($_[0] =~ /$nextpat/) {
+ $pid = $PID{$_[0]};
+ *S = shift;
+ } else {
+ $pid = $PID{$next};
+ }
+ close(S);
+ waitpid($pid,0);
+ if (defined $S{"needs_close"}) { # is it a listen socket?
+ local(*NS) = $S{"needs_close"};
+ delete $S{"needs_close"};
+ close(NS);
+ }
+}
+
+## @ready_handles = &chat'select($timeout, @handles)
+## select()'s the handles with a timeout value of $timeout seconds.
+## Returns an array of handles that are ready for I/O.
+## Both user handles and chat handles are supported (but beware of
+## stdio's buffering for user handles).
+
+sub select { ## public
+ local($timeout) = shift;
+ local(@handles) = @_;
+ local(%handlename) = ();
+ local(%ready) = ();
+ local($caller) = caller;
+ local($rmask) = "";
+ for (@handles) {
+ if (/$nextpat/o) { # one of ours... see if ready
+ local(*SYM) = $_;
+ if (length($SYM)) {
+ $timeout = 0; # we have a winner
+ $ready{$_}++;
+ }
+ $handlename{fileno($_)} = $_;
+ } else {
+ $handlename{fileno(/'/ ? $_ : "$caller\'$_")} = $_;
+ }
+ }
+ for (sort keys %handlename) {
+ vec($rmask, $_, 1) = 1;
+ }
+ select($rmask, undef, undef, $timeout);
+ for (sort keys %handlename) {
+ $ready{$handlename{$_}}++ if vec($rmask,$_,1);
+ }
+ sort keys %ready;
+}
+
+# ($pty,$tty) = $chat'_getpty(PTY,TTY):
+# internal procedure to get the next available pty.
+# opens pty on handle PTY, and matching tty on handle TTY.
+# returns undef if can't find a pty.
+
+sub _getpty { ## private
+ local($_PTY,$_TTY) = @_;
+ $_PTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
+ $_TTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
+ local($pty,$tty);
+ for $bank (112..127) {
+ next unless -e sprintf("/dev/pty%c0", $bank);
+ for $unit (48..57) {
+ $pty = sprintf("/dev/pty%c%c", $bank, $unit);
+ open($_PTY,"+>$pty") || next;
+ select((select($_PTY), $| = 1)[0]);
+ ($tty = $pty) =~ s/pty/tty/;
+ open($_TTY,"+>$tty") || next;
+ select((select($_TTY), $| = 1)[0]);
+ system "stty nl>$tty";
+ return ($pty,$tty);
+ }
+ }
+ undef;
+}
+
+1;
diff --git a/gnu/usr.bin/perl/lib/complete.pl b/gnu/usr.bin/perl/lib/complete.pl
new file mode 100644
index 0000000..dabf8f6
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/complete.pl
@@ -0,0 +1,110 @@
+;#
+;# @(#)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: {
+ package Complete;
+
+ $complete = "\004";
+ $kill = "\025";
+ $erase1 = "\177";
+ $erase2 = "\010";
+}
+
+sub Complete {
+ package Complete;
+
+ local($[) = 0;
+ if ($_[1] =~ /^StB\0/) {
+ ($prompt, *_) = @_;
+ }
+ 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;
+}
+
+1;
diff --git a/gnu/usr.bin/perl/lib/ctime.pl b/gnu/usr.bin/perl/lib/ctime.pl
new file mode 100644
index 0000000..4c59754
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/ctime.pl
@@ -0,0 +1,51 @@
+;# ctime.pl is a simple Perl emulation for the well known ctime(3C) function.
+;#
+;# Waldemar Kebsch, Federal Republic of Germany, November 1988
+;# kebsch.pad@nixpbe.UUCP
+;# Modified March 1990, Feb 1991 to properly handle timezones
+;# $RCSfile: ctime.pl,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:52 $
+;# Marion Hakanson (hakanson@cse.ogi.edu)
+;# Oregon Graduate Institute of Science and Technology
+;#
+;# usage:
+;#
+;# #include <ctime.pl> # see the -P and -I option in perl.man
+;# $Date = &ctime(time);
+
+CONFIG: {
+ package ctime;
+
+ @DoW = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat');
+ @MoY = ('Jan','Feb','Mar','Apr','May','Jun',
+ 'Jul','Aug','Sep','Oct','Nov','Dec');
+}
+
+sub ctime {
+ package ctime;
+
+ local($time) = @_;
+ local($[) = 0;
+ local($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst);
+
+ # Determine what time zone is in effect.
+ # Use GMT if TZ is defined as null, local time if TZ undefined.
+ # There's no portable way to find the system default timezone.
+
+ $TZ = defined($ENV{'TZ'}) ? ( $ENV{'TZ'} ? $ENV{'TZ'} : 'GMT' ) : '';
+ ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) =
+ ($TZ eq 'GMT') ? gmtime($time) : localtime($time);
+
+ # Hack to deal with 'PST8PDT' format of TZ
+ # Note that this can't deal with all the esoteric forms, but it
+ # does recognize the most common: [:]STDoff[DST[off][,rule]]
+
+ if($TZ=~/^([^:\d+\-,]{3,})([+-]?\d{1,2}(:\d{1,2}){0,2})([^\d+\-,]{3,})?/){
+ $TZ = $isdst ? $4 : $1;
+ }
+ $TZ .= ' ' unless $TZ eq '';
+
+ $year += ($year < 70) ? 2000 : 1900;
+ sprintf("%s %s %2d %2d:%02d:%02d %s%4d\n",
+ $DoW[$wday], $MoY[$mon], $mday, $hour, $min, $sec, $TZ, $year);
+}
+1;
diff --git a/gnu/usr.bin/perl/lib/dumpvar.pl b/gnu/usr.bin/perl/lib/dumpvar.pl
new file mode 100644
index 0000000..5427494
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/dumpvar.pl
@@ -0,0 +1,37 @@
+package dumpvar;
+
+# translate control chars to ^X - Randal Schwartz
+sub unctrl {
+ local($_) = @_;
+ s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
+ $_;
+}
+sub main'dumpvar {
+ ($package,@vars) = @_;
+ local(*stab) = eval("*_$package");
+ while (($key,$val) = each(%stab)) {
+ {
+ next if @vars && !grep($key eq $_,@vars);
+ local(*entry) = $val;
+ if (defined $entry) {
+ print "\$$key = '",&unctrl($entry),"'\n";
+ }
+ if (defined @entry) {
+ print "\@$key = (\n";
+ foreach $num ($[ .. $#entry) {
+ print " $num\t'",&unctrl($entry[$num]),"'\n";
+ }
+ print ")\n";
+ }
+ if ($key ne "_$package" && $key ne "_DB" && defined %entry) {
+ print "\%$key = (\n";
+ foreach $key (sort keys(%entry)) {
+ print " $key\t'",&unctrl($entry{$key}),"'\n";
+ }
+ print ")\n";
+ }
+ }
+ }
+}
+
+1;
diff --git a/gnu/usr.bin/perl/lib/exceptions.pl b/gnu/usr.bin/perl/lib/exceptions.pl
new file mode 100644
index 0000000..02c4498
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/exceptions.pl
@@ -0,0 +1,54 @@
+# exceptions.pl
+# tchrist@convex.com
+#
+# Here's a little code I use for exception handling. It's really just
+# glorfied eval/die. The way to use use it is when you might otherwise
+# exit, use &throw to raise an exception. The first enclosing &catch
+# handler looks at the exception and decides whether it can catch this kind
+# (catch takes a list of regexps to catch), and if so, it returns the one it
+# caught. If it *can't* catch it, then it will reraise the exception
+# for someone else to possibly see, or to die otherwise.
+#
+# I use oddly named variables in order to make darn sure I don't conflict
+# with my caller. I also hide in my own package, and eval the code in his.
+#
+# The EXCEPTION: prefix is so you can tell whether it's a user-raised
+# exception or a perl-raised one (eval error).
+#
+# --tom
+#
+# examples:
+# if (&catch('/$user_input/', 'regexp', 'syntax error') {
+# warn "oops try again";
+# redo;
+# }
+#
+# if ($error = &catch('&subroutine()')) { # catches anything
+#
+# &throw('bad input') if /^$/;
+
+sub catch {
+ package exception;
+ local($__code__, @__exceptions__) = @_;
+ local($__package__) = caller;
+ local($__exception__);
+
+ eval "package $__package__; $__code__";
+ if ($__exception__ = &'thrown) {
+ for (@__exceptions__) {
+ return $__exception__ if /$__exception__/;
+ }
+ &'throw($__exception__);
+ }
+}
+
+sub throw {
+ local($exception) = @_;
+ die "EXCEPTION: $exception\n";
+}
+
+sub thrown {
+ $@ =~ /^(EXCEPTION: )+(.+)/ && $2;
+}
+
+1;
diff --git a/gnu/usr.bin/perl/lib/fastcwd.pl b/gnu/usr.bin/perl/lib/fastcwd.pl
new file mode 100644
index 0000000..6b452e8
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/fastcwd.pl
@@ -0,0 +1,35 @@
+# By John Bazik
+#
+# Usage: $cwd = &fastcwd;
+#
+# This is a faster version of getcwd. It's also more dangerous because
+# you might chdir out of a directory that you can't chdir back into.
+
+sub fastcwd {
+ local($odev, $oino, $cdev, $cino, $tdev, $tino);
+ local(@path, $path);
+ local(*DIR);
+
+ ($cdev, $cino) = stat('.');
+ for (;;) {
+ ($odev, $oino) = ($cdev, $cino);
+ chdir('..');
+ ($cdev, $cino) = stat('.');
+ last if $odev == $cdev && $oino == $cino;
+ opendir(DIR, '.');
+ for (;;) {
+ $_ = readdir(DIR);
+ next if $_ eq '.';
+ next if $_ eq '..';
+
+ last unless $_;
+ ($tdev, $tino) = lstat($_);
+ last unless $tdev != $odev || $tino != $oino;
+ }
+ closedir(DIR);
+ unshift(@path, $_);
+ }
+ chdir($path = '/' . join('/', @path));
+ $path;
+}
+1;
diff --git a/gnu/usr.bin/perl/lib/find.pl b/gnu/usr.bin/perl/lib/find.pl
new file mode 100644
index 0000000..8dab054
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/find.pl
@@ -0,0 +1,106 @@
+# Usage:
+# require "find.pl";
+#
+# &find('/foo','/bar');
+#
+# sub wanted { ... }
+# where wanted does whatever you want. $dir contains the
+# current directory name, and $_ the current filename within
+# that directory. $name contains "$dir/$_". You are cd'ed
+# to $dir when the function is called. The function may
+# set $prune to prune the tree.
+#
+# This library is primarily for find2perl, which, when fed
+#
+# find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune
+#
+# spits out something like this
+#
+# sub wanted {
+# /^\.nfs.*$/ &&
+# (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
+# int(-M _) > 7 &&
+# unlink($_)
+# ||
+# ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) &&
+# $dev < 0 &&
+# ($prune = 1);
+# }
+
+sub find {
+ chop($cwd = `pwd`);
+ foreach $topdir (@_) {
+ (($topdev,$topino,$topmode,$topnlink) = stat($topdir))
+ || (warn("Can't stat $topdir: $!\n"), next);
+ if (-d _) {
+ if (chdir($topdir)) {
+ ($dir,$_) = ($topdir,'.');
+ $name = $topdir;
+ &wanted;
+ $topdir =~ s,/$,, ;
+ &finddir($topdir,$topnlink);
+ }
+ else {
+ warn "Can't cd to $topdir: $!\n";
+ }
+ }
+ else {
+ unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
+ ($dir,$_) = ('.', $topdir);
+ }
+ $name = $topdir;
+ chdir $dir && &wanted;
+ }
+ chdir $cwd;
+ }
+}
+
+sub finddir {
+ local($dir,$nlink) = @_;
+ local($dev,$ino,$mode,$subcount);
+ local($name);
+
+ # Get the list of files in the current directory.
+
+ opendir(DIR,'.') || (warn "Can't open $dir: $!\n", return);
+ local(@filenames) = readdir(DIR);
+ closedir(DIR);
+
+ if ($nlink == 2) { # This dir has no subdirectories.
+ for (@filenames) {
+ next if $_ eq '.';
+ next if $_ eq '..';
+ $name = "$dir/$_";
+ $nlink = 0;
+ &wanted;
+ }
+ }
+ else { # This dir has subdirectories.
+ $subcount = $nlink - 2;
+ for (@filenames) {
+ next if $_ eq '.';
+ next if $_ eq '..';
+ $nlink = $prune = 0;
+ $name = "$dir/$_";
+ &wanted;
+ if ($subcount > 0) { # Seen all the subdirs?
+
+ # Get link count and check for directoriness.
+
+ ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
+
+ if (-d _) {
+
+ # It really is a directory, so do it recursively.
+
+ if (!$prune && chdir $_) {
+ &finddir($name,$nlink);
+ chdir '..';
+ }
+ --$subcount;
+ }
+ }
+ }
+ }
+}
+1;
diff --git a/gnu/usr.bin/perl/lib/finddepth.pl b/gnu/usr.bin/perl/lib/finddepth.pl
new file mode 100644
index 0000000..15e4daf
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/finddepth.pl
@@ -0,0 +1,105 @@
+# Usage:
+# require "finddepth.pl";
+#
+# &finddepth('/foo','/bar');
+#
+# sub wanted { ... }
+# where wanted does whatever you want. $dir contains the
+# current directory name, and $_ the current filename within
+# that directory. $name contains "$dir/$_". You are cd'ed
+# to $dir when the function is called. The function may
+# set $prune to prune the tree.
+#
+# This library is primarily for find2perl, which, when fed
+#
+# find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune
+#
+# spits out something like this
+#
+# sub wanted {
+# /^\.nfs.*$/ &&
+# (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
+# int(-M _) > 7 &&
+# unlink($_)
+# ||
+# ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) &&
+# $dev < 0 &&
+# ($prune = 1);
+# }
+
+sub finddepth {
+ chop($cwd = `pwd`);
+ foreach $topdir (@_) {
+ (($topdev,$topino,$topmode,$topnlink) = stat($topdir))
+ || (warn("Can't stat $topdir: $!\n"), next);
+ if (-d _) {
+ if (chdir($topdir)) {
+ $topdir =~ s,/$,, ;
+ &finddepthdir($topdir,$topnlink);
+ ($dir,$_) = ($topdir,'.');
+ $name = $topdir;
+ &wanted;
+ }
+ else {
+ warn "Can't cd to $topdir: $!\n";
+ }
+ }
+ else {
+ unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
+ ($dir,$_) = ('.', $topdir);
+ }
+ chdir $dir && &wanted;
+ }
+ chdir $cwd;
+ }
+}
+
+sub finddepthdir {
+ local($dir,$nlink) = @_;
+ local($dev,$ino,$mode,$subcount);
+ local($name);
+
+ # Get the list of files in the current directory.
+
+ opendir(DIR,'.') || warn "Can't open $dir: $!\n";
+ local(@filenames) = readdir(DIR);
+ closedir(DIR);
+
+ if ($nlink == 2) { # This dir has no subdirectories.
+ for (@filenames) {
+ next if $_ eq '.';
+ next if $_ eq '..';
+ $name = "$dir/$_";
+ $nlink = 0;
+ &wanted;
+ }
+ }
+ else { # This dir has subdirectories.
+ $subcount = $nlink - 2;
+ for (@filenames) {
+ next if $_ eq '.';
+ next if $_ eq '..';
+ $nlink = $prune = 0;
+ $name = "$dir/$_";
+ if ($subcount > 0) { # Seen all the subdirs?
+
+ # Get link count and check for directoriness.
+
+ ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
+
+ if (-d _) {
+
+ # It really is a directory, so do it recursively.
+
+ if (!$prune && chdir $_) {
+ &finddepthdir($name,$nlink);
+ chdir '..';
+ }
+ --$subcount;
+ }
+ }
+ &wanted;
+ }
+ }
+}
+1;
diff --git a/gnu/usr.bin/perl/lib/flush.pl b/gnu/usr.bin/perl/lib/flush.pl
new file mode 100644
index 0000000..55002b9
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/flush.pl
@@ -0,0 +1,23 @@
+;# Usage: &flush(FILEHANDLE)
+;# flushes the named filehandle
+
+;# Usage: &printflush(FILEHANDLE, "prompt: ")
+;# prints arguments and flushes filehandle
+
+sub flush {
+ local($old) = select(shift);
+ $| = 1;
+ print "";
+ $| = 0;
+ select($old);
+}
+
+sub printflush {
+ local($old) = select(shift);
+ $| = 1;
+ print @_;
+ $| = 0;
+ select($old);
+}
+
+1;
diff --git a/gnu/usr.bin/perl/lib/getcwd.pl b/gnu/usr.bin/perl/lib/getcwd.pl
new file mode 100644
index 0000000..a3214ba
--- /dev/null
+++ b/gnu/usr.bin/perl/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 = lstat("$dotdots/$dir"))
+ {
+ warn "lstat($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/gnu/usr.bin/perl/lib/getopt.pl b/gnu/usr.bin/perl/lib/getopt.pl
new file mode 100644
index 0000000..6772d54
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/getopt.pl
@@ -0,0 +1,41 @@
+;# $RCSfile: getopt.pl,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:52 $
+
+;# Process single-character switches with switch clustering. Pass one argument
+;# which is a string containing all switches that take an argument. For each
+;# switch found, sets $opt_x (where x is the switch name) to the value of the
+;# argument, or 1 if no argument. Switches which take an argument don't care
+;# whether there is a space between the switch and the argument.
+
+;# Usage:
+;# do Getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect.
+
+sub Getopt {
+ local($argumentative) = @_;
+ local($_,$first,$rest);
+ local($[) = 0;
+
+ while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
+ ($first,$rest) = ($1,$2);
+ if (index($argumentative,$first) >= $[) {
+ if ($rest ne '') {
+ shift(@ARGV);
+ }
+ else {
+ shift(@ARGV);
+ $rest = shift(@ARGV);
+ }
+ eval "\$opt_$first = \$rest;";
+ }
+ else {
+ eval "\$opt_$first = 1;";
+ if ($rest ne '') {
+ $ARGV[0] = "-$rest";
+ }
+ else {
+ shift(@ARGV);
+ }
+ }
+ }
+}
+
+1;
diff --git a/gnu/usr.bin/perl/lib/getopts.pl b/gnu/usr.bin/perl/lib/getopts.pl
new file mode 100644
index 0000000..a0818d1
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/getopts.pl
@@ -0,0 +1,50 @@
+;# 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);
+ local($errs) = 0;
+ local($[) = 0;
+
+ @args = split( / */, $argumentative );
+ while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
+ ($first,$rest) = ($1,$2);
+ $pos = index($argumentative,$first);
+ if($pos >= $[) {
+ if($args[$pos+1] eq ':') {
+ shift(@ARGV);
+ if($rest eq '') {
+ ++$errs unless @ARGV;
+ $rest = shift(@ARGV);
+ }
+ eval "\$opt_$first = \$rest;";
+ }
+ else {
+ eval "\$opt_$first = 1";
+ if($rest eq '') {
+ shift(@ARGV);
+ }
+ else {
+ $ARGV[0] = "-$rest";
+ }
+ }
+ }
+ else {
+ print STDERR "Unknown option: $first\n";
+ ++$errs;
+ if($rest ne '') {
+ $ARGV[0] = "-$rest";
+ }
+ else {
+ shift(@ARGV);
+ }
+ }
+ }
+ $errs == 0;
+}
+
+1;
diff --git a/gnu/usr.bin/perl/lib/importenv.pl b/gnu/usr.bin/perl/lib/importenv.pl
new file mode 100644
index 0000000..c9ad330
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/importenv.pl
@@ -0,0 +1,16 @@
+;# $Header: /home/cvs/386BSD/ports/lang/perl/lib/importenv.pl,v 1.1.1.1 1993/08/23 21:29:53 nate Exp $
+
+;# This file, when interpreted, pulls the environment into normal variables.
+;# Usage:
+;# require 'importenv.pl';
+;# or
+;# #include <importenv.pl>
+
+local($tmp,$key) = '';
+
+foreach $key (keys(ENV)) {
+ $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/;
+}
+eval $tmp;
+
+1;
diff --git a/gnu/usr.bin/perl/lib/look.pl b/gnu/usr.bin/perl/lib/look.pl
new file mode 100644
index 0000000..4c14e64
--- /dev/null
+++ b/gnu/usr.bin/perl/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,$dict,$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 = int($size / $blksize);
+ while ($max - $min > 1) {
+ $mid = int(($max + $min) / 2);
+ seek(FH,$mid * $blksize,0);
+ $_ = <FH> if $mid; # 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;
+ }
+ }
+ $min *= $blksize;
+ seek(FH,$min,0);
+ <FH> if $min;
+ 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/gnu/usr.bin/perl/lib/newgetopt.pl b/gnu/usr.bin/perl/lib/newgetopt.pl
new file mode 100644
index 0000000..0e4cbfd
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/newgetopt.pl
@@ -0,0 +1,271 @@
+# newgetopt.pl -- new options parsing
+
+# SCCS Status : @(#)@ newgetopt.pl 1.13
+# Author : Johan Vromans
+# Created On : Tue Sep 11 15:00:12 1990
+# Last Modified By: Johan Vromans
+# Last Modified On: Tue Jun 2 11:24:03 1992
+# Update Count : 75
+# Status : Okay
+
+# This package implements a new getopt function. This function adheres
+# to the new syntax (long option names, no bundling).
+#
+# Arguments to the function are:
+#
+# - a list of possible options. These should designate valid perl
+# identifiers, optionally followed by an argument specifier ("="
+# for mandatory arguments or ":" for optional arguments) and an
+# argument type specifier: "n" or "i" for integer numbers, "f" for
+# real (fix) numbers or "s" for strings.
+# If an "@" sign is appended, the option is treated as an array.
+# Value(s) are not set, but pushed.
+#
+# - if the first option of the list consists of non-alphanumeric
+# characters only, it is interpreted as a generic option starter.
+# Everything starting with one of the characters from the starter
+# will be considered an option.
+# Likewise, a double occurrence (e.g. "--") signals end of
+# the options list.
+# The default value for the starter is "-", "--" or "+".
+#
+# Upon return, the option variables, prefixed with "opt_", are defined
+# and set to the respective option arguments, if any.
+# Options that do not take an argument are set to 1. Note that an
+# option with an optional argument will be defined, but set to '' if
+# no actual argument has been supplied.
+# A return status of 0 (false) indicates that the function detected
+# one or more errors.
+#
+# Special care is taken to give a correct treatment to optional arguments.
+#
+# E.g. if option "one:i" (i.e. takes an optional integer argument),
+# then the following situations are handled:
+#
+# -one -two -> $opt_one = '', -two is next option
+# -one -2 -> $opt_one = -2
+#
+# Also, assume "foo=s" and "bar:s" :
+#
+# -bar -xxx -> $opt_bar = '', '-xxx' is next option
+# -foo -bar -> $opt_foo = '-bar'
+# -foo -- -> $opt_foo = '--'
+#
+# HISTORY
+# 2-Jun-1992 Johan Vromans
+# Do not use //o to allow multiple NGetOpt calls with different delimeters.
+# Prevent typeless option from using previous $array state.
+# Prevent empty option from being eaten as a (negative) number.
+
+# 25-May-1992 Johan Vromans
+# Add array options. "foo=s@" will return an array @opt_foo that
+# contains all values that were supplied. E.g. "-foo one -foo -two" will
+# return @opt_foo = ("one", "-two");
+# Correct bug in handling options that allow for a argument when followed
+# by another option.
+
+# 4-May-1992 Johan Vromans
+# Add $ignorecase to match options in either case.
+# Allow '' option.
+
+# 19-Mar-1992 Johan Vromans
+# Allow require from packages.
+# NGetOpt is now defined in the package that requires it.
+# @ARGV and $opt_... are taken from the package that calls it.
+# Use standard (?) option prefixes: -, -- and +.
+
+# 20-Sep-1990 Johan Vromans
+# Set options w/o argument to 1.
+# Correct the dreadful semicolon/require bug.
+
+
+{ package newgetopt;
+ $debug = 0; # for debugging
+ $ignorecase = 1; # ignore case when matching options
+}
+
+sub NGetOpt {
+
+ @newgetopt'optionlist = @_;
+ *newgetopt'ARGV = *ARGV;
+
+ package newgetopt;
+
+ local ($[) = 0;
+ local ($genprefix) = "(--|-|\\+)";
+ local ($argend) = "--";
+ local ($error) = 0;
+ local ($opt, $optx, $arg, $type, $mand, %opctl);
+ local ($pkg) = (caller)[0];
+
+ print STDERR "NGetOpt 1.13 -- called from $pkg\n" if $debug;
+
+ # See if the first element of the optionlist contains option
+ # starter characters.
+ if ( $optionlist[0] =~ /^\W+$/ ) {
+ $genprefix = shift (@optionlist);
+ # Turn into regexp.
+ $genprefix =~ s/(\W)/\\\1/g;
+ $genprefix = "[" . $genprefix . "]";
+ undef $argend;
+ }
+
+ # Verify correctness of optionlist.
+ %opctl = ();
+ foreach $opt ( @optionlist ) {
+ $opt =~ tr/A-Z/a-z/ if $ignorecase;
+ if ( $opt !~ /^(\w*)([=:][infse]@?)?$/ ) {
+ print STDERR ("Error in option spec: \"", $opt, "\"\n");
+ $error++;
+ next;
+ }
+ $opctl{$1} = defined $2 ? $2 : "";
+ }
+
+ return 0 if $error;
+
+ if ( $debug ) {
+ local ($arrow, $k, $v);
+ $arrow = "=> ";
+ while ( ($k,$v) = each(%opctl) ) {
+ print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
+ $arrow = " ";
+ }
+ }
+
+ # Process argument list
+
+ while ( $#ARGV >= 0 ) {
+
+ # >>> See also the continue block <<<
+
+ # Get next argument
+ $opt = shift (@ARGV);
+ print STDERR ("=> option \"", $opt, "\"\n") if $debug;
+ $arg = undef;
+
+ # Check for exhausted list.
+ if ( $opt =~ /^$genprefix/ ) {
+ # Double occurrence is terminator
+ return ($error == 0)
+ if ($opt eq "$+$+") || ((defined $argend) && $opt eq $argend);
+ $opt = $'; # option name (w/o prefix)
+ }
+ else {
+ # Apparently not an option - push back and exit.
+ unshift (@ARGV, $opt);
+ return ($error == 0);
+ }
+
+ # Look it up.
+ $opt =~ tr/A-Z/a-z/ if $ignorecase;
+ unless ( defined ( $type = $opctl{$opt} ) ) {
+ print STDERR ("Unknown option: ", $opt, "\n");
+ $error++;
+ next;
+ }
+
+ # Determine argument status.
+ print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
+
+ # If it is an option w/o argument, we're almost finished with it.
+ if ( $type eq "" ) {
+ $arg = 1; # supply explicit value
+ $array = 0;
+ next;
+ }
+
+ # Get mandatory status and type info.
+ ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/;
+
+ # Check if the argument list is exhausted.
+ if ( $#ARGV < 0 ) {
+
+ # Complain if this option needs an argument.
+ if ( $mand eq "=" ) {
+ print STDERR ("Option ", $opt, " requires an argument\n");
+ $error++;
+ }
+ if ( $mand eq ":" ) {
+ $arg = $type eq "s" ? "" : 0;
+ }
+ next;
+ }
+
+ # Get (possibly optional) argument.
+ $arg = shift (@ARGV);
+
+ # Check if it is a valid argument. A mandatory string takes
+ # anything.
+ if ( "$mand$type" ne "=s" && $arg =~ /^$genprefix/ ) {
+
+ # Check for option list terminator.
+ if ( $arg eq "$+$+" ||
+ ((defined $argend) && $arg eq $argend)) {
+ # Push back so the outer loop will terminate.
+ unshift (@ARGV, $arg);
+ # Complain if an argument is required.
+ if ($mand eq "=") {
+ print STDERR ("Option ", $opt, " requires an argument\n");
+ $error++;
+ undef $arg; # don't assign it
+ }
+ else {
+ # Supply empty value.
+ $arg = $type eq "s" ? "" : 0;
+ }
+ next;
+ }
+
+ # Maybe the optional argument is the next option?
+ if ( $mand eq ":" && ($' eq "" || $' =~ /[a-zA-Z_]/) ) {
+ # Yep. Push back.
+ unshift (@ARGV, $arg);
+ $arg = $type eq "s" ? "" : 0;
+ next;
+ }
+ }
+
+ if ( $type eq "n" || $type eq "i" ) { # numeric/integer
+ if ( $arg !~ /^-?[0-9]+$/ ) {
+ print STDERR ("Value \"", $arg, "\" invalid for option ",
+ $opt, " (number expected)\n");
+ $error++;
+ undef $arg; # don't assign it
+ }
+ next;
+ }
+
+ if ( $type eq "f" ) { # fixed real number, int is also ok
+ if ( $arg !~ /^-?[0-9.]+$/ ) {
+ print STDERR ("Value \"", $arg, "\" invalid for option ",
+ $opt, " (real number expected)\n");
+ $error++;
+ undef $arg; # don't assign it
+ }
+ next;
+ }
+
+ if ( $type eq "s" ) { # string
+ next;
+ }
+
+ }
+ continue {
+ if ( defined $arg ) {
+ if ( $array ) {
+ print STDERR ('=> push (@', $pkg, '\'opt_', $opt, ", \"$arg\")\n")
+ if $debug;
+ eval ('push(@' . $pkg . '\'opt_' . $opt . ", \$arg);");
+ }
+ else {
+ print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n")
+ if $debug;
+ eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;");
+ }
+ }
+ }
+
+ return ($error == 0);
+}
+1;
diff --git a/gnu/usr.bin/perl/lib/open2.pl b/gnu/usr.bin/perl/lib/open2.pl
new file mode 100644
index 0000000..dcd68a8
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/open2.pl
@@ -0,0 +1,54 @@
+# &open2: tom christiansen, <tchrist@convex.com>
+#
+# usage: $pid = &open2('rdr', 'wtr', 'some cmd and args');
+# or $pid = &open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args');
+#
+# spawn the given $cmd and connect $rdr for
+# reading and $wtr for writing. return pid
+# of child, or 0 on failure.
+#
+# WARNING: this is dangerous, as you may block forever
+# unless you are very careful.
+#
+# $wtr is left unbuffered.
+#
+# abort program if
+# rdr or wtr are null
+# pipe or fork or exec fails
+
+package open2;
+$fh = 'FHOPEN000'; # package static in case called more than once
+
+sub main'open2 {
+ local($kidpid);
+ local($dad_rdr, $dad_wtr, @cmd) = @_;
+
+ $dad_rdr ne '' || die "open2: rdr should not be null";
+ $dad_wtr ne '' || die "open2: wtr should not be null";
+
+ # force unqualified filehandles into callers' package
+ local($package) = caller;
+ $dad_rdr =~ s/^[^']+$/$package'$&/;
+ $dad_wtr =~ s/^[^']+$/$package'$&/;
+
+ local($kid_rdr) = ++$fh;
+ local($kid_wtr) = ++$fh;
+
+ pipe($dad_rdr, $kid_wtr) || die "open2: pipe 1 failed: $!";
+ pipe($kid_rdr, $dad_wtr) || die "open2: pipe 2 failed: $!";
+
+ if (($kidpid = fork) < 0) {
+ die "open2: fork failed: $!";
+ } elsif ($kidpid == 0) {
+ close $dad_rdr; close $dad_wtr;
+ open(STDIN, "<&$kid_rdr");
+ open(STDOUT, ">&$kid_wtr");
+ warn "execing @cmd\n" if $debug;
+ exec @cmd;
+ die "open2: exec of @cmd failed";
+ }
+ close $kid_rdr; close $kid_wtr;
+ select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
+ $kidpid;
+}
+1; # so require is happy
diff --git a/gnu/usr.bin/perl/lib/perldb.pl b/gnu/usr.bin/perl/lib/perldb.pl
new file mode 100644
index 0000000..1aadb93
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/perldb.pl
@@ -0,0 +1,598 @@
+package DB;
+
+# modified Perl debugger, to be run from Emacs in perldb-mode
+# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
+# Johan Vromans -- upgrade to 4.0 pl 10
+
+$header = '$RCSfile: perldb.pl,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:51 $';
+#
+# 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 1.1.1.1 1993/08/23 21:29:51 nate
+# PERL!
+#
+# Revision 4.0.1.3 92/06/08 13:43:57 lwall
+# patch20: support for MSDOS folded into perldb.pl
+# patch20: perldb couldn't debug file containing '-', such as STDIN designator
+#
+# Revision 4.0.1.2 91/11/05 17:55:58 lwall
+# patch11: perldb.pl modified to run within emacs in perldb-mode
+#
+# Revision 4.0.1.1 91/06/07 11:17:44 lwall
+# patch4: added $^P variable to control calling of perldb routines
+# patch4: debugger sometimes listed wrong number of lines for a statement
+#
+# Revision 4.0 91/03/20 01:25:50 lwall
+# 4.0 baseline.
+#
+# Revision 3.0.1.6 91/01/11 18:08:58 lwall
+# patch42: @_ couldn't be accessed from debugger
+#
+# Revision 3.0.1.5 90/11/10 01:40:26 lwall
+# patch38: the debugger wouldn't stop correctly or do action routines
+#
+# Revision 3.0.1.4 90/10/15 17:40:38 lwall
+# patch29: added caller
+# patch29: the debugger now understands packages and evals
+# patch29: scripts now run at almost full speed under the debugger
+# patch29: more variables are settable from debugger
+#
+# Revision 3.0.1.3 90/08/09 04:00:58 lwall
+# patch19: debugger now allows continuation lines
+# patch19: debugger can now dump lists of variables
+# patch19: debugger can now add aliases easily from prompt
+#
+# Revision 3.0.1.2 90/03/12 16:39:39 lwall
+# patch13: perl -d didn't format stack traces of *foo right
+# patch13: perl -d wiped out scalar return values of subroutines
+#
+# Revision 3.0.1.1 89/10/26 23:14:02 lwall
+# patch1: RCS expanded an unintended $Header in lib/perldb.pl
+#
+# 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.
+#
+#
+
+if (-e "/dev/tty") {
+ $console = "/dev/tty";
+ $rcfile=".perldb";
+}
+else {
+ $console = "con";
+ $rcfile="perldb.ini";
+}
+
+open(IN, "<$console") || open(IN, "<&STDIN"); # so we don't dingle stdin
+open(OUT,">$console") || open(OUT, ">&STDOUT"); # so we don't dongle stdout
+select(OUT);
+$| = 1; # for DB'OUT
+select(STDOUT);
+$| = 1; # for real STDOUT
+$sub = '';
+
+# Is Perl being run from Emacs?
+$emacs = $main'ARGV[$[] eq '-emacs';
+shift(@main'ARGV) if $emacs;
+
+$header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
+print OUT "\nLoading DB routines from $header\n";
+print OUT ("Emacs support ",
+ $emacs ? "enabled" : "available",
+ ".\n");
+print OUT "\nEnter h for help.\n\n";
+
+sub DB {
+ &save;
+ ($package, $filename, $line) = caller;
+ $usercontext = '($@, $!, $[, $,, $/, $\) = @saved;' .
+ "package $package;"; # this won't let them modify, alas
+ local($^P) = 0; # don't debug our own evals
+ local(*dbline) = "_<$filename";
+ $max = $#dbline;
+ if (($stop,$action) = split(/\0/,$dbline{$line})) {
+ if ($stop eq '1') {
+ $signal |= 1;
+ }
+ else {
+ $evalarg = "\$DB'signal |= do {$stop;}"; &eval;
+ $dbline{$line} =~ s/;9($|\0)/$1/;
+ }
+ }
+ if ($single || $trace || $signal) {
+ if ($emacs) {
+ print OUT "\032\032$filename:$line:0\n";
+ } else {
+ print OUT "$package'" unless $sub =~ /'/;
+ print OUT "$sub($filename:$line):\t",$dbline[$line];
+ for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) {
+ last if $dbline[$i] =~ /^\s*(}|#|\n)/;
+ print OUT "$sub($filename:$i):\t",$dbline[$i];
+ }
+ }
+ }
+ $evalarg = $action, &eval if $action;
+ if ($single || $signal) {
+ $evalarg = $pre, &eval if $pre;
+ print OUT $#stack . " levels deep in subroutine calls!\n"
+ if $single & 4;
+ $start = $line;
+ CMD:
+ while ((print OUT " DB<", $#hist+1, "> "), $cmd=&gets) {
+ {
+ $single = 0;
+ $signal = 0;
+ $cmd eq '' && exit 0;
+ chop($cmd);
+ $cmd =~ s/\\$// && do {
+ print OUT " cont: ";
+ $cmd .= &gets;
+ redo 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.
+r Return from 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.
+f filename Switch to filename.
+/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 [pkg [vars]] List some (default all) variables in package (default current).
+X [vars] Same as \"V currentpackage [vars]\".
+< 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 \"print DB'OUT expr\" in current package.
+= [alias value] Define a command alias, or list current aliases.
+command Execute as a perl statement in current package.
+
+";
+ next CMD; };
+ $cmd =~ /^t$/ && do {
+ $trace = !$trace;
+ print OUT "Trace = ".($trace?"on":"off")."\n";
+ next CMD; };
+ $cmd =~ /^S$/ && do {
+ foreach $subname (sort(keys %sub)) {
+ print OUT $subname,"\n";
+ }
+ next CMD; };
+ $cmd =~ s/^X\b/V $package/;
+ $cmd =~ /^V$/ && do {
+ $cmd = 'V $package'; };
+ $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
+ $packname = $1;
+ @vars = split(' ',$2);
+ do 'dumpvar.pl' unless defined &main'dumpvar;
+ if (defined &main'dumpvar) {
+ &main'dumpvar($packname,@vars);
+ }
+ else {
+ print DB'OUT "dumpvar.pl not available.\n";
+ }
+ next CMD; };
+ $cmd =~ /^f\b\s*(.*)/ && do {
+ $file = $1;
+ if (!$file) {
+ print OUT "The old f command is now the r command.\n";
+ print OUT "The new f command switches filenames.\n";
+ next CMD;
+ }
+ if (!defined $_main{'_<' . $file}) {
+ if (($try) = grep(m#^_<.*$file#, keys %_main)) {
+ $file = substr($try,2);
+ print "\n$file:\n";
+ }
+ }
+ if (!defined $_main{'_<' . $file}) {
+ print OUT "There's no code here anything matching $file.\n";
+ next CMD;
+ }
+ elsif ($file ne $filename) {
+ *dbline = "_<$file";
+ $max = $#dbline;
+ $filename = $file;
+ $start = 1;
+ $cmd = "l";
+ } };
+ $cmd =~ /^l\b\s*(['A-Za-z_]['\w]*)/ && do {
+ $subname = $1;
+ $subname = "main'" . $subname unless $subname =~ /'/;
+ $subname = "main" . $subname if substr($subname,0,1) eq "'";
+ ($file,$subrange) = split(/:/,$sub{$subname});
+ if ($file ne $filename) {
+ *dbline = "_<$file";
+ $max = $#dbline;
+ $filename = $file;
+ }
+ if ($subrange) {
+ if (eval($subrange) < -$window) {
+ $subrange =~ s/-.*/+/;
+ }
+ $cmd = "l $subrange";
+ } else {
+ print OUT "Subroutine $1 not found.\n";
+ next CMD;
+ } };
+ $cmd =~ /^w\b\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\b\s*(\d*)\+(\d*)$/ && do {
+ $start = $1 if $1;
+ $incr = $2;
+ $incr = $window - 1 unless $incr;
+ $cmd = 'l ' . $start . '-' . ($start + $incr); };
+ $cmd =~ /^l\b\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;
+ if ($emacs) {
+ print OUT "\032\032$filename:$i:0\n";
+ $i = $end;
+ } else {
+ for (; $i <= $end; $i++) {
+ print OUT "$i:\t", $dbline[$i];
+ last if $signal;
+ }
+ }
+ $start = $i; # remember in case they want more
+ $start = $max if $start > $max;
+ next CMD; };
+ $cmd =~ /^D$/ && do {
+ print OUT "Deleting all breakpoints...\n";
+ for ($i = 1; $i <= $max ; $i++) {
+ if (defined $dbline{$i}) {
+ $dbline{$i} =~ s/^[^\0]+//;
+ if ($dbline{$i} =~ s/^\0?$//) {
+ delete $dbline{$i};
+ }
+ }
+ }
+ next CMD; };
+ $cmd =~ /^L$/ && do {
+ for ($i = 1; $i <= $max; $i++) {
+ if (defined $dbline{$i}) {
+ print OUT "$i:\t", $dbline[$i];
+ ($stop,$action) = split(/\0/, $dbline{$i});
+ print OUT " break if (", $stop, ")\n"
+ if $stop;
+ print OUT " action: ", $action, "\n"
+ if $action;
+ last if $signal;
+ }
+ }
+ next CMD; };
+ $cmd =~ /^b\b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do {
+ $subname = $1;
+ $cond = $2 || '1';
+ $subname = "$package'" . $subname unless $subname =~ /'/;
+ $subname = "main" . $subname if substr($subname,0,1) eq "'";
+ ($filename,$i) = split(/:/, $sub{$subname});
+ $i += 0;
+ if ($i) {
+ *dbline = "_<$filename";
+ ++$i while $dbline[$i] == 0 && $i < $#dbline;
+ $dbline{$i} =~ s/^[^\0]*/$cond/;
+ } else {
+ print OUT "Subroutine $subname not found.\n";
+ }
+ next CMD; };
+ $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
+ $i = ($1?$1:$line);
+ $cond = $2 || '1';
+ if ($dbline[$i] == 0) {
+ print OUT "Line $i not breakable.\n";
+ } else {
+ $dbline{$i} =~ s/^[^\0]*/$cond/;
+ }
+ next CMD; };
+ $cmd =~ /^d\b\s*(\d+)?/ && do {
+ $i = ($1?$1:$line);
+ $dbline{$i} =~ s/^[^\0]*//;
+ delete $dbline{$i} if $dbline{$i} eq '';
+ next CMD; };
+ $cmd =~ /^A$/ && do {
+ for ($i = 1; $i <= $max ; $i++) {
+ if (defined $dbline{$i}) {
+ $dbline{$i} =~ s/\0[^\0]*//;
+ delete $dbline{$i} if $dbline{$i} eq '';
+ }
+ }
+ next CMD; };
+ $cmd =~ /^<\s*(.*)/ && do {
+ $pre = do action($1);
+ next CMD; };
+ $cmd =~ /^>\s*(.*)/ && do {
+ $post = do action($1);
+ next CMD; };
+ $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
+ $i = $1;
+ if ($dbline[$i] == 0) {
+ print OUT "Line $i may not have an action.\n";
+ } else {
+ $dbline{$i} =~ s/\0[^\0]*//;
+ $dbline{$i} .= "\0" . do action($3);
+ }
+ next CMD; };
+ $cmd =~ /^n$/ && do {
+ $single = 2;
+ $laststep = $cmd;
+ last CMD; };
+ $cmd =~ /^s$/ && do {
+ $single = 1;
+ $laststep = $cmd;
+ last CMD; };
+ $cmd =~ /^c\b\s*(\d*)\s*$/ && do {
+ $i = $1;
+ if ($i) {
+ if ($dbline[$i] == 0) {
+ print OUT "Line $i not breakable.\n";
+ next CMD;
+ }
+ $dbline{$i} =~ s/(\0|$)/;9$1/; # add one-time-only b.p.
+ }
+ for ($i=0; $i <= $#stack; ) {
+ $stack[$i++] &= ~1;
+ }
+ last CMD; };
+ $cmd =~ /^r$/ && do {
+ $stack[$#stack] |= 2;
+ last CMD; };
+ $cmd =~ /^T$/ && do {
+ local($p,$f,$l,$s,$h,$a,@a,@sub);
+ for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
+ @a = @args;
+ for (@a) {
+ if (/^StB\000/ && length($_) == length($_main{'_main'})) {
+ $_ = sprintf("%s",$_);
+ }
+ else {
+ s/'/\\'/g;
+ s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
+ s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+ s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
+ }
+ }
+ $w = $w ? '@ = ' : '$ = ';
+ $a = $h ? '(' . join(', ', @a) . ')' : '';
+ push(@sub, "$w&$s$a from file $f line $l\n");
+ last if $signal;
+ }
+ for ($i=0; $i <= $#sub; $i++) {
+ last if $signal;
+ print OUT $sub[$i];
+ }
+ next CMD; };
+ $cmd =~ /^\/(.*)$/ && do {
+ $inpat = $1;
+ $inpat =~ s:([^\\])/$:$1:;
+ if ($inpat ne "") {
+ eval '$inpat =~ m'."\n$inpat\n";
+ if ($@ ne "") {
+ print OUT "$@";
+ next CMD;
+ }
+ $pat = $inpat;
+ }
+ $end = $start;
+ eval '
+ for (;;) {
+ ++$start;
+ $start = 1 if ($start > $max);
+ last if ($start == $end);
+ if ($dbline[$start] =~ m'."\n$pat\n".'i) {
+ if ($emacs) {
+ print OUT "\032\032$filename:$start:0\n";
+ } else {
+ print OUT "$start:\t", $dbline[$start], "\n";
+ }
+ last;
+ }
+ } ';
+ print OUT "/$pat/: not found\n" if ($start == $end);
+ next CMD; };
+ $cmd =~ /^\?(.*)$/ && do {
+ $inpat = $1;
+ $inpat =~ s:([^\\])\?$:$1:;
+ if ($inpat ne "") {
+ eval '$inpat =~ m'."\n$inpat\n";
+ if ($@ ne "") {
+ print OUT "$@";
+ next CMD;
+ }
+ $pat = $inpat;
+ }
+ $end = $start;
+ eval '
+ for (;;) {
+ --$start;
+ $start = $max if ($start <= 0);
+ last if ($start == $end);
+ if ($dbline[$start] =~ m'."\n$pat\n".'i) {
+ if ($emacs) {
+ print OUT "\032\032$filename:$start:0\n";
+ } else {
+ print OUT "$start:\t", $dbline[$start], "\n";
+ }
+ last;
+ }
+ } ';
+ print OUT "?$pat?: not found\n" if ($start == $end);
+ next CMD; };
+ $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; };
+ $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;
+ }
+ $cmd = $hist[$i] . "\n";
+ print OUT $cmd;
+ redo CMD; };
+ $cmd =~ /^H\b\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; };
+ $cmd =~ s/^p( .*)?$/print DB'OUT$1/;
+ $cmd =~ /^=/ && do {
+ if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
+ $alias{$k}="s~$k~$v~";
+ print OUT "$k = $v\n";
+ } elsif ($cmd =~ /^=\s*$/) {
+ foreach $k (sort keys(%alias)) {
+ if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
+ print OUT "$k = $v\n";
+ } else {
+ print OUT "$k\t$alias{$k}\n";
+ };
+ };
+ };
+ next CMD; };
+ }
+ $evalarg = $cmd; &eval;
+ print OUT "\n";
+ }
+ if ($post) {
+ $evalarg = $post; &eval;
+ }
+ }
+ ($@, $!, $[, $,, $/, $\) = @saved;
+}
+
+sub save {
+ @saved = ($@, $!, $[, $,, $/, $\);
+ $[ = 0; $, = ""; $/ = "\n"; $\ = "";
+}
+
+# The following takes its argument via $evalarg to preserve current @_
+
+sub eval {
+ eval "$usercontext $evalarg; &DB'save";
+ print OUT $@;
+}
+
+sub action {
+ local($action) = @_;
+ while ($action =~ s/\\$//) {
+ print OUT "+ ";
+ $action .= &gets;
+ }
+ $action;
+}
+
+sub gets {
+ local($.);
+ <IN>;
+}
+
+sub catch {
+ $signal = 1;
+}
+
+sub sub {
+ push(@stack, $single);
+ $single &= 1;
+ $single |= 4 if $#stack == $deep;
+ if (wantarray) {
+ @i = &$sub;
+ $single |= pop(@stack);
+ @i;
+ }
+ else {
+ $i = &$sub;
+ $single |= pop(@stack);
+ $i;
+ }
+}
+
+$single = 1; # so it stops on first executable statement
+@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.]+$/;
+}
+
+if (-f $rcfile) {
+ do "./$rcfile";
+}
+elsif (-f "$ENV{'LOGDIR'}/$rcfile") {
+ do "$ENV{'LOGDIR'}/$rcfile";
+}
+elsif (-f "$ENV{'HOME'}/$rcfile") {
+ do "$ENV{'HOME'}/$rcfile";
+}
+
+1;
diff --git a/gnu/usr.bin/perl/lib/pwd.pl b/gnu/usr.bin/perl/lib/pwd.pl
new file mode 100644
index 0000000..16baadc
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/pwd.pl
@@ -0,0 +1,72 @@
+;# pwd.pl - keeps track of current working directory in PWD environment var
+;#
+;# $RCSfile: pwd.pl,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:52 $
+;#
+;# $Log: pwd.pl,v $
+# Revision 1.1.1.1 1993/08/23 21:29:52 nate
+# PERL!
+#
+;# Revision 4.0.1.1 92/06/08 13:45:22 lwall
+;# patch20: support added to pwd.pl to strip automounter crud
+;#
+;# Revision 4.0 91/03/20 01:26:03 lwall
+;# 4.0 baseline.
+;#
+;# Revision 3.0.1.2 91/01/11 18:09:24 lwall
+;# patch42: some .pl files were missing their trailing 1;
+;#
+;# Revision 3.0.1.1 90/08/09 04:01:24 lwall
+;# patch19: Initial revision
+;#
+;#
+;# Usage:
+;# require "pwd.pl";
+;# &initpwd;
+;# ...
+;# &chdir($newdir);
+
+package pwd;
+
+sub main'initpwd {
+ if ($ENV{'PWD'}) {
+ local($dd,$di) = stat('.');
+ local($pd,$pi) = stat($ENV{'PWD'});
+ if ($di != $pi || $dd != $pd) {
+ chop($ENV{'PWD'} = `pwd`);
+ }
+ }
+ else {
+ chop($ENV{'PWD'} = `pwd`);
+ }
+ if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) {
+ local($pd,$pi) = stat($2);
+ local($dd,$di) = stat($1);
+ if ($di == $pi && $dd == $pd) {
+ $ENV{'PWD'}="$2$3";
+ }
+ }
+}
+
+sub main'chdir {
+ local($newdir) = shift;
+ if (chdir $newdir) {
+ if ($newdir =~ m#^/#) {
+ $ENV{'PWD'} = $newdir;
+ }
+ else {
+ local(@curdir) = split(m#/#,$ENV{'PWD'});
+ @curdir = '' unless @curdir;
+ foreach $component (split(m#/#, $newdir)) {
+ next if $component eq '.';
+ pop(@curdir),next if $component eq '..';
+ push(@curdir,$component);
+ }
+ $ENV{'PWD'} = join('/',@curdir) || '/';
+ }
+ }
+ else {
+ 0;
+ }
+}
+
+1;
diff --git a/gnu/usr.bin/perl/lib/shellwords.pl b/gnu/usr.bin/perl/lib/shellwords.pl
new file mode 100644
index 0000000..5d593da
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/shellwords.pl
@@ -0,0 +1,48 @@
+;# shellwords.pl
+;#
+;# Usage:
+;# require 'shellwords.pl';
+;# @words = &shellwords($line);
+;# or
+;# @words = &shellwords(@lines);
+;# or
+;# @words = &shellwords; # defaults to $_ (and clobbers it)
+
+sub shellwords {
+ package shellwords;
+ local($_) = join('', @_) if @_;
+ local(@words,$snippet,$field);
+
+ s/^\s+//;
+ while ($_ ne '') {
+ $field = '';
+ for (;;) {
+ if (s/^"(([^"\\]|\\[\\"])*)"//) {
+ ($snippet = $1) =~ s#\\(.)#$1#g;
+ }
+ elsif (/^"/) {
+ die "Unmatched double quote: $_\n";
+ }
+ elsif (s/^'(([^'\\]|\\[\\'])*)'//) {
+ ($snippet = $1) =~ s#\\(.)#$1#g;
+ }
+ elsif (/^'/) {
+ die "Unmatched single quote: $_\n";
+ }
+ elsif (s/^\\(.)//) {
+ $snippet = $1;
+ }
+ elsif (s/^([^\s\\'"]+)//) {
+ $snippet = $1;
+ }
+ else {
+ s/^\s+//;
+ last;
+ }
+ $field .= $snippet;
+ }
+ push(@words, $field);
+ }
+ @words;
+}
+1;
diff --git a/gnu/usr.bin/perl/lib/stat.pl b/gnu/usr.bin/perl/lib/stat.pl
new file mode 100644
index 0000000..6186f54
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/stat.pl
@@ -0,0 +1,31 @@
+;# $Header: /home/cvs/386BSD/ports/lang/perl/lib/stat.pl,v 1.1.1.1 1993/08/23 21:29:53 nate Exp $
+
+;# Usage:
+;# require 'stat.pl';
+;# @ary = stat(foo);
+;# $st_dev = @ary[$ST_DEV];
+;#
+$ST_DEV = 0 + $[;
+$ST_INO = 1 + $[;
+$ST_MODE = 2 + $[;
+$ST_NLINK = 3 + $[;
+$ST_UID = 4 + $[;
+$ST_GID = 5 + $[;
+$ST_RDEV = 6 + $[;
+$ST_SIZE = 7 + $[;
+$ST_ATIME = 8 + $[;
+$ST_MTIME = 9 + $[;
+$ST_CTIME = 10 + $[;
+$ST_BLKSIZE = 11 + $[;
+$ST_BLOCKS = 12 + $[;
+
+;# Usage:
+;# require 'stat.pl';
+;# do Stat('foo'); # sets st_* as a side effect
+;#
+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/gnu/usr.bin/perl/lib/syslog.pl b/gnu/usr.bin/perl/lib/syslog.pl
new file mode 100644
index 0000000..94a4f6a
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/syslog.pl
@@ -0,0 +1,224 @@
+#
+# syslog.pl
+#
+# $Log: syslog.pl,v $
+# Revision 1.1.1.1 1993/08/23 21:29:51 nate
+# PERL!
+#
+# Revision 4.0.1.1 92/06/08 13:48:05 lwall
+# patch20: new warning for ambiguous use of unary operators
+#
+# Revision 4.0 91/03/20 01:26:24 lwall
+# 4.0 baseline.
+#
+# Revision 3.0.1.4 90/11/10 01:41:11 lwall
+# patch38: syslog.pl was referencing an absolute path
+#
+# Revision 3.0.1.3 90/10/15 17:42:18 lwall
+# patch29: various portability fixes
+#
+# Revision 3.0.1.1 90/08/09 03:57:17 lwall
+# patch19: Initial revision
+#
+# Revision 1.2 90/06/11 18:45:30 18:45:30 root ()
+# - Changed 'warn' to 'mail|warning' in test call (to give example of
+# facility specification, and because 'warn' didn't work on HP-UX).
+# - Fixed typo in &openlog ("ncons" should be "cons").
+# - Added (package-global) $maskpri, and &setlogmask.
+# - In &syslog:
+# - put argument test ahead of &connect (why waste cycles?),
+# - allowed facility to be specified in &syslog's first arg (temporarily
+# overrides any $facility set in &openlog), just as in syslog(3C),
+# - do a return 0 when bit for $numpri not set in log mask (see syslog(3C)),
+# - changed $whoami code to use getlogin, getpwuid($<) and 'syslog'
+# (in that order) when $ident is null,
+# - made PID logging consistent with syslog(3C) and subject to $lo_pid only,
+# - fixed typo in "print CONS" statement ($<facility should be <$facility).
+# - changed \n to \r in print CONS (\r is useful, $message already has a \n).
+# - Changed &xlate to return -1 for an unknown name, instead of croaking.
+#
+#
+# tom christiansen <tchrist@convex.com>
+# modified to use sockets by Larry Wall <lwall@jpl-devvax.jpl.nasa.gov>
+# NOTE: openlog now takes three arguments, just like openlog(3)
+#
+# call syslog() with a string priority and a list of printf() args
+# like syslog(3)
+#
+# usage: require 'syslog.pl';
+#
+# then (put these all in a script to test function)
+#
+#
+# do openlog($program,'cons,pid','user');
+# do syslog('info','this is another test');
+# do syslog('mail|warning','this is a better test: %d', time);
+# do closelog();
+#
+# do syslog('debug','this is the last test');
+# do openlog("$program $$",'ndelay','user');
+# do syslog('notice','fooprogram: this is really done');
+#
+# $! = 55;
+# do syslog('info','problem was %m'); # %m == $! in syslog(3)
+
+package syslog;
+
+$host = 'localhost' unless $host; # set $syslog'host to change
+
+require 'syslog.ph';
+
+$maskpri = &LOG_UPTO(&LOG_DEBUG);
+
+sub main'openlog {
+ ($ident, $logopt, $facility) = @_; # package vars
+ $lo_pid = $logopt =~ /\bpid\b/;
+ $lo_ndelay = $logopt =~ /\bndelay\b/;
+ $lo_cons = $logopt =~ /\bcons\b/;
+ $lo_nowait = $logopt =~ /\bnowait\b/;
+ &connect if $lo_ndelay;
+}
+
+sub main'closelog {
+ $facility = $ident = '';
+ &disconnect;
+}
+
+sub main'setlogmask {
+ local($oldmask) = $maskpri;
+ $maskpri = shift;
+ $oldmask;
+}
+
+sub main'syslog {
+ local($priority) = shift;
+ local($mask) = shift;
+ local($message, $whoami);
+ local(@words, $num, $numpri, $numfac, $sum);
+ local($facility) = $facility; # may need to change temporarily.
+
+ die "syslog: expected both priority and mask" unless $mask && $priority;
+
+ @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility".
+ undef $numpri;
+ undef $numfac;
+ foreach (@words) {
+ $num = &xlate($_); # Translate word to number.
+ if (/^kern$/ || $num < 0) {
+ die "syslog: invalid level/facility: $_\n";
+ }
+ elsif ($num <= &LOG_PRIMASK) {
+ die "syslog: too many levels given: $_\n" if defined($numpri);
+ $numpri = $num;
+ return 0 unless &LOG_MASK($numpri) & $maskpri;
+ }
+ else {
+ die "syslog: too many facilities given: $_\n" if defined($numfac);
+ $facility = $_;
+ $numfac = $num;
+ }
+ }
+
+ die "syslog: level must be given\n" unless defined($numpri);
+
+ if (!defined($numfac)) { # Facility not specified in this call.
+ $facility = 'user' unless $facility;
+ $numfac = &xlate($facility);
+ }
+
+ &connect unless $connected;
+
+ $whoami = $ident;
+
+ if (!$ident && $mask =~ /^(\S.*):\s?(.*)/) {
+ $whoami = $1;
+ $mask = $2;
+ }
+
+ unless ($whoami) {
+ ($whoami = getlogin) ||
+ ($whoami = getpwuid($<)) ||
+ ($whoami = 'syslog');
+ }
+
+ $whoami .= "[$$]" if $lo_pid;
+
+ $mask =~ s/%m/$!/g;
+ $mask .= "\n" unless $mask =~ /\n$/;
+ $message = sprintf ($mask, @_);
+
+ $sum = $numpri + $numfac;
+ unless (send(SYSLOG,"<$sum>$whoami: $message",0)) {
+ if ($lo_cons) {
+ if ($pid = fork) {
+ unless ($lo_nowait) {
+ do {$died = wait;} until $died == $pid || $died < 0;
+ }
+ }
+ else {
+ open(CONS,">/dev/console");
+ print CONS "<$facility.$priority>$whoami: $message\r";
+ exit if defined $pid; # if fork failed, we're parent
+ close CONS;
+ }
+ }
+ }
+}
+
+sub xlate {
+ local($name) = @_;
+ $name =~ y/a-z/A-Z/;
+ $name = "LOG_$name" unless $name =~ /^LOG_/;
+ $name = "syslog'$name";
+ eval(&$name) || -1;
+}
+
+sub connect {
+ $pat = 'S n C4 x8';
+
+ $af_unix = 1;
+ $af_inet = 2;
+
+ $stream = 1;
+ $datagram = 2;
+
+ ($name,$aliases,$proto) = getprotobyname('udp');
+ $udp = $proto;
+
+ ($name,$aliase,$port,$proto) = getservbyname('syslog','udp');
+ $syslog = $port;
+
+ if (chop($myname = `hostname`)) {
+ ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($myname);
+ die "Can't lookup $myname\n" unless $name;
+ @bytes = unpack("C4",$addrs[0]);
+ }
+ else {
+ @bytes = (0,0,0,0);
+ }
+ $this = pack($pat, $af_inet, 0, @bytes);
+
+ if ($host =~ /^\d+\./) {
+ @bytes = split(/\./,$host);
+ }
+ else {
+ ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($host);
+ die "Can't lookup $host\n" unless $name;
+ @bytes = unpack("C4",$addrs[0]);
+ }
+ $that = pack($pat,$af_inet,$syslog,@bytes);
+
+ socket(SYSLOG,$af_inet,$datagram,$udp) || die "socket: $!\n";
+ bind(SYSLOG,$this) || die "bind: $!\n";
+ connect(SYSLOG,$that) || die "connect: $!\n";
+
+ local($old) = select(SYSLOG); $| = 1; select($old);
+ $connected = 1;
+}
+
+sub disconnect {
+ close SYSLOG;
+ $connected = 0;
+}
+
+1;
diff --git a/gnu/usr.bin/perl/lib/termcap.pl b/gnu/usr.bin/perl/lib/termcap.pl
new file mode 100644
index 0000000..81556db
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/termcap.pl
@@ -0,0 +1,165 @@
+;# $RCSfile: termcap.pl,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:52 $
+;#
+;# Usage:
+;# require 'ioctl.pl';
+;# ioctl(TTY,$TIOCGETP,$foo);
+;# ($ispeed,$ospeed) = unpack('cc',$foo);
+;# require 'termcap.pl';
+;# &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;
+ $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') || 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',ord($1) & 31)/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) = @_;
+ 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/gnu/usr.bin/perl/lib/timelocal.pl b/gnu/usr.bin/perl/lib/timelocal.pl
new file mode 100644
index 0000000..b7367fa
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/timelocal.pl
@@ -0,0 +1,82 @@
+;# timelocal.pl
+;#
+;# Usage:
+;# $time = timelocal($sec,$min,$hours,$mday,$mon,$year);
+;# $time = timegm($sec,$min,$hours,$mday,$mon,$year);
+
+;# These routines are quite efficient and yet are always guaranteed to agree
+;# with localtime() and gmtime(). We manage this by caching the start times
+;# of any months we've seen before. If we know the start time of the month,
+;# we can always calculate any time within the month. The start times
+;# themselves are guessed by successive approximation starting at the
+;# current time, since most dates seen in practice are close to the
+;# current date. Unlike algorithms that do a binary search (calling gmtime
+;# once for each bit of the time value, resulting in 32 calls), this algorithm
+;# calls it at most 6 times, and usually only once or twice. If you hit
+;# the month cache, of course, it doesn't call it at all.
+
+;# timelocal is implemented using the same cache. We just assume that we're
+;# translating a GMT time, and then fudge it when we're done for the timezone
+;# and daylight savings arguments. The timezone is determined by examining
+;# the result of localtime(0) when the package is initialized. The daylight
+;# savings offset is currently assumed to be one hour.
+
+CONFIG: {
+ package timelocal;
+
+ local($[) = 0;
+ @epoch = localtime(0);
+ $tzmin = $epoch[2] * 60 + $epoch[1]; # minutes east of GMT
+ if ($tzmin > 0) {
+ $tzmin = 24 * 60 - $tzmin; # minutes west of GMT
+ $tzmin -= 24 * 60 if $epoch[5] == 70; # account for the date line
+ }
+
+ $SEC = 1;
+ $MIN = 60 * $SEC;
+ $HR = 60 * $MIN;
+ $DAYS = 24 * $HR;
+ $YearFix = ((gmtime(946684800))[5] == 100) ? 100 : 0;
+}
+
+sub timegm {
+ package timelocal;
+
+ local($[) = 0;
+ $ym = pack(C2, @_[5,4]);
+ $cheat = $cheat{$ym} || &cheat;
+ $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAYS;
+}
+
+sub timelocal {
+ package timelocal;
+
+ local($[) = 0;
+ $time = &main'timegm + $tzmin*$MIN;
+ @test = localtime($time);
+ $time -= $HR if $test[2] != $_[2];
+ $time;
+}
+
+package timelocal;
+
+sub cheat {
+ $year = $_[5];
+ $month = $_[4];
+ die "Month out of range 0..11 in ctime.pl\n" if $month > 11;
+ $guess = $^T;
+ @g = gmtime($guess);
+ $year += $YearFix if $year < $epoch[5];
+ while ($diff = $year - $g[5]) {
+ $guess += $diff * (363 * $DAYS);
+ @g = gmtime($guess);
+ }
+ while ($diff = $month - $g[4]) {
+ $guess += $diff * (27 * $DAYS);
+ @g = gmtime($guess);
+ }
+ $g[3]--;
+ $guess -= $g[0] * $SEC + $g[1] * $MIN + $g[2] * $HR + $g[3] * $DAYS;
+ $cheat{$ym} = $guess;
+}
+1;
diff --git a/gnu/usr.bin/perl/lib/validate.pl b/gnu/usr.bin/perl/lib/validate.pl
new file mode 100644
index 0000000..4b901b6
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/validate.pl
@@ -0,0 +1,104 @@
+;# $Header: /home/cvs/386BSD/ports/lang/perl/lib/validate.pl,v 1.1.1.1 1993/08/23 21:29:51 nate Exp $
+
+;# 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:
+;# require "validate.pl";
+;# $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;
OpenPOWER on IntegriCloud