diff options
author | gclarkii <gclarkii@FreeBSD.org> | 1994-09-10 06:27:55 +0000 |
---|---|---|
committer | gclarkii <gclarkii@FreeBSD.org> | 1994-09-10 06:27:55 +0000 |
commit | bd9f08584221a6bacbfeaebf19d4c3e21fa94a83 (patch) | |
tree | 8e0cf41774fd52d25f63363297782b383c4ad1f7 /gnu/usr.bin/perl/lib | |
download | FreeBSD-src-bd9f08584221a6bacbfeaebf19d4c3e21fa94a83.zip FreeBSD-src-bd9f08584221a6bacbfeaebf19d4c3e21fa94a83.tar.gz |
Initial import of Perl 4.046 bmaked
Diffstat (limited to 'gnu/usr.bin/perl/lib')
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; |