diff options
Diffstat (limited to 'lib')
283 files changed, 5072 insertions, 4218 deletions
diff --git a/lib/AnyDBM_File.pm b/lib/AnyDBM_File.pm new file mode 100644 index 0000000000..ff9078652e --- /dev/null +++ b/lib/AnyDBM_File.pm @@ -0,0 +1,9 @@ +package AnyDBM_File; + +@ISA = qw(NDBM_File DB_File GDBM_File SDBM_File ODBM_File) unless @ISA; + +eval { require NDBM_File } || +eval { require DB_File } || +eval { require GDBM_File } || +eval { require SDBM_File } || +eval { require ODBM_File }; diff --git a/lib/AutoLoader.pm b/lib/AutoLoader.pm index dba8ca2f5f..3f5eef2375 100644 --- a/lib/AutoLoader.pm +++ b/lib/AutoLoader.pm @@ -1,13 +1,23 @@ package AutoLoader; +use Carp; AUTOLOAD { my $name = "auto/$AUTOLOAD.al"; $name =~ s#::#/#g; eval {require $name}; if ($@) { - ($p,$f,$l) = caller($AutoLevel); - $@ =~ s/ at .*\n//; - die "$@ at $f line $l\n"; + # The load might just have failed because the filename was too + # long for some old SVR3 systems which treat long names as errors. + # If we can succesfully truncate a long name then it's worth a go. + # There is a slight risk that we could pick up the wrong file here + # but autosplit should have warned about that when splitting. + if ($name =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){ + eval {require $name}; + } + if ($@){ + $@ =~ s/ at .*\n//; + croak $@; + } } goto &$AUTOLOAD; } diff --git a/lib/AutoSplit.pm b/lib/AutoSplit.pm new file mode 100644 index 0000000000..dabf43cbb8 --- /dev/null +++ b/lib/AutoSplit.pm @@ -0,0 +1,225 @@ +package AutoSplit; + +require 5.000; +require Exporter; + +use Config; +use Carp; + +@ISA = qw(Exporter); +@EXPORT = qw(&autosplit &autosplit_lib_modules); +@EXPORT_OK = qw($Verbose $Keep); + +# for portability warn about names longer than $maxlen +$Maxlen = 8; # 8 for dos, 11 (14-".al") for SYSVR3 +$Verbose = 1; # 0=none, 1=minimal, 2=list .al files +$Keep = 0; +$IndexFile = "autosplit.ix"; # file also serves as timestamp + +$maxflen = 255; +$maxflen = 14 if $Config{'d_flexfnam'} ne 'define'; +$vms = ($Config{'osname'} eq 'VMS'); + +sub autosplit{ + my($file, $autodir) = @_; + autosplit_file($file, $autodir, $Keep, 1, 0); +} + + + +# This function is used during perl building/installation +# ./miniperl -e 'use AutoSplit; autosplit_modules(@ARGV)' ... + +sub autosplit_lib_modules{ + my(@modules) = @_; # list of Module names + + foreach(@modules){ + s#::#/#g; # incase specified as ABC::XYZ + s#^lib/##; # incase specified as lib/*.pm + if ($vms && /[:>\]]/) { # may need to convert VMS-style filespecs + my ($dir,$name) = (/(.*])(.*)/); + $dir =~ s/.*lib[\.\]]//; + $dir =~ s#[\.\]]#/#g; + $_ = $dir . $name; + } + autosplit_file("lib/$_", "lib/auto", $Keep, 1, 1); + } + 0; +} + + +# private functions + +sub autosplit_file{ + my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time) = @_; + my(@names); + + # where to write output files + $autodir = "lib/auto" unless $autodir; + die "autosplit directory $autodir does not exist" unless -d $autodir; + + # allow just a package name to be used + $filename .= ".pm" unless ($filename =~ m/\.pm$/); + + open(IN, "<$filename") || die "AutoSplit: Can't open $filename: $!\n"; + my($pm_mod_time) = (stat($filename))[9]; + my($autoloader_seen) = 0; + while (<IN>) { + # record last package name seen + $package = $1 if (m/^\s*package\s+([\w:]+)\s*;/); + ++$autoloader_seen if m/^\s*use\s+AutoLoader\b/; + ++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/; + last if /^__END__/; + } + return 0 if ($check_for_autoloader && !$autoloader_seen); + $_ or die "Can't find __END__ in $filename\n"; + + $package or die "Can't find 'package Name;' in $filename\n"; + + my($modpname) = $package; $modpname =~ s#::#/#g; + my($al_idx_file) = "$autodir/$modpname/$IndexFile"; + + die "Package $package does not match filename $filename" + unless ($filename =~ m/$modpname.pm$/ or + $vms && $filename =~ m/$modpname.pm/i); + + if ($check_mod_time){ + my($al_ts_time) = (stat("$al_idx_file"))[9] || 1; + if ($al_ts_time >= $pm_mod_time){ + print "AutoSplit skipped ($al_idx_file newer that $filename)\n" + if ($Verbose >= 2); + return undef; # one undef, not a list + } + } + + my($from) = ($Verbose>=2) ? "$filename => " : ""; + print "AutoSplitting $package ($from$autodir/$modpname)\n" + if $Verbose; + + unless (-d "$autodir/$modpname"){ + local($", @p)="/"; + foreach(split(/\//,"$autodir/$modpname")){ + push(@p, $_); + next if -d "@p"; + mkdir("@p",0777) or die "AutoSplit unable to mkdir @p: $!"; + } + } + + # We must try to deal with some SVR3 systems with a limit of 14 + # characters for file names. Sadly we *cannot* simply truncate all + # file names to 14 characters on these systems because we *must* + # create filenames which exactly match the names used by AutoLoader.pm. + # This is a problem because some systems silently truncate the file + # names while others treat long file names as an error. + + # We do not yet deal with multiple packages within one file. + # Ideally both of these styles should work. + # + # package NAME; + # __END__ + # sub AAA { ... } + # package NAME::option1; + # sub BBB { ... } + # package NAME::option2; + # sub BBB { ... } + # + # package NAME; + # __END__ + # sub AAA { ... } + # sub NAME::option1::BBB { ... } + # sub NAME::option2::BBB { ... } + # + # For now both of these produce warnings. + + open(OUT,">/dev/null") || open(OUT,">nla0:"); # avoid 'not opened' warning + my(@subnames); + while (<IN>) { + if (/^package ([\w:]+)\s*;/) { + warn "package $1; in AutoSplit section ignored. Not currently supported."; + } + if (/^sub ([\w:]+)/) { + print OUT "1;\n"; + my($subname) = $1; + if ($subname =~ m/::/){ + warn "subs with package names not currently supported in AutoSplit section"; + } + push(@subnames, $subname); + my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3)); + my($lpath) = "$autodir/$modpname/$lname.al"; + my($spath) = "$autodir/$modpname/$sname.al"; + unless(open(OUT, ">$lpath")){ + open(OUT, ">$spath") or die "Can't create $spath: $!\n"; + push(@names, $sname); + print " writing $spath (with truncated name)\n" + if ($Verbose>=1); + }else{ + push(@names, $lname); + print " writing $lpath\n" if ($Verbose>=2); + } + print OUT "# NOTE: Derived from $filename. ", + "Changes made here will be lost.\n"; + print OUT "package $package;\n\n"; + } + print OUT $_; + } + print OUT "1;\n"; + close(OUT); + close(IN); + + if (!$keep){ # don't keep any obsolete *.al files in the directory + my(%names); + @names{@names} = @names; + opendir(OUTDIR,"$autodir/$modpname"); + foreach(sort readdir(OUTDIR)){ + next unless /\.al$/; + my($subname) = m/(.*)\.al$/; + next if $names{substr($subname,0,$maxflen-3)}; + my($file) = "$autodir/$modpname/$_"; + print " deleting $file\n" if ($Verbose>=2); + unlink $file or carp "Unable to delete $file: $!"; + } + closedir(OUTDIR); + } + + open(TS,">$al_idx_file") or + carp "AutoSplit: unable to create timestamp file ($al_idx_file): $!"; + print TS "# Index created by AutoSplit for $filename (file acts as timestamp)\n"; + print TS map("sub $_ ;\n", @subnames); + close(TS); + + check_unique($package, $Maxlen, 1, @names); + + @names; +} + + +sub check_unique{ + my($module, $maxlen, $warn, @names) = @_; + my(%notuniq) = (); + my(%shorts) = (); + my(@toolong) = grep(length > $maxlen, @names); + + foreach(@toolong){ + my($trunc) = substr($_,0,$maxlen); + $notuniq{$trunc}=1 if $shorts{$trunc}; + $shorts{$trunc} = ($shorts{$trunc}) ? "$shorts{$trunc}, $_" : $_; + } + if (%notuniq && $warn){ + print "$module: some names are not unique when truncated to $maxlen characters:\n"; + foreach(keys %notuniq){ + print " $shorts{$_} truncate to $_\n"; + } + } + %notuniq; +} + +1; +__END__ + +# test functions so AutoSplit.pm can be applied to itself: +sub test1{ "test 1\n"; } +sub test2{ "test 2\n"; } +sub test3{ "test 3\n"; } +sub test4{ "test 4\n"; } + + diff --git a/lib/Benchmark.pm b/lib/Benchmark.pm new file mode 100644 index 0000000000..a19caffdc8 --- /dev/null +++ b/lib/Benchmark.pm @@ -0,0 +1,245 @@ +package Benchmark; + +# Purpose: benchmark running times of code. +# +# +# Usage - to time code snippets and print results: +# +# timethis($count, '...code...'); +# +# prints: +# timethis 100: 2 secs ( 0.23 usr 0.10 sys = 0.33 cpu) +# +# +# timethese($count, { +# Name1 => '...code1...', +# Name2 => '...code2...', +# ... }); +# prints: +# Benchmark: timing 100 iterations of Name1, Name2... +# Name1: 2 secs ( 0.50 usr 0.00 sys = 0.50 cpu) +# Name2: 1 secs ( 0.48 usr 0.00 sys = 0.48 cpu) +# +# The default display style will automatically add child process +# values if non-zero. +# +# +# Usage - to time sections of your own code: +# +# use Benchmark; +# $t0 = new Benchmark; +# ... your code here ... +# $t1 = new Benchmark; +# $td = &timediff($t1, $t0); +# print "the code took:",timestr($td),"\n"; +# +# $t = &timeit($count, '...other code...') +# print "$count loops of other code took:",timestr($t),"\n"; +# +# +# Data format: +# The data is stored as a list of values from the time and times +# functions: ($real, $user, $system, $children_user, $children_system) +# in seconds for the whole loop (not divided by the number of rounds). +# +# Internals: +# The timing is done using time(3) and times(3). +# +# Code is executed in the callers package +# +# Enable debugging by: $Benchmark::debug = 1; +# +# The time of the null loop (a loop with the same +# number of rounds but empty loop body) is substracted +# from the time of the real loop. +# +# The null loop times are cached, the key being the +# number of rounds. The caching can be controlled using +# &clearcache($key); &clearallcache; +# &disablecache; &enablecache; +# +# Caveats: +# +# The real time timing is done using time(2) and +# the granularity is therefore only one second. +# +# Short tests may produce negative figures because perl +# can appear to take longer to execute the empty loop +# than a short test: try timethis(100,'1'); +# +# The system time of the null loop might be slightly +# more than the system time of the loop with the actual +# code and therefore the difference might end up being < 0 +# +# More documentation is needed :-( +# Especially for styles and formats. +# +# Authors: Jarkko Hietaniemi <Jarkko.Hietaniemi@hut.fi> +# Tim Bunce <Tim.Bunce@ig.co.uk> +# +# +# Last updated: Sept 8th 94 by Tim Bunce +# + +use Exporter; +@ISA=(Exporter); +@EXPORT=qw(timeit timethis timethese timediff timestr); +@EXPORT_OK=qw(clearcache clearallcache disablecache enablecache); + +&init; + +sub init { + $debug = 0; + $min_count = 4; + $min_cpu = 0.4; + $defaultfmt = '5.2f'; + $defaultstyle = 'auto'; + # The cache can cause a slight loss of sys time accuracy. If a + # user does many tests (>10) with *very* large counts (>10000) + # or works on a very slow machine the cache may be useful. + &disablecache; + &clearallcache; +} + +sub clearcache { delete $cache{$_[0]}; } +sub clearallcache { %cache = (); } +sub enablecache { $cache = 1; } +sub disablecache { $cache = 0; } + + +# --- Functions to process the 'time' data type + +sub new { my(@t)=(time, times); print "new=@t\n" if $debug; bless \@t; } + +sub cpu_p { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps ; } +sub cpu_c { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $cu+$cs ; } +sub cpu_a { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps+$cu+$cs ; } +sub real { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $r ; } + +sub timediff{ + my($a, $b) = @_; + my(@r); + for($i=0; $i < @$a; ++$i){ + push(@r, $a->[$i] - $b->[$i]); + } + bless \@r; +} + +sub timestr{ + my($tr, $style, $f) = @_; + my(@t) = @$tr; + warn "bad time value" unless @t==5; + my($r, $pu, $ps, $cu, $cs) = @t; + my($pt, $ct, $t) = ($tr->cpu_p, $tr->cpu_c, $tr->cpu_a); + $f = $defaultfmt unless $f; + # format a time in the required style, other formats may be added here + $style = $defaultstyle unless $style; + $style = ($ct>0) ? 'all' : 'noc' if $style=~/^auto$/; + my($s) = "@t $style"; # default for unknown style + $s=sprintf("%2d secs (%$f usr %$f sys + %$f cusr %$f csys = %$f cpu)", + @t,$t) if $style =~ /^all$/; + $s=sprintf("%2d secs (%$f usr %$f sys = %$f cpu)", + $r,$pu,$ps,$pt) if $style =~ /^noc$/; + $s=sprintf("%2d secs (%$f cusr %$f csys = %$f cpu)", + $r,$cu,$cs,$ct) if $style =~ /^nop$/; + $s; +} +sub timedebug{ + my($msg, $t) = @_; + print STDERR "$msg",timestr($t),"\n" if ($debug); +} + + +# --- Functions implementing low-level support for timing loops + +sub runloop { + my($n, $c) = @_; + my($t0, $t1, $td); # before, after, difference + + # find package of caller so we can execute code there + my ($curpack) = caller(0); + my ($i, $pack)= 0; + while (($pack) = caller(++$i)) { + last if $pack ne $curpack; + } + + my $subcode = "sub { package $pack; my(\$_i)=$n; while (\$_i--){$c;} }"; + my $subref = eval $subcode; + die "runloop unable to compile '$c': $@\ncode: $subcode\n" if $@; + print STDERR "runloop $n '$subcode'\n" if ($debug); + + $t0 = &new; + &$subref; + $t1 = &new; + $td = &timediff($t1, $t0); + + timedebug("runloop:",$td); + $td; +} + + +sub timeit { + my($n, $code) = @_; + my($wn, $wc, $wd); + + printf STDERR "timeit $n $code\n" if $debug; + + if ($cache && exists $cache{$n}){ + $wn = $cache{$n}; + }else{ + $wn = &runloop($n, ''); + $cache{$n} = $wn; + } + + $wc = &runloop($n, $code); + + $wd = timediff($wc, $wn); + + timedebug("timeit: ",$wc); + timedebug(" - ",$wn); + timedebug(" = ",$wd); + + $wd; +} + + +# --- Functions implementing high-level time-then-print utilities + +sub timethis{ + my($n, $code, $title, $style) = @_; + my($t) = timeit($n, $code); + local($|) = 1; + $title = "timethis $n" unless $title; + $style = "" unless $style; + printf("%10s: ", $title); + print timestr($t, $style),"\n"; + # A conservative warning to spot very silly tests. + # Don't assume that your benchmark is ok simply because + # you don't get this warning! + print " (warning: too few iterations for a reliable count)\n" + if ( $n < $min_count + || ($t->real < 1 && $n < 1000) + || $t->cpu_a < $min_cpu); + $t; +} + + +sub timethese{ + my($n, $alt, $style) = @_; + die "usage: timethese(count, { 'Name1'=>'code1', ... }\n" + unless ref $alt eq HASH; + my(@all); + my(@names) = sort keys %$alt; + $style = "" unless $style; + print "Benchmark: timing $n iterations of ",join(', ',@names),"...\n"; + foreach(@names){ + $t = timethis($n, $alt->{$_}, $_, $style); + push(@all, $t); + } + # we could produce a summary from @all here + # sum, min, max, avg etc etc + @all; +} + + +1; diff --git a/lib/Carp.pm b/lib/Carp.pm new file mode 100644 index 0000000000..5daba5c289 --- /dev/null +++ b/lib/Carp.pm @@ -0,0 +1,37 @@ +package Carp; + +# This package implements handy routines for modules that wish to throw +# exceptions outside of the current package. + +require Exporter; +@ISA = Exporter; +@EXPORT = qw(confess croak carp); + +sub longmess { + my $error = shift; + my $mess = ""; + my $i = 2; + my ($pack,$file,$line,$sub); + while (($pack,$file,$line,$sub) = caller($i++)) { + $mess .= "\t$sub " if $error eq "called"; + $mess .= "$error at $file line $line\n"; + $error = "called"; + } + $mess || $error; +} + +sub shortmess { + my $error = shift; + my ($curpack) = caller(1); + my $i = 2; + my ($pack,$file,$line,$sub); + while (($pack,$file,$line,$sub) = caller($i++)) { + return "$error at $file line $line\n" if $pack ne $curpack; + } + longmess $error; +} + +sub confess { die longmess @_; } +sub croak { die shortmess @_; } +sub carp { warn shortmess @_; } + diff --git a/lib/Config.pm b/lib/Config.pm deleted file mode 100644 index 20df7e009d..0000000000 --- a/lib/Config.pm +++ /dev/null @@ -1,362 +0,0 @@ -package Config; -require Exporter; -@ISA = (Exporter); -@EXPORT = qw(%Config); - -$] == 5.000 or die sprintf - "Perl lib version (5.000) doesn't match executable version (%.3f)\n", $]; - - -# -# This file was produced by running the Configure script. It holds all the -# definitions figured out by Configure. Should you modify one of these values, -# do not forget to propagate your changes by running "Configure -der". You may -# instead choose to run each of the .SH files by yourself, or "Configure -S". -# - -# Configuration time: Wed May 4 15:10:39 PDT 1994 -# Configured by: lwall -# Target system: sunos scalpel 4.1.3 3 sun4c - -$Config{'extensions'} = ' ext/dbm/NDBM_File.xs ext/dbm/ODBM_File.xs ext/dbm/SDBM_File.xs ext/posix/POSIX.xs'; -$Config{'d_eunice'} = undef; -$Config{'d_xenix'} = undef; -$Config{'eunicefix'} = ':'; -$Config{'Mcc'} = 'Mcc'; -$Config{'awk'} = '/bin/awk'; -$Config{'bash'} = ''; -$Config{'bison'} = '/usr/local/bin/bison'; -$Config{'byacc'} = 'byacc'; -$Config{'cat'} = '/bin/cat'; -$Config{'chgrp'} = ''; -$Config{'chmod'} = ''; -$Config{'chown'} = ''; -$Config{'compress'} = ''; -$Config{'cp'} = '/bin/cp'; -$Config{'cpio'} = ''; -$Config{'cpp'} = '/usr/lib/cpp'; -$Config{'csh'} = '/bin/csh'; -$Config{'date'} = '/bin/date'; -$Config{'echo'} = '/bin/echo'; -$Config{'egrep'} = '/bin/egrep'; -$Config{'emacs'} = ''; -$Config{'expr'} = '/bin/expr'; -$Config{'find'} = '/bin/find'; -$Config{'flex'} = ''; -$Config{'gcc'} = ''; -$Config{'grep'} = '/bin/grep'; -$Config{'inews'} = ''; -$Config{'ksh'} = ''; -$Config{'less'} = ''; -$Config{'line'} = '/bin/line'; -$Config{'lint'} = ''; -$Config{'ln'} = '/bin/ln'; -$Config{'lp'} = ''; -$Config{'lpr'} = ''; -$Config{'ls'} = ''; -$Config{'mail'} = ''; -$Config{'mailx'} = ''; -$Config{'make'} = ''; -$Config{'mkdir'} = '/bin/mkdir'; -$Config{'more'} = ''; -$Config{'mv'} = '/bin/mv'; -$Config{'nroff'} = '/bin/nroff'; -$Config{'perl'} = '/home/netlabs1/lwall/pl/perl'; -$Config{'pg'} = ''; -$Config{'pmake'} = ''; -$Config{'pr'} = ''; -$Config{'rm'} = '/bin/rm'; -$Config{'rmail'} = ''; -$Config{'sed'} = '/bin/sed'; -$Config{'sendmail'} = ''; -$Config{'sh'} = ''; -$Config{'shar'} = ''; -$Config{'sleep'} = ''; -$Config{'smail'} = ''; -$Config{'sort'} = '/bin/sort'; -$Config{'submit'} = ''; -$Config{'tail'} = ''; -$Config{'tar'} = ''; -$Config{'tbl'} = ''; -$Config{'test'} = 'test'; -$Config{'touch'} = '/bin/touch'; -$Config{'tr'} = '/bin/tr'; -$Config{'troff'} = ''; -$Config{'uname'} = '/bin/uname'; -$Config{'uniq'} = '/bin/uniq'; -$Config{'uuname'} = ''; -$Config{'vi'} = ''; -$Config{'zcat'} = ''; -$Config{'hint'} = 'recommended'; -$Config{'myuname'} = 'sunos scalpel 4.1.3 3 sun4c '; -$Config{'osname'} = 'sunos'; -$Config{'osvers'} = '4.1.3'; -$Config{'Author'} = ''; -$Config{'Date'} = '$Date'; -$Config{'Header'} = ''; -$Config{'Id'} = '$Id'; -$Config{'Locker'} = ''; -$Config{'Log'} = '$Log'; -$Config{'RCSfile'} = '$RCSfile'; -$Config{'Revision'} = '$Revision'; -$Config{'Source'} = ''; -$Config{'State'} = ''; -$Config{'afs'} = 'false'; -$Config{'memalignbytes'} = '8'; -$Config{'bin'} = '/usr/local/bin'; -$Config{'binexp'} = '/usr/local/bin'; -$Config{'installbin'} = '/usr/local/bin'; -$Config{'byteorder'} = '4321'; -$Config{'cc'} = 'cc'; -$Config{'gccversion'} = ''; -$Config{'ccflags'} = '-DDEBUGGING'; -$Config{'cppflags'} = ' -DDEBUGGING'; -$Config{'ldflags'} = ''; -$Config{'lkflags'} = ''; -$Config{'optimize'} = '-g'; -$Config{'cf_by'} = 'lwall'; -$Config{'cf_time'} = 'Wed May 4 15:10:39 PDT 1994'; -$Config{'contains'} = 'grep'; -$Config{'cpplast'} = ''; -$Config{'cppminus'} = ''; -$Config{'cpprun'} = '/usr/lib/cpp'; -$Config{'cppstdin'} = '/tmp_mnt/net/vaccine/export/src/local/lwall/perl5/cppstdin'; -$Config{'d_access'} = 'define'; -$Config{'d_bcmp'} = 'define'; -$Config{'d_bcopy'} = 'define'; -$Config{'d_bzero'} = 'define'; -$Config{'d_casti32'} = 'define'; -$Config{'castflags'} = '0'; -$Config{'d_castneg'} = 'define'; -$Config{'d_charsprf'} = 'define'; -$Config{'d_chsize'} = undef; -$Config{'d_const'} = undef; -$Config{'cryptlib'} = ''; -$Config{'d_crypt'} = 'define'; -$Config{'d_csh'} = 'define'; -$Config{'d_dosuid'} = undef; -$Config{'d_dup2'} = 'define'; -$Config{'d_fchmod'} = 'define'; -$Config{'d_fchown'} = 'define'; -$Config{'d_fcntl'} = 'define'; -$Config{'d_flexfnam'} = 'define'; -$Config{'d_flock'} = 'define'; -$Config{'d_getgrps'} = 'define'; -$Config{'d_gethent'} = undef; -$Config{'aphostname'} = ''; -$Config{'d_gethname'} = undef; -$Config{'d_phostname'} = undef; -$Config{'d_uname'} = 'define'; -$Config{'d_getpgrp2'} = undef; -$Config{'d_getpgrp'} = 'define'; -$Config{'d_getprior'} = 'define'; -$Config{'d_htonl'} = 'define'; -$Config{'d_isascii'} = 'define'; -$Config{'d_killpg'} = 'define'; -$Config{'d_link'} = 'define'; -$Config{'d_lstat'} = 'define'; -$Config{'d_memcmp'} = 'define'; -$Config{'d_memcpy'} = 'define'; -$Config{'d_memmove'} = undef; -$Config{'d_memset'} = 'define'; -$Config{'d_mkdir'} = 'define'; -$Config{'d_msg'} = 'define'; -$Config{'d_msgctl'} = 'define'; -$Config{'d_msgget'} = 'define'; -$Config{'d_msgrcv'} = 'define'; -$Config{'d_msgsnd'} = 'define'; -$Config{'d_open3'} = 'define'; -$Config{'d_portable'} = undef; -$Config{'d_readdir'} = 'define'; -$Config{'d_rewinddir'} = 'define'; -$Config{'d_seekdir'} = 'define'; -$Config{'d_telldir'} = 'define'; -$Config{'d_rename'} = 'define'; -$Config{'d_rmdir'} = 'define'; -$Config{'d_safebcpy'} = 'define'; -$Config{'d_safemcpy'} = undef; -$Config{'d_select'} = 'define'; -$Config{'d_sem'} = 'define'; -$Config{'d_semctl'} = 'define'; -$Config{'d_semget'} = 'define'; -$Config{'d_semop'} = 'define'; -$Config{'d_setegid'} = 'define'; -$Config{'d_seteuid'} = 'define'; -$Config{'d_setlocale'} = 'define'; -$Config{'d_setpgid'} = 'define'; -$Config{'d_setpgrp2'} = undef; -$Config{'d_bsdpgrp'} = ''; -$Config{'d_setpgrp'} = 'define'; -$Config{'d_setprior'} = 'define'; -$Config{'d_setregid'} = 'define'; -$Config{'d_setresgid'} = undef; -$Config{'d_setresuid'} = undef; -$Config{'d_setreuid'} = 'define'; -$Config{'d_setrgid'} = 'define'; -$Config{'d_setruid'} = 'define'; -$Config{'d_setsid'} = 'define'; -$Config{'d_shm'} = 'define'; -$Config{'d_shmat'} = 'define'; -$Config{'d_voidshmat'} = undef; -$Config{'d_shmctl'} = 'define'; -$Config{'d_shmdt'} = 'define'; -$Config{'d_shmget'} = 'define'; -$Config{'d_oldsock'} = undef; -$Config{'d_socket'} = 'define'; -$Config{'d_sockpair'} = 'define'; -$Config{'sockethdr'} = ''; -$Config{'socketlib'} = ''; -$Config{'d_statblks'} = 'define'; -$Config{'d_stdstdio'} = 'define'; -$Config{'d_index'} = undef; -$Config{'d_strchr'} = 'define'; -$Config{'d_strctcpy'} = 'define'; -$Config{'d_strerrm'} = 'define'; -$Config{'d_strerror'} = undef; -$Config{'d_sysernlst'} = ''; -$Config{'d_syserrlst'} = 'define'; -$Config{'d_symlink'} = 'define'; -$Config{'d_syscall'} = 'define'; -$Config{'d_system'} = 'define'; -$Config{'d_time'} = 'define'; -$Config{'timetype'} = 'long'; -$Config{'clocktype'} = 'long'; -$Config{'d_times'} = 'define'; -$Config{'d_truncate'} = 'define'; -$Config{'d_usendir'} = undef; -$Config{'i_ndir'} = undef; -$Config{'ndirc'} = ''; -$Config{'ndirlib'} = ''; -$Config{'ndiro'} = ''; -$Config{'d_vfork'} = undef; -$Config{'d_voidsig'} = 'define'; -$Config{'signal_t'} = 'void'; -$Config{'d_volatile'} = undef; -$Config{'d_charvspr'} = 'define'; -$Config{'d_vprintf'} = 'define'; -$Config{'d_wait4'} = 'define'; -$Config{'d_waitpid'} = 'define'; -$Config{'cccdlflags'} = ''; -$Config{'ccdlflags'} = ''; -$Config{'dldir'} = 'ext/dl'; -$Config{'dlobj'} = 'dl_sunos.o'; -$Config{'dlsrc'} = 'dl_sunos.c'; -$Config{'lddlflags'} = ''; -$Config{'shlibsuffix'} = '.so'; -$Config{'usedl'} = 'define'; -$Config{'gidtype'} = 'gid_t'; -$Config{'groupstype'} = 'int'; -$Config{'h_fcntl'} = 'false'; -$Config{'h_sysfile'} = 'true'; -$Config{'i_dbm'} = 'define'; -$Config{'d_dirnamlen'} = undef; -$Config{'i_dirent'} = 'define'; -$Config{'i_dlfcn'} = 'define'; -$Config{'i_fcntl'} = undef; -$Config{'i_gdbm'} = undef; -$Config{'i_grp'} = 'define'; -$Config{'i_memory'} = 'define'; -$Config{'i_ndbm'} = 'define'; -$Config{'i_neterrno'} = undef; -$Config{'i_niin'} = 'define'; -$Config{'i_sysin'} = undef; -$Config{'d_pwage'} = 'define'; -$Config{'d_pwchange'} = undef; -$Config{'d_pwclass'} = undef; -$Config{'d_pwcomment'} = 'define'; -$Config{'d_pwexpire'} = undef; -$Config{'d_pwquota'} = undef; -$Config{'i_pwd'} = 'define'; -$Config{'i_sdbm'} = 'define'; -$Config{'i_stdarg'} = undef; -$Config{'i_stddef'} = 'define'; -$Config{'i_string'} = 'define'; -$Config{'strings'} = '/usr/include/string.h'; -$Config{'i_sysdir'} = 'define'; -$Config{'i_sysfile'} = 'define'; -$Config{'d_voidtty'} = ''; -$Config{'i_bsdioctl'} = ''; -$Config{'i_sysioctl'} = 'define'; -$Config{'i_syssockio'} = ''; -$Config{'i_sysndir'} = undef; -$Config{'i_sysselct'} = undef; -$Config{'i_sgtty'} = undef; -$Config{'i_termio'} = undef; -$Config{'i_termios'} = 'define'; -$Config{'i_systime'} = 'define'; -$Config{'i_systimek'} = undef; -$Config{'i_time'} = undef; -$Config{'timeincl'} = '/usr/include/sys/time.h '; -$Config{'i_unistd'} = 'define'; -$Config{'i_utime'} = 'define'; -$Config{'i_varargs'} = 'define'; -$Config{'i_varhdr'} = 'varargs.h'; -$Config{'i_vfork'} = undef; -$Config{'intsize'} = '4'; -$Config{'lib'} = '/usr/local/lib'; -$Config{'libexp'} = '/usr/local/lib'; -$Config{'libc'} = '/usr/lib/libc.so.1.8.1'; -$Config{'libpth'} = ' /lib /usr/lib /usr/ucblib /usr/local/lib'; -$Config{'plibpth'} = ''; -$Config{'xlibpth'} = '/usr/lib/386 /lib/386'; -$Config{'libs'} = '-ldbm -ldl -lm -lposix'; -$Config{'lns'} = '/bin/ln -s'; -$Config{'lseektype'} = 'off_t'; -$Config{'d_mymalloc'} = 'define'; -$Config{'mallocobj'} = 'malloc.o'; -$Config{'mallocsrc'} = 'malloc.c'; -$Config{'malloctype'} = 'char *'; -$Config{'usemymalloc'} = 'y'; -$Config{'installmansrc'} = '/usr/local/man/man1'; -$Config{'manext'} = '1'; -$Config{'mansrc'} = '/usr/local/man/man1'; -$Config{'mansrcexp'} = '/usr/local/man/man1'; -$Config{'huge'} = ''; -$Config{'large'} = ''; -$Config{'medium'} = ''; -$Config{'models'} = 'none'; -$Config{'small'} = ''; -$Config{'split'} = ''; -$Config{'mydomain'} = ''; -$Config{'myhostname'} = 'scalpel'; -$Config{'phostname'} = 'hostname'; -$Config{'c'} = ''; -$Config{'n'} = '-n'; -$Config{'groupcat'} = ''; -$Config{'hostcat'} = 'ypcat hosts'; -$Config{'passcat'} = ''; -$Config{'orderlib'} = 'false'; -$Config{'ranlib'} = '/usr/bin/ranlib'; -$Config{'package'} = 'perl'; -$Config{'spackage'} = ''; -$Config{'installprivlib'} = '/usr/local/lib/perl'; -$Config{'privlib'} = '/usr/local/lib/perl'; -$Config{'privlibexp'} = '/usr/local/lib/perl'; -$Config{'prototype'} = undef; -$Config{'ptrsize'} = '4'; -$Config{'randbits'} = '31'; -$Config{'installscript'} = '/usr/local/bin'; -$Config{'scriptdir'} = '/usr/local/bin'; -$Config{'scriptdirexp'} = '/usr/local/bin'; -$Config{'sig_name'} = 'ZERO HUP INT QUIT ILL TRAP ABRT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM URG STOP TSTP CONT CLD TTIN TTOU IO XCPU XFSZ VTALRM PROF WINCH LOST USR1 USR2'; -$Config{'sharpbang'} = '#!'; -$Config{'shsharp'} = 'true'; -$Config{'spitshell'} = 'cat'; -$Config{'startsh'} = '#!/bin/sh'; -$Config{'stdchar'} = 'unsigned char'; -$Config{'sysman'} = '/usr/man/man1'; -$Config{'uidtype'} = 'uid_t'; -$Config{'nm_opt'} = ''; -$Config{'runnm'} = 'true'; -$Config{'usenm'} = 'true'; -$Config{'incpath'} = ''; -$Config{'mips'} = ''; -$Config{'mips_type'} = ''; -$Config{'usrinc'} = '/usr/include'; -$Config{'defvoidused'} = '15'; -$Config{'voidflags'} = '15'; -$Config{'yacc'} = 'yacc'; -$Config{'yaccflags'} = ''; -$Config{'PATCHLEVEL'} = 0; -$Config{'CONFIG'} = 'true'; -1; diff --git a/lib/Cwd.pm b/lib/Cwd.pm new file mode 100644 index 0000000000..719d1d2622 --- /dev/null +++ b/lib/Cwd.pm @@ -0,0 +1,161 @@ +package Cwd; +require 5.000; +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(getcwd fastcwd); +@EXPORT_OK = qw(chdir); + + +# By Brandon S. Allbery +# +# Usage: $cwd = getcwd(); + +sub getcwd +{ + my($dotdots, $cwd, @pst, @cst, $dir, @tst); + + unless (@cst = stat('.')) + { + warn "stat(.): $!"; + return ''; + } + $cwd = ''; + do + { + $dotdots .= '/' if $dotdots; + $dotdots .= '..'; + @pst = @cst; + unless (opendir(PARENT, $dotdots)) + { + warn "opendir($dotdots): $!"; + return ''; + } + unless (@cst = stat($dotdots)) + { + warn "stat($dotdots): $!"; + closedir(PARENT); + return ''; + } + if ($pst[0] == $cst[0] && $pst[1] == $cst[1]) + { + $dir = ''; + } + else + { + do + { + unless ($dir = readdir(PARENT)) + { + warn "readdir($dotdots): $!"; + closedir(PARENT); + return ''; + } + unless (@tst = lstat("$dotdots/$dir")) + { + warn "lstat($dotdots/$dir): $!"; + closedir(PARENT); + return ''; + } + } + while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] || + $tst[1] != $pst[1]); + } + $cwd = "$dir/$cwd"; + closedir(PARENT); + } while ($dir); + chop($cwd); + $cwd; +} + + + +# 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 { + my($odev, $oino, $cdev, $cino, $tdev, $tino); + my(@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; +} + + +# keeps track of current working directory in PWD environment var +# +# $RCSfile: pwd.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:11 $ +# +# $Log: pwd.pl,v $ +# +# Usage: +# use Cwd 'chdir'; +# chdir $newdir; + +$chdir_init = 0; + +sub chdir_init{ + if ($ENV{'PWD'}) { + my($dd,$di) = stat('.'); + my($pd,$pi) = stat($ENV{'PWD'}); + if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) { + chop($ENV{'PWD'} = `pwd`); + } + } + else { + chop($ENV{'PWD'} = `pwd`); + } + if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) { + my($pd,$pi) = stat($2); + my($dd,$di) = stat($1); + if (defined $pd and defined $dd and $di == $pi and $dd == $pd) { + $ENV{'PWD'}="$2$3"; + } + } + $chdir_init = 1; +} + +sub chdir { + my($newdir) = shift; + chdir_init() unless $chdir_init; + return 0 unless (CORE::chdir $newdir); + if ($newdir =~ m#^/#) { + $ENV{'PWD'} = $newdir; + }else{ + my(@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) || '/'; + } +} + +1; + diff --git a/lib/English.pm b/lib/English.pm index 79cceee53c..b203721a52 100644 --- a/lib/English.pm +++ b/lib/English.pm @@ -3,6 +3,8 @@ package English; require Exporter; @ISA = (Exporter); +local($^W) = 0; + @EXPORT = qw( *ARG $MATCH @@ -30,6 +32,7 @@ require Exporter; $FORMAT_FORMFEED $CHILD_ERROR $OS_ERROR + $ERRNO $EVAL_ERROR $PROCESS_ID $PID @@ -101,6 +104,7 @@ require Exporter; *CHILD_ERROR = \$? ; *OS_ERROR = \$! ; + *ERRNO = \$! ; *EVAL_ERROR = \$@ ; # Process info. @@ -131,8 +135,8 @@ require Exporter; # Deprecated. - *ARRAY_BASE = \$[ ; - *OFMT = \$# ; - *MULTILINE_MATCHING = \$* ; +# *ARRAY_BASE = \$[ ; +# *OFMT = \$# ; +# *MULTILINE_MATCHING = \$* ; 1; diff --git a/lib/Env.pm b/lib/Env.pm new file mode 100644 index 0000000000..21870903b4 --- /dev/null +++ b/lib/Env.pm @@ -0,0 +1,69 @@ +package Env; + +=head1 NAME + +Env - Perl module that imports environment variables + +=head1 DESCRIPTION + +Perl maintains environment variables in a pseudo-associative-array +named %ENV. For when this access method is inconvenient, the Perl +module C<Env> allows environment variables to be treated as simple +variables. + +The Env::import() function ties environment variables with suitable +names to global Perl variables with the same names. By default it +does so with all existing environment variables (C<keys %ENV>). If +the import function receives arguments, it takes them to be a list of +environment variables to tie; it's okay if they don't yet exist. + +After an environment variable is tied, merely use it like a normal variable. +You may access its value + + @path = split(/:/, $PATH); + +or modify it + + $PATH .= ":."; + +however you'd like. +To remove a tied environment variable from +the environment, assign it the undefined value + + undef $PATH; + +=head1 AUTHOR + +Chip Salzenberg <chip@fin.uucp> + +=cut + +sub import { + my ($callpack) = caller(0); + my $pack = shift; + my @vars = @_ ? @_ : keys(%ENV); + + foreach (@vars) { + tie ${"${callpack}::$_"}, Env, $_ if /^[A-Za-z_]\w*$/; + } +} + +sub TIESCALAR { + bless \($_[1]); +} + +sub FETCH { + my ($self) = @_; + $ENV{$$self}; +} + +sub STORE { + my ($self, $value) = @_; + if (defined($value)) { + $ENV{$$self} = $value; + } else { + delete $ENV{$$self}; + } +} + +1; diff --git a/lib/Exporter.pm b/lib/Exporter.pm index 0b021b3d71..dce6909b18 100644 --- a/lib/Exporter.pm +++ b/lib/Exporter.pm @@ -2,9 +2,11 @@ package Exporter; require 5.000; -sub import { - my ($callpack, $callfile, $callline) = caller($ExportLevel); +$ExportLevel = 0; + +sub export { my $pack = shift; + my $callpack = shift; my @imports = @_; *exports = \@{"${pack}::EXPORT"}; if (@imports) { @@ -14,11 +16,14 @@ sub import { if (!%exports) { grep(s/^&//, @exports); @exports{@exports} = (1) x @exports; + foreach $extra (@{"${pack}::EXPORT_OK"}) { + $exports{$extra} = 1; + } } foreach $sym (@imports) { if (!$exports{$sym}) { if ($sym !~ s/^&// || !$exports{$sym}) { - warn "$sym is not exported by the $pack module ", + warn qq["$sym" is not exported by the $pack module ], "at $callfile line $callline\n"; $oops++; next; @@ -43,4 +48,10 @@ sub import { } }; +sub import { + local ($callpack, $callfile, $callline) = caller($ExportLevel); + my $pack = shift; + export $pack, $callpack, @_; +} + 1; diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm new file mode 100644 index 0000000000..563241f1da --- /dev/null +++ b/lib/ExtUtils/MakeMaker.pm @@ -0,0 +1,694 @@ +package ExtUtils::MakeMaker; + +# Authors: Andy Dougherty <doughera@lafcol.lafayette.edu> +# Andreas Koenig <k@franz.ww.TU-Berlin.DE> +# Tim Bunce <Tim.Bunce@ig.co.uk> + +# Last Revision: 12 Oct 1994 + +# This utility is designed to write a Makefile for an extension +# module from a Makefile.PL. It is based on the excellent Makefile.SH +# model provided by Andy Dougherty and the perl5-porters. + +# It splits the task of generating the Makefile into several +# subroutines that can be individually overridden. +# Each subroutine returns the text it wishes to have written to +# the Makefile. + +use Config; +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(writeMakefile mkbootstrap $Verbose); +@EXPORT_OK = qw(%att @recognized_att_keys); + +use strict qw(refs); + +# Setup dummy package: +# MY exists for overriding methods to be defined within +unshift(@MY::ISA, qw(MM)); + +$Verbose = 0; +$Subdirs = 0; # set to 1 to have this .PL run all below +$^W=1; + + +# For most extensions it will do to call +# +# use ExtUtils::MakeMaker +# &writeMakefile("potential_libs" => "-L/usr/alpha -lfoo -lbar"); +# +# from Makefile.PL in the extension directory +# It is also handy to include some of the following attributes: +# +@recognized_att_keys=qw( + TOP INC DISTNAME VERSION DEFINE OBJECT LDTARGET ARMAYBE + BACKUP_LIBS AUTOSPLITMAXLEN LINKTYPE + potential_libs otherldflags perl fullperl + distclean_tarflags + clean_files realclean_files +); + +# +# TOP is the directory above lib/ and ext/ (normally ../..) +# (MakeMaker will normally work this out for itself) +# INC is something like "-I/usr/local/Minerva/include" +# DISTNAME is a name of your choice for distributing the package +# VERSION is your version number +# DEFINE is something like "-DHAVE_UNISTD_H" +# OBJECT defaults to '$(BASEEXT).o', but can be a long string containing +# all object files, e.g. "tkpBind.o tkpButton.o tkpCanvas.o" +# LDTARGET defaults to $(OBJECT) and is used in the ld command +# (some machines need additional switches for bigger projects) +# ARMAYBE defaults to ":", but can be used to run ar before ld +# BACKUP_LIBS is an anonymous array of libraries to be searched for +# until we get at least some output from ext/util/extliblist +# 'potential_libs' => "-lgdbm", +# 'BACKUP_LIBS' => [ "-ldbm -lfoo", "-ldbm.nfs" ] +# AUTOSPLITMAXLEN defaults to 8 and is used when autosplit is done +# (can be set higher on a case-by-case basis) +# defaults to `dynamic', can be set to `static' + +# +# `make distclean' builds $(DISTNAME)-$(VERSION).tar.Z after a clean + +# Be aware, that you can also pass attributes into the %att hash table +# by calling Makefile.PL with an argument of the form TOP=/some/where. + +# If the Makefile generated by default does not fit your purpose, +# you may specify private subroutines in the Makefile.PL as there are: +# +# MY->initialize => sub MY::initialize{ ... } +# MY->post_initialize => sub MY::post_initialize{ ... } +# MY->constants => etc +# MY->dynamic +# etc. (see function writeMakefile, for the current breakpoints) +# +# Each subroutines returns the text it wishes to have written to +# the Makefile. To override a section of the Makefile you can +# either say: sub MY::co { "new literal text" } +# or you can edit the default by saying something like: +# sub MY::co { $_=MM->co; s/old text/new text/; $_ } +# +# If you still need a different solution, try to develop another +# subroutine, that fits your needs and submit the diffs to +# perl5-porters or comp.lang.perl as appropriate. + +sub writeMakefile { + %att = @_; + local($\)="\n"; + + foreach (@ARGV){ + $att{$1}=$2 if m/(.*)=(.*)/; + } + print STDOUT "MakeMaker" if $Verbose; + print STDOUT map(" $_ = '$att{$_}'\n", sort keys %att) if ($Verbose && %att); + + MY->initialize(); + + print STDOUT "Writing ext/$att{FULLEXT}/Makefile (with variable substitutions)"; + + open MAKE, ">Makefile" or die "Unable to open Makefile: $!"; + + MY->mkbootstrap(split(" ", $att{'dynaloadlibs'})); + print MAKE MY->post_initialize; + + print MAKE MY->constants; + print MAKE MY->post_constants; + + print MAKE MY->subdir if $Subdirs; + print MAKE MY->dynamic; + print MAKE MY->force; + print MAKE MY->static; + print MAKE MY->co; + print MAKE MY->c; + print MAKE MY->installpm; + print MAKE MY->clean; + print MAKE MY->realclean; + print MAKE MY->test; + print MAKE MY->install; + print MAKE MY->perldepend; + print MAKE MY->distclean; + print MAKE MY->postamble; + + MY->finish; + + close MAKE; + + 1; +} + + +sub mkbootstrap{ + MY->mkbootstrap(@_) +} + + +sub avoid_typo_warnings{ + local($t) = "$t + $main::writeMakefile + $main::mkbootstrap + $main::Verbose + $DynaLoader::dl_resolve_using + $ExtUtils::MakeMaker::Config + $DynaLoader::Config + "; +} + + +# --- Supply the MakeMaker default methods --- + +package MM; + +use Config; +require Exporter; + +Exporter::import('ExtUtils::MakeMaker', qw(%att @recognized_att_keys)); + +# These attributes cannot be overridden +@other_att_keys=qw(extralibs dynaloadlibs statloadlibs bootdep); + + +sub find_perl{ + my($self, $ver, $names, $dirs, $trace) = @_; + my($name, $dir); + print "Looking for perl $ver by these names: @$names, in these dirs: @$dirs\n" + if ($trace); + foreach $dir (@$dirs){ + foreach $name (@$names){ + print "checking $dir/$name\n" if ($trace >= 2); + next unless -x "$dir/$name"; + print "executing $dir/$name\n" if ($trace); + my($out) = `$dir/$name -e 'require $ver; print "5OK\n" ' 2>&1`; + return "$dir/$name" if $out =~ /5OK/; + } + } + warn "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n"; + 0; # false and not empty +} + + +sub initialize { + # Find out directory name. This is also the extension name. + chop($pwd=`pwd`); + + unless ( $top = $att{TOP} ){ + foreach(qw(../.. ../../.. ../../../..)){ + ($top=$_, last) if -f "$_/config.sh"; + } + die "Can't find config.sh" unless -f "$top/config.sh"; + } + chdir $top or die "Couldn't chdir $top: $!"; + chop($abstop=`pwd`); + chdir $pwd; + + # EXTMODNAME = The perl module name for this extension. + # FULLEXT = Full pathname to extension directory. + # BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. + # ROOTEXT = Directory part of FULLEXT. May be empty. + my($p) = $pwd; $p =~ s:^\Q$abstop/ext/\E::; + ($att{EXTMODNAME}=$p) =~ s#/#::#g ; #eg. BSD::Foo::Socket + ($att{FULLEXT} =$p); #eg. BSD/Foo/Socket + ($att{BASEEXT} =$p) =~ s:.*/:: ; #eg. Socket + ($att{ROOTEXT} =$p) =~ s:/?\Q$att{BASEEXT}\E$:: ; #eg. BSD/Foo + + # Find Perl 5. The only contract here is that both 'perl' and 'fullperl' + # will be working versions of perl 5. + $att{'perl'} = MY->find_perl(5.0, [ qw(perl5 perl miniperl) ], + [ $abstop, split(":", $ENV{PATH}) ], 0 ) + unless ($att{'perl'} && -x $att{'perl'}); + + # Define 'fullperl' to be a non-miniperl (used in test: target) + ($att{'fullperl'} = $att{'perl'}) =~ s/miniperl$/perl/ + unless ($att{'fullperl'} && -x $att{'fullperl'}); + + for $key (@recognized_att_keys, @other_att_keys){ + # avoid warnings for uninitialized vars + $att{$key} = "" unless defined $att{$key}; + } + + # compute extralibs, dynaloadlibs and statloadlibs from + # $att{'potential_libs'} + + unless ( &run_extliblist($att{'potential_libs'}) ){ + foreach ( @{$att{'BACKUP_LIBS'} || []} ){ + # Try again. Maybe they have specified some other libraries + last if &run_extliblist($_); + } + } +} + + +sub run_extliblist { + my($potential_libs)=@_; + # Now run ext/util/extliblist to discover what *libs definitions + # are required for the needs of $potential_libs + $ENV{'potential_libs'} = $potential_libs; + $_=`. $abstop/ext/util/extliblist; + echo extralibs=\$extralibs + echo dynaloadlibs=\$dynaloadlibs + echo statloadlibs=\$statloadlibs + echo bootdep=\$bootdep + `; + my(@w); + foreach $line (split "\n", $_){ + chomp $line; + if ($line =~ /(.*)\s*=\s*(.*)$/){ + $att{$1} = $2; + print STDERR " $1 = $2" if $Verbose; + }else{ + push(@w, $line); + } + } + print STDERR "Messages from extliblist:\n", join("\n",@w,'') + if @w ; + join '', @att{qw(extralibs dynaloadlibs statloadlibs)}; +} + + +sub post_initialize{ + ""; +} + + +sub constants { + my(@m); + + $att{BOOTDEP} = (-f "$att{BASEEXT}_BS") ? "$att{BASEEXT}_BS" : ""; + $att{OBJECT} = '$(BASEEXT).o' unless $att{OBJECT}; + $att{LDTARGET} = '$(OBJECT)' unless $att{LDTARGET}; + $att{ARMAYBE} = ":" unless $att{ARMAYBE}; + $att{AUTOSPLITMAXLEN} = 8 unless $att{AUTOSPLITMAXLEN}; + $att{LINKTYPE} = ($Config{'usedl'}) ? 'dynamic' : 'static' + unless $att{LINKTYPE}; + + + push @m, " +# +# This Makefile is for the $att{FULLEXT} extension to perl. +# It was written by Makefile.PL, so don't edit it, edit +# Makefile.PL instead. ANY CHANGES MADE HERE WILL BE LOST! +# + +DISTNAME = $att{DISTNAME} +VERSION = $att{VERSION} + +TOP = $top +ABSTOP = $abstop +PERL = $att{'perl'} +FULLPERL = $att{'fullperl'} +INC = $att{INC} +DEFINE = $att{DEFINE} +OBJECT = $att{OBJECT} +LDTARGET = $att{LDTARGET} +"; + + push @m, " +CC = $Config{'cc'} +LIBC = $Config{'libc'} +LDFLAGS = $Config{'ldflags'} +CLDFLAGS = $Config{'ldflags'} +LINKTYPE = $att{LINKTYPE} +ARMAYBE = $att{ARMAYBE} +RANLIB = $Config{'ranlib'} + +SMALL = $Config{'small'} +LARGE = $Config{'large'} $Config{'split'} +# The following are used to build and install shared libraries for +# dynamic loading. +LDDLFLAGS = $Config{'lddlflags'} +CCDLFLAGS = $Config{'ccdlflags'} +CCCDLFLAGS = $Config{'cccdlflags'} +SO = $Config{'so'} +DLEXT = $Config{'dlext'} +DLSRC = $Config{'dlsrc'} +"; + + push @m, " +# $att{FULLEXT} might need to be linked with some extra libraries. +# EXTRALIBS = full list of libraries needed for static linking. +# Only those libraries that actually exist are included. +# DYNALOADLIBS = list of those libraries that are needed but can be +# linked in dynamically on this platform. On SunOS, for +# example, this would be .so* libraries, but not archive +# libraries. The bootstrap file is installed only if +# this list is not empty. +# STATLOADLIBS = list of those libraries which must be statically +# linked into the shared library. On SunOS 4.1.3, +# for example, I have only an archive version of +# -lm, and it must be linked in statically. +EXTRALIBS = $att{'extralibs'} +DYNALOADLIBS = $att{'dynaloadlibs'} +STATLOADLIBS = $att{'statloadlibs'} + +"; + + push @m, " +# EXTMODNAME = The perl module name for this extension. +# FULLEXT = Full pathname to extension directory. +# BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. +# ROOTEXT = Directory part of FULLEXT. May be empty. +EXTMODNAME = $att{EXTMODNAME} +FULLEXT = $att{FULLEXT} +BASEEXT = $att{BASEEXT} +ROOTEXT = $att{ROOTEXT} +# and for backward compatibility and for AIX support (due to change!) +EXT = $att{BASEEXT} + +# $att{FULLEXT} might have its own typemap +EXTTYPEMAP = ".(-f "typemap" ? "typemap" : "")." +# $att{FULLEXT} might have its own bootstrap support +BOOTSTRAP = $att{BASEEXT}.bs +BOOTDEP = $att{BOOTDEP} +"; + + push @m, ' +# Where to put things: +AUTO = $(TOP)/lib/auto +AUTOEXT = $(TOP)/lib/auto/$(FULLEXT) +INST_BOOT = $(AUTOEXT)/$(BASEEXT).bs +INST_DYNAMIC = $(AUTOEXT)/$(BASEEXT).$(DLEXT) +INST_STATIC = $(BASEEXT).a +INST_PM = $(TOP)/lib/$(FULLEXT).pm +'." +# These two are only used by install: targets +INSTALLPRIVLIB = $Config{'installprivlib'} +INSTALLARCHLIB = $Config{'installarchlib'} +"; + + push @m, "\nshellflags = $Config{'shellflags'}" if $Config{'shellflags'}; + + push @m, q{ +# Tools +SHELL = /bin/sh +CCCMD = `sh $(shellflags) $(ABSTOP)/cflags $@` +XSUBPP = $(TOP)/ext/xsubpp +# the following is a portable way to say mkdir -p +MKPATH = $(PERL) -we '$$"="/"; foreach(split(/\//,$$ARGV[0])){ push(@p, $$_); next if -d "@p"; print "mkdir @p\n"; mkdir("@p",0777)||die "mkdir @p: $$!" } exit 0;' +AUTOSPLITLIB = cd $(TOP); \ + $(PERL) -Ilib -e 'use AutoSplit; $$AutoSplit::Maxlen=}.$att{AUTOSPLITMAXLEN}.q{; autosplit_lib_modules(@ARGV) ;' +}; + + push @m, ' + +all :: + +config :: Makefile + @$(MKPATH) $(AUTOEXT) + +install :: + +'; + + join('',@m); +} + + +sub post_constants{ + ""; +} + + +sub subdir { + my(@m); + foreach $MakefilePL (<*/Makefile.PL>){ + ($subdir=$MakefilePL) =~ s:/Makefile\.PL$:: ; + push @m, " +config :: + \@cd $subdir ; \\ + if test ! -f Makefile; then \\ + test -f Makefile.PL && \$(PERL) -I\$(ABSTOP)/lib Makefile.PL TOP=\$(ABSTOP) ; \\ + fi + +all :: + cd $subdir ; \$(MAKE) config + cd $subdir ; \$(MAKE) all +"; + + } + join('',@m); +} + + +sub co { + ' +.c.o: + $(CCCMD) $(CCCDLFLAGS) $(DEFINE) -I$(TOP) $(INC) $*.c +'; +} + + +sub force { + ' +# Phony target to force checking subdirectories. +FORCE: +'; +} + + +sub dynamic { + ' +all:: $(LINKTYPE) + +# Target for Dynamic Loading: +dynamic:: $(INST_DYNAMIC) $(INST_PM) $(INST_BOOT) + +$(INST_DYNAMIC): $(OBJECT) + @$(MKPATH) $(AUTOEXT) + $(ARMAYBE) cr $(EXTMODNAME).a $(OBJECT) + ld $(LDDLFLAGS) -o $@ $(LDTARGET) '.$att{'otherldflags'}.' $(STATLOADLIBS) + +$(BOOTSTRAP): $(BOOTDEP) + $(PERL) -I$(TOP)/lib -e \'use ExtUtils::MakeMaker; &mkbootstrap("$(DYNALOADLIBS)");\' + touch $(BOOTSTRAP) + +$(INST_BOOT): $(BOOTSTRAP) + @test ! -s $(BOOTSTRAP) || cp $(BOOTSTRAP) $@ +'; +} + + +sub static { + ' +# Target for Static Loading: +static:: $(INST_STATIC) $(INST_PM) + +$(INST_STATIC): $(OBJECT) + ar cr $@ $(OBJECT) + $(RANLIB) $@ + echo $(EXTRALIBS) >> $(TOP)/ext.libs +'; +} + + +sub c { + ' +$(BASEEXT).c: $(BASEEXT).xs $(XSUBPP) $(TOP)/ext/typemap $(EXTTYPEMAP) $(TOP)/cflags + $(PERL) $(XSUBPP) $(BASEEXT).xs >tmp + mv tmp $@ +'; +} + + +sub installpm { + ' +$(INST_PM): $(BASEEXT).pm + @$(MKPATH) $(TOP)/lib/$(ROOTEXT) + rm -f $@ + cp $(BASEEXT).pm $@ + @$(AUTOSPLITLIB) $(EXTMODNAME) +'; +} + + +sub clean { + ' +clean:: + rm -f *.o *.a mon.out core $(BASEEXT).c so_locations + rm -f makefile Makefile $(BOOTSTRAP) $(BASEEXT).bso '.$att{'clean_files'}.' +'; +} + + +sub realclean { + ' +realclean:: clean + rm -f $(INST_DYNAMIC) $(INST_STATIC) $(INST_BOOT) + rm -rf $(INST_PM) $(AUTOEXT) '.$att{'realclean_files'}.' + +purge: realclean +'; +} + + +sub test { + ' +test: all + $(FULLPERL) -I$(TOP)/lib -e \'use Test::Harness; runtests @ARGV;\' t/*.t +'; +} + + +sub install { + ' +# used if installperl will not be installing it for you +install:: all + # not yet defined +'; +} + + +sub distclean { + my($tarflags) = $att{'distclean_tarflags'} || 'cvf'; + ' +distclean: clean + rm -f Makefile *~ t/*~ + cd ..; tar '.$tarflags.' "$(DISTNAME)-$(VERSION).tar" $(BASEEXT) + cd ..; compress "$(DISTNAME)-$(VERSION).tar" +'; +} + + +sub perldepend { + ' +$(OBJECT) : Makefile +$(OBJECT) : $(TOP)/EXTERN.h +$(OBJECT) : $(TOP)/INTERN.h +$(OBJECT) : $(TOP)/XSUB.h +$(OBJECT) : $(TOP)/av.h +$(OBJECT) : $(TOP)/cop.h +$(OBJECT) : $(TOP)/cv.h +$(OBJECT) : $(TOP)/dosish.h +$(OBJECT) : $(TOP)/embed.h +$(OBJECT) : $(TOP)/form.h +$(OBJECT) : $(TOP)/gv.h +$(OBJECT) : $(TOP)/handy.h +$(OBJECT) : $(TOP)/hv.h +$(OBJECT) : $(TOP)/keywords.h +$(OBJECT) : $(TOP)/mg.h +$(OBJECT) : $(TOP)/op.h +$(OBJECT) : $(TOP)/opcode.h +$(OBJECT) : $(TOP)/patchlevel.h +$(OBJECT) : $(TOP)/perl.h +$(OBJECT) : $(TOP)/perly.h +$(OBJECT) : $(TOP)/pp.h +$(OBJECT) : $(TOP)/proto.h +$(OBJECT) : $(TOP)/regcomp.h +$(OBJECT) : $(TOP)/regexp.h +$(OBJECT) : $(TOP)/scope.h +$(OBJECT) : $(TOP)/sv.h +$(OBJECT) : $(TOP)/unixish.h +$(OBJECT) : $(TOP)/util.h +$(TOP)/config.h: $(TOP)/config.sh; cd $(TOP); /bin/sh config_h.SH +$(TOP)/embed.h: $(TOP)/config.sh; cd $(TOP); /bin/sh embed_h.SH +$(TOP)/cflags: $(TOP)/config.sh; cd $(TOP); /bin/sh cflags.SH + +Makefile: Makefile.PL + $(PERL) -I$(TOP)/lib Makefile.PL +'; +} + + +sub postamble{ + ""; +} + + +sub finish { + chmod 0644, "Makefile"; + system("$Config{'eunicefix'} Makefile") unless $Config{'eunicefix'} eq ":"; +} + + + +sub mkbootstrap { +# +# mkbootstrap, by: +# +# Andreas Koenig <k@otto.ww.TU-Berlin.DE> +# Tim Bunce <Tim.Bunce@ig.co.uk> +# Andy Dougherty <doughera@lafcol.lafayette.edu> +# +# This perl script attempts to make a bootstrap file for use by this +# system's DynaLoader. It typically gets called from an extension +# Makefile. +# +# There is no .bs file supplied with the extension. Instead a _BS +# file which has code for the special cases, like posix for berkeley db +# on the NeXT. +# +# This file will get parsed, and produce a maybe empty +# @DynaLoader::dl_resolve_using array for the current architecture. +# That will be extended by $dynaloadlibs, which was computed by Andy's +# extliblist script. If this array still is empty, we do nothing, else +# we write a .bs file with an @DynaLoader::dl_resolve_using array, but +# without any `if's, because there is no longer a need to deal with +# special cases. +# +# The _BS file can put some code into the generated .bs file by placing +# it in $bscode. This is a handy 'escape' mechanism that may prove +# useful in complex situations. +# +# If @DynaLoader::dl_resolve_using contains -L* or -l* entries then +# mkbootstrap will automatically add a dl_findfile() call to the +# generated .bs file. +# + my($self, @dynaloadlibs)=@_; + print STDERR " dynaloadlibs=@dynaloadlibs" if $Verbose; + require DynaLoader; # we need DynaLoader, if the *_BS gets interpreted + import DynaLoader; # we don't say `use', so if DynaLoader is not + # yet built MakeMaker works nonetheless except here + + &initialize unless defined $att{'perl'}; + + rename "$att{BASEEXT}.bs", "$att{BASEEXT}.bso"; + + if (-f "$att{BASEEXT}_BS"){ + $_ = "$att{BASEEXT}_BS"; + package DynaLoader; # execute code as if in DynaLoader + local($osname, $dlsrc) = (); # avoid warnings + ($osname, $dlsrc) = @Config{qw(osname dlsrc)}; + $bscode = ""; + unshift @INC, "."; + require $_; + } + + if ($Config{'dlsrc'} =~ /^dl_dld/){ + package DynaLoader; + push(@dl_resolve_using, dl_findfile('-lc')); + } + + my(@all) = (@dynaloadlibs, @DynaLoader::dl_resolve_using); + my($method) = ''; + if (@all){ + open BS, ">$att{BASEEXT}.bs" + or die "Unable to open $att{BASEEXT}.bs: $!"; + print STDOUT "Writing $att{BASEEXT}.bs\n"; + print STDOUT " containing: @all" if $Verbose; + print BS "# $att{BASEEXT} DynaLoader bootstrap file for $Config{'osname'} architecture.\n"; + print BS "# Do not edit this file, changes will be lost.\n"; + print BS "# This file was automatically generated by the\n"; + print BS "# mkbootstrap routine in ExtUtils/MakeMaker.pm.\n"; + print BS "\@DynaLoader::dl_resolve_using = "; + if (" @all" =~ m/ -[lL]/){ + print BS " dl_findfile(qw(\n @all\n ));\n"; + }else{ + print BS " qw(@all);\n"; + } + # write extra code if *_BS says so + print BS $DynaLoader::bscode if $DynaLoader::bscode; + print BS "1;\n"; + close BS; + } + + if ($Config{'dlsrc'} =~ /^dl_aix/){ + open AIX, ">$att{BASEEXT}.exp"; + print AIX "#!\nboot_$att{BASEEXT}\n"; + close AIX; + } +} + +# the following makes AutoSplit happy (bug in perl5b3e) +package ExtUtils::MakeMaker; +1; + +__END__ diff --git a/lib/FOOBAR.pm b/lib/FOOBAR.pm deleted file mode 100644 index 9013b4eb09..0000000000 --- a/lib/FOOBAR.pm +++ /dev/null @@ -1,10 +0,0 @@ -package FOOBAR; - -require Exporter; -@ISA = (Exporter); -@EXPORT = (foo, bar); - -sub foo { print "FOO\n" }; -sub bar { print "BAR\n" }; - -1; diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm new file mode 100644 index 0000000000..9e2e25e889 --- /dev/null +++ b/lib/File/Basename.pm @@ -0,0 +1,138 @@ +package File::Basename; + +require 5.000; +use Config; +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(fileparse set_fileparse_fstype basename dirname); + +# fileparse_set_fstype() - specify OS-based rules used in future +# calls to routines in this package +# +# Currently recognized values: VMS, MSDOS, MacOS +# Any other name uses Unix-style rules + +sub fileparse_set_fstype { + $Fileparse_fstype = $_[0]; +} + +# fileparse() - parse file specification +# +# calling sequence: +# ($filename,$prefix,$tail) = &basename_pat($filespec,@excludelist); +# where $filespec is the file specification to be parsed, and +# @excludelist is a list of patterns which should be removed +# from the end of $filename. +# $filename is the part of $filespec after $prefix (i.e. the +# name of the file). The elements of @excludelist +# are compared to $filename, and if an +# $prefix is the path portion $filespec, up to and including +# the end of the last directory name +# $tail any characters removed from $filename because they +# matched an element of @excludelist. +# +# fileparse() first removes the directory specification from $filespec, +# according to the syntax of the OS (code is provided below to handle +# VMS, Unix, MSDOS and MacOS; you can pick the one you want using +# fileparse_set_fstype(), or you can accept the default, which is +# based on the information in the %Config array). It then compares +# each element of @excludelist to $filename, and if that element is a +# suffix of $filename, it is removed from $filename and prepended to +# $tail. By specifying the elements of @excludelist in the right order, +# you can 'nibble back' $filename to extract the portion of interest +# to you. +# +# For example, on a system running Unix, +# ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7', +# '\.book\d+'); +# would yield $base == 'draft', +# $path == '/virgil/aeneid', and +# $tail == '.book7'. +# Similarly, on a system running VMS, +# ($name,$dir,$type) = fileparse('Doc_Root:[Help]Rhetoric.Rnh','\..*'); +# would yield $name == 'Rhetoric'; +# $dir == 'Doc_Root:[Help]', and +# $type == '.Rnh'. +# +# Version 2.2 13-Oct-1994 Charles Bailey bailey@genetics.upenn.edu + + +sub fileparse { + my($fullname,@suffices) = @_; + my($fstype) = $Fileparse_fstype; + my($dirpath,$tail,$suffix,$idx); + + if ($fstype =~ /^VMS/i) { + if ($fullname =~ m#/#) { $fstype = '' } # We're doing Unix emulation + else { + ($dirpath,$basename) = ($fullname =~ /(.*[:>\]])?(.*)/); + $dirpath = $ENV{'PATH'} unless $dirpath; + } + } + if ($fstype =~ /^MSDOS/i) { + ($dirpath,$basename) = ($fullname =~ /(.*\\)?(.*)/); + $dirpath = '.' unless $dirpath; + } + elsif ($fstype =~ /^MAC/i) { + ($dirpath,$basename) = ($fullname =~ /(.*:)?(.*)/); + } + else { # default to Unix + ($dirpath,$basename) = ($fullname =~ m#(.*/)?(.*)#); + $dirpath = '.' unless $dirpath; + } + + if (@suffices) { + foreach $suffix (@suffices) { + if ($basename =~ /($suffix)$/) { + $tail = $1 . $tail; + $basename = $`; + } + } + } + + ($basename,$dirpath,$tail); + +} + + +# basename() - returns first element of list returned by fileparse() + +sub basename { + (fileparse(@_))[0]; +} + + +# dirname() - returns device and directory portion of file specification +# Behavior matches that of Unix dirname(1) exactly for Unix and MSDOS +# filespecs. This differs from the second element of the list returned +# by fileparse() in that the trailing '/' (Unix) or '\' (MSDOS) (and +# the last directory name if the filespec ends in a '/' or '\'), is lost. + +sub dirname { + my($basename,$dirname) = fileparse($_[0]); + my($fstype) = $Fileparse_fstype; + + if ($fstype =~ /VMS/i) { + if (m#/#) { $fstype = '' } + else { return $dirname } + } + if ($fstype =~ /MacOS/i) { return $dirname } + elsif ($fstype =~ /MSDOS/i) { + if ( $dirname =~ /:\\$/) { return $dirname } + chop $dirname; + $dirname =~ s:[^/]+$:: unless $basename; + $dirname = '.' unless $dirname; + } + else { + if ( $dirname eq '/') { return $dirname } + chop $dirname; + $dirname =~ s:[^/]+$:: unless $basename; + $dirname = '.' unless $dirname; + } + + $dirname; +} + +$Fileparse_fstype = $Config{'osname'}; + +1; diff --git a/lib/File/CheckTree.pm b/lib/File/CheckTree.pm new file mode 100644 index 0000000000..d3dfa70084 --- /dev/null +++ b/lib/File/CheckTree.pm @@ -0,0 +1,112 @@ +package File::CheckTree; +require 5.000; +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(validate); + +# $RCSfile: validate.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:19 $ + +# 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: +# use File::CheckTree; +# $warnings += 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 || 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; + diff --git a/lib/File/Find.pm b/lib/File/Find.pm new file mode 100644 index 0000000000..612f14525a --- /dev/null +++ b/lib/File/Find.pm @@ -0,0 +1,224 @@ +package File::Find; +require 5.000; +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(find finddepth); + +# Usage: +# use File::Find; +# +# find(\&wanted, '/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); +# } +# +# Set the variable $dont_use_nlink if you're using AFS, since AFS cheats. + +sub find { + my $wanted = shift; + 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; + ($fixtopdir = $topdir) =~ s,/$,, ; + &finddir($wanted,$fixtopdir,$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($wanted,$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 && !$dont_use_nlink) { # 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 || $dont_use_nlink) { # 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($wanted,$name,$nlink); + chdir '..'; + } + --$subcount; + } + } + } + } +} + +# Usage: +# use File::Find; +# +# finddepth(\&wanted, '/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 { + my $wanted = shift; + chop($cwd = `pwd`); + foreach $topdir (@_) { + (($topdev,$topino,$topmode,$topnlink) = stat($topdir)) + || (warn("Can't stat $topdir: $!\n"), next); + if (-d _) { + if (chdir($topdir)) { + ($fixtopdir = $topdir) =~ s,/$,, ; + &finddepthdir($wanted,$fixtopdir,$topnlink); + ($dir,$_) = ($fixtopdir,'.'); + $name = $fixtopdir; + &$wanted; + } + else { + warn "Can't cd to $topdir: $!\n"; + } + } + else { + unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) { + ($dir,$_) = ('.', $topdir); + } + chdir $dir && &$wanted; + } + chdir $cwd; + } +} + +sub finddepthdir { + my($wanted,$dir,$nlink) = @_; + my($dev,$ino,$mode,$subcount); + my($name); + + # Get the list of files in the current directory. + + opendir(DIR,'.') || warn "Can't open $dir: $!\n"; + my(@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($wanted,$name,$nlink); + chdir '..'; + } + --$subcount; + } + } + &$wanted; + } + } +} + +1; + diff --git a/lib/FileHandle.pm b/lib/FileHandle.pm index 2452a15a1f..c45f446667 100644 --- a/lib/FileHandle.pm +++ b/lib/FileHandle.pm @@ -1,12 +1,12 @@ package FileHandle; -BEGIN { - require 5.000; - require English; import English; - require Exporter; -} +# Note that some additional FileHandle methods are defined in POSIX.pm. + +require 5.000; +use English; +use Exporter; -@ISA = (Exporter); +@ISA = qw(Exporter); @EXPORT = qw( print autoflush @@ -21,6 +21,7 @@ BEGIN { format_top_name format_line_break_characters format_formfeed + cacheout ); sub print { @@ -124,4 +125,50 @@ sub format_formfeed { $prev; } + +# --- cacheout functions --- + +# Open in their package. + +sub cacheout_open { + my $pack = caller(1); + open(*{$pack . '::' . $_[0]}, $_[1]); +} + +sub cacheout_close { + my $pack = caller(1); + close(*{$pack . '::' . $_[0]}); +} + +# But only this sub name is visible to them. + +sub cacheout { + ($file) = @_; + if (!$cacheout_maxopen){ + if (open(PARAM,'/usr/include/sys/param.h')) { + local($.); + while (<PARAM>) { + $cacheout_maxopen = $1 - 4 + if /^\s*#\s*define\s+NOFILE\s+(\d+)/; + } + close PARAM; + } + $cacheout_maxopen = 16 unless $cacheout_maxopen; + } + if (!$isopen{$file}) { + if (++$cacheout_numopen > $cacheout_maxopen) { + local(@lru) = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen); + splice(@lru, $cacheout_maxopen / 3); + $cacheout_numopen -= @lru; + for (@lru) { &cacheout_close($_); delete $isopen{$_}; } + } + &cacheout_open($file, ($saw{$file}++ ? '>>' : '>') . $file) + || croak("Can't create $file: $!"); + } + $isopen{$file} = ++$cacheout_seq; +} + +$cacheout_seq = 0; +$cacheout_numopen = 0; + 1; diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm new file mode 100644 index 0000000000..9c66264fdd --- /dev/null +++ b/lib/Getopt/Long.pm @@ -0,0 +1,513 @@ +package Getopt::Long; +require 5.000; +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(GetOptions); + + +# newgetopt.pl -- new options parsing + +# SCCS Status : @(#)@ newgetopt.pl 1.14 +# Author : Johan Vromans +# Created On : Tue Sep 11 15:00:12 1990 +# Last Modified By: Johan Vromans +# Last Modified On: Sat Feb 12 18:24:02 1994 +# Update Count : 138 +# Status : Okay + +################ Introduction ################ +# +# This package implements an extended getopt function. This function adheres +# to the new syntax (long option names, no bundling). +# It tries to implement the better functionality of traditional, GNU and +# POSIX getopt functions. +# +# This program is Copyright 1990,1994 by Johan Vromans. +# This program is free software; you can redistribute it and/or +# modify it under the terms of the GNU General Public License +# as published by the Free Software Foundation; either version 2 +# of the License, or (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# If you do not have a copy of the GNU General Public License write to +# the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, +# MA 02139, USA. + +################ Description ################ +# +# Usage: +# +# require "newgetopt.pl"; +# ...change configuration values, if needed... +# $result = &NGetOpt (...option-descriptions...); +# +# Each description should designate a valid perl identifier, optionally +# followed by an argument specifier. +# +# Values for argument specifiers are: +# +# <none> option does not take an argument +# ! option does not take an argument and may be negated +# =s :s option takes a mandatory (=) or optional (:) string argument +# =i :i option takes a mandatory (=) or optional (:) integer argument +# =f :f option takes a mandatory (=) or optional (:) real number argument +# +# If option "name" is set, it will cause the perl variable $opt_name to +# be set to the specified value. The calling program can use this +# variable to detect whether the option has been set. Options that do +# not take an argument will be set to 1 (one). +# +# Options that take an optional argument will be defined, but set to '' +# if no actual argument has been supplied. +# +# If an "@" sign is appended to the argument specifier, the option is +# treated as an array. Value(s) are not set, but pushed into array +# @opt_name. +# +# Options that do not take a value may have an "!" argument spacifier to +# indicate that they may be negated. E.g. "foo!" will allow -foo (which +# sets $opt_foo to 1) and -nofoo (which will set $opt_foo to 0). +# +# The option name may actually be a list of option names, separated by +# '|'s, e.g. "foo|bar|blech=s". In this example, options 'bar' and +# 'blech' will set $opt_foo instead. +# +# Option names may be abbreviated to uniqueness, depending on +# configuration variable $autoabbrev. +# +# Dashes in option names are allowed (e.g. pcc-struct-return) and will +# be translated to underscores in the corresponding perl variable (e.g. +# $opt_pcc_struct_return). Note that a lone dash "-" is considered an +# option, corresponding perl identifier is $opt_ . +# +# A double dash "--" signals end of the options list. +# +# 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. +# +# The default values for the option starters are "-" (traditional), "--" +# (POSIX) and "+" (GNU, being phased out). +# +# Options that start with "--" may have an argument appended, separated +# with an "=", e.g. "--foo=bar". +# +# If configuration varaible $getopt_compat is set to a non-zero value, +# options that start with "+" may also include their arguments, +# e.g. "+foo=bar". +# +# A return status of 0 (false) indicates that the function detected +# one or more errors. +# +################ Some examples ################ +# +# 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 = '--' +# +# In GNU or POSIX format, option names and values can be combined: +# +# +foo=blech -> $opt_foo = 'blech' +# --bar= -> $opt_bar = '' +# --bar=-- -> $opt_bar = '--' +# +################ Configuration values ################ +# +# $autoabbrev Allow option names to be abbreviated to uniqueness. +# Default is 1 unless environment variable +# POSIXLY_CORRECT has been set. +# +# $getopt_compat Allow '+' to start options. +# Default is 1 unless environment variable +# POSIXLY_CORRECT has been set. +# +# $option_start Regexp with option starters. +# Default is (--|-) if environment variable +# POSIXLY_CORRECT has been set, (--|-|\+) otherwise. +# +# $order Whether non-options are allowed to be mixed with +# options. +# Default is $REQUIRE_ORDER if environment variable +# POSIXLY_CORRECT has been set, $PERMUTE otherwise. +# +# $ignorecase Ignore case when matching options. Default is 1. +# +# $debug Enable debugging output. Default is 0. + +################ History ################ +# +# 12-Feb-1994 Johan Vromans +# Added "!" for negation. +# Released to the net. +# +# 26-Aug-1992 Johan Vromans +# More POSIX/GNU compliance. +# Lone dash and double-dash are now independent of the option prefix +# that is used. +# Make errors in NGetOpt parameters fatal. +# Allow options to be mixed with arguments. +# Check $ENV{"POSIXLY_CORRECT"} to suppress this. +# Allow --foo=bar and +foo=bar (but not -foo=bar). +# Allow options to be abbreviated to minimum needed for uniqueness. +# (Controlled by configuration variable $autoabbrev.) +# Allow alias names for options (e.g. "foo|bar=s"). +# Allow "-" in option names (e.g. --pcc-struct-return). Dashes are +# translated to "_" to form valid perl identifiers +# (e.g. $opt_pcc_struct_return). +# +# 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. + +################ Configuration Section ################ + +{ + + # Values for $order. See GNU getopt.c for details. + $REQUIRE_ORDER = 0; + $PERMUTE = 1; + $RETURN_IN_ORDER = 2; + + # Handle POSIX compliancy. + if ( defined $ENV{"POSIXLY_CORRECT"} ) { + $autoabbrev = 0; # no automatic abbrev of options (???) + $getopt_compat = 0; # disallow '+' to start options + $option_start = "(--|-)"; + $order = $REQUIRE_ORDER; + } + else { + $autoabbrev = 1; # automatic abbrev of options + $getopt_compat = 1; # allow '+' to start options + $option_start = "(--|-|\\+)"; + $order = $PERMUTE; + } + + # Other configurable settings. + $debug = 0; # for debugging + $ignorecase = 1; # ignore case when matching options + $argv_end = "--"; # don't change this! +} + +################ Subroutines ################ + +sub GetOptions { + + @optionlist = @_; #'; + + local ($[) = 0; + local ($genprefix) = $option_start; + local ($argend) = $argv_end; + local ($error) = 0; + local ($opt, $optx, $arg, $type, $mand, %opctl); + local ($pkg) = (caller)[0]; + local ($optarg); + local (%aliases); + local (@ret) = (); + + print STDERR "NGetOpt 1.14 -- 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 . "]"; + } + + # Verify correctness of optionlist. + %opctl = (); + foreach $opt ( @optionlist ) { + $opt =~ tr/A-Z/a-z/ if $ignorecase; + if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse]@?)?$/ ) { + die ("Error in option spec: \"", $opt, "\"\n"); + $error++; + next; + } + local ($o, $c, $a) = ($1, $2); + + if ( ! defined $o ) { + $opctl{''} = defined $c ? $c : ''; + } + else { + # Handle alias names + foreach ( split (/\|/, $o)) { + if ( defined $c && $c eq '!' ) { + $opctl{"no$_"} = $c; + $c = ''; + } + $opctl{$_} = defined $c ? $c : ''; + if ( defined $a ) { + # Note alias. + $aliases{$_} = $a; + } + else { + # Set primary name. + $a = $_; + } + } + } + } + @opctl = sort(keys (%opctl)) if $autoabbrev; + + 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; + $optarg = undef; + $array = 0; + + #### Determine what we have #### + + # Double dash is option list terminator. + if ( $opt eq $argend ) { + unshift (@ret, @ARGV) if $order == $PERMUTE; + return ($error == 0); + } + elsif ( $opt =~ /^$genprefix/ ) { + # Looks like an option. + $opt = $'; # option name (w/o prefix) + # If it is a long opt, it may include the value. + if (($+ eq "--" || ($getopt_compat && $+ eq "+")) && + $opt =~ /^([^=]+)=/ ) { + $opt = $1; + $optarg = $'; + print STDERR ("=> option \"", $opt, + "\", optarg = \"$optarg\"\n") + if $debug; + } + + } + # Not an option. Save it if we may permute... + elsif ( $order == $PERMUTE ) { + push (@ret, $opt); + next; + } + # ...otherwise, terminate. + else { + # Push back and exit. + unshift (@ARGV, $opt); + return ($error == 0); + } + + #### Look it up ### + + $opt =~ tr/A-Z/a-z/ if $ignorecase; + + local ($tryopt) = $opt; + if ( $autoabbrev ) { + local ($pat, @hits); + + # Turn option name into pattern. + ($pat = $opt) =~ s/(\W)/\\$1/g; + # Look up in option names. + @hits = grep (/^$pat/, @opctl); + print STDERR ("=> ", 0+@hits, " hits (@hits) with \"$pat\" ", + "out of ", 0+@opctl, "\n") + if $debug; + + # Check for ambiguous results. + unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) { + print STDERR ("Option ", $opt, " is ambiguous (", + join(", ", @hits), ")\n"); + $error++; + next; + } + + # Complete the option name, if appropriate. + if ( @hits == 1 && $hits[0] ne $opt ) { + $tryopt = $hits[0]; + print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n") + if $debug; + } + } + + unless ( defined ( $type = $opctl{$tryopt} ) ) { + print STDERR ("Unknown option: ", $opt, "\n"); + $error++; + next; + } + $opt = $tryopt; + print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug; + + #### Determine argument status #### + + # If it is an option w/o argument, we're almost finished with it. + if ( $type eq '' || $type eq '!' ) { + if ( defined $optarg ) { + print STDERR ("Option ", $opt, " does not take an argument\n"); + $error++; + } + elsif ( $type eq '' ) { + $arg = 1; # supply explicit value + } + else { + substr ($opt, 0, 2) = ''; # strip NO prefix + $arg = 0; # supply explicit value + } + next; + } + + # Get mandatory status and type info. + ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/; + + # Check if there is an option argument available. + if ( defined $optarg ? ($optarg eq '') : ($#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 = defined $optarg ? $optarg : shift (@ARGV); + + #### Check if the argument is valid for this option #### + + if ( $type eq "s" ) { # string + # A mandatory string takes anything. + next if $mand eq "="; + + # An optional string takes almost anything. + next if defined $optarg; + next if $arg eq "-"; + + # Check for option or option list terminator. + if ($arg eq $argend || + $arg =~ /^$genprefix.+/) { + # Push back. + unshift (@ARGV, $arg); + # Supply empty value. + $arg = ''; + } + next; + } + + if ( $type eq "n" || $type eq "i" ) { # numeric/integer + if ( $arg !~ /^-?[0-9]+$/ ) { + if ( defined $optarg || $mand eq "=" ) { + print STDERR ("Value \"", $arg, "\" invalid for option ", + $opt, " (number expected)\n"); + $error++; + undef $arg; # don't assign it + } + else { + # Push back. + unshift (@ARGV, $arg); + # Supply default value. + $arg = 0; + } + } + next; + } + + if ( $type eq "f" ) { # fixed real number, int is also ok + if ( $arg !~ /^-?[0-9.]+$/ ) { + if ( defined $optarg || $mand eq "=" ) { + print STDERR ("Value \"", $arg, "\" invalid for option ", + $opt, " (real number expected)\n"); + $error++; + undef $arg; # don't assign it + } + else { + # Push back. + unshift (@ARGV, $arg); + # Supply default value. + $arg = 0.0; + } + } + next; + } + + die ("NGetOpt internal error (Can't happen)\n"); + } + + continue { + if ( defined $arg ) { + $opt = $aliases{$opt} if defined $aliases{$opt}; + # Make sure a valid perl identifier results. + $opt =~ s/\W/_/g; + 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;"); + } + } + } + + if ( $order == $PERMUTE && @ret > 0 ) { + unshift (@ARGV, @ret); + } + return ($error == 0); +} + +################ Package return ################ + +1; + + diff --git a/lib/Getopt/Std.pm b/lib/Getopt/Std.pm new file mode 100644 index 0000000000..e1de3b531f --- /dev/null +++ b/lib/Getopt/Std.pm @@ -0,0 +1,104 @@ +package Getopt::Std; +require 5.000; +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(getopt getopts); + +# $RCSfile: getopt.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:58 $ + +# 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: +# getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect. + +sub getopt { + local($argumentative) = @_; + local($_,$first,$rest); + local $Exporter::ExportLevel; + + while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { + ($first,$rest) = ($1,$2); + if (index($argumentative,$first) >= 0) { + if ($rest ne '') { + shift(@ARGV); + } + else { + shift(@ARGV); + $rest = shift(@ARGV); + } + eval "\$opt_$first = \$rest;"; + push( @EXPORT, "\$opt_$first" ); + } + else { + eval "\$opt_$first = 1;"; + push( @EXPORT, "\$opt_$first" ); + if ($rest ne '') { + $ARGV[0] = "-$rest"; + } + else { + shift(@ARGV); + } + } + } + $Exporter::ExportLevel++; + import Getopt::Std; +} + +# Usage: +# 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 $Exporter::ExportLevel; + + @args = split( / */, $argumentative ); + while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { + ($first,$rest) = ($1,$2); + $pos = index($argumentative,$first); + if($pos >= 0) { + if($args[$pos+1] eq ':') { + shift(@ARGV); + if($rest eq '') { + ++$errs unless @ARGV; + $rest = shift(@ARGV); + } + eval "\$opt_$first = \$rest;"; + push( @EXPORT, "\$opt_$first" ); + } + else { + eval "\$opt_$first = 1"; + push( @EXPORT, "\$opt_$first" ); + 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); + } + } + } + $Exporter::ExportLevel++; + import Getopt::Std; + $errs == 0; +} + +1; + diff --git a/lib/I18N/Collate.pm b/lib/I18N/Collate.pm new file mode 100644 index 0000000000..52c78abe83 --- /dev/null +++ b/lib/I18N/Collate.pm @@ -0,0 +1,97 @@ +package I18N::Collate; + +# Collate.pm +# +# Author: Jarkko Hietaniemi <Jarkko.Hietaniemi@hut.fi> +# Helsinki University of Technology, Finland +# +# Acks: Guy Decoux <decoux@moulon.inra.fr> understood +# overloading magic much deeper than I and told +# how to cut the size of this code by more than half. +# (my first version did overload all of lt gt eq le ge cmp) +# +# Purpose: compare 8-bit scalar data according to the current locale +# +# Requirements: Perl5 POSIX::setlocale() and POSIX::strxfrm() +# +# Exports: setlocale 1) +# collate_xfrm 2) +# +# Overloads: cmp # 3) +# +# Usage: use Collate; +# setlocale(&LC_COLLATE, 'locale-of-your-choice'); # 4) +# $s1 = new Collate "scalar_data_1"; +# $s2 = new Collate "scalar_data_2"; +# +# now you can compare $s1 and $s2: $s1 le $s2 +# to extract the data itself, you need to deref: $$s1 +# +# Notes: +# 1) this uses POSIX::setlocale +# 2) the basic collation conversion is done by strxfrm() which +# terminates at NUL characters being a decent C routine. +# collate_xfrm handles embedded NUL characters gracefully. +# 3) due to cmp and overload magic, lt le eq ge gt work also +# 4) the available locales depend on your operating system; +# try whether "locale -a" shows them or the more direct +# approach "ls /usr/lib/nls/loc" or "ls /usr/lib/nls". +# The locale names are probably something like +# 'xx_XX.(ISO)?8859-N'. +# +# Updated: 19940913 1341 GMT +# +# --- + +use POSIX qw(strxfrm LC_COLLATE); + +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(collate_xfrm setlocale LC_COLLATE); +@EXPORT_OK = qw(); + +%OVERLOAD = qw( +fallback 1 +cmp collate_cmp +); + +sub new { my $new = $_[1]; bless \$new } + +sub setlocale { + my ($category, $locale) = @_[0,1]; + + POSIX::setlocale($category, $locale) if (defined $category); + # the current $LOCALE + $LOCALE = $locale || $ENV{'LC_COLLATE'} || $ENV{'LC_ALL'} || ''; +} + +sub C { + my $s = ${$_[0]}; + + $C->{$LOCALE}->{$s} = collate_xfrm($s) + unless (defined $C->{$LOCALE}->{$s}); # cache when met + + $C->{$LOCALE}->{$s}; +} + +sub collate_xfrm { + my $s = $_[0]; + my $x = ''; + + for (split(/(\000+)/, $s)) { + $x .= (/^\000/) ? $_ : strxfrm("$_\000"); + } + + $x; +} + +sub collate_cmp { + &C($_[0]) cmp &C($_[1]); +} + +# init $LOCALE + +&I18N::Collate::setlocale(); + +1; # keep require happy diff --git a/lib/IPC/Open2.pm b/lib/IPC/Open2.pm new file mode 100644 index 0000000000..c59c7d6897 --- /dev/null +++ b/lib/IPC/Open2.pm @@ -0,0 +1,62 @@ +package IPC::Open2; +require 5.000; +require Exporter; +use Carp; + +@ISA = qw(Exporter); +@EXPORT = qw(open2); + +# &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 + +$fh = 'FHOPEN000'; # package static in case called more than once + +sub open2 { + local($kidpid); + local($dad_rdr, $dad_wtr, @cmd) = @_; + + $dad_rdr ne '' || croak "open2: rdr should not be null"; + $dad_wtr ne '' || croak "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) || croak "open2: pipe 1 failed: $!"; + pipe($kid_rdr, $dad_wtr) || croak "open2: pipe 2 failed: $!"; + + if (($kidpid = fork) < 0) { + croak "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; + croak "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/lib/IPC/Open3.pm b/lib/IPC/Open3.pm new file mode 100644 index 0000000000..3426f19111 --- /dev/null +++ b/lib/IPC/Open3.pm @@ -0,0 +1,113 @@ +package IPC::Open3; +require 5.000; +require Exporter; +use Carp; + +@ISA = qw(Exporter); +@EXPORT = qw(open3); + +# &open3: Marc Horowitz <marc@mit.edu> +# derived mostly from &open2 by tom christiansen, <tchrist@convex.com> +# +# $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $ +# +# usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...); +# +# spawn the given $cmd and connect rdr for +# reading, wtr for writing, and err for errors. +# if err is '', or the same as rdr, then stdout and +# stderr of the child are on the same fh. returns pid +# of child, or 0 on failure. + + +# if wtr begins with '>&', then wtr will be closed in the parent, and +# the child will read from it directly. if rdr or err begins with +# '>&', then the child will send output directly to that fd. In both +# cases, there will be a dup() instead of a pipe() made. + + +# 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 + +$fh = 'FHOPEN000'; # package static in case called more than once + +sub open3 { + local($kidpid); + local($dad_wtr, $dad_rdr, $dad_err, @cmd) = @_; + local($dup_wtr, $dup_rdr, $dup_err); + + $dad_wtr || croak "open3: wtr should not be null"; + $dad_rdr || croak "open3: rdr should not be null"; + $dad_err = $dad_rdr if ($dad_err eq ''); + + $dup_wtr = ($dad_wtr =~ s/^\>\&//); + $dup_rdr = ($dad_rdr =~ s/^\>\&//); + $dup_err = ($dad_err =~ s/^\>\&//); + + # force unqualified filehandles into callers' package + local($package) = caller; + $dad_wtr =~ s/^[^']+$/$package'$&/; + $dad_rdr =~ s/^[^']+$/$package'$&/; + $dad_err =~ s/^[^']+$/$package'$&/; + + local($kid_rdr) = ++$fh; + local($kid_wtr) = ++$fh; + local($kid_err) = ++$fh; + + if (!$dup_wtr) { + pipe($kid_rdr, $dad_wtr) || croak "open3: pipe 1 (stdin) failed: $!"; + } + if (!$dup_rdr) { + pipe($dad_rdr, $kid_wtr) || croak "open3: pipe 2 (stdout) failed: $!"; + } + if ($dad_err ne $dad_rdr && !$dup_err) { + pipe($dad_err, $kid_err) || croak "open3: pipe 3 (stderr) failed: $!"; + } + + if (($kidpid = fork) < 0) { + croak "open2: fork failed: $!"; + } elsif ($kidpid == 0) { + if ($dup_wtr) { + open(STDIN, ">&$dad_wtr") if (fileno(STDIN) != fileno($dad_wtr)); + } else { + close($dad_wtr); + open(STDIN, ">&$kid_rdr"); + } + if ($dup_rdr) { + open(STDOUT, ">&$dad_rdr") if (fileno(STDOUT) != fileno($dad_rdr)); + } else { + close($dad_rdr); + open(STDOUT, ">&$kid_wtr"); + } + if ($dad_rdr ne $dad_err) { + if ($dup_err) { + open(STDERR, ">&$dad_err") + if (fileno(STDERR) != fileno($dad_err)); + } else { + close($dad_err); + open(STDERR, ">&$kid_err"); + } + } else { + open(STDERR, ">&STDOUT") if (fileno(STDERR) != fileno(STDOUT)); + } + local($")=(" "); + exec @cmd; + croak "open2: exec of @cmd failed"; + } + + close $kid_rdr; close $kid_wtr; close $kid_err; + if ($dup_wtr) { + close($dad_wtr); + } + + select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe + $kidpid; +} +1; # so require is happy + diff --git a/lib/Math/BigFloat.pm b/lib/Math/BigFloat.pm new file mode 100644 index 0000000000..92e701666f --- /dev/null +++ b/lib/Math/BigFloat.pm @@ -0,0 +1,297 @@ +package Math::BigFloat; + +use Math::BigInt; + +use Exporter; # just for use to be happy +@ISA = (Exporter); + +%OVERLOAD = ( + # Anonymous subroutines: +'+' => sub {new BigFloat &fadd}, +'-' => sub {new BigFloat + $_[2]? fsub($_[1],${$_[0]}) : fsub(${$_[0]},$_[1])}, +'<=>' => sub {new BigFloat + $_[2]? fcmp($_[1],${$_[0]}) : fcmp(${$_[0]},$_[1])}, +'cmp' => sub {new BigFloat + $_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])}, +'*' => sub {new BigFloat &fmul}, +'/' => sub {new BigFloat + $_[2]? scalar fdiv($_[1],${$_[0]}) : + scalar fdiv(${$_[0]},$_[1])}, +'neg' => sub {new BigFloat &fneg}, +'abs' => sub {new BigFloat &fabs}, + +qw( +"" stringify +0+ numify) # Order of arguments unsignificant +); + +sub new { + my $foo = fnorm($_[1]); + panic("Not a number initialized to BigFloat") if $foo eq "NaN"; + bless \$foo; +} +sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead + # comparing to direct compilation based on + # stringify +sub stringify { + my $n = ${$_[0]}; + + $n =~ s/^\+//; + $n =~ s/E//; + + $n =~ s/([-+]\d+)$//; + + my $e = $1; + my $ln = length($n); + + if ($e > 0) { + $n .= "0" x $e . '.'; + } elsif (abs($e) < $ln) { + substr($n, $ln + $e, 0) = '.'; + } else { + $n = '.' . ("0" x (abs($e) - $ln)) . $n; + } + + # 1 while $n =~ s/(.*\d)(\d\d\d)/$1,$2/; + + return $n; +} + +# 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'; + +sub fadd; sub fsub; sub fmul; sub fdiv; +sub fneg; sub fabs; sub fcmp; +sub fround; sub ffround; +sub fnorm; sub fsqrt; + +# 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 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 fneg { #(fnum_str) return fnum_str + local($_) = fnorm($_[$[]); + vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0E+0'; # flip sign + s/^H/N/; + $_; +} + +# absolute value +sub fabs { #(fnum_str) return fnum_str + local($_) = fnorm($_[$[]); + s/^-/+/; # mash sign + $_; +} + +# multiplication +sub fmul { #(fnum_str, fnum_str) return fnum_str + local($x,$y) = (fnorm($_[$[]),fnorm($_[$[+1])); + if ($x eq 'NaN' || $y eq 'NaN') { + 'NaN'; + } else { + local($xm,$xe) = split('E',$x); + local($ym,$ye) = split('E',$y); + &norm(Math::BigInt::bmul($xm,$ym),$xe+$ye); + } +} + +# addition +sub fadd { #(fnum_str, fnum_str) return fnum_str + local($x,$y) = (fnorm($_[$[]),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(Math::BigInt::badd($ym,$xm.('0' x ($xe-$ye))),$ye); + } +} + +# subtraction +sub fsub { #(fnum_str, fnum_str) return fnum_str + fadd($_[$[],fneg($_[$[+1])); +} + +# division +# args are dividend, divisor, scale (optional) +# result has at most max(scale, length(dividend), length(divisor)) digits +sub fdiv #(fnum_str, fnum_str[,scale]) return fnum_str +{ + local($x,$y,$scale) = (fnorm($_[$[]),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(Math::BigInt::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) = Math::BigInt::bcmp(Math::BigInt::bmul($r,'+2'),$base); + if ( $cmp < 0 || + ($cmp == 0 && + ( $rnd_mode eq 'zero' || + ($rnd_mode eq '-inf' && (substr($q,$[,1) eq '+')) || + ($rnd_mode eq '+inf' && (substr($q,$[,1) eq '-')) || + ($rnd_mode eq 'even' && $q =~ /[24680]$/) || + ($rnd_mode eq 'odd' && $q =~ /[13579]$/) )) ) { + $q; # round down + } else { + Math::BigInt::badd($q, ((substr($q,$[,1) eq '-') ? '-1' : '+1')); + # round up + } + } +} + +# round the mantissa of $x to $scale digits +sub fround { #(fnum_str, scale) return fnum_str + local($x,$scale) = (fnorm($_[$[]),$_[$[+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,$[,$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 ffround { #(fnum_str, scale) return fnum_str + local($x,$scale) = (fnorm($_[$[]),$_[$[+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,$[,$xe), + "+0".substr($xm,$[+$xe,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 fcmp #(fnum_str, fnum_str) return cond_code +{ + local($x, $y) = (fnorm($_[$[]),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,$[,1).'1') + || Math::BigInt::cmp($xm,$ym)) + ); + } +} + +# square root by Newtons method. +sub fsqrt { #(fnum_str[, scale]) return fnum_str + local($x, $scale) = (fnorm($_[$[]), $_[$[+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; + } + new BigFloat &fround($guess, $scale); + } +} + +1; diff --git a/lib/Math/BigInt.pm b/lib/Math/BigInt.pm new file mode 100644 index 0000000000..3e0fc17ff6 --- /dev/null +++ b/lib/Math/BigInt.pm @@ -0,0 +1,347 @@ +package Math::BigInt; + +%OVERLOAD = ( + # Anonymous subroutines: +'+' => sub {new BigInt &badd}, +'-' => sub {new BigInt + $_[2]? bsub($_[1],${$_[0]}) : bsub(${$_[0]},$_[1])}, +'<=>' => sub {new BigInt + $_[2]? bcmp($_[1],${$_[0]}) : bcmp(${$_[0]},$_[1])}, +'cmp' => sub {new BigInt + $_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])}, +'*' => sub {new BigInt &bmul}, +'/' => sub {new BigInt + $_[2]? scalar bdiv($_[1],${$_[0]}) : + scalar bdiv(${$_[0]},$_[1])}, +'%' => sub {new BigInt + $_[2]? bmod($_[1],${$_[0]}) : bmod(${$_[0]},$_[1])}, +'**' => sub {new BigInt + $_[2]? bpow($_[1],${$_[0]}) : bpow(${$_[0]},$_[1])}, +'neg' => sub {new BigInt &bneg}, +'abs' => sub {new BigInt &babs}, + +qw( +"" stringify +0+ numify) # Order of arguments unsignificant +); + +sub new { + my $foo = bnorm($_[1]); + die "Not a number initialized to BigInt" if $foo eq "NaN"; + bless \$foo; +} +sub stringify { "${$_[0]}" } +sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead + # comparing to direct compilation based on + # stringify + +# 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 +# + +$zero = 0; + + +# 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 bnorm { #(num_str) return num_str + local($_) = @_; + s/\s+//g; # strip white space + if (s/^([+-]?)0*(\d+)$/$1$2/) { # test if number + substr($_,$[,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,$[,1),length($d)-2); + substr($d,$[,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 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 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 bcmp { #(num_str, num_str) return cond_code + local($x,$y) = (&bnorm($_[$[]),&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 badd { #(num_str, num_str) return num_str + local(*x, *y); ($x, $y) = (&bnorm($_[$[]),&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 bsub { #(num_str, num_str) return num_str + &badd($_[$[],&bneg($_[$[+1])); +} + +# GCD -- Euclids algorithm Knuth Vol 2 pg 296 +sub bgcd { #(num_str, num_str) return num_str + local($x,$y) = (&bnorm($_[$[]),&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 bmul { #(num_str, num_str) return num_str + local(*x, *y); ($x, $y) = (&bnorm($_[$[]), &bnorm($_[$[+1])); + if ($x eq 'NaN') { + 'NaN'; + } elsif ($y eq 'NaN') { + 'NaN'; + } else { + @x = &internal($x); + @y = &internal($y); + &external(&mul(*x,*y)); + } +} + +# multiply two numbers in internal representation +# destroys the arguments, supposes that two arguments are different +sub mul { #(*int_num_array, *int_num_array) return int_num_array + local(*x, *y) = (shift, shift); + local($signr) = (shift @x ne shift @y) ? '-' : '+'; + @prod = (); + for $x (@x) { + ($car, $cty) = (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; + } + ($signr, @x, @prod); +} + +# modulus +sub bmod { #(num_str, num_str) return num_str + (&bdiv(@_))[$[+1]; +} + +sub bdiv { #(dividend: num_str, divisor: num_str) return num_str + local (*x, *y); ($x, $y) = (&bnorm($_[$[]), &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[$[]; + $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[-2,-1]; + while ($#x > $#y) { + ($u2,$u1,$u0) = @x[-3..-1]; + $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 = $[, $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 = $[, $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, $zero)); + } else { + &external($sr, @q); + } +} + +# compute power of two numbers -- stolen from Knuth Vol 2 pg 233 +sub bpow { #(num_str, num_str) return num_str + local(*x, *y); ($x, $y) = (&bnorm($_[$[]), &bnorm($_[$[+1])); + if ($x eq 'NaN') { + 'NaN'; + } elsif ($y eq 'NaN') { + 'NaN'; + } elsif ($x eq '+1') { + '+1'; + } elsif ($x eq '-1') { + &bmod($x,2) ? '-1': '+1'; + } elsif ($y =~ /^-/) { + 'NaN'; + } elsif ($x eq '+0' && $y eq '+0') { + 'NaN'; + } else { + @x = &internal($x); + local(@pow2)=@x; + local(@pow)=&internal("+1"); + local($y1,$res,@tmp1,@tmp2)=(1); # need tmp to send to mul + while ($y ne '+0') { + ($y,$res)=&bdiv($y,2); + if ($res ne '+0') {@tmp=@pow2; @pow=&mul(*pow,*tmp);} + if ($y ne '+0') {@tmp=@pow2;@pow2=&mul(*pow2,*tmp);} + } + &external(@pow); + } +} + +1; diff --git a/lib/Math/Complex.pm b/lib/Math/Complex.pm new file mode 100644 index 0000000000..a5a40b2486 --- /dev/null +++ b/lib/Math/Complex.pm @@ -0,0 +1,136 @@ +# +# Perl5 Package for complex numbers +# +# 1994 by David Nadler +# Coding know-how provided by Tom Christiansen, Tim Bunce, and Larry Wall +# sqrt() added by Tom Christiansen; beware should have two roots, +# but only returns one. (use wantarray?) +# +# +# The functions "Re", "Im", and "arg" are provided. +# "~" is used as the conjugation operator and "abs" is overloaded. +# +# Transcendental functions overloaded: so far only sin, cos, and exp. +# + +package Math::Complex; + +require Exporter; + +@ISA = ('Exporter'); + +# just to make use happy + +%OVERLOAD= ( + '+' => sub { my($x1,$y1,$x2,$y2) = (@{$_[0]},@{$_[1]}); + bless [ $x1+$x2, $y1+$y2]; + }, + + '-' => sub { my($x1,$y1,$x2,$y2) = (@{$_[0]},@{$_[1]}); + bless [ $x1-$x2, $y1-$y2]; + }, + + '*' => sub { my($x1,$y1,$x2,$y2) = (@{$_[0]},@{$_[1]}); + bless [ $x1*$x2-$y1*$y2,$x1*$y2+$x2*$y1]; + }, + + '/' => sub { my($x1,$y1,$x2,$y2) = (@{$_[0]},@{$_[1]}); + my $q = $x2*$x2+$y2*$y2; + bless [($x1*$x2+$y1*$y2)/$q, ($y1*$x2-$y2*$x1)/$q]; + }, + + 'neg' => sub { my($x,$y) = @{$_[0]}; bless [ -$x, -$y]; + }, + + '~' => sub { my($x,$y) = @{$_[0]}; bless [ $x, -$y]; + }, + + 'abs' => sub { my($x,$y) = @{$_[0]}; sqrt $x*$x+$y*$y; + }, + + 'cos' => sub { my($x,$y) = @{$_[0]}; + my ($ab,$c,$s) = (exp $y, cos $x, sin $x); + my $abr = 1/(2*$ab); $ab /= 2; + bless [ ($abr+$ab)*$c, ($abr-$ab)*$s]; + }, + + 'sin' => sub { my($x,$y) = @{$_[0]}; + my ($ab,$c,$s) = (exp $y, cos $x, sin $x); + my $abr = 1/(2*$ab); $ab /= 2; + bless [ (-$abr-$ab)*$s, ($abr-$ab)*$c]; + }, + + 'exp' => sub { my($x,$y) = @{$_[0]}; + my ($ab,$c,$s) = (exp $x, cos $y, sin $y); + bless [ $ab*$c, $ab*$s ]; + }, + + 'sqrt' => sub { + my($zr,$zi) = @{$_[0]}; + my ($x, $y, $r, $w); + my $c = new Math::Complex (0,0); + if (($zr == 0) && ($zi == 0)) { + # nothing, $c already set + } + else { + $x = abs($zr); + $y = abs($zi); + if ($x >= $y) { + $r = $y/$x; + $w = sqrt($x) * sqrt(0.5*(1.0+sqrt(1.0+$r*$r))); + } + else { + $r = $x/$y; + $w = sqrt($y) * sqrt($y) * sqrt(0.5*($r+sqrt(1.0+$r*$r))); + } + if ( $zr >= 0) { + @$c = ($w, $zi/(2 * $w) ); + } + else { + $c->[1] = ($zi >= 0) ? $w : -$w; + $c->[0] = $zi/(2.0* $c->[1]); + } + } + return $c; + }, + + qw("" stringify) +); + +sub new { + shift; + my @C = @_; + bless \@C; +} + +sub Re { + my($x,$y) = @{$_[0]}; + $x; +} + +sub Im { + my($x,$y) = @{$_[0]}; + $y; +} + +sub arg { + my($x,$y) = @{$_[0]}; + atan2($y,$x); +} + +sub stringify { + my($x,$y) = @{$_[0]}; + my($re,$im); + + $re = $x if ($x); + if ($y == 1) {$im = 'i';} + elsif ($y == -1){$im = '-i';} + elsif ($y) {$im = "${y}i"; } + + local $_ = $re.'+'.$im; + s/\+-/-/; + s/^\+//; + s/[\+-]$//; + $_ = 0 if ($_ eq ''); + return $_; +} diff --git a/lib/NDBM_File.pm b/lib/NDBM_File.pm deleted file mode 100644 index 637001f71c..0000000000 --- a/lib/NDBM_File.pm +++ /dev/null @@ -1,9 +0,0 @@ -package NDBM_File; - -require Exporter; -@ISA = (Exporter, DynamicLoader); -@EXPORT = split(' ', 'new fetch store delete firstkey nextkey error clearerr'); - -bootstrap NDBM_File; - -1; diff --git a/lib/Net/Ping.pm b/lib/Net/Ping.pm new file mode 100644 index 0000000000..2528f55255 --- /dev/null +++ b/lib/Net/Ping.pm @@ -0,0 +1,64 @@ +package Net::Ping; + +# Authors: karrer@bernina.ethz.ch (Andreas Karrer) +# pmarquess@bfsec.bt.co.uk (Paul Marquess) + +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(ping pingecho); + +use Socket; +use Carp ; + +$tcp_proto = (getprotobyname('tcp'))[2]; +$echo_port = (getservbyname('echo', 'tcp'))[2]; + +sub ping { + croak "ping not implemented yet. Use pingecho()"; +} + + +sub pingecho { + + croak "usage: pingecho host [timeout]" + unless @_ == 1 || @_ == 2 ; + + local ($host, $timeout) = @_; + local (*PINGSOCK); + local ($saddr, $ip); + local ($ret) ; + + # check if $host is alive by connecting to its echo port, within $timeout + # (default 5) seconds. returns 1 if OK, 0 if no answer, 0 if host not found + + $timeout = 5 unless $timeout; + + if ($host =~ /^\s*((\d+\.){3}\d+)\s*$/) + { $ip = pack ('C4', split (/\./, $1)) } + else + { $ip = (gethostbyname($host))[4] } + + return 0 unless $ip; # "no such host" + + $saddr = pack('S n a4 x8', AF_INET, $echo_port, $ip); + $SIG{'ALRM'} = sub { die } ; + alarm($timeout); + + $ret = eval <<'EOM' ; + + return 0 + unless socket(PINGSOCK, PF_INET, SOCK_STREAM, $tcp_proto) ; + + return 0 + unless connect(PINGSOCK, $saddr) ; + + return 1 ; +EOM + + alarm(0); + close(PINGSOCK); + $ret == 1 ? 1 : 0 ; +} + +1; diff --git a/lib/POSIX.pm b/lib/POSIX.pm deleted file mode 100644 index e2ccbccac0..0000000000 --- a/lib/POSIX.pm +++ /dev/null @@ -1,1232 +0,0 @@ -package POSIX; - -require Exporter; -require AutoLoader; -@ISA = (Exporter, AutoLoader, DynamicLoader); - -$H{assert_h} = [qw(assert NDEBUG)]; - -$H{ctype_h} = [qw(isalnum isalpha iscntrl isdigit isgraph islower - isprint ispunct isspace isupper isxdigit tolower toupper)]; - -$H{dirent_h} = [qw(closedir opendir readdir rewinddir)]; - -$H{errno_h} = [qw(E2BIG EACCES EAGAIN EBADF EBUSY ECHILD EDEADLK EDOM - EEXIST EFAULT EFBIG EINTR EINVAL EIO EISDIR EMFILE - EMLINK ENAMETOOLONG ENFILE ENODEV ENOENT ENOEXEC ENOLCK - ENOMEM ENOSPC ENOSYS ENOTDIR ENOTEMPTY ENOTTY ENXIO - EPERM EPIPE ERANGE EROFS ESPIPE ESRCH EXDEV errno)]; - -$H{fcntl_h} = [qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK - F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK - O_ACCMODE O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK - O_RDONLY O_RDWR O_TRUNC O_WRONLY - creat fcntl open - SEEK_CUR SEEK_END SEEK_SET - S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU - S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG S_ISUID - S_IWGRP S_IWOTH S_IWUSR)]; - -$H{float_h} = [qw(DBL_DIG DBL_EPSILON DBL_MANT_DIG - DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP - DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP - FLT_DIG FLT_EPSILON FLT_MANT_DIG - FLT_MAX FLT_MAX_10_EXP FLT_MAX_EXP - FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP - FLT_RADIX FLT_ROUNDS - LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG - LDBL_MAX LDBL_MAX_10_EXP LDBL_MAX_EXP - LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP)]; - -$H{grp_h} = [qw(getgrgid getgrnam)]; - -$H{limits_h} = [qw( ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX - INT_MAX INT_MIN LINK_MAX LONG_MAX LONG_MIN MAX_CANON - MAX_INPUT MB_LEN_MAX NAME_MAX NGROUPS_MAX OPEN_MAX - PATH_MAX PIPE_BUF SCHAR_MAX SCHAR_MIN SHRT_MAX SHRT_MIN - SSIZE_MAX STREAM_MAX TZNAME_MAX UCHAR_MAX UINT_MAX - ULONG_MAX USHRT_MAX _POSIX_ARG_MAX _POSIX_CHILD_MAX - _POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT - _POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_OPEN_MAX - _POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_SSIZE_MAX - _POSIX_STREADM_MAX _POSIX_TZNAME_MAX)]; - -$H{locale_h} = [qw(LC_ALL LC_COLLATE LC_CTYPE LC_MONETARY LC_NUMERIC - LC_TIME NULL localeconv setlocale)]; - -$H{math_h} = [qw(HUGE_VAL acos asin atan2 atan ceil cos cosh exp - fabs floor fmod frexp ldexp log10 log modf pow sin sinh - sqrt tan tanh)]; - -$H{pwd_h} = [qw(getpwnam getpwuid)]; - -$H{setjmp_h} = [qw(longjmp setjmp siglongjmp sigsetjmp)]; - -$H{signal_h} = [qw(SA_NOCLDSTOP SIGABRT SIGALRM SIGCHLD SIGCONT SIGFPE - SIGHUP SIGILL SIGINT SIGKILL SIGPIPE SIGQUIT SIGSEGV - SIGSTOP SIGTERM SIGTSTP SIGTTIN SIGTTOU SIGUSR1 SIGUSR2 - SIG_BLOCK SIG_DFL SIG_ERR SIG_IGN SIG_SETMASK SIG_UNBLOCK - kill raise sigaction signal sigpending sigprocmask - sigsuspend)]; - -$H{stdarg_h} = [qw()]; - -$H{stddef_h} = [qw(NULL offsetof)]; - -$H{stdio_h} = [qw(BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid - L_tmpname NULL SEEK_CUR SEEK_END SEEK_SET STREAM_MAX - TMP_MAX stderr stdin stdout _IOFBF _IOLBF _IONBF - clearerr fclose fdopen feof ferror fflush fgetc fgetpos - fgets fileno fopen fprintf fputc fputs fread freopen - fscanf fseek fsetpos ftell fwrite getc getchar gets - perror printf putc putchar puts remove rename rewind - scanf setbuf setvbuf sprintf sscanf tmpfile tmpnam - ungetc vfprintf vprintf vsprintf)]; - -$H{stdlib_h} = [qw(EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX NULL RAND_MAX - abort abs atexit atof atoi atol bsearch calloc div exit - free getenv labs ldiv malloc mblen mbstowcs mbtowc - qsort rand realloc srand strtod strtol stroul system - wcstombs wctomb)]; - -$H{string_h} = [qw(NULL memchr memcmp memcpy memmove memset strcat - strchr strcmp strcoll strcpy strcspn strerror strlen - strncat strncmp strncpy strpbrk strrchr strspn strstr - strtok strxfrm)]; - -$H{sys_stat_h} = [qw(S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU - S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG - S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR - chmod fstat mkdir mkfifo stat umask)]; - -$H{sys_times_h} = [qw(times)]; - -$H{sys_types_h} = [qw()]; - -$H{sys_utsname_h} = [qw(uname)]; - -$H{sys_wait_h} = [qw(WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED - WNOHANG WSTOPSIG WTERMSIG WUNTRACED wait waitpid)]; - -$H{termios_h} = [qw( B0 B110 B1200 B134 B150 B1800 B19200 B200 B2400 - B300 B38400 B4800 B50 B600 B75 B9600 BRKINT CLOCAL - CREAD CS5 CS6 CS7 CS8 CSIZE CSTOPB ECHO ECHOE ECHOK - ECHONL HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR - INLCR INPCK ISIG ISTRIP IXOFF IXON NCCS NOFLSH OPOST - PARENB PARMRK PARODD TCIFLUSH TCIOFF TCIOFLUSH TCION - TCOFLUSH TCOOFF TCOON TCSADRAIN TCSAFLUSH TCSANOW - TOSTOP VEOF VEOL VERASE VINTR VKILL VMIN VQUIT VSTART - VSTOP VSUSP VTIME - cfgetispeed cfgetospeed cfsetispeed cfsetospeed tcdrain - tcflow tcflush tcgetattr tcsendbreak tcsetattr )]; - -$H{time_h} = [qw(CLK_TCK CLOCKS_PER_SEC NULL asctime clock ctime - difftime gmtime localtime mktime strftime time tzset tzname)]; - -$H{unistd_h} = [qw(F_OK NULL R_OK SEEK_CUR SEEK_END SEEK_SET - STRERR_FILENO STDIN_FILENO STDOUT_FILENO W_OK X_OK - _PC_CHOWN_RESTRICTED _PC_LINK_MAX _PC_MAX_CANON - _PC_MAX_INPUT _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX - _PC_PIPE_BUF _PC_VDISABLE _POSIX_CHOWN_RESTRICTED - _POSIX_JOB_CONTROL _POSIX_NO_TRUNC _POSIX_SAVED_IDS - _POSIX_VDISABLE _POSIX_VERSION _SC_ARG_MAX - _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL - _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_SAVED_IDS - _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION - _exit access alarm chdir chown close ctermid cuserid - dup2 dup execl execle execlp execv execve execvp fork - fpathconf getcwd getegid geteuid getgid getgroups - getlogin getpgrp getpid getppid getuid isatty link - lseek pathconf pause pipe read rmdir setgid setpgid - setsid setuid sleep sysconf tcgetpgrp tcsetpgrp ttyname - unlink write)]; - -$H{utime_h} = [qw(utime)]; - -sub expand { - local (@mylist); - foreach $entry (@_) { - if ($H{$entry}) { - push(@mylist, @{$H{$entry}}); - } - else { - push(@mylist, $entry); - } - } - @mylist; -} - -@EXPORT = expand qw(assert_h ctype_h dirent_h errno_h fcntl_h float_h - grp_h limits_h locale_h math_h pwd_h setjmp_h signal_h - stdarg_h stddef_h stdio_h stdlib_h string_h sys_stat_h - sys_times_h sys_types_h sys_utsname_h sys_wait_h - termios_h time_h unistd_h utime_h); - -sub import { - my $this = shift; - my @list = expand @_; - local $Exporter::ExportLevel = 1; - Exporter::import($this,@list); -} - -sub AUTOLOAD { - if ($AUTOLOAD =~ /::(_?[a-z])/) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD - } - local $constname = $AUTOLOAD; - $constname =~ s/.*:://; - $val = constant($constname, $_[0]); - if ($! != 0) { - ($pack,$file,$line) = caller; - if ($! =~ /Invalid/) { - die "$constname is not a valid POSIX macro at $file line $line.\n"; - } - else { - die "Your vendor has not defined POSIX macro $constname, used at $file line $line.\n"; - } - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - -bootstrap POSIX; - -sub usage { - local ($mess, $pack, $file, $line) = @_; - die "Usage: POSIX::$mess at $file line $line\n"; -} - -sub unimpl { - local ($mess, $pack, $file, $line) = @_; - $mess =~ s/xxx//; - die "Unimplemented: POSIX::$mess at $file line $line\n"; -} - -$gensym = "SYM000"; - -sub gensym { - $gensym++; -} - -sub ungensym { - delete $_POSIX{$_[0]}; -} - -1; - -package POSIX::SigAction; - -sub new { - bless {HANDLER => $_[1], MASK => $_[2], FLAGS => $_[3]}; -} -__END__ - -sub assert { - usage "assert(expr)", caller if @_ != 1; - if (!$_[0]) { - local ($pack,$file,$line) = caller; - die "Assertion failed at $file line $line\n"; - } -} - -sub tolower { - usage "tolower(string)", caller if @_ != 1; - lc($_[0]); -} - -sub toupper { - usage "toupper(string)", caller if @_ != 1; - uc($_[0]); -} - -sub closedir { - usage "closedir(dirhandle)", caller if @_ != 1; - closedir($_[0]); - ungensym($_[0]); -} - -sub opendir { - usage "opendir(directory)", caller if @_ != 1; - local($dirhandle) = &gensym; - opendir($dirhandle, $_[0]) - ? $dirhandle - : (ungensym($dirhandle), undef); -} - -sub readdir { - usage "readdir(dirhandle)", caller if @_ != 1; - readdir($_[0]); -} - -sub rewinddir { - usage "rewinddir(dirhandle)", caller if @_ != 1; - rewinddir($_[0]); -} - -sub errno { - usage "errno()", caller if @_ != 0; - $! + 0; -} - -sub creat { - usage "creat(filename, mode)", caller if @_ != 2; - &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[2]); -} - -sub fcntl { - usage "fcntl(filehandle, cmd, arg)", caller if @_ != 3; - fcntl($_[0], $_[1], $_[2]); -} - -sub getgrgid { - usage "getgrgid(gid)", caller if @_ != 1; - getgrgid($_[0]); -} - -sub getgrnam { - usage "getgrnam(name)", caller if @_ != 1; - getgrnam($_[0]); -} - -sub atan2 { - usage "atan2(x,y)", caller if @_ != 2; - atan2($_[0], $_[1]); -} - -sub cos { - usage "cos(x)", caller if @_ != 1; - cos($_[0]); -} - -sub exp { - usage "exp(x)", caller if @_ != 1; - exp($_[0]); -} - -sub fabs { - usage "fabs(x)", caller if @_ != 1; - abs($_[0]); -} - -sub log { - usage "log(x)", caller if @_ != 1; - log($_[0]); -} - -sub pow { - usage "pow(x,exponent)", caller if @_ != 2; - $_[0] ** $_[1]; -} - -sub sin { - usage "sin(x)", caller if @_ != 1; - sin($_[0]); -} - -sub sqrt { - usage "sqrt(x)", caller if @_ != 1; - sqrt($_[0]); -} - -sub tan { - usage "tan(x)", caller if @_ != 1; - tan($_[0]); -} - -sub getpwnam { - usage "getpwnam(name)", caller if @_ != 1; - getpwnam($_[0]); -} - -sub getpwuid { - usage "getpwuid(uid)", caller if @_ != 1; - getpwuid($_[0]); -} - -sub longjmp { - unimpl "longjmp() is C-specific: use die instead", caller; -} - -sub setjmp { - unimpl "setjmp() is C-specific: use eval {} instead", caller; -} - -sub siglongjmp { - unimpl "siglongjmp() is C-specific: use die instead", caller; -} - -sub sigsetjmp { - unimpl "sigsetjmp() is C-specific: use eval {} instead", caller; -} - -sub kill { - usage "kill(pid, sig)", caller if @_ != 2; - kill $_[1], $_[0]; -} - -sub raise { - usage "raise(sig)", caller if @_ != 1; - kill $$, $_[0]; # Is this good enough? -} - -sub offsetof { - unimpl "offsetof() is C-specific, stopped", caller; -} - -sub clearerr { - usage "clearerr(filehandle)", caller if @_ != 1; - seek($_[0], 0, 1); -} - -sub fclose { - unimpl "fclose() is C-specific--use close instead", caller; -} - -sub feof { - usage "feof(filehandle)", caller if @_ != 1; - eof($_[0]); -} - -sub fgetc { - usage "fgetc(filehandle)", caller if @_ != 1; - getc($_[0]); -} - -sub fgetpos { - unimpl "fgetpos(xxx)", caller if @_ != 123; - fgetpos($_[0]); -} - -sub fgets { - usage "fgets(filehandle)", caller if @_ != 1; - local($handle) = @_; - scalar <$handle>; -} - -sub fileno { - usage "fileno(filehandle)", caller if @_ != 1; - fileno($_[0]); -} - -sub fopen { - unimpl "fopen() is C-specific--use open instead", caller; -} - -sub fprintf { - unimpl "fprintf() is C-specific--use printf instead", caller; -} - -sub fputc { - unimpl "fputc() is C-specific--use print instead", caller; -} - -sub fputs { - unimpl "fputs() is C-specific--use print instead", caller; - usage "fputs(string, handle)", caller if @_ != 2; - local($handle) = pop; - print $handle @_; -} - -sub fread { - unimpl "fread() is C-specific--use read instead", caller; - unimpl "fread(xxx)", caller if @_ != 123; - fread($_[0]); -} - -sub freopen { - unimpl "freopen() is C-specific--use open instead", caller; - unimpl "freopen(xxx)", caller if @_ != 123; - freopen($_[0]); -} - -sub fscanf { - unimpl "fscanf() is C-specific--use <> and regular expressions instead", caller; - unimpl "fscanf(xxx)", caller if @_ != 123; - fscanf($_[0]); -} - -sub fseek { - unimpl "fseek() is C-specific--use seek instead", caller; - unimpl "fseek(xxx)", caller if @_ != 123; - fseek($_[0]); -} - -sub fsetpos { - unimpl "fsetpos() is C-specific--use seek instead", caller; - unimpl "fsetpos(xxx)", caller if @_ != 123; - fsetpos($_[0]); -} - -sub ftell { - unimpl "ftell() is C-specific--use tell instead", caller; - unimpl "ftell(xxx)", caller if @_ != 123; - ftell($_[0]); -} - -sub fwrite { - unimpl "fwrite() is C-specific--use print instead", caller; - unimpl "fwrite(xxx)", caller if @_ != 123; - fwrite($_[0]); -} - -sub getc { - usage "getc(handle)", caller if @_ != 1; - getc($_[0]); -} - -sub getchar { - usage "getchar()", caller if @_ != 0; - getc(STDIN); -} - -sub gets { - usage "gets(handle)", caller if @_ != 1; - local($handle) = shift; - scalar <$handle>; -} - -sub perror { - unimpl "perror() is C-specific--print $! instead", caller; - unimpl "perror(xxx)", caller if @_ != 123; - perror($_[0]); -} - -sub printf { - usage "printf(pattern, args...)", caller if @_ < 1; - printf STDOUT @_; -} - -sub putc { - unimpl "putc() is C-specific--use print instead", caller; - unimpl "putc(xxx)", caller if @_ != 123; - putc($_[0]); -} - -sub putchar { - unimpl "putchar() is C-specific--use print instead", caller; - unimpl "putchar(xxx)", caller if @_ != 123; - putchar($_[0]); -} - -sub puts { - unimpl "puts() is C-specific--use print instead", caller; - unimpl "puts(xxx)", caller if @_ != 123; - puts($_[0]); -} - -sub remove { - unimpl "remove(xxx)", caller if @_ != 123; - remove($_[0]); -} - -sub rename { - usage "rename(oldfilename, newfilename)", caller if @_ != 2; - rename($_[0], $_[1]); -} - -sub rewind { - unimpl "rewind(xxx)", caller if @_ != 123; - rewind($_[0]); -} - -sub scanf { - unimpl "scanf(xxx)", caller if @_ != 123; - scanf($_[0]); -} - -sub setbuf { - unimpl "setbuf(xxx)", caller if @_ != 123; - setbuf($_[0]); -} - -sub setvbuf { - unimpl "setvbuf(xxx)", caller if @_ != 123; - setvbuf($_[0]); -} - -sub sprintf { - unimpl "sprintf(xxx)", caller if @_ != 123; - sprintf($_[0]); -} - -sub sscanf { - unimpl "sscanf(xxx)", caller if @_ != 123; - sscanf($_[0]); -} - -sub tmpfile { - unimpl "tmpfile(xxx)", caller if @_ != 123; - tmpfile($_[0]); -} - -sub tmpnam { - unimpl "tmpnam(xxx)", caller if @_ != 123; - tmpnam($_[0]); -} - -sub ungetc { - unimpl "ungetc(xxx)", caller if @_ != 123; - ungetc($_[0]); -} - -sub vfprintf { - unimpl "vfprintf(xxx)", caller if @_ != 123; - vfprintf($_[0]); -} - -sub vprintf { - unimpl "vprintf(xxx)", caller if @_ != 123; - vprintf($_[0]); -} - -sub vsprintf { - unimpl "vsprintf(xxx)", caller if @_ != 123; - vsprintf($_[0]); -} - -sub abort { - unimpl "abort(xxx)", caller if @_ != 123; - abort($_[0]); -} - -sub abs { - usage "abs(x)", caller if @_ != 1; - abs($_[0]); -} - -sub atexit { - unimpl "atexit() is C-specific: use END {} instead", caller; -} - -sub atof { - unimpl "atof() is C-specific, stopped", caller; -} - -sub atoi { - unimpl "atoi() is C-specific, stopped", caller; -} - -sub atol { - unimpl "atol() is C-specific, stopped", caller; -} - -sub bsearch { - unimpl "bsearch(xxx)", caller if @_ != 123; - bsearch($_[0]); -} - -sub calloc { - unimpl "calloc(xxx)", caller if @_ != 123; - calloc($_[0]); -} - -sub div { - unimpl "div(xxx)", caller if @_ != 123; - div($_[0]); -} - -sub exit { - unimpl "exit(xxx)", caller if @_ != 123; - exit($_[0]); -} - -sub free { - unimpl "free(xxx)", caller if @_ != 123; - free($_[0]); -} - -sub getenv { - unimpl "getenv(xxx)", caller if @_ != 123; - getenv($_[0]); -} - -sub labs { - unimpl "labs(xxx)", caller if @_ != 123; - labs($_[0]); -} - -sub ldiv { - unimpl "ldiv(xxx)", caller if @_ != 123; - ldiv($_[0]); -} - -sub malloc { - unimpl "malloc(xxx)", caller if @_ != 123; - malloc($_[0]); -} - -sub mblen { - unimpl "mblen(xxx)", caller if @_ != 123; - mblen($_[0]); -} - -sub mbstowcs { - unimpl "mbstowcs(xxx)", caller if @_ != 123; - mbstowcs($_[0]); -} - -sub mbtowc { - unimpl "mbtowc(xxx)", caller if @_ != 123; - mbtowc($_[0]); -} - -sub qsort { - unimpl "qsort(xxx)", caller if @_ != 123; - qsort($_[0]); -} - -sub rand { - unimpl "rand(xxx)", caller if @_ != 123; - rand($_[0]); -} - -sub realloc { - unimpl "realloc(xxx)", caller if @_ != 123; - realloc($_[0]); -} - -sub srand { - unimpl "srand(xxx)", caller if @_ != 123; - srand($_[0]); -} - -sub strtod { - unimpl "strtod(xxx)", caller if @_ != 123; - strtod($_[0]); -} - -sub strtol { - unimpl "strtol(xxx)", caller if @_ != 123; - strtol($_[0]); -} - -sub stroul { - unimpl "stroul(xxx)", caller if @_ != 123; - stroul($_[0]); -} - -sub system { - usage "system(command)", caller if @_ != 1; - system($_[0]); -} - -sub wcstombs { - unimpl "wcstombs(xxx)", caller if @_ != 123; - wcstombs($_[0]); -} - -sub wctomb { - unimpl "wctomb(xxx)", caller if @_ != 123; - wctomb($_[0]); -} - -sub memchr { - unimpl "memchr(xxx)", caller if @_ != 123; - memchr($_[0]); -} - -sub memcmp { - unimpl "memcmp(xxx)", caller if @_ != 123; - memcmp($_[0]); -} - -sub memcpy { - unimpl "memcpy(xxx)", caller if @_ != 123; - memcpy($_[0]); -} - -sub memmove { - unimpl "memmove(xxx)", caller if @_ != 123; - memmove($_[0]); -} - -sub memset { - unimpl "memset(xxx)", caller if @_ != 123; - memset($_[0]); -} - -sub strcat { - unimpl "strcat(xxx)", caller if @_ != 123; - strcat($_[0]); -} - -sub strchr { - unimpl "strchr(xxx)", caller if @_ != 123; - strchr($_[0]); -} - -sub strcmp { - unimpl "strcmp(xxx)", caller if @_ != 123; - strcmp($_[0]); -} - -sub strcoll { - unimpl "strcoll(xxx)", caller if @_ != 123; - strcoll($_[0]); -} - -sub strcpy { - unimpl "strcpy(xxx)", caller if @_ != 123; - strcpy($_[0]); -} - -sub strcspn { - unimpl "strcspn(xxx)", caller if @_ != 123; - strcspn($_[0]); -} - -sub strerror { - unimpl "strerror(xxx)", caller if @_ != 123; - strerror($_[0]); -} - -sub strlen { - unimpl "strlen(xxx)", caller if @_ != 123; - strlen($_[0]); -} - -sub strncat { - unimpl "strncat(xxx)", caller if @_ != 123; - strncat($_[0]); -} - -sub strncmp { - unimpl "strncmp(xxx)", caller if @_ != 123; - strncmp($_[0]); -} - -sub strncpy { - unimpl "strncpy(xxx)", caller if @_ != 123; - strncpy($_[0]); -} - -sub strpbrk { - unimpl "strpbrk(xxx)", caller if @_ != 123; - strpbrk($_[0]); -} - -sub strrchr { - unimpl "strrchr(xxx)", caller if @_ != 123; - strrchr($_[0]); -} - -sub strspn { - unimpl "strspn(xxx)", caller if @_ != 123; - strspn($_[0]); -} - -sub strstr { - unimpl "strstr(xxx)", caller if @_ != 123; - strstr($_[0]); -} - -sub strtok { - unimpl "strtok(xxx)", caller if @_ != 123; - strtok($_[0]); -} - -sub strxfrm { - unimpl "strxfrm(xxx)", caller if @_ != 123; - strxfrm($_[0]); -} - -sub chmod { - usage "chmod(filename, mode)", caller if @_ != 2; - chmod($_[0], $_[1]); -} - -sub fstat { - usage "fstat(fd)", caller if @_ != 1; - local(*TMP); - open(TMP, "<&$_[0]"); # Gross. - local(@l) = stat(TMP); - close(TMP); - @l; -} - -sub mkdir { - usage "mkdir(directoryname, mode)", caller if @_ != 2; - mkdir($_[0], $_[1]); -} - -sub mkfifo { - unimpl "mkfifo(xxx)", caller if @_ != 123; - mkfifo($_[0]); -} - -sub stat { - usage "stat(filename)", caller if @_ != 1; - stat($_[0]); -} - -sub umask { - usage "umask(mask)", caller if @_ != 1; - umask($_[0]); -} - -sub times { - usage "times()", caller if @_ != 0; - times(); -} - -sub wait { - usage "wait(statusvariable)", caller if @_ != 1; - local $result = wait(); - $_[0] = $?; - $result; -} - -sub waitpid { - usage "waitpid(pid, statusvariable, options)", caller if @_ != 3; - local $result = waitpid($_[0], $_[2]); - $_[1] = $?; - $result; -} - -sub cfgetispeed { - unimpl "cfgetispeed(xxx)", caller if @_ != 123; - cfgetispeed($_[0]); -} - -sub cfgetospeed { - unimpl "cfgetospeed(xxx)", caller if @_ != 123; - cfgetospeed($_[0]); -} - -sub cfsetispeed { - unimpl "cfsetispeed(xxx)", caller if @_ != 123; - cfsetispeed($_[0]); -} - -sub cfsetospeed { - unimpl "cfsetospeed(xxx)", caller if @_ != 123; - cfsetospeed($_[0]); -} - -sub tcdrain { - unimpl "tcdrain(xxx)", caller if @_ != 123; - tcdrain($_[0]); -} - -sub tcflow { - unimpl "tcflow(xxx)", caller if @_ != 123; - tcflow($_[0]); -} - -sub tcflush { - unimpl "tcflush(xxx)", caller if @_ != 123; - tcflush($_[0]); -} - -sub tcgetattr { - unimpl "tcgetattr(xxx)", caller if @_ != 123; - tcgetattr($_[0]); -} - -sub tcsendbreak { - unimpl "tcsendbreak(xxx)", caller if @_ != 123; - tcsendbreak($_[0]); -} - -sub tcsetattr { - unimpl "tcsetattr(xxx)", caller if @_ != 123; - tcsetattr($_[0]); -} - -sub asctime { - unimpl "asctime(xxx)", caller if @_ != 123; - asctime($_[0]); -} - -sub clock { - unimpl "clock(xxx)", caller if @_ != 123; - clock($_[0]); -} - -sub ctime { - unimpl "ctime(xxx)", caller if @_ != 123; - ctime($_[0]); -} - -sub difftime { - unimpl "difftime(xxx)", caller if @_ != 123; - difftime($_[0]); -} - -sub gmtime { - unimpl "gmtime(xxx)", caller if @_ != 123; - gmtime($_[0]); -} - -sub localtime { - unimpl "localtime(xxx)", caller if @_ != 123; - localtime($_[0]); -} - -sub mktime { - unimpl "mktime(xxx)", caller if @_ != 123; - mktime($_[0]); -} - -sub strftime { - unimpl "strftime(xxx)", caller if @_ != 123; - strftime($_[0]); -} - -sub time { - unimpl "time(xxx)", caller if @_ != 123; - time($_[0]); -} - -sub tzset { - unimpl "tzset(xxx)", caller if @_ != 123; - tzset($_[0]); -} - -sub tzname { - unimpl "tzname(xxx)", caller if @_ != 123; - tzname($_[0]); -} - -sub _exit { - unimpl "_exit(xxx)", caller if @_ != 123; - _exit($_[0]); -} - -sub access { - unimpl "access(xxx)", caller if @_ != 123; - access($_[0]); -} - -sub alarm { - unimpl "alarm(xxx)", caller if @_ != 123; - alarm($_[0]); -} - -sub chdir { - unimpl "chdir(xxx)", caller if @_ != 123; - chdir($_[0]); -} - -sub chown { - usage "chown(filename, uid, gid)", caller if @_ != 3; - chown($_[0], $_[1], $_[2]); -} - -sub close { - unimpl "close(xxx)", caller if @_ != 123; - close($_[0]); -} - -sub ctermid { - unimpl "ctermid(xxx)", caller if @_ != 123; - ctermid($_[0]); -} - -sub cuserid { - unimpl "cuserid(xxx)", caller if @_ != 123; - cuserid($_[0]); -} - -sub dup2 { - unimpl "dup2(xxx)", caller if @_ != 123; - dup2($_[0]); -} - -sub dup { - unimpl "dup(xxx)", caller if @_ != 123; - dup($_[0]); -} - -sub execl { - unimpl "execl(xxx)", caller if @_ != 123; - execl($_[0]); -} - -sub execle { - unimpl "execle(xxx)", caller if @_ != 123; - execle($_[0]); -} - -sub execlp { - unimpl "execlp(xxx)", caller if @_ != 123; - execlp($_[0]); -} - -sub execv { - unimpl "execv(xxx)", caller if @_ != 123; - execv($_[0]); -} - -sub execve { - unimpl "execve(xxx)", caller if @_ != 123; - execve($_[0]); -} - -sub execvp { - unimpl "execvp(xxx)", caller if @_ != 123; - execvp($_[0]); -} - -sub fork { - usage "fork()", caller if @_ != 0; - fork; -} - -sub fpathconf { - unimpl "fpathconf(xxx)", caller if @_ != 123; - fpathconf($_[0]); -} - -sub getcwd { - unimpl "getcwd(xxx)", caller if @_ != 123; - getcwd($_[0]); -} - -sub getegid { - usage "getegid()", caller if @_ != 0; - $) + 0; -} - -sub geteuid { - usage "geteuid()", caller if @_ != 0; - $> + 0; -} - -sub getgid { - usage "getgid()", caller if @_ != 0; - $( + 0; -} - -sub getgroups { - usage "getgroups()", caller if @_ != 0; - local(%seen) = (); - grep(!%seen{$_}++, split(' ', $) )); -} - -sub getlogin { - usage "getlogin(xxx)", caller if @_ != 0; - getlogin(); -} - -sub getpgrp { - usage "getpgrp()", caller if @_ != 0; - getpgrp($_[0]); -} - -sub getpid { - usage "getpid()", caller if @_ != 0; - $$; -} - -sub getppid { - usage "getppid()", caller if @_ != 0; - getppid; -} - -sub getuid { - usage "getuid()", caller if @_ != 0; - $<; -} - -sub isatty { - unimpl "isatty(xxx)", caller if @_ != 123; - isatty($_[0]); -} - -sub link { - usage "link(oldfilename, newfilename)", caller if @_ != 2; - link($_[0], $_[1]); -} - -sub lseek { - unimpl "lseek(xxx)", caller if @_ != 123; - lseek($_[0]); -} - -sub pathconf { - unimpl "pathconf(xxx)", caller if @_ != 123; - pathconf($_[0]); -} - -sub pause { - unimpl "pause(xxx)", caller if @_ != 123; - pause($_[0]); -} - -sub pipe { - unimpl "pipe(xxx)", caller if @_ != 123; - pipe($_[0]); -} - -sub read { - unimpl "read(xxx)", caller if @_ != 123; - read($_[0]); -} - -sub rmdir { - usage "rmdir(directoryname)", caller if @_ != 1; - rmdir($_[0]); -} - -sub setgid { - unimpl "setgid(xxx)", caller if @_ != 123; - setgid($_[0]); -} - -sub setpgid { - unimpl "setpgid(xxx)", caller if @_ != 123; - setpgid($_[0]); -} - -sub setsid { - unimpl "setsid(xxx)", caller if @_ != 123; - setsid($_[0]); -} - -sub setuid { - unimpl "setuid(xxx)", caller if @_ != 123; - setuid($_[0]); -} - -sub sleep { - unimpl "sleep(xxx)", caller if @_ != 123; - sleep($_[0]); -} - -sub sysconf { - unimpl "sysconf(xxx)", caller if @_ != 123; - sysconf($_[0]); -} - -sub tcgetpgrp { - unimpl "tcgetpgrp(xxx)", caller if @_ != 123; - tcgetpgrp($_[0]); -} - -sub tcsetpgrp { - unimpl "tcsetpgrp(xxx)", caller if @_ != 123; - tcsetpgrp($_[0]); -} - -sub ttyname { - unimpl "ttyname(xxx)", caller if @_ != 123; - ttyname($_[0]); -} - -sub unlink { - usage "unlink(filename)", caller if @_ != 1; - unlink($_[0]); -} - -sub write { - unimpl "write(xxx)", caller if @_ != 123; - write($_[0]); -} - -sub utime { - usage "utime(filename, atime, mtime)", caller if @_ != 3; - utime($_[1], $_[2], $_[0]); -} - diff --git a/lib/SDBM_File.pm b/lib/SDBM_File.pm deleted file mode 100644 index 544f66f237..0000000000 --- a/lib/SDBM_File.pm +++ /dev/null @@ -1,9 +0,0 @@ -package SDBM_File; - -require Exporter; -@ISA = (Exporter, DynamicLoader); -@EXPORT = qw(new fetch store delete firstkey nextkey error clearerr); - -bootstrap SDBM_File; - -1; diff --git a/lib/Search/Dict.pm b/lib/Search/Dict.pm new file mode 100644 index 0000000000..10aa4ff583 --- /dev/null +++ b/lib/Search/Dict.pm @@ -0,0 +1,52 @@ +package Search::Dict; +require 5.000; +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(look); + +# 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 =~ tr/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; + tr/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/lib/Shell.pm b/lib/Shell.pm new file mode 100644 index 0000000000..8098bf2892 --- /dev/null +++ b/lib/Shell.pm @@ -0,0 +1,47 @@ +package Shell; + +sub import { + my $self = shift; + my ($callpack, $callfile, $callline) = caller; + my @EXPORT; + if (@_) { + @EXPORT = @_; + } + else { + @EXPORT = 'AUTOLOAD'; + } + foreach $sym (@EXPORT) { + *{"${callpack}::$sym"} = \&{"Shell::$sym"}; + } +}; + +AUTOLOAD { + my $cmd = $AUTOLOAD; + $cmd =~ s/^.*:://; + eval qq { + sub $AUTOLOAD { + if (\@_ < 2) { + `$cmd \@_`; + } + else { + open(SUBPROC, "-|") + or exec '$cmd', \@_ + or die "Can't exec $cmd: \$!\n"; + if (wantarray) { + my \@ret = <SUBPROC>; + close SUBPROC; # XXX Oughta use a destructor. + \@ret; + } + else { + local(\$/) = undef; + my \$ret = <SUBPROC>; + close SUBPROC; + \$ret; + } + } + } + }; + goto &$AUTOLOAD; +} + +1; diff --git a/lib/Hostname.pm b/lib/Sys/Hostname.pm index f61592eebe..4dd4fe2bdc 100644 --- a/lib/Hostname.pm +++ b/lib/Sys/Hostname.pm @@ -1,30 +1,35 @@ # by David Sundstrom sunds@asictest.sc.ti.com # Texas Instruments -package Hostname; +package Sys::Hostname; +use Carp; require Exporter; -@ISA = (Exporter); -@EXPORT = (hostname); +@ISA = qw(Exporter); +@EXPORT = qw(hostname); # # Try every conceivable way to get hostname. # sub hostname { + # method 1 - we already know it return $host if defined $host; # method 2 - syscall is preferred since it avoids tainting problems eval { - require "syscall.ph"; + { + package main; + require "syscall.ph"; + } $host = "\0" x 65; ## preload scalar - syscall(&SYS_gethostname, $host, 65) == 0; + syscall(&main::SYS_gethostname, $host, 65) == 0; } # method 3 - trusty old hostname command || eval { - $host = `hostname 2>/dev/null`; # bsdish + $host = `(hostname) 2>/dev/null`; # bsdish } # method 4 - sysV uname command (may truncate) @@ -38,7 +43,7 @@ sub hostname { } # bummer - || die "Cannot get host name of local machine\n"; + || Carp::croak "Cannot get host name of local machine"; # remove garbage $host =~ tr/\0\r\n//d; diff --git a/lib/Sys/Syslog.pm b/lib/Sys/Syslog.pm new file mode 100644 index 0000000000..0f7859e226 --- /dev/null +++ b/lib/Sys/Syslog.pm @@ -0,0 +1,195 @@ +package Sys::Syslog; +require 5.000; +require Exporter; +use Carp; + +@ISA = qw(Exporter); +@EXPORT = qw(openlog closelog setlogmask syslog); + +# +# syslog.pl +# +# $Log: syslog.pl,v $ +# +# 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: use Syslog; +# +# then (put these all in a script to test function) +# +# openlog($program,'cons,pid','user'); +# syslog('info','this is another test'); +# syslog('mail|warning','this is a better test: %d', time); +# closelog(); +# +# syslog('debug','this is the last test'); +# openlog("$program $$",'ndelay','user'); +# syslog('notice','fooprogram: this is really done'); +# +# $! = 55; +# syslog('info','problem was %m'); # %m == $! in syslog(3) + +$host = 'localhost' unless $host; # set $Syslog::host to change + +require 'syslog.ph'; + +$maskpri = &LOG_UPTO(&LOG_DEBUG); + +sub 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 closelog { + $facility = $ident = ''; + &disconnect; +} + +sub setlogmask { + local($oldmask) = $maskpri; + $maskpri = shift; + $oldmask; +} + +sub syslog { + local($priority) = shift; + local($mask) = shift; + local($message, $whoami); + local(@words, $num, $numpri, $numfac, $sum); + local($facility) = $facility; # may need to change temporarily. + + croak "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) { + croak "syslog: invalid level/facility: $_"; + } + elsif ($num <= &LOG_PRIMASK) { + croak "syslog: too many levels given: $_" if defined($numpri); + $numpri = $num; + return 0 unless &LOG_MASK($numpri) & $maskpri; + } + else { + croak "syslog: too many facilities given: $_" if defined($numfac); + $facility = $_; + $numfac = $num; + } + } + + croak "syslog: level must be given" 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); + croak "Can't lookup $myname" 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); + croak "Can't lookup $host" unless $name; + @bytes = unpack("C4",$addrs[0]); + } + $that = pack($pat,$af_inet,$syslog,@bytes); + + socket(SYSLOG,$af_inet,$datagram,$udp) || croak "socket: $!"; + bind(SYSLOG,$this) || croak "bind: $!"; + connect(SYSLOG,$that) || croak "connect: $!"; + + local($old) = select(SYSLOG); $| = 1; select($old); + $connected = 1; +} + +sub disconnect { + close SYSLOG; + $connected = 0; +} + +1; + diff --git a/lib/Term/Cap.pm b/lib/Term/Cap.pm new file mode 100644 index 0000000000..30389bb37c --- /dev/null +++ b/lib/Term/Cap.pm @@ -0,0 +1,174 @@ +package Term::Cap; +require 5.000; +require Exporter; +use Carp; + +@ISA = qw(Exporter); +@EXPORT = qw(&Tgetent &Tputs &Tgoto $ispeed $ospeed %TC); + +# $RCSfile: termcap.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:16 $ +# +# Usage: +# require 'ioctl.pl'; +# ioctl(TTY,$TIOCGETP,$foo); +# ($ispeed,$ospeed) = unpack('cc',$foo); +# use Termcap; +# &Tgetent('vt100'); # sets $TC{'cm'}, etc. +# &Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE'); +# &Tputs($TC{'dl'},$affcnt,'FILEHANDLE'); +# +sub Tgetent { + local($TERM) = @_; + local($TERMCAP,$_,$entry,$loop,$field); + + warn "Tgetent: no ospeed set" unless $ospeed; + foreach $key (keys(%TC)) { + delete $TC{$key}; + } + $TERM = $ENV{'TERM'} unless $TERM; + $TERM =~ s/(\W)/\\$1/g; + $TERMCAP = $ENV{'TERMCAP'}; + $TERMCAP = '/etc/termcap' unless $TERMCAP; + if ($TERMCAP !~ m:^/:) { + if ($TERMCAP !~ /(^|\|)$TERM[:\|]/) { + $TERMCAP = '/etc/termcap'; + } + } + if ($TERMCAP =~ m:^/:) { + $entry = ''; + do { + $loop = " + open(TERMCAP,'<$TERMCAP') || croak \"Can't open $TERMCAP\"; + while (<TERMCAP>) { + next if /^#/; + next if /^\t/; + if (/(^|\\|)${TERM}[:\\|]/) { + chop; + while (chop eq '\\\\') { + \$_ .= <TERMCAP>; + chop; + } + \$_ .= ':'; + last; + } + } + close TERMCAP; + \$entry .= \$_; + "; + eval $loop; + } while s/:tc=([^:]+):/:/ && ($TERM = $1); + $TERMCAP = $entry; + } + + foreach $field (split(/:[\s:\\]*/,$TERMCAP)) { + if ($field =~ /^\w\w$/) { + $TC{$field} = 1; + } + elsif ($field =~ /^(\w\w)#(.*)/) { + $TC{$1} = $2 unless defined $TC{$1}; + } + elsif ($field =~ /^(\w\w)=(.*)/) { + $entry = $1; + $_ = $2; + s/\\E/\033/g; + s/\\(\d\d\d)/pack('c',$1 & 0177)/eg; + s/\\n/\n/g; + s/\\r/\r/g; + s/\\t/\t/g; + s/\\b/\b/g; + s/\\f/\f/g; + s/\\\^/\377/g; + s/\^\?/\177/g; + s/\^(.)/pack('c',ord($1) & 31)/eg; + s/\\(.)/$1/g; + s/\377/^/g; + $TC{$entry} = $_ unless defined $TC{$entry}; + } + } + $TC{'pc'} = "\0" unless defined $TC{'pc'}; + $TC{'bc'} = "\b" unless defined $TC{'bc'}; +} + +@Tputs = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2); + +sub Tputs { + local($string,$affcnt,$FH) = @_; + local($ms); + if ($string =~ /(^[\d.]+)(\*?)(.*)$/) { + $ms = $1; + $ms *= $affcnt if $2; + $string = $3; + $decr = $Tputs[$ospeed]; + if ($decr > .1) { + $ms += $decr / 2; + $string .= $TC{'pc'} x ($ms / $decr); + } + } + print $FH $string if $FH; + $string; +} + +sub Tgoto { + local($string) = shift(@_); + local($result) = ''; + local($after) = ''; + local($code,$tmp) = @_; + local(@tmp); + @tmp = ($tmp,$code); + local($online) = 0; + while ($string =~ /^([^%]*)%(.)(.*)/) { + $result .= $1; + $code = $2; + $string = $3; + if ($code eq 'd') { + $result .= sprintf("%d",shift(@tmp)); + } + elsif ($code eq '.') { + $tmp = shift(@tmp); + if ($tmp == 0 || $tmp == 4 || $tmp == 10) { + if ($online) { + ++$tmp, $after .= $TC{'up'} if $TC{'up'}; + } + else { + ++$tmp, $after .= $TC{'bc'}; + } + } + $result .= sprintf("%c",$tmp); + $online = !$online; + } + elsif ($code eq '+') { + $result .= sprintf("%c",shift(@tmp)+ord($string)); + $string = substr($string,1,99); + $online = !$online; + } + elsif ($code eq 'r') { + ($code,$tmp) = @tmp; + @tmp = ($tmp,$code); + $online = !$online; + } + elsif ($code eq '>') { + ($code,$tmp,$string) = unpack("CCa99",$string); + if ($tmp[$[] > $code) { + $tmp[$[] += $tmp; + } + } + elsif ($code eq '2') { + $result .= sprintf("%02d",shift(@tmp)); + $online = !$online; + } + elsif ($code eq '3') { + $result .= sprintf("%03d",shift(@tmp)); + $online = !$online; + } + elsif ($code eq 'i') { + ($code,$tmp) = @tmp; + @tmp = ($code+1,$tmp+1); + } + else { + return "OOPS"; + } + } + $result . $string . $after; +} + +1; diff --git a/lib/Term/Complete.pm b/lib/Term/Complete.pm new file mode 100644 index 0000000000..10b12a2b5c --- /dev/null +++ b/lib/Term/Complete.pm @@ -0,0 +1,113 @@ +package Term::Complete; +require 5.000; +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(Complete); + +# +# @(#)complete.pl,v1.1 (me@anywhere.EBay.Sun.COM) 09/23/91 +# +# Author: Wayne Thompson +# +# Description: +# This routine provides word completion. +# (TAB) attempts word completion. +# (^D) prints completion list. +# (These may be changed by setting $Complete::complete, etc.) +# +# Diagnostics: +# Bell when word completion fails. +# +# Dependencies: +# The tty driver is put into raw mode. +# +# Bugs: +# +# Usage: +# $input = complete('prompt_string', \@completion_list); +# or +# $input = complete('prompt_string', @completion_list); +# + +CONFIG: { + $complete = "\004"; + $kill = "\025"; + $erase1 = "\177"; + $erase2 = "\010"; +} + +sub complete { + $prompt = shift; + if (ref $_[0] || $_[0] =~ /^\*/) { + @cmp_lst = sort @{$_[0]}; + } + else { + @cmp_lst = sort(@_); + } + + system('stty raw -echo'); + LOOP: { + print($prompt, $return); + while (($_ = getc(STDIN)) ne "\r") { + CASE: { + # (TAB) attempt completion + $_ eq "\t" && do { + @match = grep(/^$return/, @cmp_lst); + $l = length($test = shift(@match)); + unless ($#match < 0) { + foreach $cmp (@match) { + until (substr($cmp, 0, $l) eq substr($test, 0, $l)) { + $l--; + } + } + print("\a"); + } + print($test = substr($test, $r, $l - $r)); + $r = length($return .= $test); + last CASE; + }; + + # (^D) completion list + $_ eq $complete && do { + print(join("\r\n", '', grep(/^$return/, @cmp_lst)), "\r\n"); + redo LOOP; + }; + + # (^U) kill + $_ eq $kill && do { + if ($r) { + undef($r, $return); + print("\r\n"); + redo LOOP; + } + last CASE; + }; + + # (DEL) || (BS) erase + ($_ eq $erase1 || $_ eq $erase2) && do { + if($r) { + print("\b \b"); + chop($return); + $r--; + } + last CASE; + }; + + # printable char + ord >= 32 && do { + $return .= $_; + $r++; + print; + last CASE; + }; + } + } + } + system('stty -raw echo'); + print("\n"); + $return; +} + +1; + diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm new file mode 100644 index 0000000000..8422f8e4bc --- /dev/null +++ b/lib/Test/Harness.pm @@ -0,0 +1,80 @@ +package Test::Harness; + +use Exporter; +use Benchmark; +@ISA=(Exporter); +@EXPORT= qw(&runtests &test_lib); +@EXPORT_OK= qw($verbose $switches); + +$verbose = 0; +$switches = "-w"; + +sub runtests { + my(@tests) = @_; + local($|) = 1; + my($test,$te,$ok,$next,$max,$totmax, $files,$pct); + my $bad = 0; + my $good = 0; + my $total = @tests; + local($ENV{'PERL5LIB'}) = join(':', @INC); # pass -I flags to children + + my $t_start = new Benchmark; + while ($test = shift(@tests)) { + $te = $test; + chop($te); + print "$te" . '.' x (20 - length($te)); + my $fh = "RESULTS"; + open($fh,"$^X $switches $test|") || (print "can't run. $!\n"); + $ok = 0; + $next = 0; + while (<$fh>) { + if( $verbose ){ + print $_; + } + unless (/^#/) { + if (/^1\.\.([0-9]+)/) { + $max = $1; + $totmax += $max; + $files += 1; + $next = 1; + $ok = 1; + } else { + $next = $1, $ok = 0, last if /^not ok ([0-9]*)/; + if (/^ok (.*)/ && $1 == $next) { + $next = $next + 1; + } + } + } + } + close($fh); # must close to reap child resource values + $next -= 1; + if ($ok && $next == $max) { + print "ok\n"; + $good += 1; + } else { + $next += 1; + print "FAILED on test $next\n"; + $bad += 1; + $_ = $test; + } + } + my $t_total = timediff(new Benchmark, $t_start); + + if ($bad == 0) { + if ($ok) { + print "All tests successful.\n"; + } else { + die "FAILED--no tests were run for some reason.\n"; + } + } else { + $pct = sprintf("%.2f", $good / $total * 100); + if ($bad == 1) { + warn "Failed 1 test, $pct% okay.\n"; + } else { + die "Failed $bad/$total tests, $pct% okay.\n"; + } + } + printf("Files=%d, Tests=%d, %s\n", $files,$totmax, timestr($t_total, 'nop')); +} + +1; diff --git a/lib/Text/Abbrev.pm b/lib/Text/Abbrev.pm new file mode 100644 index 0000000000..77370d37c3 --- /dev/null +++ b/lib/Text/Abbrev.pm @@ -0,0 +1,37 @@ +package Text::Abbrev; +require 5.000; +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(abbrev); + +# Usage: +# &abbrev(*foo,LIST); +# ... +# $long = $foo{$short}; + +sub abbrev { + local(*domain) = shift; + @cmp = @_; + %domain = (); + 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) { + $abbrev .= shift(@extra); + $domain{$abbrev} = $name; + } + } +} + +1; + diff --git a/lib/quotewords.pl.art b/lib/Text/ParseWords.pm index 65e9f0abc8..89278501d1 100644 --- a/lib/quotewords.pl.art +++ b/lib/Text/ParseWords.pm @@ -1,47 +1,23 @@ -Article 20075 of comp.lang.perl: -Newsgroups: comp.lang.perl -Path: netlabs!news.cerf.net!ihnp4.ucsd.edu!swrinde!sgiblab!rpal.rockwell.com!imagen!pomeranz -From: pomeranz@imagen.com (Hal Pomeranz) -Subject: quotewords.pl [REVISED] -Message-ID: <1994Mar23.071634.23171@aqm.com> -Sender: usenet@aqm.com -Nntp-Posting-Host: imagen -Organization: QMS Inc., Santa Clara -Date: Wed, 23 Mar 1994 07:16:34 GMT -Lines: 132 - - -ARRGH! The version I posted earlier tonight contained an error, so -I've sent out a cancel to chase it down and kill it. Please use this -version dated "23 March 1994". - -quotewords.pl is a generic replacement for shellwords.pl. -"ewords() allows you to specify a delimiter, which may be a -regular expression, and returns a list of words broken on that -delimiter ignoring any instances of the delimiter which may appear -within a quoted string. There's a boolean flag to tell the function -whether or not you want it to strip quotes and backslashes or retain -them. - -I've also included a revised version of &shellwords() (written in -terms of "ewords() of course) which is 99% the same as the -original version. The only difference is that the new version will -not default to using $_ if no arguments are supplied. - -Share and enjoy... - -============================================================================== - Hal Pomeranz pomeranz@sclara.qms.com pomeranz@cs.swarthmore.edu -System/Network Manager "All I can say is that my life is pretty plain. - QMS Santa Clara I like watchin' the puddles gather rain." Blind Melon -============================================================================== - -# quotewords.pl +package Text::ParseWords; + +require 5.000; +require Exporter; +require AutoLoader; +use Carp; + +@ISA = qw(Exporter AutoLoader); +@EXPORT = qw(shellwords quotewords); +@EXPORT_OK = qw(old_shellwords); + +# This code needs updating to use new Perl 5 features (regexp etc). + +# ParseWords.pm # # Usage: -# require 'quotes.pl'; +# use ParseWords; # @words = "ewords($delim, $keep, @lines); # @words = &shellwords(@lines); +# @words = &old_shellwords(@lines); # Hal Pomeranz (pomeranz@netcom.com), 23 March 1994 # Permission to use and distribute under the same terms as Perl. @@ -58,20 +34,27 @@ System/Network Manager "All I can say is that my life is pretty plain. # with each word, otherwise quotes are stripped in the splitting process. # $keep also defines whether unprotected backslashes are retained. # -# A &shellwords() replacement is included to demonstrate the new package. -# This version differs from the original in that it will _NOT_ default -# to using $_ if no arguments are given. I personally find the old behavior -# to be a mis-feature. -package quotewords; +1; +__END__ + + +sub shellwords { + + # A &shellwords() replacement is included to demonstrate the new package. + # This version differs from the original in that it will _NOT_ default + # to using $_ if no arguments are given. I personally find the old behavior + # to be a mis-feature. -sub main'shellwords { local(@lines) = @_; $lines[$#lines] =~ s/\s+$//; - &main'quotewords('\s+', 0, @lines); + "ewords('\s+', 0, @lines); } + +sub quotewords { + # "ewords() works by simply jamming all of @lines into a single # string in $_ and then pulling off words a bit at a time until $_ # is exhausted. @@ -90,7 +73,7 @@ sub main'shellwords { # conditional. The second case handles single quoted strings. In # the third case we've found a quote at the current beginning of $_, # but it didn't match the quoted string regexps in the first two cases, -# so it must be an unbalanced quote and we die with an error (which can +# so it must be an unbalanced quote and we croak with an error (which can # be caught by eval()). # # The next case handles backslashed characters, and the next case is the @@ -102,7 +85,6 @@ sub main'shellwords { # at a time behavior was necessary if the delimiter was going to be a # regexp (love to hear it if you can figure out a better way). -sub main'quotewords { local($delim, $keep, @lines) = @_; local(@words,$snippet,$field,$_); @@ -120,7 +102,7 @@ sub main'quotewords { $snippet = "'$snippet'" if ($keep); } elsif (/^["']/) { - die "Unmatched quote\n"; + croak "Unmatched quote"; } elsif (s/^\\(.)//) { $snippet = $1; @@ -141,6 +123,48 @@ sub main'quotewords { } @words; } -1; +sub old_shellwords { + + # Usage: + # use ParseWords; + # @words = old_shellwords($line); + # or + # @words = old_shellwords(@lines); + + local($_) = join('', @_); + my(@words,$snippet,$field); + + s/^\s+//; + while ($_ ne '') { + $field = ''; + for (;;) { + if (s/^"(([^"\\]|\\.)*)"//) { + ($snippet = $1) =~ s#\\(.)#$1#g; + } + elsif (/^"/) { + croak "Unmatched double quote: $_"; + } + elsif (s/^'(([^'\\]|\\.)*)'//) { + ($snippet = $1) =~ s#\\(.)#$1#g; + } + elsif (/^'/) { + croak "Unmatched single quote: $_"; + } + elsif (s/^\\(.)//) { + $snippet = $1; + } + elsif (s/^([^\s\\'"]+)//) { + $snippet = $1; + } + else { + s/^\s+//; + last; + } + $field .= $snippet; + } + push(@words, $field); + } + @words; +} diff --git a/lib/Text/Soundex.pm b/lib/Text/Soundex.pm new file mode 100644 index 0000000000..655152347c --- /dev/null +++ b/lib/Text/Soundex.pm @@ -0,0 +1,82 @@ +package Text::Soundex; +require 5.000; +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(&soundex $soundex_nocode); + +# $Id: soundex.pl,v 1.2 1994/03/24 00:30:27 mike Exp $ +# +# Implementation of soundex algorithm as described by Knuth in volume +# 3 of The Art of Computer Programming, with ideas stolen from Ian +# Phillips <ian@pipex.net>. +# +# Mike Stok <Mike.Stok@meiko.concord.ma.us>, 2 March 1994. +# +# Knuth's test cases are: +# +# Euler, Ellery -> E460 +# Gauss, Ghosh -> G200 +# Hilbert, Heilbronn -> H416 +# Knuth, Kant -> K530 +# Lloyd, Ladd -> L300 +# Lukasiewicz, Lissajous -> L222 +# +# $Log: soundex.pl,v $ +# Revision 1.2 1994/03/24 00:30:27 mike +# Subtle bug (any excuse :-) spotted by Rich Pinder <rpinder@hsc.usc.edu> +# in the way I handles leasing characters which were different but had +# the same soundex code. This showed up comparing it with Oracle's +# soundex output. +# +# Revision 1.1 1994/03/02 13:01:30 mike +# Initial revision +# +# +############################################################################## + +# $soundex_nocode is used to indicate a string doesn't have a soundex +# code, I like undef other people may want to set it to 'Z000'. + +$soundex_nocode = undef; + +# soundex +# +# usage: +# +# @codes = &soundex (@wordList); +# $code = &soundex ($word); +# +# This strenuously avoids 0 + +sub soundex +{ + local (@s, $f, $fc, $_) = @_; + + foreach (@s) + { + tr/a-z/A-Z/; + tr/A-Z//cd; + + if ($_ eq '') + { + $_ = $soundex_nocode; + } + else + { + ($f) = /^(.)/; + tr/AEHIOUWYBFPVCGJKQSXZDTLMNR/00000000111122222222334556/; + ($fc) = /^(.)/; + s/^$fc+//; + tr///cs; + tr/0//d; + $_ = $f . $_ . '000'; + s/^(.{4}).*/$1/; + } + } + + wantarray ? @s : shift @s; +} + +1; + diff --git a/lib/Text/Tabs.pm b/lib/Text/Tabs.pm new file mode 100644 index 0000000000..8ca833f8e8 --- /dev/null +++ b/lib/Text/Tabs.pm @@ -0,0 +1,47 @@ +# +# expand and unexpand tabs as per the unix expand and +# unexpand programs. +# +# expand and unexpand operate on arrays of lines. Do not +# feed strings that contain newlines to them. +# +# David Muir Sharnoff <muir@idiom.com> +# + +package Tabs; + +require Exporter; + +@ISA = (Exporter); +@EXPORT = qw(expand unexpand $tabstop); + +$tabstop = 8; + +sub expand +{ + my @l = @_; + for $_ (@l) { + 1 while s/^([^\t]*)(\t+)/ + $1 . (" " x + ($tabstop * length($2) + - (length($1) % $tabstop))) + /e; + } + return @l; +} + +sub unexpand +{ + my @l = &expand(@_); + my @e; + for $x (@l) { + @e = split(/(.{$tabstop})/,$x); + for $_ (@e) { + s/ +$/\t/; + } + $x = join('',@e); + } + return @l; +} + +1; diff --git a/lib/TieHash.pm b/lib/TieHash.pm new file mode 100644 index 0000000000..0cb4afa20d --- /dev/null +++ b/lib/TieHash.pm @@ -0,0 +1,42 @@ +package TieHash; +use Carp; + +sub new { + my $pack = shift; + $pack->TIEHASH(@_); +} + +# Grandfather "new" + +sub TIEHASH { + my $pack = shift; + if (defined &{"{$pack}::new"}) { + carp "WARNING: calling ${pack}->new since ${pack}->TIEHASH is missing" + if $^W; + $pack->new(@_); + } + else { + croak "$pack doesn't define a TIEHASH method"; + } +} + +sub EXISTS { + my $pack = ref $_[0]; + croak "$pack doesn't define an EXISTS method"; +} + +sub CLEAR { + my $self = shift; + my $key = $self->FIRSTKEY(@_); + my @keys; + + while (defined $key) { + push @keys, $key; + $key = $self->NEXTKEY(@_, $key); + } + foreach $key (@keys) { + $self->DELETE(@_, $key); + } +} + +1; diff --git a/lib/Time/Local.pm b/lib/Time/Local.pm new file mode 100644 index 0000000000..64e62405f7 --- /dev/null +++ b/lib/Time/Local.pm @@ -0,0 +1,105 @@ +package Time::Local; +require 5.000; +require Exporter; +use Carp; + +@ISA = qw(Exporter); +@EXPORT = qw(timegm timelocal); + +# 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. + +# Both routines return -1 if the integer limit is hit. I.e. for dates +# after the 1st of January, 2038 on most machines. + +@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 { + $ym = pack(C2, @_[5,4]); + $cheat = $cheat{$ym} || &cheat; + return -1 if $cheat<0; + $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAYS; +} + +sub timelocal { + $time = &timegm + $tzmin*$MIN; + return -1 if $cheat<0; + @test = localtime($time); + $time -= $HR if $test[2] != $_[2]; + $time; +} + +sub cheat { + $year = $_[5]; + $month = $_[4]; + croak "Month out of range 0..11 in timelocal.pl" + if $month > 11 || $month < 0; + croak "Day out of range 1..31 in timelocal.pl" + if $_[3] > 31 || $_[3] < 1; + croak "Hour out of range 0..23 in timelocal.pl" + if $_[2] > 23 || $_[2] < 0; + croak "Minute out of range 0..59 in timelocal.pl" + if $_[1] > 59 || $_[1] < 0; + croak "Second out of range 0..59 in timelocal.pl" + if $_[0] > 59 || $_[0] < 0; + $guess = $^T; + @g = gmtime($guess); + $year += $YearFix if $year < $epoch[5]; + $lastguess = ""; + while ($diff = $year - $g[5]) { + $guess += $diff * (363 * $DAYS); + @g = gmtime($guess); + if (($thisguess = "@g") eq $lastguess){ + return -1; #date beyond this machine's integer limit + } + $lastguess = $thisguess; + } + while ($diff = $month - $g[4]) { + $guess += $diff * (27 * $DAYS); + @g = gmtime($guess); + if (($thisguess = "@g") eq $lastguess){ + return -1; #date beyond this machine's integer limit + } + $lastguess = $thisguess; + } + @gfake = gmtime($guess-1); #still being sceptic + if ("@gfake" eq $lastguess){ + return -1; #date beyond this machine's integer limit + } + $g[3]--; + $guess -= $g[0] * $SEC + $g[1] * $MIN + $g[2] * $HR + $g[3] * $DAYS; + $cheat{$ym} = $guess; +} + +1; diff --git a/lib/auto/NDBM_File.so b/lib/auto/NDBM_File.so Binary files differdeleted file mode 100755 index af2b0d3476..0000000000 --- a/lib/auto/NDBM_File.so +++ /dev/null diff --git a/lib/auto/NDBM_File/NDBM_File.so b/lib/auto/NDBM_File/NDBM_File.so Binary files differdeleted file mode 100755 index 49c04e6858..0000000000 --- a/lib/auto/NDBM_File/NDBM_File.so +++ /dev/null diff --git a/lib/auto/ODBM_File.so b/lib/auto/ODBM_File.so Binary files differdeleted file mode 100755 index 5044c8a1ab..0000000000 --- a/lib/auto/ODBM_File.so +++ /dev/null diff --git a/lib/auto/ODBM_File/ODBM_File.so b/lib/auto/ODBM_File/ODBM_File.so Binary files differdeleted file mode 100755 index f61231f38e..0000000000 --- a/lib/auto/ODBM_File/ODBM_File.so +++ /dev/null diff --git a/lib/auto/POSIX.so b/lib/auto/POSIX.so Binary files differdeleted file mode 100755 index 7065a09cf1..0000000000 --- a/lib/auto/POSIX.so +++ /dev/null diff --git a/lib/auto/POSIX/POSIX.so b/lib/auto/POSIX/POSIX.so Binary files differdeleted file mode 100755 index 17560bd798..0000000000 --- a/lib/auto/POSIX/POSIX.so +++ /dev/null diff --git a/lib/auto/POSIX/_exit b/lib/auto/POSIX/_exit deleted file mode 100644 index a860527257..0000000000 --- a/lib/auto/POSIX/_exit +++ /dev/null @@ -1,9 +0,0 @@ -package POSIX; - -sub _exit { - unimpl "_exit(xxx)", caller if @_ != 123; - _exit($_[0]); -} - - -1; diff --git a/lib/auto/POSIX/_exit.al b/lib/auto/POSIX/_exit.al deleted file mode 100644 index 7666cebe6e..0000000000 --- a/lib/auto/POSIX/_exit.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub _exit { - unimpl "_exit(xxx)", caller if @_ != 123; - _exit($_[0]); -} - -1; diff --git a/lib/auto/POSIX/abort.al b/lib/auto/POSIX/abort.al deleted file mode 100644 index 58e7ce915b..0000000000 --- a/lib/auto/POSIX/abort.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub abort { - unimpl "abort(xxx)", caller if @_ != 123; - abort($_[0]); -} - -1; diff --git a/lib/auto/POSIX/abs.al b/lib/auto/POSIX/abs.al deleted file mode 100644 index 4a832b40d5..0000000000 --- a/lib/auto/POSIX/abs.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub abs { - usage "abs(x)", caller if @_ != 1; - abs($_[0]); -} - -1; diff --git a/lib/auto/POSIX/access.al b/lib/auto/POSIX/access.al deleted file mode 100644 index 89bbfb043a..0000000000 --- a/lib/auto/POSIX/access.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub access { - unimpl "access(xxx)", caller if @_ != 123; - access($_[0]); -} - -1; diff --git a/lib/auto/POSIX/alarm.al b/lib/auto/POSIX/alarm.al deleted file mode 100644 index 183b6d965e..0000000000 --- a/lib/auto/POSIX/alarm.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub alarm { - unimpl "alarm(xxx)", caller if @_ != 123; - alarm($_[0]); -} - -1; diff --git a/lib/auto/POSIX/asctime.al b/lib/auto/POSIX/asctime.al deleted file mode 100644 index 067e0f4211..0000000000 --- a/lib/auto/POSIX/asctime.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub asctime { - unimpl "asctime(xxx)", caller if @_ != 123; - asctime($_[0]); -} - -1; diff --git a/lib/auto/POSIX/assert.al b/lib/auto/POSIX/assert.al deleted file mode 100644 index f32a8537ed..0000000000 --- a/lib/auto/POSIX/assert.al +++ /dev/null @@ -1,12 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub assert { - usage "assert(expr)", caller if @_ != 1; - if (!$_[0]) { - local ($pack,$file,$line) = caller; - die "Assertion failed at $file line $line\n"; - } -} - -1; diff --git a/lib/auto/POSIX/atan2.al b/lib/auto/POSIX/atan2.al deleted file mode 100644 index 1b2e23a533..0000000000 --- a/lib/auto/POSIX/atan2.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub atan2 { - usage "atan2(x,y)", caller if @_ != 2; - atan2($_[0], $_[1]); -} - -1; diff --git a/lib/auto/POSIX/atexit.al b/lib/auto/POSIX/atexit.al deleted file mode 100644 index 054d8da133..0000000000 --- a/lib/auto/POSIX/atexit.al +++ /dev/null @@ -1,8 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub atexit { - unimpl "atexit() is C-specific: use END {} instead", caller; -} - -1; diff --git a/lib/auto/POSIX/atof.al b/lib/auto/POSIX/atof.al deleted file mode 100644 index 0875991941..0000000000 --- a/lib/auto/POSIX/atof.al +++ /dev/null @@ -1,8 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub atof { - unimpl "atof() is C-specific, stopped", caller; -} - -1; diff --git a/lib/auto/POSIX/atoi.al b/lib/auto/POSIX/atoi.al deleted file mode 100644 index 6f18387899..0000000000 --- a/lib/auto/POSIX/atoi.al +++ /dev/null @@ -1,8 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub atoi { - unimpl "atoi() is C-specific, stopped", caller; -} - -1; diff --git a/lib/auto/POSIX/atol.al b/lib/auto/POSIX/atol.al deleted file mode 100644 index 9393d21333..0000000000 --- a/lib/auto/POSIX/atol.al +++ /dev/null @@ -1,8 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub atol { - unimpl "atol() is C-specific, stopped", caller; -} - -1; diff --git a/lib/auto/POSIX/bsearch.al b/lib/auto/POSIX/bsearch.al deleted file mode 100644 index ed104adf41..0000000000 --- a/lib/auto/POSIX/bsearch.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub bsearch { - unimpl "bsearch(xxx)", caller if @_ != 123; - bsearch($_[0]); -} - -1; diff --git a/lib/auto/POSIX/calloc.al b/lib/auto/POSIX/calloc.al deleted file mode 100644 index d53352385c..0000000000 --- a/lib/auto/POSIX/calloc.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub calloc { - unimpl "calloc(xxx)", caller if @_ != 123; - calloc($_[0]); -} - -1; diff --git a/lib/auto/POSIX/cfgetispeed.al b/lib/auto/POSIX/cfgetispeed.al deleted file mode 100644 index a95efd6f54..0000000000 --- a/lib/auto/POSIX/cfgetispeed.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub cfgetispeed { - unimpl "cfgetispeed(xxx)", caller if @_ != 123; - cfgetispeed($_[0]); -} - -1; diff --git a/lib/auto/POSIX/cfgetospeed.al b/lib/auto/POSIX/cfgetospeed.al deleted file mode 100644 index 69e66ad76c..0000000000 --- a/lib/auto/POSIX/cfgetospeed.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub cfgetospeed { - unimpl "cfgetospeed(xxx)", caller if @_ != 123; - cfgetospeed($_[0]); -} - -1; diff --git a/lib/auto/POSIX/cfsetispeed.al b/lib/auto/POSIX/cfsetispeed.al deleted file mode 100644 index cbcc646b1e..0000000000 --- a/lib/auto/POSIX/cfsetispeed.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub cfsetispeed { - unimpl "cfsetispeed(xxx)", caller if @_ != 123; - cfsetispeed($_[0]); -} - -1; diff --git a/lib/auto/POSIX/cfsetospeed.al b/lib/auto/POSIX/cfsetospeed.al deleted file mode 100644 index 7dae85c36a..0000000000 --- a/lib/auto/POSIX/cfsetospeed.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub cfsetospeed { - unimpl "cfsetospeed(xxx)", caller if @_ != 123; - cfsetospeed($_[0]); -} - -1; diff --git a/lib/auto/POSIX/chdir.al b/lib/auto/POSIX/chdir.al deleted file mode 100644 index 9e1f685dc9..0000000000 --- a/lib/auto/POSIX/chdir.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub chdir { - unimpl "chdir(xxx)", caller if @_ != 123; - chdir($_[0]); -} - -1; diff --git a/lib/auto/POSIX/chmod.al b/lib/auto/POSIX/chmod.al deleted file mode 100644 index 24fe4c5ab1..0000000000 --- a/lib/auto/POSIX/chmod.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub chmod { - usage "chmod(filename, mode)", caller if @_ != 2; - chmod($_[0], $_[1]); -} - -1; diff --git a/lib/auto/POSIX/chown.al b/lib/auto/POSIX/chown.al deleted file mode 100644 index 127d89861c..0000000000 --- a/lib/auto/POSIX/chown.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub chown { - usage "chown(filename, uid, gid)", caller if @_ != 3; - chown($_[0], $_[1], $_[2]); -} - -1; diff --git a/lib/auto/POSIX/clearerr.al b/lib/auto/POSIX/clearerr.al deleted file mode 100644 index 412f521938..0000000000 --- a/lib/auto/POSIX/clearerr.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub clearerr { - usage "clearerr(filehandle)", caller if @_ != 1; - seek($_[0], 0, 1); -} - -1; diff --git a/lib/auto/POSIX/clock.al b/lib/auto/POSIX/clock.al deleted file mode 100644 index 7fae255378..0000000000 --- a/lib/auto/POSIX/clock.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub clock { - unimpl "clock(xxx)", caller if @_ != 123; - clock($_[0]); -} - -1; diff --git a/lib/auto/POSIX/close.al b/lib/auto/POSIX/close.al deleted file mode 100644 index ce471881d0..0000000000 --- a/lib/auto/POSIX/close.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub close { - unimpl "close(xxx)", caller if @_ != 123; - close($_[0]); -} - -1; diff --git a/lib/auto/POSIX/closedir.al b/lib/auto/POSIX/closedir.al deleted file mode 100644 index bb12a2608d..0000000000 --- a/lib/auto/POSIX/closedir.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub closedir { - usage "closedir(dirhandle)", caller if @_ != 1; - closedir($_[0]); - ungensym($_[0]); -} - -1; diff --git a/lib/auto/POSIX/cos.al b/lib/auto/POSIX/cos.al deleted file mode 100644 index 4ea59dfb32..0000000000 --- a/lib/auto/POSIX/cos.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub cos { - usage "cos(x)", caller if @_ != 1; - cos($_[0]); -} - -1; diff --git a/lib/auto/POSIX/creat.al b/lib/auto/POSIX/creat.al deleted file mode 100644 index 74656e7dd0..0000000000 --- a/lib/auto/POSIX/creat.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub creat { - usage "creat(filename, mode)", caller if @_ != 2; - &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[2]); -} - -1; diff --git a/lib/auto/POSIX/ctermid.al b/lib/auto/POSIX/ctermid.al deleted file mode 100644 index 37a8f71a14..0000000000 --- a/lib/auto/POSIX/ctermid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub ctermid { - unimpl "ctermid(xxx)", caller if @_ != 123; - ctermid($_[0]); -} - -1; diff --git a/lib/auto/POSIX/ctime.al b/lib/auto/POSIX/ctime.al deleted file mode 100644 index d12aa4e64c..0000000000 --- a/lib/auto/POSIX/ctime.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub ctime { - unimpl "ctime(xxx)", caller if @_ != 123; - ctime($_[0]); -} - -1; diff --git a/lib/auto/POSIX/cuserid.al b/lib/auto/POSIX/cuserid.al deleted file mode 100644 index 546c3091fa..0000000000 --- a/lib/auto/POSIX/cuserid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub cuserid { - unimpl "cuserid(xxx)", caller if @_ != 123; - cuserid($_[0]); -} - -1; diff --git a/lib/auto/POSIX/difftime.al b/lib/auto/POSIX/difftime.al deleted file mode 100644 index dd4b3db5db..0000000000 --- a/lib/auto/POSIX/difftime.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub difftime { - unimpl "difftime(xxx)", caller if @_ != 123; - difftime($_[0]); -} - -1; diff --git a/lib/auto/POSIX/div.al b/lib/auto/POSIX/div.al deleted file mode 100644 index 0102b32fc9..0000000000 --- a/lib/auto/POSIX/div.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub div { - unimpl "div(xxx)", caller if @_ != 123; - div($_[0]); -} - -1; diff --git a/lib/auto/POSIX/dup.al b/lib/auto/POSIX/dup.al deleted file mode 100644 index 393119e5e0..0000000000 --- a/lib/auto/POSIX/dup.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub dup { - unimpl "dup(xxx)", caller if @_ != 123; - dup($_[0]); -} - -1; diff --git a/lib/auto/POSIX/dup2.al b/lib/auto/POSIX/dup2.al deleted file mode 100644 index c85f16e9d5..0000000000 --- a/lib/auto/POSIX/dup2.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub dup2 { - unimpl "dup2(xxx)", caller if @_ != 123; - dup2($_[0]); -} - -1; diff --git a/lib/auto/POSIX/errno.al b/lib/auto/POSIX/errno.al deleted file mode 100644 index 971b7e8241..0000000000 --- a/lib/auto/POSIX/errno.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub errno { - usage "errno()", caller if @_ != 0; - $! + 0; -} - -1; diff --git a/lib/auto/POSIX/execl.al b/lib/auto/POSIX/execl.al deleted file mode 100644 index c89c6fd8c0..0000000000 --- a/lib/auto/POSIX/execl.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub execl { - unimpl "execl(xxx)", caller if @_ != 123; - execl($_[0]); -} - -1; diff --git a/lib/auto/POSIX/execle.al b/lib/auto/POSIX/execle.al deleted file mode 100644 index 530ac768dc..0000000000 --- a/lib/auto/POSIX/execle.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub execle { - unimpl "execle(xxx)", caller if @_ != 123; - execle($_[0]); -} - -1; diff --git a/lib/auto/POSIX/execlp.al b/lib/auto/POSIX/execlp.al deleted file mode 100644 index ea78975435..0000000000 --- a/lib/auto/POSIX/execlp.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub execlp { - unimpl "execlp(xxx)", caller if @_ != 123; - execlp($_[0]); -} - -1; diff --git a/lib/auto/POSIX/execv.al b/lib/auto/POSIX/execv.al deleted file mode 100644 index 382ec7dde6..0000000000 --- a/lib/auto/POSIX/execv.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub execv { - unimpl "execv(xxx)", caller if @_ != 123; - execv($_[0]); -} - -1; diff --git a/lib/auto/POSIX/execve.al b/lib/auto/POSIX/execve.al deleted file mode 100644 index 9f5790a0f1..0000000000 --- a/lib/auto/POSIX/execve.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub execve { - unimpl "execve(xxx)", caller if @_ != 123; - execve($_[0]); -} - -1; diff --git a/lib/auto/POSIX/execvp.al b/lib/auto/POSIX/execvp.al deleted file mode 100644 index 38677d8b7d..0000000000 --- a/lib/auto/POSIX/execvp.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub execvp { - unimpl "execvp(xxx)", caller if @_ != 123; - execvp($_[0]); -} - -1; diff --git a/lib/auto/POSIX/exit.al b/lib/auto/POSIX/exit.al deleted file mode 100644 index fc46de2cb8..0000000000 --- a/lib/auto/POSIX/exit.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub exit { - unimpl "exit(xxx)", caller if @_ != 123; - exit($_[0]); -} - -1; diff --git a/lib/auto/POSIX/exp.al b/lib/auto/POSIX/exp.al deleted file mode 100644 index 70683e072f..0000000000 --- a/lib/auto/POSIX/exp.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub exp { - usage "exp(x)", caller if @_ != 1; - exp($_[0]); -} - -1; diff --git a/lib/auto/POSIX/fabs.al b/lib/auto/POSIX/fabs.al deleted file mode 100644 index 5683d66ca5..0000000000 --- a/lib/auto/POSIX/fabs.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fabs { - usage "fabs(x)", caller if @_ != 1; - abs($_[0]); -} - -1; diff --git a/lib/auto/POSIX/fclose.al b/lib/auto/POSIX/fclose.al deleted file mode 100644 index 493b964561..0000000000 --- a/lib/auto/POSIX/fclose.al +++ /dev/null @@ -1,8 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fclose { - unimpl "fclose() is C-specific--use close instead", caller; -} - -1; diff --git a/lib/auto/POSIX/fcntl.al b/lib/auto/POSIX/fcntl.al deleted file mode 100644 index 8108a00fc6..0000000000 --- a/lib/auto/POSIX/fcntl.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fcntl { - usage "fcntl(filehandle, cmd, arg)", caller if @_ != 3; - fcntl($_[0], $_[1], $_[2]); -} - -1; diff --git a/lib/auto/POSIX/fdopen.al b/lib/auto/POSIX/fdopen.al deleted file mode 100644 index 23487cabdc..0000000000 --- a/lib/auto/POSIX/fdopen.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fdopen { - unimpl "fdopen(xxx)", caller if @_ != 123; - fdopen($_[0]); -} - -1; diff --git a/lib/auto/POSIX/feof.al b/lib/auto/POSIX/feof.al deleted file mode 100644 index 895d58b7f0..0000000000 --- a/lib/auto/POSIX/feof.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub feof { - usage "feof(filehandle)", caller if @_ != 1; - eof($_[0]); -} - -1; diff --git a/lib/auto/POSIX/ferror.al b/lib/auto/POSIX/ferror.al deleted file mode 100644 index 0588424f06..0000000000 --- a/lib/auto/POSIX/ferror.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub ferror { - unimpl "ferror(xxx)", caller if @_ != 123; - ferror($_[0]); -} - -1; diff --git a/lib/auto/POSIX/fflush.al b/lib/auto/POSIX/fflush.al deleted file mode 100644 index b7b767680c..0000000000 --- a/lib/auto/POSIX/fflush.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fflush { - unimpl "fflush(xxx)", caller if @_ != 123; - fflush($_[0]); -} - -1; diff --git a/lib/auto/POSIX/fgetc.al b/lib/auto/POSIX/fgetc.al deleted file mode 100644 index 41cd70f593..0000000000 --- a/lib/auto/POSIX/fgetc.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fgetc { - usage "fgetc(filehandle)", caller if @_ != 1; - getc($_[0]); -} - -1; diff --git a/lib/auto/POSIX/fgetpos.al b/lib/auto/POSIX/fgetpos.al deleted file mode 100644 index 679fcd50dd..0000000000 --- a/lib/auto/POSIX/fgetpos.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fgetpos { - unimpl "fgetpos(xxx)", caller if @_ != 123; - fgetpos($_[0]); -} - -1; diff --git a/lib/auto/POSIX/fgets.al b/lib/auto/POSIX/fgets.al deleted file mode 100644 index 7a475b3778..0000000000 --- a/lib/auto/POSIX/fgets.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fgets { - usage "fgets(filehandle)", caller if @_ != 1; - local($handle) = @_; - scalar <$handle>; -} - -1; diff --git a/lib/auto/POSIX/fileno.al b/lib/auto/POSIX/fileno.al deleted file mode 100644 index 62c7c0aff8..0000000000 --- a/lib/auto/POSIX/fileno.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fileno { - usage "fileno(filehandle)", caller if @_ != 1; - fileno($_[0]); -} - -1; diff --git a/lib/auto/POSIX/fopen.al b/lib/auto/POSIX/fopen.al deleted file mode 100644 index f4394ad6cb..0000000000 --- a/lib/auto/POSIX/fopen.al +++ /dev/null @@ -1,8 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fopen { - unimpl "fopen() is C-specific--use open instead", caller; -} - -1; diff --git a/lib/auto/POSIX/fork.al b/lib/auto/POSIX/fork.al deleted file mode 100644 index 06466157e5..0000000000 --- a/lib/auto/POSIX/fork.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fork { - usage "fork()", caller if @_ != 0; - fork; -} - -1; diff --git a/lib/auto/POSIX/fpathconf.al b/lib/auto/POSIX/fpathconf.al deleted file mode 100644 index 533f906395..0000000000 --- a/lib/auto/POSIX/fpathconf.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fpathconf { - unimpl "fpathconf(xxx)", caller if @_ != 123; - fpathconf($_[0]); -} - -1; diff --git a/lib/auto/POSIX/fprintf.al b/lib/auto/POSIX/fprintf.al deleted file mode 100644 index b577f9ad35..0000000000 --- a/lib/auto/POSIX/fprintf.al +++ /dev/null @@ -1,8 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fprintf { - unimpl "fprintf() is C-specific--use printf instead", caller; -} - -1; diff --git a/lib/auto/POSIX/fputc.al b/lib/auto/POSIX/fputc.al deleted file mode 100644 index 0cdf82c5a3..0000000000 --- a/lib/auto/POSIX/fputc.al +++ /dev/null @@ -1,8 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fputc { - unimpl "fputc() is C-specific--use print instead", caller; -} - -1; diff --git a/lib/auto/POSIX/fputs.al b/lib/auto/POSIX/fputs.al deleted file mode 100644 index 208eea6ba9..0000000000 --- a/lib/auto/POSIX/fputs.al +++ /dev/null @@ -1,11 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fputs { - unimpl "fputs() is C-specific--use print instead", caller; - usage "fputs(string, handle)", caller if @_ != 2; - local($handle) = pop; - print $handle @_; -} - -1; diff --git a/lib/auto/POSIX/fread.al b/lib/auto/POSIX/fread.al deleted file mode 100644 index 5b5c0c5fd7..0000000000 --- a/lib/auto/POSIX/fread.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fread { - unimpl "fread() is C-specific--use read instead", caller; - unimpl "fread(xxx)", caller if @_ != 123; - fread($_[0]); -} - -1; diff --git a/lib/auto/POSIX/free.al b/lib/auto/POSIX/free.al deleted file mode 100644 index 319a76d5a9..0000000000 --- a/lib/auto/POSIX/free.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub free { - unimpl "free(xxx)", caller if @_ != 123; - free($_[0]); -} - -1; diff --git a/lib/auto/POSIX/freopen.al b/lib/auto/POSIX/freopen.al deleted file mode 100644 index ed4eca6d67..0000000000 --- a/lib/auto/POSIX/freopen.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub freopen { - unimpl "freopen() is C-specific--use open instead", caller; - unimpl "freopen(xxx)", caller if @_ != 123; - freopen($_[0]); -} - -1; diff --git a/lib/auto/POSIX/fscanf.al b/lib/auto/POSIX/fscanf.al deleted file mode 100644 index 80a8e61454..0000000000 --- a/lib/auto/POSIX/fscanf.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fscanf { - unimpl "fscanf() is C-specific--use <> and regular expressions instead", caller; - unimpl "fscanf(xxx)", caller if @_ != 123; - fscanf($_[0]); -} - -1; diff --git a/lib/auto/POSIX/fseek.al b/lib/auto/POSIX/fseek.al deleted file mode 100644 index 55da72a549..0000000000 --- a/lib/auto/POSIX/fseek.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fseek { - unimpl "fseek() is C-specific--use seek instead", caller; - unimpl "fseek(xxx)", caller if @_ != 123; - fseek($_[0]); -} - -1; diff --git a/lib/auto/POSIX/fsetpos.al b/lib/auto/POSIX/fsetpos.al deleted file mode 100644 index 9b59546e40..0000000000 --- a/lib/auto/POSIX/fsetpos.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fsetpos { - unimpl "fsetpos() is C-specific--use seek instead", caller; - unimpl "fsetpos(xxx)", caller if @_ != 123; - fsetpos($_[0]); -} - -1; diff --git a/lib/auto/POSIX/fstat.al b/lib/auto/POSIX/fstat.al deleted file mode 100644 index 64ac1b6dad..0000000000 --- a/lib/auto/POSIX/fstat.al +++ /dev/null @@ -1,13 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fstat { - usage "fstat(fd)", caller if @_ != 1; - local(*TMP); - open(TMP, "<&$_[0]"); # Gross. - local(@l) = stat(TMP); - close(TMP); - @l; -} - -1; diff --git a/lib/auto/POSIX/ftell.al b/lib/auto/POSIX/ftell.al deleted file mode 100644 index aa922c69b1..0000000000 --- a/lib/auto/POSIX/ftell.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub ftell { - unimpl "ftell() is C-specific--use tell instead", caller; - unimpl "ftell(xxx)", caller if @_ != 123; - ftell($_[0]); -} - -1; diff --git a/lib/auto/POSIX/fwrite.al b/lib/auto/POSIX/fwrite.al deleted file mode 100644 index 09d8e7db55..0000000000 --- a/lib/auto/POSIX/fwrite.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fwrite { - unimpl "fwrite() is C-specific--use print instead", caller; - unimpl "fwrite(xxx)", caller if @_ != 123; - fwrite($_[0]); -} - -1; diff --git a/lib/auto/POSIX/getc.al b/lib/auto/POSIX/getc.al deleted file mode 100644 index 5919395af1..0000000000 --- a/lib/auto/POSIX/getc.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getc { - usage "getc(handle)", caller if @_ != 1; - getc($_[0]); -} - -1; diff --git a/lib/auto/POSIX/getchar.al b/lib/auto/POSIX/getchar.al deleted file mode 100644 index 08e5111b60..0000000000 --- a/lib/auto/POSIX/getchar.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getchar { - usage "getchar()", caller if @_ != 0; - getc(STDIN); -} - -1; diff --git a/lib/auto/POSIX/getcwd.al b/lib/auto/POSIX/getcwd.al deleted file mode 100644 index 1e1ec7c688..0000000000 --- a/lib/auto/POSIX/getcwd.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getcwd { - unimpl "getcwd(xxx)", caller if @_ != 123; - getcwd($_[0]); -} - -1; diff --git a/lib/auto/POSIX/getegid.al b/lib/auto/POSIX/getegid.al deleted file mode 100644 index 6f3719cc44..0000000000 --- a/lib/auto/POSIX/getegid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getegid { - usage "getegid()", caller if @_ != 0; - $) + 0; -} - -1; diff --git a/lib/auto/POSIX/getenv.al b/lib/auto/POSIX/getenv.al deleted file mode 100644 index 04fc148f23..0000000000 --- a/lib/auto/POSIX/getenv.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getenv { - unimpl "getenv(xxx)", caller if @_ != 123; - getenv($_[0]); -} - -1; diff --git a/lib/auto/POSIX/geteuid.al b/lib/auto/POSIX/geteuid.al deleted file mode 100644 index 74b10ff30f..0000000000 --- a/lib/auto/POSIX/geteuid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub geteuid { - usage "geteuid()", caller if @_ != 0; - $> + 0; -} - -1; diff --git a/lib/auto/POSIX/getgid.al b/lib/auto/POSIX/getgid.al deleted file mode 100644 index a106618fff..0000000000 --- a/lib/auto/POSIX/getgid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getgid { - usage "getgid()", caller if @_ != 0; - $( + 0; -} - -1; diff --git a/lib/auto/POSIX/getgrgid.al b/lib/auto/POSIX/getgrgid.al deleted file mode 100644 index 485ed2b04c..0000000000 --- a/lib/auto/POSIX/getgrgid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getgrgid { - usage "getgrgid(gid)", caller if @_ != 1; - getgrgid($_[0]); -} - -1; diff --git a/lib/auto/POSIX/getgrnam.al b/lib/auto/POSIX/getgrnam.al deleted file mode 100644 index 1dcbc69850..0000000000 --- a/lib/auto/POSIX/getgrnam.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getgrnam { - usage "getgrnam(name)", caller if @_ != 1; - getgrnam($_[0]); -} - -1; diff --git a/lib/auto/POSIX/getgroups.al b/lib/auto/POSIX/getgroups.al deleted file mode 100644 index 34ae5e87cd..0000000000 --- a/lib/auto/POSIX/getgroups.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getgroups { - usage "getgroups()", caller if @_ != 0; - local(%seen) = (); - grep(!%seen{$_}++, split(' ', $) )); -} - -1; diff --git a/lib/auto/POSIX/getlogin.al b/lib/auto/POSIX/getlogin.al deleted file mode 100644 index 8f61cb24f2..0000000000 --- a/lib/auto/POSIX/getlogin.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getlogin { - usage "getlogin(xxx)", caller if @_ != 0; - getlogin(); -} - -1; diff --git a/lib/auto/POSIX/getpgrp.al b/lib/auto/POSIX/getpgrp.al deleted file mode 100644 index 0364706e53..0000000000 --- a/lib/auto/POSIX/getpgrp.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getpgrp { - usage "getpgrp()", caller if @_ != 0; - getpgrp($_[0]); -} - -1; diff --git a/lib/auto/POSIX/getpid.al b/lib/auto/POSIX/getpid.al deleted file mode 100644 index 51deea44db..0000000000 --- a/lib/auto/POSIX/getpid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getpid { - usage "getpid()", caller if @_ != 0; - $$; -} - -1; diff --git a/lib/auto/POSIX/getppid.al b/lib/auto/POSIX/getppid.al deleted file mode 100644 index 95450e95ee..0000000000 --- a/lib/auto/POSIX/getppid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getppid { - usage "getppid()", caller if @_ != 0; - getppid; -} - -1; diff --git a/lib/auto/POSIX/getpwnam.al b/lib/auto/POSIX/getpwnam.al deleted file mode 100644 index d4cbc8d766..0000000000 --- a/lib/auto/POSIX/getpwnam.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getpwnam { - usage "getpwnam(name)", caller if @_ != 1; - getpwnam($_[0]); -} - -1; diff --git a/lib/auto/POSIX/getpwuid.al b/lib/auto/POSIX/getpwuid.al deleted file mode 100644 index cfb1265761..0000000000 --- a/lib/auto/POSIX/getpwuid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getpwuid { - usage "getpwuid(uid)", caller if @_ != 1; - getpwuid($_[0]); -} - -1; diff --git a/lib/auto/POSIX/gets.al b/lib/auto/POSIX/gets.al deleted file mode 100644 index d989692172..0000000000 --- a/lib/auto/POSIX/gets.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub gets { - usage "gets(handle)", caller if @_ != 1; - local($handle) = shift; - scalar <$handle>; -} - -1; diff --git a/lib/auto/POSIX/getuid.al b/lib/auto/POSIX/getuid.al deleted file mode 100644 index 6b97d4889f..0000000000 --- a/lib/auto/POSIX/getuid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getuid { - usage "getuid()", caller if @_ != 0; - $<; -} - -1; diff --git a/lib/auto/POSIX/gmtime.al b/lib/auto/POSIX/gmtime.al deleted file mode 100644 index 520d2dadc5..0000000000 --- a/lib/auto/POSIX/gmtime.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub gmtime { - unimpl "gmtime(xxx)", caller if @_ != 123; - gmtime($_[0]); -} - -1; diff --git a/lib/auto/POSIX/isatty.al b/lib/auto/POSIX/isatty.al deleted file mode 100644 index dfc50f4d63..0000000000 --- a/lib/auto/POSIX/isatty.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub isatty { - unimpl "isatty(xxx)", caller if @_ != 123; - isatty($_[0]); -} - -1; diff --git a/lib/auto/POSIX/kill.al b/lib/auto/POSIX/kill.al deleted file mode 100644 index 138a6d72f4..0000000000 --- a/lib/auto/POSIX/kill.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub kill { - usage "kill(pid, sig)", caller if @_ != 2; - kill $_[1], $_[0]; -} - -1; diff --git a/lib/auto/POSIX/labs.al b/lib/auto/POSIX/labs.al deleted file mode 100644 index 90426e8298..0000000000 --- a/lib/auto/POSIX/labs.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub labs { - unimpl "labs(xxx)", caller if @_ != 123; - labs($_[0]); -} - -1; diff --git a/lib/auto/POSIX/ldiv.al b/lib/auto/POSIX/ldiv.al deleted file mode 100644 index 788fb3219e..0000000000 --- a/lib/auto/POSIX/ldiv.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub ldiv { - unimpl "ldiv(xxx)", caller if @_ != 123; - ldiv($_[0]); -} - -1; diff --git a/lib/auto/POSIX/link.al b/lib/auto/POSIX/link.al deleted file mode 100644 index 662ad9d41e..0000000000 --- a/lib/auto/POSIX/link.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub link { - usage "link(oldfilename, newfilename)", caller if @_ != 2; - link($_[0], $_[1]); -} - -1; diff --git a/lib/auto/POSIX/localtime.al b/lib/auto/POSIX/localtime.al deleted file mode 100644 index 5e4d61a940..0000000000 --- a/lib/auto/POSIX/localtime.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub localtime { - unimpl "localtime(xxx)", caller if @_ != 123; - localtime($_[0]); -} - -1; diff --git a/lib/auto/POSIX/log.al b/lib/auto/POSIX/log.al deleted file mode 100644 index 2ba36f20cc..0000000000 --- a/lib/auto/POSIX/log.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub log { - usage "log(x)", caller if @_ != 1; - log($_[0]); -} - -1; diff --git a/lib/auto/POSIX/longjmp.al b/lib/auto/POSIX/longjmp.al deleted file mode 100644 index d403d46bc5..0000000000 --- a/lib/auto/POSIX/longjmp.al +++ /dev/null @@ -1,8 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub longjmp { - unimpl "longjmp() is C-specific: use die instead", caller; -} - -1; diff --git a/lib/auto/POSIX/lseek.al b/lib/auto/POSIX/lseek.al deleted file mode 100644 index ded754a642..0000000000 --- a/lib/auto/POSIX/lseek.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub lseek { - unimpl "lseek(xxx)", caller if @_ != 123; - lseek($_[0]); -} - -1; diff --git a/lib/auto/POSIX/malloc.al b/lib/auto/POSIX/malloc.al deleted file mode 100644 index e860639b0d..0000000000 --- a/lib/auto/POSIX/malloc.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub malloc { - unimpl "malloc(xxx)", caller if @_ != 123; - malloc($_[0]); -} - -1; diff --git a/lib/auto/POSIX/mblen.al b/lib/auto/POSIX/mblen.al deleted file mode 100644 index 1a7b7f3428..0000000000 --- a/lib/auto/POSIX/mblen.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub mblen { - unimpl "mblen(xxx)", caller if @_ != 123; - mblen($_[0]); -} - -1; diff --git a/lib/auto/POSIX/mbstowcs.al b/lib/auto/POSIX/mbstowcs.al deleted file mode 100644 index 8f15fe306e..0000000000 --- a/lib/auto/POSIX/mbstowcs.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub mbstowcs { - unimpl "mbstowcs(xxx)", caller if @_ != 123; - mbstowcs($_[0]); -} - -1; diff --git a/lib/auto/POSIX/mbtowc.al b/lib/auto/POSIX/mbtowc.al deleted file mode 100644 index 695dcb98f4..0000000000 --- a/lib/auto/POSIX/mbtowc.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub mbtowc { - unimpl "mbtowc(xxx)", caller if @_ != 123; - mbtowc($_[0]); -} - -1; diff --git a/lib/auto/POSIX/memchr.al b/lib/auto/POSIX/memchr.al deleted file mode 100644 index 28b0c1255b..0000000000 --- a/lib/auto/POSIX/memchr.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub memchr { - unimpl "memchr(xxx)", caller if @_ != 123; - memchr($_[0]); -} - -1; diff --git a/lib/auto/POSIX/memcmp.al b/lib/auto/POSIX/memcmp.al deleted file mode 100644 index 8406f28ed9..0000000000 --- a/lib/auto/POSIX/memcmp.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub memcmp { - unimpl "memcmp(xxx)", caller if @_ != 123; - memcmp($_[0]); -} - -1; diff --git a/lib/auto/POSIX/memcpy.al b/lib/auto/POSIX/memcpy.al deleted file mode 100644 index eee2dd61fd..0000000000 --- a/lib/auto/POSIX/memcpy.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub memcpy { - unimpl "memcpy(xxx)", caller if @_ != 123; - memcpy($_[0]); -} - -1; diff --git a/lib/auto/POSIX/memmove.al b/lib/auto/POSIX/memmove.al deleted file mode 100644 index c926d78fa0..0000000000 --- a/lib/auto/POSIX/memmove.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub memmove { - unimpl "memmove(xxx)", caller if @_ != 123; - memmove($_[0]); -} - -1; diff --git a/lib/auto/POSIX/memset.al b/lib/auto/POSIX/memset.al deleted file mode 100644 index 369930e346..0000000000 --- a/lib/auto/POSIX/memset.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub memset { - unimpl "memset(xxx)", caller if @_ != 123; - memset($_[0]); -} - -1; diff --git a/lib/auto/POSIX/mkdir.al b/lib/auto/POSIX/mkdir.al deleted file mode 100644 index 0b1088271e..0000000000 --- a/lib/auto/POSIX/mkdir.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub mkdir { - usage "mkdir(directoryname, mode)", caller if @_ != 2; - mkdir($_[0], $_[1]); -} - -1; diff --git a/lib/auto/POSIX/mkfifo.al b/lib/auto/POSIX/mkfifo.al deleted file mode 100644 index 8b6ad724f1..0000000000 --- a/lib/auto/POSIX/mkfifo.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub mkfifo { - unimpl "mkfifo(xxx)", caller if @_ != 123; - mkfifo($_[0]); -} - -1; diff --git a/lib/auto/POSIX/mktime.al b/lib/auto/POSIX/mktime.al deleted file mode 100644 index df7e3556fd..0000000000 --- a/lib/auto/POSIX/mktime.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub mktime { - unimpl "mktime(xxx)", caller if @_ != 123; - mktime($_[0]); -} - -1; diff --git a/lib/auto/POSIX/offsetof.al b/lib/auto/POSIX/offsetof.al deleted file mode 100644 index fb5ecfb819..0000000000 --- a/lib/auto/POSIX/offsetof.al +++ /dev/null @@ -1,8 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub offsetof { - unimpl "offsetof() is C-specific, stopped", caller; -} - -1; diff --git a/lib/auto/POSIX/opendir.al b/lib/auto/POSIX/opendir.al deleted file mode 100644 index 7c264d4770..0000000000 --- a/lib/auto/POSIX/opendir.al +++ /dev/null @@ -1,12 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub opendir { - usage "opendir(directory)", caller if @_ != 1; - local($dirhandle) = &gensym; - opendir($dirhandle, $_[0]) - ? $dirhandle - : (ungensym($dirhandle), undef); -} - -1; diff --git a/lib/auto/POSIX/pathconf.al b/lib/auto/POSIX/pathconf.al deleted file mode 100644 index 4a66189185..0000000000 --- a/lib/auto/POSIX/pathconf.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub pathconf { - unimpl "pathconf(xxx)", caller if @_ != 123; - pathconf($_[0]); -} - -1; diff --git a/lib/auto/POSIX/pause.al b/lib/auto/POSIX/pause.al deleted file mode 100644 index 41fcea6c23..0000000000 --- a/lib/auto/POSIX/pause.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub pause { - unimpl "pause(xxx)", caller if @_ != 123; - pause($_[0]); -} - -1; diff --git a/lib/auto/POSIX/perror.al b/lib/auto/POSIX/perror.al deleted file mode 100644 index 36ae11e4c7..0000000000 --- a/lib/auto/POSIX/perror.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub perror { - unimpl "perror() is C-specific--print $! instead", caller; - unimpl "perror(xxx)", caller if @_ != 123; - perror($_[0]); -} - -1; diff --git a/lib/auto/POSIX/pipe.al b/lib/auto/POSIX/pipe.al deleted file mode 100644 index d65b5ec885..0000000000 --- a/lib/auto/POSIX/pipe.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub pipe { - unimpl "pipe(xxx)", caller if @_ != 123; - pipe($_[0]); -} - -1; diff --git a/lib/auto/POSIX/pow.al b/lib/auto/POSIX/pow.al deleted file mode 100644 index 0893b2260e..0000000000 --- a/lib/auto/POSIX/pow.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub pow { - usage "pow(x,exponent)", caller if @_ != 2; - $_[0] ** $_[1]; -} - -1; diff --git a/lib/auto/POSIX/printf.al b/lib/auto/POSIX/printf.al deleted file mode 100644 index f911780072..0000000000 --- a/lib/auto/POSIX/printf.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub printf { - usage "printf(pattern, args...)", caller if @_ < 1; - printf STDOUT @_; -} - -1; diff --git a/lib/auto/POSIX/putc.al b/lib/auto/POSIX/putc.al deleted file mode 100644 index 59eaca87a3..0000000000 --- a/lib/auto/POSIX/putc.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub putc { - unimpl "putc() is C-specific--use print instead", caller; - unimpl "putc(xxx)", caller if @_ != 123; - putc($_[0]); -} - -1; diff --git a/lib/auto/POSIX/putchar.al b/lib/auto/POSIX/putchar.al deleted file mode 100644 index 1d6016c08d..0000000000 --- a/lib/auto/POSIX/putchar.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub putchar { - unimpl "putchar() is C-specific--use print instead", caller; - unimpl "putchar(xxx)", caller if @_ != 123; - putchar($_[0]); -} - -1; diff --git a/lib/auto/POSIX/puts.al b/lib/auto/POSIX/puts.al deleted file mode 100644 index 84d3d8072a..0000000000 --- a/lib/auto/POSIX/puts.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub puts { - unimpl "puts() is C-specific--use print instead", caller; - unimpl "puts(xxx)", caller if @_ != 123; - puts($_[0]); -} - -1; diff --git a/lib/auto/POSIX/qsort.al b/lib/auto/POSIX/qsort.al deleted file mode 100644 index 93eb12496c..0000000000 --- a/lib/auto/POSIX/qsort.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub qsort { - unimpl "qsort(xxx)", caller if @_ != 123; - qsort($_[0]); -} - -1; diff --git a/lib/auto/POSIX/raise.al b/lib/auto/POSIX/raise.al deleted file mode 100644 index de43d2a29e..0000000000 --- a/lib/auto/POSIX/raise.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub raise { - usage "raise(sig)", caller if @_ != 1; - kill $$, $_[0]; # Is this good enough? -} - -1; diff --git a/lib/auto/POSIX/rand.al b/lib/auto/POSIX/rand.al deleted file mode 100644 index 08c3a1bfc7..0000000000 --- a/lib/auto/POSIX/rand.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub rand { - unimpl "rand(xxx)", caller if @_ != 123; - rand($_[0]); -} - -1; diff --git a/lib/auto/POSIX/read.al b/lib/auto/POSIX/read.al deleted file mode 100644 index 50363afd41..0000000000 --- a/lib/auto/POSIX/read.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub read { - unimpl "read(xxx)", caller if @_ != 123; - read($_[0]); -} - -1; diff --git a/lib/auto/POSIX/readdir.al b/lib/auto/POSIX/readdir.al deleted file mode 100644 index 84792b0c41..0000000000 --- a/lib/auto/POSIX/readdir.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub readdir { - usage "readdir(dirhandle)", caller if @_ != 1; - readdir($_[0]); -} - -1; diff --git a/lib/auto/POSIX/realloc.al b/lib/auto/POSIX/realloc.al deleted file mode 100644 index 4899b059c2..0000000000 --- a/lib/auto/POSIX/realloc.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub realloc { - unimpl "realloc(xxx)", caller if @_ != 123; - realloc($_[0]); -} - -1; diff --git a/lib/auto/POSIX/remove.al b/lib/auto/POSIX/remove.al deleted file mode 100644 index 83d2b8aa79..0000000000 --- a/lib/auto/POSIX/remove.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub remove { - unimpl "remove(xxx)", caller if @_ != 123; - remove($_[0]); -} - -1; diff --git a/lib/auto/POSIX/rename.al b/lib/auto/POSIX/rename.al deleted file mode 100644 index b657c5a39d..0000000000 --- a/lib/auto/POSIX/rename.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub rename { - usage "rename(oldfilename, newfilename)", caller if @_ != 2; - rename($_[0], $_[1]); -} - -1; diff --git a/lib/auto/POSIX/rewind.al b/lib/auto/POSIX/rewind.al deleted file mode 100644 index 0bbcc845a6..0000000000 --- a/lib/auto/POSIX/rewind.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub rewind { - unimpl "rewind(xxx)", caller if @_ != 123; - rewind($_[0]); -} - -1; diff --git a/lib/auto/POSIX/rewinddir.al b/lib/auto/POSIX/rewinddir.al deleted file mode 100644 index 610f45818d..0000000000 --- a/lib/auto/POSIX/rewinddir.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub rewinddir { - usage "rewinddir(dirhandle)", caller if @_ != 1; - rewinddir($_[0]); -} - -1; diff --git a/lib/auto/POSIX/rmdir.al b/lib/auto/POSIX/rmdir.al deleted file mode 100644 index a439aa6f93..0000000000 --- a/lib/auto/POSIX/rmdir.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub rmdir { - usage "rmdir(directoryname)", caller if @_ != 1; - rmdir($_[0]); -} - -1; diff --git a/lib/auto/POSIX/scanf.al b/lib/auto/POSIX/scanf.al deleted file mode 100644 index f15440924d..0000000000 --- a/lib/auto/POSIX/scanf.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub scanf { - unimpl "scanf(xxx)", caller if @_ != 123; - scanf($_[0]); -} - -1; diff --git a/lib/auto/POSIX/setbuf.al b/lib/auto/POSIX/setbuf.al deleted file mode 100644 index 96f2e976dd..0000000000 --- a/lib/auto/POSIX/setbuf.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub setbuf { - unimpl "setbuf(xxx)", caller if @_ != 123; - setbuf($_[0]); -} - -1; diff --git a/lib/auto/POSIX/setgid.al b/lib/auto/POSIX/setgid.al deleted file mode 100644 index fcbb8b6f79..0000000000 --- a/lib/auto/POSIX/setgid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub setgid { - unimpl "setgid(xxx)", caller if @_ != 123; - setgid($_[0]); -} - -1; diff --git a/lib/auto/POSIX/setjmp.al b/lib/auto/POSIX/setjmp.al deleted file mode 100644 index 93e614a32e..0000000000 --- a/lib/auto/POSIX/setjmp.al +++ /dev/null @@ -1,8 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub setjmp { - unimpl "setjmp() is C-specific: use eval {} instead", caller; -} - -1; diff --git a/lib/auto/POSIX/setpgid.al b/lib/auto/POSIX/setpgid.al deleted file mode 100644 index 948e79a977..0000000000 --- a/lib/auto/POSIX/setpgid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub setpgid { - unimpl "setpgid(xxx)", caller if @_ != 123; - setpgid($_[0]); -} - -1; diff --git a/lib/auto/POSIX/setsid.al b/lib/auto/POSIX/setsid.al deleted file mode 100644 index 7edc965f05..0000000000 --- a/lib/auto/POSIX/setsid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub setsid { - unimpl "setsid(xxx)", caller if @_ != 123; - setsid($_[0]); -} - -1; diff --git a/lib/auto/POSIX/setuid.al b/lib/auto/POSIX/setuid.al deleted file mode 100644 index 02da7d3ab6..0000000000 --- a/lib/auto/POSIX/setuid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub setuid { - unimpl "setuid(xxx)", caller if @_ != 123; - setuid($_[0]); -} - -1; diff --git a/lib/auto/POSIX/setvbuf.al b/lib/auto/POSIX/setvbuf.al deleted file mode 100644 index 5303581077..0000000000 --- a/lib/auto/POSIX/setvbuf.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub setvbuf { - unimpl "setvbuf(xxx)", caller if @_ != 123; - setvbuf($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sigaction.al b/lib/auto/POSIX/sigaction.al deleted file mode 100644 index c2b83002b6..0000000000 --- a/lib/auto/POSIX/sigaction.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sigaction { - unimpl "sigaction(xxx)", caller if @_ != 123; - sigaction($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sigaddset.al b/lib/auto/POSIX/sigaddset.al deleted file mode 100644 index 9a0ea675f7..0000000000 --- a/lib/auto/POSIX/sigaddset.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sigaddset { - unimpl "sigaddset(xxx)", caller if @_ != 123; - sigaddset($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sigdelset.al b/lib/auto/POSIX/sigdelset.al deleted file mode 100644 index c252f9f876..0000000000 --- a/lib/auto/POSIX/sigdelset.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sigdelset { - unimpl "sigdelset(xxx)", caller if @_ != 123; - sigdelset($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sigemptyset.al b/lib/auto/POSIX/sigemptyset.al deleted file mode 100644 index f665f624e6..0000000000 --- a/lib/auto/POSIX/sigemptyset.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sigemptyset { - unimpl "sigemptyset(xxx)", caller if @_ != 123; - sigemptyset($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sigfillset.al b/lib/auto/POSIX/sigfillset.al deleted file mode 100644 index b685797815..0000000000 --- a/lib/auto/POSIX/sigfillset.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sigfillset { - unimpl "sigfillset(xxx)", caller if @_ != 123; - sigfillset($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sigismember.al b/lib/auto/POSIX/sigismember.al deleted file mode 100644 index 67c9d98eb5..0000000000 --- a/lib/auto/POSIX/sigismember.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sigismember { - unimpl "sigismember(xxx)", caller if @_ != 123; - sigismember($_[0]); -} - -1; diff --git a/lib/auto/POSIX/siglongjmp.al b/lib/auto/POSIX/siglongjmp.al deleted file mode 100644 index 48ab95ed26..0000000000 --- a/lib/auto/POSIX/siglongjmp.al +++ /dev/null @@ -1,8 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub siglongjmp { - unimpl "siglongjmp() is C-specific: use die instead", caller; -} - -1; diff --git a/lib/auto/POSIX/signal.al b/lib/auto/POSIX/signal.al deleted file mode 100644 index 2471bd302c..0000000000 --- a/lib/auto/POSIX/signal.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub signal { - unimpl "signal(xxx)", caller if @_ != 123; - signal($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sigpending.al b/lib/auto/POSIX/sigpending.al deleted file mode 100644 index bb2c76de5d..0000000000 --- a/lib/auto/POSIX/sigpending.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sigpending { - unimpl "sigpending(xxx)", caller if @_ != 123; - sigpending($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sigprocmask.al b/lib/auto/POSIX/sigprocmask.al deleted file mode 100644 index a6d42a2d43..0000000000 --- a/lib/auto/POSIX/sigprocmask.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sigprocmask { - unimpl "sigprocmask(xxx)", caller if @_ != 123; - sigprocmask($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sigsetjmp.al b/lib/auto/POSIX/sigsetjmp.al deleted file mode 100644 index b737259b1a..0000000000 --- a/lib/auto/POSIX/sigsetjmp.al +++ /dev/null @@ -1,8 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sigsetjmp { - unimpl "sigsetjmp() is C-specific: use eval {} instead", caller; -} - -1; diff --git a/lib/auto/POSIX/sigsuspend.al b/lib/auto/POSIX/sigsuspend.al deleted file mode 100644 index 159f1d5aa6..0000000000 --- a/lib/auto/POSIX/sigsuspend.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sigsuspend { - unimpl "sigsuspend(xxx)", caller if @_ != 123; - sigsuspend($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sin.al b/lib/auto/POSIX/sin.al deleted file mode 100644 index 90681ff8d9..0000000000 --- a/lib/auto/POSIX/sin.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sin { - usage "sin(x)", caller if @_ != 1; - sin($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sleep.al b/lib/auto/POSIX/sleep.al deleted file mode 100644 index ac326e8882..0000000000 --- a/lib/auto/POSIX/sleep.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sleep { - unimpl "sleep(xxx)", caller if @_ != 123; - sleep($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sprintf.al b/lib/auto/POSIX/sprintf.al deleted file mode 100644 index 5a61a83dd9..0000000000 --- a/lib/auto/POSIX/sprintf.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sprintf { - unimpl "sprintf(xxx)", caller if @_ != 123; - sprintf($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sqrt.al b/lib/auto/POSIX/sqrt.al deleted file mode 100644 index f2efe5d76d..0000000000 --- a/lib/auto/POSIX/sqrt.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sqrt { - usage "sqrt(x)", caller if @_ != 1; - sqrt($_[0]); -} - -1; diff --git a/lib/auto/POSIX/srand.al b/lib/auto/POSIX/srand.al deleted file mode 100644 index 563757dcd1..0000000000 --- a/lib/auto/POSIX/srand.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub srand { - unimpl "srand(xxx)", caller if @_ != 123; - srand($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sscanf.al b/lib/auto/POSIX/sscanf.al deleted file mode 100644 index 05701419d7..0000000000 --- a/lib/auto/POSIX/sscanf.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sscanf { - unimpl "sscanf(xxx)", caller if @_ != 123; - sscanf($_[0]); -} - -1; diff --git a/lib/auto/POSIX/stat.al b/lib/auto/POSIX/stat.al deleted file mode 100644 index 636607eb33..0000000000 --- a/lib/auto/POSIX/stat.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub stat { - usage "stat(filename)", caller if @_ != 1; - stat($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strcat.al b/lib/auto/POSIX/strcat.al deleted file mode 100644 index b80dd70529..0000000000 --- a/lib/auto/POSIX/strcat.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strcat { - unimpl "strcat(xxx)", caller if @_ != 123; - strcat($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strchr.al b/lib/auto/POSIX/strchr.al deleted file mode 100644 index 9dbea2e1ec..0000000000 --- a/lib/auto/POSIX/strchr.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strchr { - unimpl "strchr(xxx)", caller if @_ != 123; - strchr($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strcmp.al b/lib/auto/POSIX/strcmp.al deleted file mode 100644 index 72f53043a8..0000000000 --- a/lib/auto/POSIX/strcmp.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strcmp { - unimpl "strcmp(xxx)", caller if @_ != 123; - strcmp($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strcoll.al b/lib/auto/POSIX/strcoll.al deleted file mode 100644 index a904097e3f..0000000000 --- a/lib/auto/POSIX/strcoll.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strcoll { - unimpl "strcoll(xxx)", caller if @_ != 123; - strcoll($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strcpy.al b/lib/auto/POSIX/strcpy.al deleted file mode 100644 index aa3e05d713..0000000000 --- a/lib/auto/POSIX/strcpy.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strcpy { - unimpl "strcpy(xxx)", caller if @_ != 123; - strcpy($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strcspn.al b/lib/auto/POSIX/strcspn.al deleted file mode 100644 index 00a5c1a968..0000000000 --- a/lib/auto/POSIX/strcspn.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strcspn { - unimpl "strcspn(xxx)", caller if @_ != 123; - strcspn($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strerror.al b/lib/auto/POSIX/strerror.al deleted file mode 100644 index d4dbd7eeb9..0000000000 --- a/lib/auto/POSIX/strerror.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strerror { - unimpl "strerror(xxx)", caller if @_ != 123; - strerror($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strftime.al b/lib/auto/POSIX/strftime.al deleted file mode 100644 index 578b3245c2..0000000000 --- a/lib/auto/POSIX/strftime.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strftime { - unimpl "strftime(xxx)", caller if @_ != 123; - strftime($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strlen.al b/lib/auto/POSIX/strlen.al deleted file mode 100644 index afb3a7e025..0000000000 --- a/lib/auto/POSIX/strlen.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strlen { - unimpl "strlen(xxx)", caller if @_ != 123; - strlen($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strncat.al b/lib/auto/POSIX/strncat.al deleted file mode 100644 index d5694bdddd..0000000000 --- a/lib/auto/POSIX/strncat.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strncat { - unimpl "strncat(xxx)", caller if @_ != 123; - strncat($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strncmp.al b/lib/auto/POSIX/strncmp.al deleted file mode 100644 index d85972c0a2..0000000000 --- a/lib/auto/POSIX/strncmp.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strncmp { - unimpl "strncmp(xxx)", caller if @_ != 123; - strncmp($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strncpy.al b/lib/auto/POSIX/strncpy.al deleted file mode 100644 index 1ebe12dd5a..0000000000 --- a/lib/auto/POSIX/strncpy.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strncpy { - unimpl "strncpy(xxx)", caller if @_ != 123; - strncpy($_[0]); -} - -1; diff --git a/lib/auto/POSIX/stroul.al b/lib/auto/POSIX/stroul.al deleted file mode 100644 index bbdb71e2ec..0000000000 --- a/lib/auto/POSIX/stroul.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub stroul { - unimpl "stroul(xxx)", caller if @_ != 123; - stroul($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strpbrk.al b/lib/auto/POSIX/strpbrk.al deleted file mode 100644 index ee8bef9a27..0000000000 --- a/lib/auto/POSIX/strpbrk.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strpbrk { - unimpl "strpbrk(xxx)", caller if @_ != 123; - strpbrk($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strrchr.al b/lib/auto/POSIX/strrchr.al deleted file mode 100644 index 175f3265e3..0000000000 --- a/lib/auto/POSIX/strrchr.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strrchr { - unimpl "strrchr(xxx)", caller if @_ != 123; - strrchr($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strspn.al b/lib/auto/POSIX/strspn.al deleted file mode 100644 index 1856caea4e..0000000000 --- a/lib/auto/POSIX/strspn.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strspn { - unimpl "strspn(xxx)", caller if @_ != 123; - strspn($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strstr.al b/lib/auto/POSIX/strstr.al deleted file mode 100644 index c9ef04aa80..0000000000 --- a/lib/auto/POSIX/strstr.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strstr { - unimpl "strstr(xxx)", caller if @_ != 123; - strstr($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strtod.al b/lib/auto/POSIX/strtod.al deleted file mode 100644 index 44ada12c08..0000000000 --- a/lib/auto/POSIX/strtod.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strtod { - unimpl "strtod(xxx)", caller if @_ != 123; - strtod($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strtok.al b/lib/auto/POSIX/strtok.al deleted file mode 100644 index 47825149b0..0000000000 --- a/lib/auto/POSIX/strtok.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strtok { - unimpl "strtok(xxx)", caller if @_ != 123; - strtok($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strtol.al b/lib/auto/POSIX/strtol.al deleted file mode 100644 index 4a40dffa0b..0000000000 --- a/lib/auto/POSIX/strtol.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strtol { - unimpl "strtol(xxx)", caller if @_ != 123; - strtol($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strxfrm.al b/lib/auto/POSIX/strxfrm.al deleted file mode 100644 index 9ad22f1efa..0000000000 --- a/lib/auto/POSIX/strxfrm.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strxfrm { - unimpl "strxfrm(xxx)", caller if @_ != 123; - strxfrm($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sysconf.al b/lib/auto/POSIX/sysconf.al deleted file mode 100644 index 5dfeab8e9d..0000000000 --- a/lib/auto/POSIX/sysconf.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sysconf { - unimpl "sysconf(xxx)", caller if @_ != 123; - sysconf($_[0]); -} - -1; diff --git a/lib/auto/POSIX/system.al b/lib/auto/POSIX/system.al deleted file mode 100644 index c143ca1e23..0000000000 --- a/lib/auto/POSIX/system.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub system { - usage "system(command)", caller if @_ != 1; - system($_[0]); -} - -1; diff --git a/lib/auto/POSIX/tan.al b/lib/auto/POSIX/tan.al deleted file mode 100644 index a86b877f3f..0000000000 --- a/lib/auto/POSIX/tan.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tan { - usage "tan(x)", caller if @_ != 1; - tan($_[0]); -} - -1; diff --git a/lib/auto/POSIX/tcdrain.al b/lib/auto/POSIX/tcdrain.al deleted file mode 100644 index 97ea14f0ab..0000000000 --- a/lib/auto/POSIX/tcdrain.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tcdrain { - unimpl "tcdrain(xxx)", caller if @_ != 123; - tcdrain($_[0]); -} - -1; diff --git a/lib/auto/POSIX/tcflow.al b/lib/auto/POSIX/tcflow.al deleted file mode 100644 index 690587aa46..0000000000 --- a/lib/auto/POSIX/tcflow.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tcflow { - unimpl "tcflow(xxx)", caller if @_ != 123; - tcflow($_[0]); -} - -1; diff --git a/lib/auto/POSIX/tcflush.al b/lib/auto/POSIX/tcflush.al deleted file mode 100644 index 733ab16425..0000000000 --- a/lib/auto/POSIX/tcflush.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tcflush { - unimpl "tcflush(xxx)", caller if @_ != 123; - tcflush($_[0]); -} - -1; diff --git a/lib/auto/POSIX/tcgetattr.al b/lib/auto/POSIX/tcgetattr.al deleted file mode 100644 index c8a5e09b6e..0000000000 --- a/lib/auto/POSIX/tcgetattr.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tcgetattr { - unimpl "tcgetattr(xxx)", caller if @_ != 123; - tcgetattr($_[0]); -} - -1; diff --git a/lib/auto/POSIX/tcgetpgrp.al b/lib/auto/POSIX/tcgetpgrp.al deleted file mode 100644 index 8b6f884f2b..0000000000 --- a/lib/auto/POSIX/tcgetpgrp.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tcgetpgrp { - unimpl "tcgetpgrp(xxx)", caller if @_ != 123; - tcgetpgrp($_[0]); -} - -1; diff --git a/lib/auto/POSIX/tcsendbreak.al b/lib/auto/POSIX/tcsendbreak.al deleted file mode 100644 index e90b7fabd3..0000000000 --- a/lib/auto/POSIX/tcsendbreak.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tcsendbreak { - unimpl "tcsendbreak(xxx)", caller if @_ != 123; - tcsendbreak($_[0]); -} - -1; diff --git a/lib/auto/POSIX/tcsetattr.al b/lib/auto/POSIX/tcsetattr.al deleted file mode 100644 index 1735cf6862..0000000000 --- a/lib/auto/POSIX/tcsetattr.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tcsetattr { - unimpl "tcsetattr(xxx)", caller if @_ != 123; - tcsetattr($_[0]); -} - -1; diff --git a/lib/auto/POSIX/tcsetpgrp.al b/lib/auto/POSIX/tcsetpgrp.al deleted file mode 100644 index 9dcff24b8c..0000000000 --- a/lib/auto/POSIX/tcsetpgrp.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tcsetpgrp { - unimpl "tcsetpgrp(xxx)", caller if @_ != 123; - tcsetpgrp($_[0]); -} - -1; diff --git a/lib/auto/POSIX/time.al b/lib/auto/POSIX/time.al deleted file mode 100644 index d750d24e90..0000000000 --- a/lib/auto/POSIX/time.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub time { - unimpl "time(xxx)", caller if @_ != 123; - time($_[0]); -} - -1; diff --git a/lib/auto/POSIX/times.al b/lib/auto/POSIX/times.al deleted file mode 100644 index d8f588ad63..0000000000 --- a/lib/auto/POSIX/times.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub times { - usage "times()", caller if @_ != 0; - times(); -} - -1; diff --git a/lib/auto/POSIX/tmpfile.al b/lib/auto/POSIX/tmpfile.al deleted file mode 100644 index 7adb01fb9b..0000000000 --- a/lib/auto/POSIX/tmpfile.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tmpfile { - unimpl "tmpfile(xxx)", caller if @_ != 123; - tmpfile($_[0]); -} - -1; diff --git a/lib/auto/POSIX/tmpnam.al b/lib/auto/POSIX/tmpnam.al deleted file mode 100644 index 23e7dfb11b..0000000000 --- a/lib/auto/POSIX/tmpnam.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tmpnam { - unimpl "tmpnam(xxx)", caller if @_ != 123; - tmpnam($_[0]); -} - -1; diff --git a/lib/auto/POSIX/tolower.al b/lib/auto/POSIX/tolower.al deleted file mode 100644 index 8bcbb8494a..0000000000 --- a/lib/auto/POSIX/tolower.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tolower { - usage "tolower(string)", caller if @_ != 1; - lc($_[0]); -} - -1; diff --git a/lib/auto/POSIX/toupper.al b/lib/auto/POSIX/toupper.al deleted file mode 100644 index e8b4c0b4ff..0000000000 --- a/lib/auto/POSIX/toupper.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub toupper { - usage "toupper(string)", caller if @_ != 1; - uc($_[0]); -} - -1; diff --git a/lib/auto/POSIX/ttyname.al b/lib/auto/POSIX/ttyname.al deleted file mode 100644 index 60f39dc5f4..0000000000 --- a/lib/auto/POSIX/ttyname.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub ttyname { - unimpl "ttyname(xxx)", caller if @_ != 123; - ttyname($_[0]); -} - -1; diff --git a/lib/auto/POSIX/tzname.al b/lib/auto/POSIX/tzname.al deleted file mode 100644 index 86e7019547..0000000000 --- a/lib/auto/POSIX/tzname.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tzname { - unimpl "tzname(xxx)", caller if @_ != 123; - tzname($_[0]); -} - -1; diff --git a/lib/auto/POSIX/tzset.al b/lib/auto/POSIX/tzset.al deleted file mode 100644 index 44b5b0a878..0000000000 --- a/lib/auto/POSIX/tzset.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tzset { - unimpl "tzset(xxx)", caller if @_ != 123; - tzset($_[0]); -} - -1; diff --git a/lib/auto/POSIX/umask.al b/lib/auto/POSIX/umask.al deleted file mode 100644 index e7c7fc71d3..0000000000 --- a/lib/auto/POSIX/umask.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub umask { - usage "umask(mask)", caller if @_ != 1; - umask($_[0]); -} - -1; diff --git a/lib/auto/POSIX/ungetc.al b/lib/auto/POSIX/ungetc.al deleted file mode 100644 index 76c426e72e..0000000000 --- a/lib/auto/POSIX/ungetc.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub ungetc { - unimpl "ungetc(xxx)", caller if @_ != 123; - ungetc($_[0]); -} - -1; diff --git a/lib/auto/POSIX/unlink.al b/lib/auto/POSIX/unlink.al deleted file mode 100644 index 798ce431d8..0000000000 --- a/lib/auto/POSIX/unlink.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub unlink { - usage "unlink(filename)", caller if @_ != 1; - unlink($_[0]); -} - -1; diff --git a/lib/auto/POSIX/utime.al b/lib/auto/POSIX/utime.al deleted file mode 100644 index fff416df89..0000000000 --- a/lib/auto/POSIX/utime.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub utime { - usage "utime(filename, atime, mtime)", caller if @_ != 3; - utime($_[1], $_[2], $_[0]); -} - -1; diff --git a/lib/auto/POSIX/vfprintf.al b/lib/auto/POSIX/vfprintf.al deleted file mode 100644 index b18f42fd85..0000000000 --- a/lib/auto/POSIX/vfprintf.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub vfprintf { - unimpl "vfprintf(xxx)", caller if @_ != 123; - vfprintf($_[0]); -} - -1; diff --git a/lib/auto/POSIX/vprintf.al b/lib/auto/POSIX/vprintf.al deleted file mode 100644 index f295a99906..0000000000 --- a/lib/auto/POSIX/vprintf.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub vprintf { - unimpl "vprintf(xxx)", caller if @_ != 123; - vprintf($_[0]); -} - -1; diff --git a/lib/auto/POSIX/vsprintf.al b/lib/auto/POSIX/vsprintf.al deleted file mode 100644 index c8e00c7803..0000000000 --- a/lib/auto/POSIX/vsprintf.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub vsprintf { - unimpl "vsprintf(xxx)", caller if @_ != 123; - vsprintf($_[0]); -} - -1; diff --git a/lib/auto/POSIX/wait.al b/lib/auto/POSIX/wait.al deleted file mode 100644 index 489b1e3b07..0000000000 --- a/lib/auto/POSIX/wait.al +++ /dev/null @@ -1,11 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub wait { - usage "wait(statusvariable)", caller if @_ != 1; - local $result = wait(); - $_[0] = $?; - $result; -} - -1; diff --git a/lib/auto/POSIX/waitpid.al b/lib/auto/POSIX/waitpid.al deleted file mode 100644 index a7706a7243..0000000000 --- a/lib/auto/POSIX/waitpid.al +++ /dev/null @@ -1,11 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub waitpid { - usage "waitpid(pid, statusvariable, options)", caller if @_ != 3; - local $result = waitpid($_[0], $_[2]); - $_[1] = $?; - $result; -} - -1; diff --git a/lib/auto/POSIX/wcstombs.al b/lib/auto/POSIX/wcstombs.al deleted file mode 100644 index 1f8782b9d6..0000000000 --- a/lib/auto/POSIX/wcstombs.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub wcstombs { - unimpl "wcstombs(xxx)", caller if @_ != 123; - wcstombs($_[0]); -} - -1; diff --git a/lib/auto/POSIX/wctomb.al b/lib/auto/POSIX/wctomb.al deleted file mode 100644 index e4ccf87cb9..0000000000 --- a/lib/auto/POSIX/wctomb.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub wctomb { - unimpl "wctomb(xxx)", caller if @_ != 123; - wctomb($_[0]); -} - -1; diff --git a/lib/auto/POSIX/write.al b/lib/auto/POSIX/write.al deleted file mode 100644 index 2306b69a01..0000000000 --- a/lib/auto/POSIX/write.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub write { - unimpl "write(xxx)", caller if @_ != 123; - write($_[0]); -} - -1; diff --git a/lib/auto/README b/lib/auto/README deleted file mode 100644 index b217acc5cd..0000000000 --- a/lib/auto/README +++ /dev/null @@ -1,2 +0,0 @@ -Everything down here is derived from elsewhere. If you modify anything -down here it will someday be overwritten. diff --git a/lib/auto/SDBM_File.so b/lib/auto/SDBM_File.so Binary files differdeleted file mode 100755 index 8414d44a5e..0000000000 --- a/lib/auto/SDBM_File.so +++ /dev/null diff --git a/lib/auto/SDBM_File/SDBM_File.so b/lib/auto/SDBM_File/SDBM_File.so Binary files differdeleted file mode 100755 index 362042ccc0..0000000000 --- a/lib/auto/SDBM_File/SDBM_File.so +++ /dev/null diff --git a/lib/auto/SDBM_File/foo b/lib/auto/SDBM_File/foo Binary files differdeleted file mode 100755 index 193c50caba..0000000000 --- a/lib/auto/SDBM_File/foo +++ /dev/null diff --git a/lib/cacheout.pl b/lib/cacheout.pl index 513c25b6fe..48d594bf82 100644 --- a/lib/cacheout.pl +++ b/lib/cacheout.pl @@ -4,6 +4,12 @@ sub cacheout'open { open($_[0], $_[1]); } +# Close as well + +sub cacheout'close { + close($_[0]); +} + # But only this sub name is visible to them. sub cacheout { @@ -15,7 +21,7 @@ sub cacheout { local(@lru) = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen); splice(@lru, $maxopen / 3); $numopen -= @lru; - for (@lru) { close $_; delete $isopen{$_}; } + for (@lru) { &close($_); delete $isopen{$_}; } } &open($file, ($saw{$file}++ ? '>>' : '>') . $file) || die "Can't create $file: $!\n"; diff --git a/lib/chat2.pl b/lib/chat2.pl index 67d0c84069..58674e5a8b 100644 --- a/lib/chat2.pl +++ b/lib/chat2.pl @@ -1,6 +1,6 @@ # chat.pl: chat with a server # Based on: V2.01.alpha.7 91/06/16 -# Randal L. Schwartz (was <merlyn@iwarp.intel.com>) +# Randal L. Schwartz (was <merlyn@stonehenge.com>) # multihome additions by A.Macpherson@bnr.co.uk # allow for /dev/pts based systems by Joe Doupnik <JRD@CC.USU.EDU> diff --git a/lib/dotsh.pl b/lib/dotsh.pl new file mode 100644 index 0000000000..4db85e742b --- /dev/null +++ b/lib/dotsh.pl @@ -0,0 +1,67 @@ +# +# @(#)dotsh.pl 03/19/94 +# +# Author: Charles Collins +# +# Description: +# This routine takes a shell script and 'dots' it into the current perl +# environment. This makes it possible to use existing system scripts +# to alter environment variables on the fly. +# +# Usage: +# &dotsh ('ShellScript', 'DependentVariable(s)'); +# +# where +# +# 'ShellScript' is the full name of the shell script to be dotted +# +# 'DependentVariable(s)' is an optional list of shell variables in the +# form VARIABLE=VALUE,VARIABLE=VALUE,... that 'ShellScript' is +# dependent upon. These variables MUST be defined using shell syntax. +# +# Example: +# &dotsh ('/tmp/foo', 'arg1'); +# &dotsh ('/tmp/foo'); +# &dotsh ('/tmp/foo arg1 ... argN'); +# +sub dotsh { + local(@sh) = @_; + local($tmp,$key,$shell,*dotsh,$command,$args,$vars) = ''; + $dotsh = shift(@sh); + @dotsh = split (/\s/, $dotsh); + $command = shift (@dotsh); + $args = join (" ", @dotsh); + $vars = join ("\n", @sh); + open (_SH_ENV, "$command") || die "Could not open $dotsh!\n"; + chop($_ = <_SH_ENV>); + $shell = "$1 -c" if ($_ =~ /^\#\!\s*(\S+(\/sh|\/ksh|\/zsh|\/csh))\s*$/); + close (_SH_ENV); + if (!$shell) { + if ($ENV{'SHELL'} =~ /\/sh$|\/ksh$|\/zsh$|\/csh$/) { + $shell = "$ENV{'SHELL'} -c"; + } else { + print "SHELL not recognized!\nUsing /bin/sh...\n"; + $shell = "/bin/sh -c"; + } + } + if (length($vars) > 0) { + system "$shell \"$vars;. $command $args; set > /tmp/_sh_env$$\""; + } else { + system "$shell \". $command $args; set > /tmp/_sh_env$$\""; + } + + open (_SH_ENV, "/tmp/_sh_env$$") || die "Could not open /tmp/_sh_env$$!\n"; + while (<_SH_ENV>) { + chop; + /=/; + $ENV{$`} = $'; + } + close (_SH_ENV); + system "rm -f /tmp/_sh_env$$"; + + foreach $key (keys(ENV)) { + $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/; + } + eval $tmp; +} +1; diff --git a/lib/dotsh.pl.art b/lib/dotsh.pl.art deleted file mode 100644 index 4f0f188e3c..0000000000 --- a/lib/dotsh.pl.art +++ /dev/null @@ -1,154 +0,0 @@ -Article 19995 of comp.lang.perl: -Newsgroups: comp.lang.perl -Path: netlabs!news.cerf.net!mvb.saic.com!MathWorks.Com!europa.eng.gtefsd.com!howland.reston.ans.net!news.ans.net!malgudi.oar.net!chemabs!skf26 -From: skf26@cas.org (Scott Frost) -Subject: HOW TO source shell scripts into Perl -Message-ID: <1994Mar21.191518.11636@chemabs.uucp> -Followup-To: scott.frost@cas.org -Keywords: Shell, Source, Dot -Sender: usenet@chemabs.uucp -Organization: Chemical Abstracts Service -Date: Mon, 21 Mar 1994 19:15:18 GMT -Lines: 139 - -A few days ago I posted a request for information on how to source -a shell script into a perl script. In general, the responses indicated that -it could not be done (although one came pretty close to the actual solution). - -A fellow staff member (who I was posting the request for) wasn't satisfied with -the response and came up with a way. - -Before I indicate how he solved the problem, let me suggest some alternative -methods of resolving this issue, - - 1. Hard code the environment variables directly in your PERL script. This - is easy but unreliable. System administrators could change the - production shell script environment variables and your PERL script would - be hosed. - - 2. Create a shell wrapper that dots the shell script into your current - environment and then invoke your perl script. This approach is easy - to do, fairly full proof, but an affront to serious PERL programmers - who believe PERL is God's gift to man (or at least Larry's :-) ). - -Chuck's solution involves running the script in the appropriate shell -environment, dumping the shell's environment variables to a file, and then -reading the environment variables into PERL's environment. - -It supports ksh, sh, csh, and zsh shells. It'll look at the first line of -the file to be executed to determine the shell to run it under, if not found, -it'll look at the SHELL environment variable. If the shell is not one of the -four listed, it'll warn you and attempt to run the shell script under /bin/sh. - - A typical usage might look like this, - #!/usr/bin/perl - - # Make sure dotsh.pl is placed in your /usr/perl/lib - require "dotsh.pl"; - - print "SHELL_ENV_VAR = $SHELL_ENV_VAR\n" ; - &dotsh('/tmp/foo') ; # script to run - print "SHELL_ENV_VAR = $SHELL_ENV_VAR\n" ; - - /tmp/foo looks like this: - #!/bin/ksh - export SHELL_ENV_VAR="hi mom" - -The actual dotsh.pl script follows (BTW, this is now public domain): -# -# @(#)dotsh.pl 03/19/94 -# -# Author: Charles Collins -# -# Description: -# This routine takes a shell script and 'dots' it into the current perl -# environment. This makes it possible to use existing system scripts -# to alter environment variables on the fly. -# -# Usage: -# &dotsh ('ShellScript', 'DependentVariable(s)'); -# -# where -# -# 'ShellScript' is the full name of the shell script to be dotted -# -# 'DependentVariable(s)' is an optional list of shell variables in the -# form VARIABLE=VALUE,VARIABLE=VALUE,... that 'ShellScript' is -# dependent upon. These variables MUST be defined using shell syntax. -# -# Example: -# &dotsh ('/tmp/foo', 'arg1'); -# &dotsh ('/tmp/foo'); -# &dotsh ('/tmp/foo arg1 ... argN'); -# -sub dotsh { - local(@sh) = @_; - local($tmp,$key,$shell,*dotsh,$command,$args,$vars) = ''; - $dotsh = shift(@sh); - @dotsh = split (/\s/, $dotsh); - $command = shift (@dotsh); - $args = join (" ", @dotsh); - $vars = join ("\n", @sh); - open (_SH_ENV, "$command") || die "Could not open $dotsh!\n"; - chop($_ = <_SH_ENV>); - $shell = "$1 -c" if ($_ =~ /^\#\!\s*(\S+(\/sh|\/ksh|\/zsh|\/csh))\s*$/); - close (_SH_ENV); - if (!$shell) { - if ($ENV{'SHELL'} =~ /\/sh$|\/ksh$|\/zsh$|\/csh$/) { - $shell = "$ENV{'SHELL'} -c"; - } else { - print "SHELL not recognized!\nUsing /bin/sh...\n"; - $shell = "/bin/sh -c"; - } - } - if (length($vars) > 0) { - system "$shell \"$vars;. $command $args; set > /tmp/_sh_env$$\""; - } else { - system "$shell \". $command $args; set > /tmp/_sh_env$$\""; - } - - open (_SH_ENV, "/tmp/_sh_env$$") || die "Could not open /tmp/_sh_env$$!\n"; - while (<_SH_ENV>) { - chop; - /=/; - $ENV{$`} = $'; - } - close (_SH_ENV); - system "rm -f /tmp/_sh_env$$"; - - foreach $key (keys(ENV)) { - $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/; - } - eval $tmp; -} -1; - - - - - - - - - - - - - - - - - - - - - - - - - - --- -Scott K. Frost INET: scott.frost@cas.org - - diff --git a/lib/dumpvar.pl b/lib/dumpvar.pl index 03dbbcd8fe..4ebcb5203d 100644 --- a/lib/dumpvar.pl +++ b/lib/dumpvar.pl @@ -3,18 +3,23 @@ package dumpvar; # translate control chars to ^X - Randal Schwartz sub unctrl { local($_) = @_; + return \$_ if ref \$_ eq "GLOB"; s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg; $_; } sub main'dumpvar { ($package,@vars) = @_; - local(*stab) = *{"::_$package"}; + $package .= "::" unless $package =~ /::$/; + *stab = *{"main::"}; + while ($package =~ /(\w+?::)/g){ + *stab = ${stab}{$1}; + } while (($key,$val) = each(%stab)) { { next if @vars && !grep($key eq $_,@vars); local(*entry) = $val; if (defined $entry) { - print "\$$key = '",&unctrl($entry),"'\n"; + print "\$",&unctrl($key)," = '",&unctrl($entry),"'\n"; } if (defined @entry) { print "\@$key = (\n"; @@ -23,7 +28,8 @@ sub main'dumpvar { } print ")\n"; } - if ($key ne "_$package" && $key ne "_DB" && defined %entry) { + if ($key ne "main::" && $key ne "DB::" && defined %entry + && !($package eq "dumpvar" and $key eq "stab")) { print "\%$key = (\n"; foreach $key (sort keys(%entry)) { print " $key\t'",&unctrl($entry{$key}),"'\n"; diff --git a/lib/find.pl b/lib/find.pl index d55cd33122..40e613e97e 100644 --- a/lib/find.pl +++ b/lib/find.pl @@ -39,8 +39,8 @@ sub find { ($dir,$_) = ($topdir,'.'); $name = $topdir; &wanted; - $topdir =~ s,/$,, ; - &finddir($topdir,$topnlink); + ($fixtopdir = $topdir) =~ s,/$,, ; + &finddir($fixtopdir,$topnlink); } else { warn "Can't cd to $topdir: $!\n"; diff --git a/lib/finddepth.pl b/lib/finddepth.pl index 15e4daf561..1fe6a375b6 100644 --- a/lib/finddepth.pl +++ b/lib/finddepth.pl @@ -34,10 +34,10 @@ sub finddepth { || (warn("Can't stat $topdir: $!\n"), next); if (-d _) { if (chdir($topdir)) { - $topdir =~ s,/$,, ; - &finddepthdir($topdir,$topnlink); - ($dir,$_) = ($topdir,'.'); - $name = $topdir; + ($fixtopdir = $topdir) =~ s,/$,, ; + &finddepthdir($fixtopdir,$topnlink); + ($dir,$_) = ($fixtopdir,'.'); + $name = $fixtopdir; &wanted; } else { diff --git a/lib/integer.pm b/lib/integer.pm new file mode 100644 index 0000000000..74039bb962 --- /dev/null +++ b/lib/integer.pm @@ -0,0 +1,11 @@ +package integer; + +sub import { + $^H |= 1; +} + +sub unimport { + $^H &= ~1; +} + +1; diff --git a/lib/less.pm b/lib/less.pm new file mode 100644 index 0000000000..a95484ff76 --- /dev/null +++ b/lib/less.pm @@ -0,0 +1,2 @@ +package less; +1; diff --git a/lib/open3.pl b/lib/open3.pl index 1dbe525f68..7c8b6ae288 100644 --- a/lib/open3.pl +++ b/lib/open3.pl @@ -90,9 +90,8 @@ sub main'open3 { } else { open(STDERR, ">&STDOUT") if (fileno(STDERR) != fileno(STDOUT)); } - exec @cmd; - local($")=(" "); + exec @cmd; die "open2: exec of @cmd failed"; } diff --git a/lib/perldb.pl b/lib/perl5db.pl index 0b50555172..ac03c098fe 100644 --- a/lib/perldb.pl +++ b/lib/perl5db.pl @@ -4,75 +4,34 @@ package DB; # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990 # Johan Vromans -- upgrade to 4.0 pl 10 -$header = '$RCSfile: perldb.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:07 $'; +$header = '$RCSfile: perl5db.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:07 $'; # # 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 +# a &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 4.1 92/08/07 18:24:07 lwall -# -# 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. -# -# + +local($^W) = 0; if (-e "/dev/tty") { $console = "/dev/tty"; $rcfile=".perldb"; } -else { +elsif (-e "con") { $console = "con"; $rcfile="perldb.ini"; } +else { + $console = "sys\$command"; + $rcfile="perldb.ini"; +} open(IN, "<$console") || open(IN, "<&STDIN"); # so we don't dingle stdin -open(OUT,">$console") || open(OUT, "<&STDERR") +open(OUT,">$console") || open(OUT, ">&STDERR") || open(OUT, ">&STDOUT"); # so we don't dongle stdout select(OUT); $| = 1; # for DB::OUT @@ -81,7 +40,7 @@ $| = 1; # for real STDOUT $sub = ''; # Is Perl being run from Emacs? -$emacs = $main::ARGV[$[] eq '-emacs'; +$emacs = $main::ARGV[0] eq '-emacs'; shift(@main::ARGV) if $emacs; $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/; @@ -94,7 +53,7 @@ print OUT "\nEnter h for help.\n\n"; sub DB { &save; ($package, $filename, $line) = caller; - $usercontext = '($@, $!, $[, $,, $/, $\) = @saved;' . + $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' . "package $package;"; # this won't let them modify, alas local(*dbline) = "::_<$filename"; $max = $#dbline; @@ -111,11 +70,20 @@ sub DB { if ($emacs) { print OUT "\032\032$filename:$line:0\n"; } else { - print OUT "$package::" unless $sub =~ /'|::/; - print OUT "$sub($filename:$line):\t",$dbline[$line]; + $prefix = $sub =~ /'|::/ ? "" : "${package}::"; + $prefix .= "$sub($filename:"; + if (length($prefix) > 30) { + print OUT "$prefix$line):\n$line:\t",$dbline[$line]; + $prefix = ""; + $infix = ":\t"; + } + else { + $infix = "):\t"; + print OUT "$prefix$line$infix",$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]; + print OUT "$prefix$i$infix",$dbline[$i]; } } } @@ -222,13 +190,13 @@ command Execute as a perl statement in current package. print OUT "The new f command switches filenames.\n"; next CMD; } - if (!defined $::_main{'_<' . $file}) { - if (($try) = grep(m#^_<.*$file#, keys %::_main)) { + if (!defined $main::{'_<' . $file}) { + if (($try) = grep(m#^_<.*$file#, keys %main::)) { $file = substr($try,2); print "\n$file:\n"; } } - if (!defined $::_main{'_<' . $file}) { + if (!defined $main::{'_<' . $file}) { print OUT "There's no code here anything matching $file.\n"; next CMD; } @@ -320,7 +288,8 @@ command Execute as a perl statement in current package. $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do { $subname = $1; $cond = $2 || '1'; - $subname = "$package::" . $subname unless $subname =~ /'|::/; + $subname = "${package}::" . $subname + unless $subname =~ /'|::/; $subname = "main" . $subname if substr($subname,0,1) eq "'"; $subname = "main" . $subname if substr($subname,0,2) eq "::"; ($filename,$i) = split(/:/, $sub{$subname}); @@ -356,10 +325,10 @@ command Execute as a perl statement in current package. } next CMD; }; $cmd =~ /^<\s*(.*)/ && do { - $pre = do action($1); + $pre = action($1); next CMD; }; $cmd =~ /^>\s*(.*)/ && do { - $post = do action($1); + $post = action($1); next CMD; }; $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do { $i = $1; @@ -367,7 +336,7 @@ command Execute as a perl statement in current package. print OUT "Line $i may not have an action.\n"; } else { $dbline{$i} =~ s/\0[^\0]*//; - $dbline{$i} .= "\0" . do action($3); + $dbline{$i} .= "\0" . action($3); } next CMD; }; $cmd =~ /^n$/ && do { @@ -397,16 +366,19 @@ command Execute as a perl statement in current package. $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) { + @a = (); + for $arg (@args) { + $_ = "$arg"; s/'/\\'/g; - s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/; + s/([^\0]*)/'$1'/ + unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; + push(@a, $_); } $w = $w ? '@ = ' : '$ = '; $a = $h ? '(' . join(', ', @a) . ')' : ''; - push(@sub, "$w&$s$a from file $f line $l\n"); + push(@sub, "$w$s$a from file $f line $l\n"); last if $signal; } for ($i=0; $i <= $#sub; $i++) { @@ -418,7 +390,7 @@ command Execute as a perl statement in current package. $inpat = $1; $inpat =~ s:([^\\])/$:$1:; if ($inpat ne "") { - eval '$inpat =~ m'."\n$inpat\n"; + eval '$inpat =~ m'."\a$inpat\a"; if ($@ ne "") { print OUT "$@"; next CMD; @@ -431,7 +403,7 @@ command Execute as a perl statement in current package. ++$start; $start = 1 if ($start > $max); last if ($start == $end); - if ($dbline[$start] =~ m'."\n$pat\n".'i) { + if ($dbline[$start] =~ m'."\a$pat\a".'i) { if ($emacs) { print OUT "\032\032$filename:$start:0\n"; } else { @@ -446,7 +418,7 @@ command Execute as a perl statement in current package. $inpat = $1; $inpat =~ s:([^\\])\?$:$1:; if ($inpat ne "") { - eval '$inpat =~ m'."\n$inpat\n"; + eval '$inpat =~ m'."\a$inpat\a"; if ($@ ne "") { print OUT "$@"; next CMD; @@ -459,7 +431,7 @@ command Execute as a perl statement in current package. --$start; $start = $max if ($start <= 0); last if ($start == $end); - if ($dbline[$start] =~ m'."\n$pat\n".'i) { + if ($dbline[$start] =~ m'."\a$pat\a".'i) { if ($emacs) { print OUT "\032\032$filename:$start:0\n"; } else { @@ -520,12 +492,12 @@ command Execute as a perl statement in current package. $evalarg = $post; &eval; } } - ($@, $!, $[, $,, $/, $\) = @saved; + ($@, $!, $,, $/, $\) = @saved; } sub save { - @saved = ($@, $!, $[, $,, $/, $\); - $[ = 0; $, = ""; $/ = "\n"; $\ = ""; + @saved = ($@, $!, $,, $/, $\, $^W); + $, = ""; $/ = "\n"; $\ = ""; $^W = 0; } # The following takes its argument via $evalarg to preserve current @_ @@ -569,7 +541,8 @@ sub sub { } } -$single = 1; # so it stops on first executable statement +$trace = $signal = $single = 0; # uninitialized warning suppression + @hist = ('?'); $SIG{'INT'} = "DB::catch"; $deep = 100; # warning if stack gets this deep diff --git a/lib/pwd.pl b/lib/pwd.pl index 8e17dd02d2..0cc3d4e96e 100644 --- a/lib/pwd.pl +++ b/lib/pwd.pl @@ -3,20 +3,6 @@ ;# $RCSfile: pwd.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:11 $ ;# ;# $Log: pwd.pl,v $ -;# Revision 4.1 92/08/07 18:24:11 lwall -;# -;# 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"; diff --git a/lib/shellwords.pl b/lib/shellwords.pl index 5d593daa50..1c45a5a090 100644 --- a/lib/shellwords.pl +++ b/lib/shellwords.pl @@ -17,13 +17,13 @@ sub shellwords { while ($_ ne '') { $field = ''; for (;;) { - if (s/^"(([^"\\]|\\[\\"])*)"//) { + if (s/^"(([^"\\]|\\.)*)"//) { ($snippet = $1) =~ s#\\(.)#$1#g; } elsif (/^"/) { die "Unmatched double quote: $_\n"; } - elsif (s/^'(([^'\\]|\\[\\'])*)'//) { + elsif (s/^'(([^'\\]|\\.)*)'//) { ($snippet = $1) =~ s#\\(.)#$1#g; } elsif (/^'/) { diff --git a/lib/sigtrap.pm b/lib/sigtrap.pm new file mode 100644 index 0000000000..72b9cb6044 --- /dev/null +++ b/lib/sigtrap.pm @@ -0,0 +1,47 @@ +package sigtrap; + +require Carp; + +sub import { + my $pack = shift; + my @sigs = @_; + @sigs or @sigs = qw(QUIT ILL TRAP ABRT EMT FPE BUS SEGV SYS PIPE TERM); + foreach $sig (@sigs) { + $SIG{$sig} = 'sigtrap::trap'; + } +} + +sub trap { + package DB; # To get subroutine args. + $SIG{'ABRT'} = DEFAULT; + kill 'ABRT', $$ if $panic++; + syswrite(STDERR, 'Caught a SIG', 12); + syswrite(STDERR, $_[0], length($_[0])); + syswrite(STDERR, ' at ', 4); + ($pack,$file,$line) = caller; + syswrite(STDERR, $file, length($file)); + syswrite(STDERR, ' line ', 6); + syswrite(STDERR, $line, length($line)); + syswrite(STDERR, "\n", 1); + + # Now go for broke. + for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) { + @a = (); + for $arg (@args) { + $_ = "$arg"; + s/'/\\'/g; + s/([^\0]*)/'$1'/ + unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; + s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; + s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; + push(@a, $_); + } + $w = $w ? '@ = ' : '$ = '; + $a = $h ? '(' . join(', ', @a) . ')' : ''; + $mess = "$w$s$a called from $f line $l\n"; + syswrite(STDERR, $mess, length($mess)); + } + kill 'ABRT', $$; +} + +1; diff --git a/lib/soundex.pl.art b/lib/soundex.pl.art deleted file mode 100644 index 1cc0b9e53c..0000000000 --- a/lib/soundex.pl.art +++ /dev/null @@ -1,285 +0,0 @@ -Article 20106 of comp.lang.perl: -Path: netlabs!news.cerf.net!ihnp4.ucsd.edu!mvb.saic.com!MathWorks.Com!noc.near.net!newshost.meiko.com!not-for-mail -From: mike@meiko.com (Mike Stok) -Newsgroups: comp.lang.perl -Subject: Soundex (again :-) -Date: 23 Mar 1994 19:44:35 -0500 -Organization: Meiko Scientific, Inc., MA -Lines: 272 -Message-ID: <2mqnpj$qk4@hibbert.meiko.com> -NNTP-Posting-Host: hibbert.meiko.com - -Thanks to Rich Pinder <rpinder@hsc.usc.edu> for finding a little bug in my -soundex code I posted a while back. This showed up when he compared it -with the output from Oracle's soundex function, and were caused by leading -characters which were different but shared the same soundex code. - -Here's a fixed shar file... - -Mike - -#!/bin/sh -# This is a shell archive (produced by shar 3.49) -# To extract the files from this archive, save it to a file, remove -# everything above the "!/bin/sh" line above, and type "sh file_name". -# -# made 03/24/1994 00:35 UTC by Mike.Stok@meiko.concord.ma.us -# Source directory /tmp_mnt/develop/sw/misc/mike/soundex -# -# existing files will NOT be overwritten unless -c is specified -# -# This shar contains: -# length mode name -# ------ ---------- ------------------------------------------ -# 1677 -r--r--r-- soundex.pl -# 2408 -r-xr-xr-x soundex.t -# -# ============= soundex.pl ============== -if test -f 'soundex.pl' -a X"$1" != X"-c"; then - echo 'x - skipping soundex.pl (File already exists)' -else -echo 'x - extracting soundex.pl (Text)' -sed 's/^X//' << 'SHAR_EOF' > 'soundex.pl' && -package soundex; -X -;# $Id: soundex.pl,v 1.2 1994/03/24 00:30:27 mike Exp $ -;# -;# Implementation of soundex algorithm as described by Knuth in volume -;# 3 of The Art of Computer Programming, with ideas stolen from Ian -;# Phillips <ian@pipex.net>. -;# -;# Mike Stok <Mike.Stok@meiko.concord.ma.us>, 2 March 1994. -;# -;# Knuth's test cases are: -;# -;# Euler, Ellery -> E460 -;# Gauss, Ghosh -> G200 -;# Hilbert, Heilbronn -> H416 -;# Knuth, Kant -> K530 -;# Lloyd, Ladd -> L300 -;# Lukasiewicz, Lissajous -> L222 -;# -;# $Log: soundex.pl,v $ -;# Revision 1.2 1994/03/24 00:30:27 mike -;# Subtle bug (any excuse :-) spotted by Rich Pinder <rpinder@hsc.usc.edu> -;# in the way I handles leasing characters which were different but had -;# the same soundex code. This showed up comparing it with Oracle's -;# soundex output. -;# -;# Revision 1.1 1994/03/02 13:01:30 mike -;# Initial revision -;# -;# -;############################################################################## -X -;# $soundex'noCode is used to indicate a string doesn't have a soundex -;# code, I like undef other people may want to set it to 'Z000'. -X -$noCode = undef; -X -;# main'soundex -;# -;# usage: -;# -;# @codes = &main'soundex (@wordList); -;# $code = &main'soundex ($word); -;# -;# This strenuously avoids $[ -X -sub main'soundex -{ -X local (@s, $f, $fc, $_) = @_; -X -X foreach (@s) -X { -X tr/a-z/A-Z/; -X tr/A-Z//cd; -X -X if ($_ eq '') -X { -X $_ = $noCode; -X } -X else -X { -X ($f) = /^(.)/; -X tr/AEHIOUWYBFPVCGJKQSXZDTLMNR/00000000111122222222334556/; -X ($fc) = /^(.)/; -X s/^$fc+//; -X tr///cs; -X tr/0//d; -X $_ = $f . $_ . '000'; -X s/^(.{4}).*/$1/; -X } -X } -X -X wantarray ? @s : shift @s; -} -X -1; -SHAR_EOF -chmod 0444 soundex.pl || -echo 'restore of soundex.pl failed' -Wc_c="`wc -c < 'soundex.pl'`" -test 1677 -eq "$Wc_c" || - echo 'soundex.pl: original size 1677, current size' "$Wc_c" -fi -# ============= soundex.t ============== -if test -f 'soundex.t' -a X"$1" != X"-c"; then - echo 'x - skipping soundex.t (File already exists)' -else -echo 'x - extracting soundex.t (Text)' -sed 's/^X//' << 'SHAR_EOF' > 'soundex.t' && -#!./perl -;# -;# $Id: soundex.t,v 1.2 1994/03/24 00:30:27 mike Exp $ -;# -;# test module for soundex.pl -;# -;# $Log: soundex.t,v $ -;# Revision 1.2 1994/03/24 00:30:27 mike -;# Subtle bug (any excuse :-) spotted by Rich Pinder <rpinder@hsc.usc.edu> -;# in the way I handles leasing characters which were different but had -;# the same soundex code. This showed up comparing it with Oracle's -;# soundex output. -;# -;# Revision 1.1 1994/03/02 13:03:02 mike -;# Initial revision -;# -;# -X -require '../lib/soundex.pl'; -X -$test = 0; -print "1..13\n"; -X -while (<DATA>) -{ -X chop; -X next if /^\s*;?#/; -X next if /^\s*$/; -X -X ++$test; -X $bad = 0; -X -X if (/^eval\s+/) -X { -X ($try = $_) =~ s/^eval\s+//; -X -X eval ($try); -X if ($@) -X { -X $bad++; -X print "not ok $test\n"; -X print "# eval '$try' returned $@"; -X } -X } -X elsif (/^\(/) -X { -X ($in, $out) = split (':'); -X -X $try = "\@expect = $out; \@got = &soundex $in;"; -X eval ($try); -X -X if (@expect != @got) -X { -X $bad++; -X print "not ok $test\n"; -X print "# expected ", scalar @expect, " results, got ", scalar @got, "\n"; -X print "# expected (", join (', ', @expect), -X ") got (", join (', ', @got), ")\n"; -X } -X else -X { -X while (@got) -X { -X $expect = shift @expect; -X $got = shift @got; -X -X if ($expect ne $got) -X { -X $bad++; -X print "not ok $test\n"; -X print "# expected $expect, got $got\n"; -X } -X } -X } -X } -X else -X { -X ($in, $out) = split (':'); -X -X $try = "\$expect = $out; \$got = &soundex ($in);"; -X eval ($try); -X -X if ($expect ne $got) -X { -X $bad++; -X print "not ok $test\n"; -X print "# expected $expect, got $got\n"; -X } -X } -X -X print "ok $test\n" unless $bad; -} -X -__END__ -# -# 1..6 -# -# Knuth's test cases, scalar in, scalar out -# -'Euler':'E460' -'Gauss':'G200' -'Hilbert':'H416' -'Knuth':'K530' -'Lloyd':'L300' -'Lukasiewicz':'L222' -# -# 7..8 -# -# check default bad code -# -'2 + 2 = 4':undef -undef:undef -# -# 9 -# -# check array in, array out -# -('Ellery', 'Ghosh', 'Heilbronn', 'Kant', 'Ladd', 'Lissajous'):('E460', 'G200', 'H416', 'K530', 'L300', 'L222') -# -# 10 -# -# check array with explicit undef -# -('Mike', undef, 'Stok'):('M200', undef, 'S320') -# -# 11..12 -# -# check setting $soundex'noCode -# -eval $soundex'noCode = 'Z000'; -('Mike', undef, 'Stok'):('M200', 'Z000', 'S320') -# -# 13 -# -# a subtle difference between me & oracle, spotted by Rich Pinder -# <rpinder@hsc.usc.edu> -# -CZARKOWSKA:C622 -SHAR_EOF -chmod 0555 soundex.t || -echo 'restore of soundex.t failed' -Wc_c="`wc -c < 'soundex.t'`" -test 2408 -eq "$Wc_c" || - echo 'soundex.t: original size 2408, current size' "$Wc_c" -fi -exit 0 - --- -The "usual disclaimers" apply. | Meiko -Mike Stok | 130C Baker Ave. Ext -Mike.Stok@meiko.concord.ma.us | Concord, MA 01742 -Meiko tel: (508) 371 0088 | - - diff --git a/lib/strict.pm b/lib/strict.pm new file mode 100644 index 0000000000..adaf47c720 --- /dev/null +++ b/lib/strict.pm @@ -0,0 +1,23 @@ +package strict; + +sub bits { + my $bits = 0; + foreach $sememe (@_) { + $bits |= 0x00000002 if $sememe eq 'refs'; + $bits |= 0x00000200 if $sememe eq 'subs'; + $bits |= 0x00000400 if $sememe eq 'vars'; + } + $bits; +} + +sub import { + shift; + $^H |= bits(@_ ? @_ : qw(refs subs vars)); +} + +sub unimport { + shift; + $^H &= ~ bits(@_ ? @_ : qw(refs subs vars)); +} + +1; diff --git a/lib/subs.pm b/lib/subs.pm new file mode 100644 index 0000000000..8b5835770f --- /dev/null +++ b/lib/subs.pm @@ -0,0 +1,16 @@ +package subs; + +require 5.000; + +$ExportLevel = 0; + +sub import { + my $callpack = caller; + my $pack = shift; + my @imports = @_; + foreach $sym (@imports) { + *{"${callpack}::$sym"} = \&{"${callpack}::$sym"}; + } +}; + +1; diff --git a/lib/syslog.pl b/lib/syslog.pl index 8e64a0028d..a3b9edf8da 100644 --- a/lib/syslog.pl +++ b/lib/syslog.pl @@ -2,41 +2,7 @@ # syslog.pl # # $Log: syslog.pl,v $ -# Revision 4.1 92/08/07 18:24:15 lwall # -# 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) diff --git a/lib/Termcap.pm b/lib/termcap.pl index da4c7ce2bc..e8f108df06 100644 --- a/lib/Termcap.pm +++ b/lib/termcap.pl @@ -1,19 +1,10 @@ -package Termcap; - -require 5.000; -require Exporter; -@ISA = (Exporter); -@EXPORT = qw(&Tgetent $ispeed $ospeed &Tputs %TC &Tgoto); - - -;# Termcap.pm +;# $RCSfile: termcap.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:16 $ ;# ;# Usage: ;# require 'ioctl.pl'; -;# require Termcap; -;# import Termcap; ;# 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'); @@ -23,10 +14,11 @@ sub Tgetent { local($TERMCAP,$_,$entry,$loop,$field); warn "Tgetent: no ospeed set" unless $ospeed; - foreach $key (keys(%TC)) { + foreach $key (keys(TC)) { delete $TC{$key}; } $TERM = $ENV{'TERM'} unless $TERM; + $TERM =~ s/(\W)/\\$1/g; $TERMCAP = $ENV{'TERMCAP'}; $TERMCAP = '/etc/termcap' unless $TERMCAP; if ($TERMCAP !~ m:^/:) { @@ -42,7 +34,7 @@ sub Tgetent { while (<TERMCAP>) { next if /^#/; next if /^\t/; - if (/(^|\\|)$TERM\[:\\|]/) { + if (/(^|\\|)${TERM}[:\\|]/) { chop; while (chop eq '\\\\') { \$_ .= <TERMCAP>; @@ -65,7 +57,7 @@ sub Tgetent { $TC{$field} = 1; } elsif ($field =~ /^(\w\w)#(.*)/) { - $TC{$1} = $2 unless defined $TC{$1}; + $TC{$1} = $2 if $TC{$1} eq ''; } elsif ($field =~ /^(\w\w)=(.*)/) { $entry = $1; @@ -82,11 +74,11 @@ sub Tgetent { s/\^(.)/pack('c',ord($1) & 31)/eg; s/\\(.)/$1/g; s/\377/^/g; - $TC{$entry} = $_ unless defined $TC{$entry}; + $TC{$entry} = $_ if $TC{$entry} eq ''; } } - $TC{'pc'} = "\0" unless defined $TC{'pc'}; - $TC{'bc'} = "\b" unless defined $TC{'bc'}; + $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); diff --git a/lib/timelocal.pl b/lib/timelocal.pl index c5d8a92920..75f1ac1851 100644 --- a/lib/timelocal.pl +++ b/lib/timelocal.pl @@ -21,6 +21,9 @@ ;# the result of localtime(0) when the package is initialized. The daylight ;# savings offset is currently assumed to be one hour. +;# Both routines return -1 if the integer limit is hit. I.e. for dates +;# after the 1st of January, 2038 on most machines. + CONFIG: { package timelocal; @@ -46,6 +49,7 @@ sub timegm { local($[) = 0; $ym = pack(C2, @_[5,4]); $cheat = $cheat{$ym} || &cheat; + return -1 if $cheat<0; $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAYS; } @@ -54,6 +58,7 @@ sub timelocal { local($[) = 0; $time = &main'timegm + $tzmin*$MIN; + return -1 if $cheat<0; @test = localtime($time); $time -= $HR if $test[2] != $_[2]; $time; @@ -64,17 +69,39 @@ package timelocal; sub cheat { $year = $_[5]; $month = $_[4]; - die "Month out of range 0..11 in ctime.pl\n" if $month > 11; + die "Month out of range 0..11 in timelocal.pl\n" + if $month > 11 || $month < 0; + die "Day out of range 1..31 in timelocal.pl\n" + if $_[3] > 31 || $_[3] < 1; + die "Hour out of range 0..23 in timelocal.pl\n" + if $_[2] > 23 || $_[2] < 0; + die "Minute out of range 0..59 in timelocal.pl\n" + if $_[1] > 59 || $_[1] < 0; + die "Second out of range 0..59 in timelocal.pl\n" + if $_[0] > 59 || $_[0] < 0; $guess = $^T; @g = gmtime($guess); $year += $YearFix if $year < $epoch[5]; + $lastguess = ""; while ($diff = $year - $g[5]) { $guess += $diff * (363 * $DAYS); @g = gmtime($guess); + if (($thisguess = "@g") eq $lastguess){ + return -1; #date beyond this machine's integer limit + } + $lastguess = $thisguess; } while ($diff = $month - $g[4]) { $guess += $diff * (27 * $DAYS); @g = gmtime($guess); + if (($thisguess = "@g") eq $lastguess){ + return -1; #date beyond this machine's integer limit + } + $lastguess = $thisguess; + } + @gfake = gmtime($guess-1); #still being sceptic + if ("@gfake" eq $lastguess){ + return -1; #date beyond this machine's integer limit } $g[3]--; $guess -= $g[0] * $SEC + $g[1] * $MIN + $g[2] * $HR + $g[3] * $DAYS; |