From 8cc871bd82ee24f31b8b9cf2c8458ced9d3dfd42 Mon Sep 17 00:00:00 2001 From: Florian Ragwitz Date: Sun, 3 Jul 2011 12:22:37 +0200 Subject: [PATCH] Remove deprecated Perl 4 core libraries --- MANIFEST | 34 ---- META.yml | 1 - Porting/Maintainers.pl | 11 +- cpan/Getopt-Long/t/gol-compat.t | 39 ---- lib/abbrev.pl | 46 ----- lib/assert.pl | 63 ------ lib/bigfloat.pl | 258 ------------------------ lib/bigfloatpl.t | 422 ---------------------------------------- lib/bigint.pl | 324 ------------------------------ lib/bigintpl.t | 296 ---------------------------- lib/bigrat.pl | 159 --------------- lib/cacheout.pl | 59 ------ lib/complete.pl | 124 ------------ lib/ctime.pl | 63 ------ lib/dotsh.pl | 78 -------- lib/exceptions.pl | 64 ------ lib/fastcwd.pl | 47 ----- lib/find.pl | 54 ----- lib/finddepth.pl | 53 ----- lib/flush.pl | 36 ---- lib/getcwd.pl | 74 ------- lib/getopt.pl | 52 ----- lib/getopts.pl | 67 ------- lib/hostname.pl | 35 ---- lib/importenv.pl | 21 -- lib/look.pl | 54 ----- lib/newgetopt.pl | 77 -------- lib/open2.pl | 17 -- lib/open3.pl | 17 -- lib/pwd.pl | 71 ------- lib/shellwords.pl | 19 -- lib/stat.pl | 35 ---- lib/syslog.pl | 201 ------------------- lib/tainted.pl | 14 -- lib/termcap.pl | 183 ----------------- lib/timelocal.pl | 23 --- lib/validate.pl | 104 ---------- 37 files changed, 3 insertions(+), 3292 deletions(-) delete mode 100644 cpan/Getopt-Long/t/gol-compat.t delete mode 100644 lib/abbrev.pl delete mode 100644 lib/assert.pl delete mode 100644 lib/bigfloat.pl delete mode 100644 lib/bigfloatpl.t delete mode 100644 lib/bigint.pl delete mode 100644 lib/bigintpl.t delete mode 100644 lib/bigrat.pl delete mode 100644 lib/cacheout.pl delete mode 100644 lib/complete.pl delete mode 100644 lib/ctime.pl delete mode 100644 lib/dotsh.pl delete mode 100644 lib/exceptions.pl delete mode 100644 lib/fastcwd.pl delete mode 100644 lib/find.pl delete mode 100644 lib/finddepth.pl delete mode 100644 lib/flush.pl delete mode 100644 lib/getcwd.pl delete mode 100644 lib/getopt.pl delete mode 100644 lib/getopts.pl delete mode 100644 lib/hostname.pl delete mode 100644 lib/importenv.pl delete mode 100644 lib/look.pl delete mode 100644 lib/newgetopt.pl delete mode 100644 lib/open2.pl delete mode 100644 lib/open3.pl delete mode 100644 lib/pwd.pl delete mode 100644 lib/shellwords.pl delete mode 100644 lib/stat.pl delete mode 100644 lib/syslog.pl delete mode 100644 lib/tainted.pl delete mode 100644 lib/termcap.pl delete mode 100644 lib/timelocal.pl delete mode 100644 lib/validate.pl diff --git a/MANIFEST b/MANIFEST index d64ad09..48a3987 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1086,7 +1086,6 @@ cpan/Getopt-Long/CHANGES Getopt::Long changes cpan/Getopt-Long/lib/Getopt/Long.pm Fetch command options (GetOptions) cpan/Getopt-Long/README Getopt::Long README cpan/Getopt-Long/t/gol-basic.t See if Getopt::Long works -cpan/Getopt-Long/t/gol-compat.t See if Getopt::Long works cpan/Getopt-Long/t/gol-linkage.t See if Getopt::Long works cpan/Getopt-Long/t/gol-oo.t See if Getopt::Long works cpan/Getopt-Long/t/gol-xargv.t See if Getopt::Long works @@ -3854,23 +3853,15 @@ iperlsys.h Perl's interface to the system keywords.c Perl_keyword(), generated by regen/keywords.pl keywords.h The keyword numbers l1_char_class_tab.h 256 word bit table of character classes (for handy.h) -lib/abbrev.pl An abbreviation table builder lib/AnyDBM_File.pm Perl module to emulate dbmopen lib/AnyDBM_File.t See if AnyDBM_File works -lib/assert.pl assertion and panic with stack trace lib/Benchmark.pm Measure execution time lib/Benchmark.t See if Benchmark works -lib/bigfloat.pl An arbitrary precision floating point package -lib/bigfloatpl.t See if bigfloat.pl works -lib/bigint.pl An arbitrary precision integer arithmetic package -lib/bigintpl.t See if bigint.pl works -lib/bigrat.pl An arbitrary precision rational arithmetic package lib/blib.pm For "use blib" lib/blib.t blib.pm test lib/bytes_heavy.pl Support routines for byte pragma lib/bytes.pm Pragma to enable byte operations lib/bytes.t bytes.pm test -lib/cacheout.pl Manages output filehandles when you need too many lib/Carp/Heavy.pm Error message workhorse lib/Carp.pm Error message base class lib/Carp.t See if Carp works @@ -3878,12 +3869,10 @@ lib/charnames.pm Character names lib/charnames.t See if character names work lib/Class/Struct.pm Declare struct-like datatypes as Perl classes lib/Class/Struct.t See if Class::Struct works -lib/complete.pl A command completion subroutine lib/Config/Extensions.pm Convenient hash lookup for built extensions lib/Config/Extensions.t See if Config::Extensions works lib/Config.t See if Config works lib/CORE.pod document the CORE namespace -lib/ctime.pl A ctime workalike lib/DBM_Filter/Changes DBM Filter Change history lib/DBM_Filter/compress.pm DBM Filter to compress keys/values lib/DBM_Filter/encode.pm DBM Filter for encoding @@ -3906,12 +3895,10 @@ lib/diagnostics.pm Print verbose diagnostics lib/diagnostics.t See if diagnostics.pm works lib/DirHandle.pm like FileHandle only for directories lib/DirHandle.t See if DirHandle works -lib/dotsh.pl Code to "dot" in a shell script lib/dumpvar.pl A variable dumper lib/dumpvar.t A variable dumper tester lib/English.pm Readable aliases for short variables lib/English.t See if English works -lib/exceptions.pl catch and throw routines lib/Exporter/Heavy.pm Complicated routines for Exporter lib/Exporter.pm Exporter base class lib/Exporter.t See if Exporter works @@ -3919,7 +3906,6 @@ lib/ExtUtils/Embed.pm Utilities for embedding Perl in C programs lib/ExtUtils/t/Embed.t See if ExtUtils::Embed and embedding works lib/ExtUtils/typemap Extension interface types lib/ExtUtils/XSSymSet.pm on VMS, manage linker symbols when building extensions -lib/fastcwd.pl a faster but more dangerous getcwd lib/feature.pm Pragma to enable new syntax lib/feature.t See if features work lib/feature/unicode_strings.t See if feature "unicode_strings" work @@ -3942,18 +3928,10 @@ lib/filetest.pm For "use filetest" lib/filetest.t See if filetest works lib/FindBin.pm Find name of currently executing program lib/FindBin.t See if FindBin works -lib/finddepth.pl A depth-first find emulator--used by find2perl -lib/find.pl A find emulator--used by find2perl -lib/flush.pl Routines to do single flush -lib/getcwd.pl A getcwd() emulator -lib/getopt.pl Perl library supporting option parsing -lib/getopts.pl Perl library supporting option parsing lib/Getopt/Std.pm Fetch command options (getopt, getopts) lib/Getopt/Std.t See if Getopt::Std and Getopt::Long work lib/h2ph.t See if h2ph works like it should lib/h2xs.t See if h2xs produces expected lists of files -lib/hostname.pl Old hostname code -lib/importenv.pl Perl routine to get environment into variables lib/integer.pm For "use integer" lib/integer.t For "use integer" testing lib/Internals.t For Internals::* testing @@ -3961,7 +3939,6 @@ lib/less.pm For "use less" lib/less.t See if less support works lib/locale.pm For "use locale" lib/locale.t See if locale support works -lib/look.pl A "look" equivalent lib/Net/hostent.pm By-name interface to Perl's builtin gethost* lib/Net/hostent.t See if Net::hostent works lib/Net/netent.pm By-name interface to Perl's builtin getnet* @@ -3970,9 +3947,6 @@ lib/Net/protoent.pm By-name interface to Perl's builtin getproto* lib/Net/protoent.t See if Net::protoent works lib/Net/servent.pm By-name interface to Perl's builtin getserv* lib/Net/servent.t See if Net::servtent works -lib/newgetopt.pl A perl library supporting long option parsing -lib/open2.pl Open a two-ended pipe (uses IPC::Open2) -lib/open3.pl Open a three-ended pipe (uses IPC::Open3) lib/open.pm Pragma to specify default I/O layers lib/open.t See if the open pragma works lib/overload64.t See if operator overloading works with 64-bit ints @@ -4001,26 +3975,20 @@ lib/Pod/t/InputObjects.t See if Pod::InputObjects works lib/Pod/t/Select.t See if Pod::Select works lib/Pod/t/Usage.t See if Pod::Usage works lib/Pod/t/utils.t Test for Pod::ParseUtils -lib/pwd.pl Routines to keep track of PWD environment variable lib/Search/Dict.pm Perform binary search on dictionaries lib/Search/Dict.t See if Search::Dict works lib/SelectSaver.pm Enforce proper select scoping lib/SelectSaver.t See if SelectSaver works -lib/shellwords.pl Perl library to split into words with shell quoting lib/sigtrap.pm For trapping an abort and giving traceback lib/sigtrap.t See if sigtrap works lib/sort.pm For "use sort" lib/sort.t See if "use sort" works -lib/stat.pl Perl library supporting stat function lib/strict.pm For "use strict" lib/strict.t See if strictures work lib/subs.pm Declare overriding subs lib/subs.t See if subroutine pseudo-importation works lib/Symbol.pm Symbol table manipulation routines lib/Symbol.t See if Symbol works -lib/syslog.pl Perl library supporting syslogging -lib/tainted.pl Old code for tainting -lib/termcap.pl Perl library supporting termcap usage lib/Term/Complete.pm A command completion subroutine lib/Term/Complete.t See if Term::Complete works lib/Term/ReadLine.pm Stub readline library @@ -4045,7 +4013,6 @@ lib/Tie/SubstrHash.pm Compact hash for known key, value and table size lib/Tie/SubstrHash.t Test for Tie::SubstrHash lib/Time/gmtime.pm By-name interface to Perl's builtin gmtime lib/Time/gmtime.t Test for Time::gmtime -lib/timelocal.pl Perl library supporting inverse of localtime, gmtime lib/Time/localtime.pm By-name interface to Perl's builtin localtime lib/Time/localtime.t Test for Time::localtime lib/Time/tm.pm Internal object for Time::{gm,local}time @@ -4110,7 +4077,6 @@ lib/User/pwent.t See if User::pwent works lib/utf8_heavy.pl Support routines for utf8 pragma lib/utf8.pm Pragma to control Unicode support lib/utf8.t See if utf8 operations work -lib/validate.pl Perl library supporting wholesale file mode validation lib/vars_carp.t See if "use vars" doesn't load Carp.pm per default lib/vars.pm Declare pseudo-imported global variables lib/vars.t See if "use vars" works diff --git a/META.yml b/META.yml index 4c999d3..52cd85f 100644 --- a/META.yml +++ b/META.yml @@ -97,7 +97,6 @@ no_index: - lib/Exporter.pm - lib/Exporter.t - lib/Exporter/Heavy.pm - - lib/newgetopt.pl - lib/unicore/mktables - lib/version.pm - lib/version.pod diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index d3f3d79..8265910 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -943,17 +943,12 @@ use File::Glob qw(:case); { 'MAINTAINER' => 'jv', 'DISTRIBUTION' => 'JV/Getopt-Long-2.38.tar.gz', - 'FILES' => q[cpan/Getopt-Long - lib/newgetopt.pl - ], + 'FILES' => q[cpan/Getopt-Long], 'EXCLUDED' => [ qr{^examples/}, - qw{perl-Getopt-Long.spec}, + qw{perl-Getopt-Long.spec lib/newgetopt.pl}, ], - 'MAP' => { '' => 'cpan/Getopt-Long/', - 'lib/newgetopt.pl' => 'lib/newgetopt.pl', - }, + 'MAP' => { '' => 'cpan/Getopt-Long/' }, 'UPSTREAM' => 'cpan', - 'CUSTOMIZED' => [ qw( lib/newgetopt.pl t/gol-compat.t)], }, 'Getopt::Std' => diff --git a/cpan/Getopt-Long/t/gol-compat.t b/cpan/Getopt-Long/t/gol-compat.t deleted file mode 100644 index 610474f..0000000 --- a/cpan/Getopt-Long/t/gol-compat.t +++ /dev/null @@ -1,39 +0,0 @@ -#!./perl -w - -no strict; - -BEGIN { - if ($ENV{PERL_CORE}) { - @INC = '../lib'; - chdir 't'; - } -} - -{ - # Silence the deprecation warnings from newgetopt.pl for the purpose - # of testing. These tests will be removed along with newgetopt.pl in - # the next major release of perl. - local $SIG{__WARN__} = sub { - if ($_[0] !~ /will be removed from the Perl core distribution/) { - print(STDERR @_); - } - }; - require "newgetopt.pl"; -} - -print "1..9\n"; - -@ARGV = qw(-Foo -baR --foo bar); -$newgetopt::ignorecase = 0; -$newgetopt::ignorecase = 0; -undef $opt_baR; -undef $opt_bar; -print "ok 1\n" if NGetOpt ("foo", "Foo=s"); -print ((defined $opt_foo) ? "" : "not ", "ok 2\n"); -print (($opt_foo == 1) ? "" : "not ", "ok 3\n"); -print ((defined $opt_Foo) ? "" : "not ", "ok 4\n"); -print (($opt_Foo eq "-baR") ? "" : "not ", "ok 5\n"); -print ((@ARGV == 1) ? "" : "not ", "ok 6\n"); -print (($ARGV[0] eq "bar") ? "" : "not ", "ok 7\n"); -print (!(defined $opt_baR) ? "" : "not ", "ok 8\n"); -print (!(defined $opt_bar) ? "" : "not ", "ok 9\n"); diff --git a/lib/abbrev.pl b/lib/abbrev.pl deleted file mode 100644 index d46321f..0000000 --- a/lib/abbrev.pl +++ /dev/null @@ -1,46 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -;# Usage: -;# %foo = (); -;# &abbrev(*foo,LIST); -;# ... -;# $long = $foo{$short}; - -# -# This library is no longer being maintained, and is included for backward -# compatibility with Perl 4 programs which may require it. -# This legacy library is deprecated and will be removed in a future -# release of perl. -# -# In particular, this should not be used as an example of modern Perl -# programming techniques. -# -# Suggested alternative: Text::Abbrev -# - -package abbrev; - -sub main'abbrev { - local(*domain) = @_; - shift(@_); - @cmp = @_; - foreach $name (@_) { - @extra = split(//,$name); - $abbrev = shift(@extra); - $len = 1; - foreach $cmp (@cmp) { - next if $cmp eq $name; - while (@extra && substr($cmp,0,$len) eq $abbrev) { - $abbrev .= shift(@extra); - ++$len; - } - } - $domain{$abbrev} = $name; - while ($#extra >= 0) { - $abbrev .= shift(@extra); - $domain{$abbrev} = $name; - } - } -} - -1; diff --git a/lib/assert.pl b/lib/assert.pl deleted file mode 100644 index d47e006..0000000 --- a/lib/assert.pl +++ /dev/null @@ -1,63 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -# -# This library is no longer being maintained, and is included for backward -# compatibility with Perl 4 programs which may require it. -# This legacy library is deprecated and will be removed in a future -# release of perl. -# -# assert.pl -# tchrist@convex.com (Tom Christiansen) -# -# Usage: -# -# &assert('@x > @y'); -# &assert('$var > 10', $var, $othervar, @various_info); -# -# That is, if the first expression evals false, we blow up. The -# rest of the args, if any, are nice to know because they will -# be printed out by &panic, which is just the stack-backtrace -# routine shamelessly borrowed from the perl debugger. - -sub assert { - &panic("ASSERTION BOTCHED: $_[0]",$@) unless eval $_[0]; -} - -sub panic { - package DB; - - select(STDERR); - - print "\npanic: @_\n"; - - exit 1 if $] <= 4.003; # caller broken - - # stack traceback gratefully borrowed from perl debugger - - local $_; - my $i; - my ($p,$f,$l,$s,$h,$a,@a,@frames); - for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) { - @a = @args; - for (@a) { - if (/^StB\000/ && length($_) == length($_main{'_main'})) { - $_ = sprintf("%s",$_); - } - else { - s/'/\\'/g; - s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/; - s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; - s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; - } - } - $w = $w ? '@ = ' : '$ = '; - $a = $h ? '(' . join(', ', @a) . ')' : ''; - push(@frames, "$w&$s$a from file $f line $l\n"); - } - for ($i=0; $i <= $#frames; $i++) { - print $frames[$i]; - } - exit 1; -} - -1; diff --git a/lib/bigfloat.pl b/lib/bigfloat.pl deleted file mode 100644 index 82d0f5c..0000000 --- a/lib/bigfloat.pl +++ /dev/null @@ -1,258 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -package bigfloat; -require "bigint.pl"; -# -# This library is no longer being maintained, and is included for backward -# compatibility with Perl 4 programs which may require it. -# This legacy library is deprecated and will be removed in a future -# release of perl. -# -# In particular, this should not be used as an example of modern Perl -# programming techniques. -# -# Suggested alternative: Math::BigFloat - -# Arbitrary length float math package -# -# by Mark Biggar -# -# number format -# canonical strings have the form /[+-]\d+E[+-]\d+/ -# Input values can have embedded whitespace -# Error returns -# 'NaN' An input parameter was "Not a Number" or -# divide by zero or sqrt of negative number -# Division is computed to -# max($div_scale,length(dividend)+length(divisor)) -# digits by default. -# Also used for default sqrt scale - -$div_scale = 40; - -# Rounding modes one of 'even', 'odd', '+inf', '-inf', 'zero' or 'trunc'. - -$rnd_mode = 'even'; - -# bigfloat routines -# -# fadd(NSTR, NSTR) return NSTR addition -# fsub(NSTR, NSTR) return NSTR subtraction -# fmul(NSTR, NSTR) return NSTR multiplication -# fdiv(NSTR, NSTR[,SCALE]) returns NSTR division to SCALE places -# fneg(NSTR) return NSTR negation -# fabs(NSTR) return NSTR absolute value -# fcmp(NSTR,NSTR) return CODE compare undef,<0,=0,>0 -# fround(NSTR, SCALE) return NSTR round to SCALE digits -# ffround(NSTR, SCALE) return NSTR round at SCALEth place -# fnorm(NSTR) return (NSTR) normalize -# fsqrt(NSTR[, SCALE]) return NSTR sqrt to SCALE places - -# Convert a number to canonical string form. -# Takes something that looks like a number and converts it to -# the form /^[+-]\d+E[+-]\d+$/. -sub main'fnorm { #(string) return fnum_str - local($_) = @_; - s/\s+//g; # strip white space - if (/^([+-]?)(\d*)(\.(\d*))?([Ee]([+-]?\d+))?$/ - && ($2 ne '' || defined($4))) { - my $x = defined($4) ? $4 : ''; - &norm(($1 ? "$1$2$x" : "+$2$x"), (($x ne '') ? $6-length($x) : $6)); - } else { - 'NaN'; - } -} - -# normalize number -- for internal use -sub norm { #(mantissa, exponent) return fnum_str - local($_, $exp) = @_; - if ($_ eq 'NaN') { - 'NaN'; - } else { - s/^([+-])0+/$1/; # strip leading zeros - if (length($_) == 1) { - '+0E+0'; - } else { - $exp += length($1) if (s/(0+)$//); # strip trailing zeros - sprintf("%sE%+ld", $_, $exp); - } - } -} - -# negation -sub main'fneg { #(fnum_str) return fnum_str - local($_) = &'fnorm($_[0]); - vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0E+0'; # flip sign - if ( ord("\t") == 9 ) { # ascii - s/^H/N/; - } - else { # ebcdic character set - s/\373/N/; - } - $_; -} - -# absolute value -sub main'fabs { #(fnum_str) return fnum_str - local($_) = &'fnorm($_[0]); - s/^-/+/; # mash sign - $_; -} - -# multiplication -sub main'fmul { #(fnum_str, fnum_str) return fnum_str - local($x,$y) = (&'fnorm($_[0]),&'fnorm($_[1])); - if ($x eq 'NaN' || $y eq 'NaN') { - 'NaN'; - } else { - local($xm,$xe) = split('E',$x); - local($ym,$ye) = split('E',$y); - &norm(&'bmul($xm,$ym),$xe+$ye); - } -} - -# addition -sub main'fadd { #(fnum_str, fnum_str) return fnum_str - local($x,$y) = (&'fnorm($_[0]),&'fnorm($_[1])); - if ($x eq 'NaN' || $y eq 'NaN') { - 'NaN'; - } else { - local($xm,$xe) = split('E',$x); - local($ym,$ye) = split('E',$y); - ($xm,$xe,$ym,$ye) = ($ym,$ye,$xm,$xe) if ($xe < $ye); - &norm(&'badd($ym,$xm.('0' x ($xe-$ye))),$ye); - } -} - -# subtraction -sub main'fsub { #(fnum_str, fnum_str) return fnum_str - &'fadd($_[0],&'fneg($_[1])); -} - -# division -# args are dividend, divisor, scale (optional) -# result has at most max(scale, length(dividend), length(divisor)) digits -sub main'fdiv #(fnum_str, fnum_str[,scale]) return fnum_str -{ - local($x,$y,$scale) = (&'fnorm($_[0]),&'fnorm($_[1]),$_[2]); - if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0E+0') { - 'NaN'; - } else { - local($xm,$xe) = split('E',$x); - local($ym,$ye) = split('E',$y); - $scale = $div_scale if (!$scale); - $scale = length($xm)-1 if (length($xm)-1 > $scale); - $scale = length($ym)-1 if (length($ym)-1 > $scale); - $scale = $scale + length($ym) - length($xm); - &norm(&round(&'bdiv($xm.('0' x $scale),$ym),&'babs($ym)), - $xe-$ye-$scale); - } -} - -# round int $q based on fraction $r/$base using $rnd_mode -sub round { #(int_str, int_str, int_str) return int_str - local($q,$r,$base) = @_; - if ($q eq 'NaN' || $r eq 'NaN') { - 'NaN'; - } elsif ($rnd_mode eq 'trunc') { - $q; # just truncate - } else { - local($cmp) = &'bcmp(&'bmul($r,'+2'),$base); - if ( $cmp < 0 || - ($cmp == 0 && - ( $rnd_mode eq 'zero' || - ($rnd_mode eq '-inf' && (substr($q,0,1) eq '+')) || - ($rnd_mode eq '+inf' && (substr($q,0,1) eq '-')) || - ($rnd_mode eq 'even' && $q =~ /[24680]$/) || - ($rnd_mode eq 'odd' && $q =~ /[13579]$/) )) ) { - $q; # round down - } else { - &'badd($q, ((substr($q,0,1) eq '-') ? '-1' : '+1')); - # round up - } - } -} - -# round the mantissa of $x to $scale digits -sub main'fround { #(fnum_str, scale) return fnum_str - local($x,$scale) = (&'fnorm($_[0]),$_[1]); - if ($x eq 'NaN' || $scale <= 0) { - $x; - } else { - local($xm,$xe) = split('E',$x); - if (length($xm)-1 <= $scale) { - $x; - } else { - &norm(&round(substr($xm,0,$scale+1), - "+0".substr($xm,$scale+1,1),"+10"), - $xe+length($xm)-$scale-1); - } - } -} - -# round $x at the 10 to the $scale digit place -sub main'ffround { #(fnum_str, scale) return fnum_str - local($x,$scale) = (&'fnorm($_[0]),$_[1]); - if ($x eq 'NaN') { - 'NaN'; - } else { - local($xm,$xe) = split('E',$x); - if ($xe >= $scale) { - $x; - } else { - $xe = length($xm)+$xe-$scale; - if ($xe < 1) { - '+0E+0'; - } elsif ($xe == 1) { - # The first substr preserves the sign, which means that - # we'll pass a non-normalized "-0" to &round when rounding - # -0.006 (for example), purely so that &round won't lose - # the sign. - &norm(&round(substr($xm,0,1).'0', - "+0".substr($xm,1,1),"+10"), $scale); - } else { - &norm(&round(substr($xm,0,$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 main'fcmp #(fnum_str, fnum_str) return cond_code -{ - local($x, $y) = (&'fnorm($_[0]),&'fnorm($_[1])); - if ($x eq "NaN" || $y eq "NaN") { - undef; - } else { - ord($y) <=> ord($x) - || - ( local($xm,$xe,$ym,$ye) = split('E', $x."E$y"), - (($xe <=> $ye) * (substr($x,0,1).'1') - || &bigint'cmp($xm,$ym)) - ); - } -} - -# square root by Newtons method. -sub main'fsqrt { #(fnum_str[, scale]) return fnum_str - local($x, $scale) = (&'fnorm($_[0]), $_[1]); - if ($x eq 'NaN' || $x =~ /^-/) { - 'NaN'; - } elsif ($x eq '+0E+0') { - '+0E+0'; - } else { - local($xm, $xe) = split('E',$x); - $scale = $div_scale if (!$scale); - $scale = length($xm)-1 if ($scale < length($xm)-1); - local($gs, $guess) = (1, sprintf("1E%+d", (length($xm)+$xe-1)/2)); - while ($gs < 2*$scale) { - $guess = &'fmul(&'fadd($guess,&'fdiv($x,$guess,$gs*2)),".5"); - $gs *= 2; - } - &'fround($guess, $scale); - } -} - -1; diff --git a/lib/bigfloatpl.t b/lib/bigfloatpl.t deleted file mode 100644 index 0a26598..0000000 --- a/lib/bigfloatpl.t +++ /dev/null @@ -1,422 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -{ - # Silence the deprecation warnings from bigfloat.pl for the purpose - # of testing. These tests will be removed along with bigfloat.pl in - # the next major release of perl. - local $SIG{__WARN__} = sub { - if ($_[0] !~ /will be removed from the Perl core distribution/) { - print(STDERR @_); - } - }; - require "bigfloat.pl"; -} - -$test = 0; -$| = 1; -print "1..355\n"; -while () { - chop; - if (/^&/) { - $f = $_; - } elsif (/^\$.*/) { - eval "$_;"; - } else { - ++$test; - @args = split(/:/,$_,99); - $ans = pop(@args); - $try = "$f('" . join("','", @args) . "');"; - if (($ans1 = eval($try)) eq $ans) { - print "ok $test\n"; - } else { - print "not ok $test\n"; - print "# '$try' expected: '$ans' got: '$ans1'\n"; - } - } -} -__END__ -&fnorm -abc:NaN - 1 a:NaN -1bcd2:NaN -11111b:NaN -+1z:NaN --1z:NaN -0:+0E+0 -+0:+0E+0 -+00:+0E+0 -+0 0 0:+0E+0 -000000 0000000 00000:+0E+0 --0:+0E+0 --0000:+0E+0 -+1:+1E+0 -+01:+1E+0 -+001:+1E+0 -+00000100000:+1E+5 -123456789:+123456789E+0 --1:-1E+0 --01:-1E+0 --001:-1E+0 --123456789:-123456789E+0 --00000100000:-1E+5 -123.456a:NaN -123.456:+123456E-3 -0.01:+1E-2 -.002:+2E-3 --0.0003:-3E-4 --.0000000004:-4E-10 -123456E2:+123456E+2 -123456E-2:+123456E-2 --123456E2:-123456E+2 --123456E-2:-123456E-2 -1e1:+1E+1 -2e-11:+2E-11 --3e111:-3E+111 --4e-1111:-4E-1111 -&fneg -abd:NaN -+0:+0E+0 -+1:-1E+0 --1:+1E+0 -+123456789:-123456789E+0 --123456789:+123456789E+0 -+123.456789:-123456789E-6 --123456.789:+123456789E-3 -&fabs -abc:NaN -+0:+0E+0 -+1:+1E+0 --1:+1E+0 -+123456789:+123456789E+0 --123456789:+123456789E+0 -+123.456789:+123456789E-6 --123456.789:+123456789E-3 -&fround -$bigfloat::rnd_mode = 'trunc' -+10123456789:5:+10123E+6 --10123456789:5:-10123E+6 -+10123456789:9:+101234567E+2 --10123456789:9:-101234567E+2 -+101234500:6:+101234E+3 --101234500:6:-101234E+3 -$bigfloat::rnd_mode = 'zero' -+20123456789:5:+20123E+6 --20123456789:5:-20123E+6 -+20123456789:9:+201234568E+2 --20123456789:9:-201234568E+2 -+201234500:6:+201234E+3 --201234500:6:-201234E+3 -$bigfloat::rnd_mode = '+inf' -+30123456789:5:+30123E+6 --30123456789:5:-30123E+6 -+30123456789:9:+301234568E+2 --30123456789:9:-301234568E+2 -+301234500:6:+301235E+3 --301234500:6:-301234E+3 -$bigfloat::rnd_mode = '-inf' -+40123456789:5:+40123E+6 --40123456789:5:-40123E+6 -+40123456789:9:+401234568E+2 --40123456789:9:-401234568E+2 -+401234500:6:+401234E+3 --401234500:6:-401235E+3 -$bigfloat::rnd_mode = 'odd' -+50123456789:5:+50123E+6 --50123456789:5:-50123E+6 -+50123456789:9:+501234568E+2 --50123456789:9:-501234568E+2 -+501234500:6:+501235E+3 --501234500:6:-501235E+3 -$bigfloat::rnd_mode = 'even' -+60123456789:5:+60123E+6 --60123456789:5:-60123E+6 -+60123456789:9:+601234568E+2 --60123456789:9:-601234568E+2 -+601234500:6:+601234E+3 --601234500:6:-601234E+3 -&ffround -$bigfloat::rnd_mode = 'trunc' -+1.23:-1:+12E-1 --1.23:-1:-12E-1 -+1.27:-1:+12E-1 --1.27:-1:-12E-1 -+1.25:-1:+12E-1 --1.25:-1:-12E-1 -+1.35:-1:+13E-1 --1.35:-1:-13E-1 --0.006:-1:+0E+0 --0.006:-2:+0E+0 -$bigfloat::rnd_mode = 'zero' -+2.23:-1:+22E-1 --2.23:-1:-22E-1 -+2.27:-1:+23E-1 --2.27:-1:-23E-1 -+2.25:-1:+22E-1 --2.25:-1:-22E-1 -+2.35:-1:+23E-1 --2.35:-1:-23E-1 --0.0065:-1:+0E+0 --0.0065:-2:-1E-2 --0.0065:-3:-6E-3 --0.0065:-4:-65E-4 --0.0065:-5:-65E-4 -$bigfloat::rnd_mode = '+inf' -+3.23:-1:+32E-1 --3.23:-1:-32E-1 -+3.27:-1:+33E-1 --3.27:-1:-33E-1 -+3.25:-1:+33E-1 --3.25:-1:-32E-1 -+3.35:-1:+34E-1 --3.35:-1:-33E-1 --0.0065:-1:+0E+0 --0.0065:-2:-1E-2 --0.0065:-3:-6E-3 --0.0065:-4:-65E-4 --0.0065:-5:-65E-4 -$bigfloat::rnd_mode = '-inf' -+4.23:-1:+42E-1 --4.23:-1:-42E-1 -+4.27:-1:+43E-1 --4.27:-1:-43E-1 -+4.25:-1:+42E-1 --4.25:-1:-43E-1 -+4.35:-1:+43E-1 --4.35:-1:-44E-1 --0.0065:-1:+0E+0 --0.0065:-2:-1E-2 --0.0065:-3:-7E-3 --0.0065:-4:-65E-4 --0.0065:-5:-65E-4 -$bigfloat::rnd_mode = 'odd' -+5.23:-1:+52E-1 --5.23:-1:-52E-1 -+5.27:-1:+53E-1 --5.27:-1:-53E-1 -+5.25:-1:+53E-1 --5.25:-1:-53E-1 -+5.35:-1:+53E-1 --5.35:-1:-53E-1 --0.0065:-1:+0E+0 --0.0065:-2:-1E-2 --0.0065:-3:-7E-3 --0.0065:-4:-65E-4 --0.0065:-5:-65E-4 -$bigfloat::rnd_mode = 'even' -+6.23:-1:+62E-1 --6.23:-1:-62E-1 -+6.27:-1:+63E-1 --6.27:-1:-63E-1 -+6.25:-1:+62E-1 --6.25:-1:-62E-1 -+6.35:-1:+64E-1 --6.35:-1:-64E-1 --0.0065:-1:+0E+0 --0.0065:-2:-1E-2 --0.0065:-3:-6E-3 --0.0065:-4:-65E-4 --0.0065:-5:-65E-4 -&fcmp -abc:abc: -abc:+0: -+0:abc: -+0:+0:0 --1:+0:-1 -+0:-1:1 -+1:+0:1 -+0:+1:-1 --1:+1:-1 -+1:-1:1 --1:-1:0 -+1:+1:0 -+123:+123:0 -+123:+12:1 -+12:+123:-1 --123:-123:0 --123:-12:-1 --12:-123:1 -+123:+124:-1 -+124:+123:1 --123:-124:1 --124:-123:-1 -&fadd -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0E+0 -+1:+0:+1E+0 -+0:+1:+1E+0 -+1:+1:+2E+0 --1:+0:-1E+0 -+0:-1:-1E+0 --1:-1:-2E+0 --1:+1:+0E+0 -+1:-1:+0E+0 -+9:+1:+1E+1 -+99:+1:+1E+2 -+999:+1:+1E+3 -+9999:+1:+1E+4 -+99999:+1:+1E+5 -+999999:+1:+1E+6 -+9999999:+1:+1E+7 -+99999999:+1:+1E+8 -+999999999:+1:+1E+9 -+9999999999:+1:+1E+10 -+99999999999:+1:+1E+11 -+10:-1:+9E+0 -+100:-1:+99E+0 -+1000:-1:+999E+0 -+10000:-1:+9999E+0 -+100000:-1:+99999E+0 -+1000000:-1:+999999E+0 -+10000000:-1:+9999999E+0 -+100000000:-1:+99999999E+0 -+1000000000:-1:+999999999E+0 -+10000000000:-1:+9999999999E+0 -+123456789:+987654321:+111111111E+1 --123456789:+987654321:+864197532E+0 --123456789:-987654321:-111111111E+1 -+123456789:-987654321:-864197532E+0 -&fsub -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0E+0 -+1:+0:+1E+0 -+0:+1:-1E+0 -+1:+1:+0E+0 --1:+0:-1E+0 -+0:-1:+1E+0 --1:-1:+0E+0 --1:+1:-2E+0 -+1:-1:+2E+0 -+9:+1:+8E+0 -+99:+1:+98E+0 -+999:+1:+998E+0 -+9999:+1:+9998E+0 -+99999:+1:+99998E+0 -+999999:+1:+999998E+0 -+9999999:+1:+9999998E+0 -+99999999:+1:+99999998E+0 -+999999999:+1:+999999998E+0 -+9999999999:+1:+9999999998E+0 -+99999999999:+1:+99999999998E+0 -+10:-1:+11E+0 -+100:-1:+101E+0 -+1000:-1:+1001E+0 -+10000:-1:+10001E+0 -+100000:-1:+100001E+0 -+1000000:-1:+1000001E+0 -+10000000:-1:+10000001E+0 -+100000000:-1:+100000001E+0 -+1000000000:-1:+1000000001E+0 -+10000000000:-1:+10000000001E+0 -+123456789:+987654321:-864197532E+0 --123456789:+987654321:-111111111E+1 --123456789:-987654321:+864197532E+0 -+123456789:-987654321:+111111111E+1 -&fmul -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0E+0 -+0:+1:+0E+0 -+1:+0:+0E+0 -+0:-1:+0E+0 --1:+0:+0E+0 -+123456789123456789:+0:+0E+0 -+0:+123456789123456789:+0E+0 --1:-1:+1E+0 --1:+1:-1E+0 -+1:-1:-1E+0 -+1:+1:+1E+0 -+2:+3:+6E+0 --2:+3:-6E+0 -+2:-3:-6E+0 --2:-3:+6E+0 -+111:+111:+12321E+0 -+10101:+10101:+102030201E+0 -+1001001:+1001001:+1002003002001E+0 -+100010001:+100010001:+10002000300020001E+0 -+10000100001:+10000100001:+100002000030000200001E+0 -+11111111111:+9:+99999999999E+0 -+22222222222:+9:+199999999998E+0 -+33333333333:+9:+299999999997E+0 -+44444444444:+9:+399999999996E+0 -+55555555555:+9:+499999999995E+0 -+66666666666:+9:+599999999994E+0 -+77777777777:+9:+699999999993E+0 -+88888888888:+9:+799999999992E+0 -+99999999999:+9:+899999999991E+0 -&fdiv -abc:abc:NaN -abc:+1:abc:NaN -+1:abc:NaN -+0:+0:NaN -+0:+1:+0E+0 -+1:+0:NaN -+0:-1:+0E+0 --1:+0:NaN -+1:+1:+1E+0 --1:-1:+1E+0 -+1:-1:-1E+0 --1:+1:-1E+0 -+1:+2:+5E-1 -+2:+1:+2E+0 -+10:+5:+2E+0 -+100:+4:+25E+0 -+1000:+8:+125E+0 -+10000:+16:+625E+0 -+10000:-16:-625E+0 -+999999999999:+9:+111111111111E+0 -+999999999999:+99:+10101010101E+0 -+999999999999:+999:+1001001001E+0 -+999999999999:+9999:+100010001E+0 -+999999999999999:+99999:+10000100001E+0 -+1000000000:+9:+1111111111111111111111111111111111111111E-31 -+2000000000:+9:+2222222222222222222222222222222222222222E-31 -+3000000000:+9:+3333333333333333333333333333333333333333E-31 -+4000000000:+9:+4444444444444444444444444444444444444444E-31 -+5000000000:+9:+5555555555555555555555555555555555555556E-31 -+6000000000:+9:+6666666666666666666666666666666666666667E-31 -+7000000000:+9:+7777777777777777777777777777777777777778E-31 -+8000000000:+9:+8888888888888888888888888888888888888889E-31 -+9000000000:+9:+1E+9 -+35500000:+113:+3141592920353982300884955752212389380531E-34 -+71000000:+226:+3141592920353982300884955752212389380531E-34 -+106500000:+339:+3141592920353982300884955752212389380531E-34 -+1000000000:+3:+3333333333333333333333333333333333333333E-31 -$bigfloat::div_scale = 20 -+1000000000:+9:+11111111111111111111E-11 -+2000000000:+9:+22222222222222222222E-11 -+3000000000:+9:+33333333333333333333E-11 -+4000000000:+9:+44444444444444444444E-11 -+5000000000:+9:+55555555555555555556E-11 -+6000000000:+9:+66666666666666666667E-11 -+7000000000:+9:+77777777777777777778E-11 -+8000000000:+9:+88888888888888888889E-11 -+9000000000:+9:+1E+9 -+35500000:+113:+314159292035398230088E-15 -+71000000:+226:+314159292035398230088E-15 -+106500000:+339:+31415929203539823009E-14 -+1000000000:+3:+33333333333333333333E-11 -$bigfloat::div_scale = 40 -&fsqrt -+0:+0E+0 --1:NaN --2:NaN --16:NaN --123.456:NaN -+1:+1E+0 -+1.44:+12E-1 -+2:+141421356237309504880168872420969807857E-38 -+4:+2E+0 -+16:+4E+0 -+100:+1E+1 -+123.456:+1111107555549866648462149404118219234119E-38 -+15241.383936:+123456E-3 diff --git a/lib/bigint.pl b/lib/bigint.pl deleted file mode 100644 index 6de1c53..0000000 --- a/lib/bigint.pl +++ /dev/null @@ -1,324 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -package bigint; -# -# This library is no longer being maintained, and is included for backward -# compatibility with Perl 4 programs which may require it. -# -# In particular, this should not be used as an example of modern Perl -# programming techniques. -# This legacy library is deprecated and will be removed in a future -# release of perl. -# -# Suggested alternative: Math::BigInt - -# arbitrary size integer math package -# -# by Mark Biggar -# -# Canonical Big integer value are strings of the form -# /^[+-]\d+$/ with leading zeros suppressed -# Input values to these routines may be strings of the form -# /^\s*[+-]?[\d\s]+$/. -# Examples: -# '+0' canonical zero value -# ' -123 123 123' canonical value '-123123123' -# '1 23 456 7890' canonical value '+1234567890' -# Output values always 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 -# - -# overcome a floating point problem on certain osnames (posix-bc, os390) -BEGIN { - my $x = 100000.0; - my $use_mult = int($x*1e-5)*1e5 == $x ? 1 : 0; -} - -$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 main'bnorm { #(num_str) return num_str - local($_) = @_; - s/\s+//g; # strip white space - if (s/^([+-]?)0*(\d+)$/$1$2/) { # test if number - substr($_,0,0) = '+' unless $1; # Add missing sign - s/^-0/+0/; - $_; - } else { - 'NaN'; - } -} - -# Convert a number from string format to internal base 100000 format. -# Assumes normalized value as input. -sub internal { #(num_str) return int_num_array - local($d) = @_; - ($is,$il) = (substr($d,0,1),length($d)-2); - substr($d,0,1) = ''; - ($is, reverse(unpack("a" . ($il%5+1) . ("a5" x ($il/5)), $d))); -} - -# Convert a number from internal base 100000 format to string format. -# This routine scribbles all over input array. -sub external { #(int_num_array) return num_str - $es = shift; - grep($_ > 9999 || ($_ = substr('0000'.$_,-5)), @_); # zero pad - &'bnorm(join('', $es, reverse(@_))); # reverse concat and normalize -} - -# Negate input value. -sub main'bneg { #(num_str) return num_str - local($_) = &'bnorm(@_); - vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0'; - s/^./N/ unless /^[-+]/; # works both in ASCII and EBCDIC - $_; -} - -# Returns the absolute value of the input. -sub main'babs { #(num_str) return num_str - &abs(&'bnorm(@_)); -} - -sub abs { # post-normalized abs for internal use - local($_) = @_; - s/^-/+/; - $_; -} - -# Compares 2 values. Returns one of undef, <0, =0, >0. (suitable for sort) -sub main'bcmp { #(num_str, num_str) return cond_code - local($x,$y) = (&'bnorm($_[0]),&'bnorm($_[1])); - if ($x eq 'NaN') { - undef; - } elsif ($y eq 'NaN') { - undef; - } else { - &cmp($x,$y); - } -} - -sub cmp { # post-normalized compare for internal use - local($cx, $cy) = @_; - return 0 if ($cx eq $cy); - - local($sx, $sy) = (substr($cx, 0, 1), substr($cy, 0, 1)); - local($ld); - - if ($sx eq '+') { - return 1 if ($sy eq '-' || $cy eq '+0'); - $ld = length($cx) - length($cy); - return $ld if ($ld); - return $cx cmp $cy; - } else { # $sx eq '-' - return -1 if ($sy eq '+'); - $ld = length($cy) - length($cx); - return $ld if ($ld); - return $cy cmp $cx; - } - -} - -sub main'badd { #(num_str, num_str) return num_str - local(*x, *y); ($x, $y) = (&'bnorm($_[0]),&'bnorm($_[1])); - if ($x eq 'NaN') { - 'NaN'; - } elsif ($y eq 'NaN') { - 'NaN'; - } else { - @x = &internal($x); # convert to internal form - @y = &internal($y); - local($sx, $sy) = (shift @x, shift @y); # get signs - if ($sx eq $sy) { - &external($sx, &add(*x, *y)); # if same sign add - } else { - ($x, $y) = (&abs($x),&abs($y)); # make abs - if (&cmp($y,$x) > 0) { - &external($sy, &sub(*y, *x)); - } else { - &external($sx, &sub(*x, *y)); - } - } - } -} - -sub main'bsub { #(num_str, num_str) return num_str - &'badd($_[0],&'bneg($_[1])); -} - -# GCD -- Euclid's algorithm Knuth Vol 2 pg 296 -sub main'bgcd { #(num_str, num_str) return num_str - local($x,$y) = (&'bnorm($_[0]),&'bnorm($_[1])); - if ($x eq 'NaN' || $y eq 'NaN') { - 'NaN'; - } else { - ($x, $y) = ($y,&'bmod($x,$y)) while $y ne '+0'; - $x; - } -} - -# routine to add two base 1e5 numbers -# stolen from Knuth Vol 2 Algorithm A pg 231 -# there are separate routines to add and sub as per Kunth pg 233 -sub add { #(int_num_array, int_num_array) return int_num_array - local(*x, *y) = @_; - $car = 0; - for $x (@x) { - last unless @y || $car; - $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5) ? 1 : 0; - } - for $y (@y) { - last unless $car; - $y -= 1e5 if $car = (($y += $car) >= 1e5) ? 1 : 0; - } - (@x, @y, $car); -} - -# subtract base 1e5 numbers -- stolen from Knuth Vol 2 pg 232, $x > $y -sub sub { #(int_num_array, int_num_array) return int_num_array - local(*sx, *sy) = @_; - $bar = 0; - for $sx (@sx) { - last unless @y || $bar; - $sx += 1e5 if $bar = (($sx -= shift(@sy) + $bar) < 0); - } - @sx; -} - -# multiply two numbers -- stolen from Knuth Vol 2 pg 233 -sub main'bmul { #(num_str, num_str) return num_str - local(*x, *y); ($x, $y) = (&'bnorm($_[0]), &'bnorm($_[1])); - if ($x eq 'NaN') { - 'NaN'; - } elsif ($y eq 'NaN') { - 'NaN'; - } else { - @x = &internal($x); - @y = &internal($y); - local($signr) = (shift @x ne shift @y) ? '-' : '+'; - @prod = (); - for $x (@x) { - ($car, $cty) = (0, 0); - for $y (@y) { - $prod = $x * $y + $prod[$cty] + $car; - if ($use_mult) { - $prod[$cty++] = - $prod - ($car = int($prod * 1e-5)) * 1e5; - } - else { - $prod[$cty++] = - $prod - ($car = int($prod / 1e5)) * 1e5; - } - } - $prod[$cty] += $car if $car; - $x = shift @prod; - } - &external($signr, @x, @prod); - } -} - -# modulus -sub main'bmod { #(num_str, num_str) return num_str - (&'bdiv(@_))[1]; -} - -sub main'bdiv { #(dividend: num_str, divisor: num_str) return num_str - local (*x, *y); ($x, $y) = (&'bnorm($_[0]), &'bnorm($_[1])); - return wantarray ? ('NaN','NaN') : 'NaN' - if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0'); - return wantarray ? ('+0',$x) : '+0' if (&cmp(&abs($x),&abs($y)) < 0); - @x = &internal($x); @y = &internal($y); - $srem = $y[0]; - $sr = (shift @x ne shift @y) ? '-' : '+'; - $car = $bar = $prd = 0; - if (($dd = int(1e5/($y[$#y]+1))) != 1) { - for $x (@x) { - $x = $x * $dd + $car; - if ($use_mult) { - $x -= ($car = int($x * 1e-5)) * 1e5; - } - else { - $x -= ($car = int($x / 1e5)) * 1e5; - } - } - push(@x, $car); $car = 0; - for $y (@y) { - $y = $y * $dd + $car; - if ($use_mult) { - $y -= ($car = int($y * 1e-5)) * 1e5; - } - else { - $y -= ($car = int($y / 1e5)) * 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 = 0, $x = $#x-$#y-1; $y <= $#y; ++$y,++$x) { - $prd = $q * $y[$y] + $car; - if ($use_mult) { - $prd -= ($car = int($prd * 1e-5)) * 1e5; - } - else { - $prd -= ($car = int($prd / 1e5)) * 1e5; - } - $x[$x] += 1e5 if ($bar = (($x[$x] -= $prd + $bar) < 0)); - } - if ($x[$#x] < $car + $bar) { - $car = 0; --$q; - for ($y = 0, $x = $#x-$#y-1; $y <= $#y; ++$y,++$x) { - $x[$x] -= 1e5 - if ($car = (($x[$x] += $y[$y] + $car) > 1e5)); - } - } - } - pop(@x); unshift(@q, $q); - } - if (wantarray) { - @d = (); - if ($dd != 1) { - $car = 0; - for $x (reverse @x) { - $prd = $car * 1e5 + $x; - $car = $prd - ($tmp = int($prd / $dd)) * $dd; - unshift(@d, $tmp); - } - } - else { - @d = @x; - } - (&external($sr, @q), &external($srem, @d, $zero)); - } else { - &external($sr, @q); - } -} -1; diff --git a/lib/bigintpl.t b/lib/bigintpl.t deleted file mode 100644 index bdd4919..0000000 --- a/lib/bigintpl.t +++ /dev/null @@ -1,296 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -{ - # Silence the deprecation warnings from bigint.pl for the purpose - # of testing. These tests will be removed along with bigint.pl in - # the next major release of perl. - local $SIG{__WARN__} = sub { - if ($_[0] !~ /will be removed from the Perl core distribution/) { - print(STDERR @_); - } - }; - require "bigint.pl"; -} - -$test = 0; -$| = 1; -print "1..246\n"; -while () { - chop; - if (/^&/) { - $f = $_; - } else { - ++$test; - @args = split(/:/,$_,99); - $ans = pop(@args); - $try = "$f('" . join("','", @args) . "');"; - if (($ans1 = eval($try)) eq $ans) { - print "ok $test\n"; - } else { - print "not ok $test\n"; - print "# '$try' expected: '$ans' got: '$ans1'\n"; - } - } -} -__END__ -&bnorm -abc:NaN - 1 a:NaN -1bcd2:NaN -11111b:NaN -+1z:NaN --1z:NaN -0:+0 -+0:+0 -+00:+0 -+0 0 0:+0 -000000 0000000 00000:+0 --0:+0 --0000:+0 -+1:+1 -+01:+1 -+001:+1 -+00000100000:+100000 -123456789:+123456789 --1:-1 --01:-1 --001:-1 --123456789:-123456789 --00000100000:-100000 -&bneg -abd:NaN -+0:+0 -+1:-1 --1:+1 -+123456789:-123456789 --123456789:+123456789 -&babs -abc:NaN -+0:+0 -+1:+1 --1:+1 -+123456789:+123456789 --123456789:+123456789 -&bcmp -abc:abc: -abc:+0: -+0:abc: -+0:+0:0 --1:+0:-1 -+0:-1:1 -+1:+0:1 -+0:+1:-1 --1:+1:-1 -+1:-1:1 --1:-1:0 -+1:+1:0 -+123:+123:0 -+123:+12:1 -+12:+123:-1 --123:-123:0 --123:-12:-1 --12:-123:1 -+123:+124:-1 -+124:+123:1 --123:-124:1 --124:-123:-1 -&badd -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0 -+1:+0:+1 -+0:+1:+1 -+1:+1:+2 --1:+0:-1 -+0:-1:-1 --1:-1:-2 --1:+1:+0 -+1:-1:+0 -+9:+1:+10 -+99:+1:+100 -+999:+1:+1000 -+9999:+1:+10000 -+99999:+1:+100000 -+999999:+1:+1000000 -+9999999:+1:+10000000 -+99999999:+1:+100000000 -+999999999:+1:+1000000000 -+9999999999:+1:+10000000000 -+99999999999:+1:+100000000000 -+10:-1:+9 -+100:-1:+99 -+1000:-1:+999 -+10000:-1:+9999 -+100000:-1:+99999 -+1000000:-1:+999999 -+10000000:-1:+9999999 -+100000000:-1:+99999999 -+1000000000:-1:+999999999 -+10000000000:-1:+9999999999 -+123456789:+987654321:+1111111110 --123456789:+987654321:+864197532 --123456789:-987654321:-1111111110 -+123456789:-987654321:-864197532 -&bsub -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0 -+1:+0:+1 -+0:+1:-1 -+1:+1:+0 --1:+0:-1 -+0:-1:+1 --1:-1:+0 --1:+1:-2 -+1:-1:+2 -+9:+1:+8 -+99:+1:+98 -+999:+1:+998 -+9999:+1:+9998 -+99999:+1:+99998 -+999999:+1:+999998 -+9999999:+1:+9999998 -+99999999:+1:+99999998 -+999999999:+1:+999999998 -+9999999999:+1:+9999999998 -+99999999999:+1:+99999999998 -+10:-1:+11 -+100:-1:+101 -+1000:-1:+1001 -+10000:-1:+10001 -+100000:-1:+100001 -+1000000:-1:+1000001 -+10000000:-1:+10000001 -+100000000:-1:+100000001 -+1000000000:-1:+1000000001 -+10000000000:-1:+10000000001 -+123456789:+987654321:-864197532 --123456789:+987654321:-1111111110 --123456789:-987654321:+864197532 -+123456789:-987654321:+1111111110 -&bmul -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0 -+0:+1:+0 -+1:+0:+0 -+0:-1:+0 --1:+0:+0 -+123456789123456789:+0:+0 -+0:+123456789123456789:+0 --1:-1:+1 --1:+1:-1 -+1:-1:-1 -+1:+1:+1 -+2:+3:+6 --2:+3:-6 -+2:-3:-6 --2:-3:+6 -+111:+111:+12321 -+10101:+10101:+102030201 -+1001001:+1001001:+1002003002001 -+100010001:+100010001:+10002000300020001 -+10000100001:+10000100001:+100002000030000200001 -+11111111111:+9:+99999999999 -+22222222222:+9:+199999999998 -+33333333333:+9:+299999999997 -+44444444444:+9:+399999999996 -+55555555555:+9:+499999999995 -+66666666666:+9:+599999999994 -+77777777777:+9:+699999999993 -+88888888888:+9:+799999999992 -+99999999999:+9:+899999999991 -&bdiv -abc:abc:NaN -abc:+1:abc:NaN -+1:abc:NaN -+0:+0:NaN -+0:+1:+0 -+1:+0:NaN -+0:-1:+0 --1:+0:NaN -+1:+1:+1 --1:-1:+1 -+1:-1:-1 --1:+1:-1 -+1:+2:+0 -+2:+1:+2 -+1000000000:+9:+111111111 -+2000000000:+9:+222222222 -+3000000000:+9:+333333333 -+4000000000:+9:+444444444 -+5000000000:+9:+555555555 -+6000000000:+9:+666666666 -+7000000000:+9:+777777777 -+8000000000:+9:+888888888 -+9000000000:+9:+1000000000 -+35500000:+113:+314159 -+71000000:+226:+314159 -+106500000:+339:+314159 -+1000000000:+3:+333333333 -+10:+5:+2 -+100:+4:+25 -+1000:+8:+125 -+10000:+16:+625 -+999999999999:+9:+111111111111 -+999999999999:+99:+10101010101 -+999999999999:+999:+1001001001 -+999999999999:+9999:+100010001 -+999999999999999:+99999:+10000100001 -&bmod -abc:abc:NaN -abc:+1:abc:NaN -+1:abc:NaN -+0:+0:NaN -+0:+1:+0 -+1:+0:NaN -+0:-1:+0 --1:+0:NaN -+1:+1:+0 --1:-1:+0 -+1:-1:+0 --1:+1:+0 -+1:+2:+1 -+2:+1:+0 -+1000000000:+9:+1 -+2000000000:+9:+2 -+3000000000:+9:+3 -+4000000000:+9:+4 -+5000000000:+9:+5 -+6000000000:+9:+6 -+7000000000:+9:+7 -+8000000000:+9:+8 -+9000000000:+9:+0 -+35500000:+113:+33 -+71000000:+226:+66 -+106500000:+339:+99 -+1000000000:+3:+1 -+10:+5:+0 -+100:+4:+0 -+1000:+8:+0 -+10000:+16:+0 -+999999999999:+9:+0 -+999999999999:+99:+0 -+999999999999:+999:+0 -+999999999999:+9999:+0 -+999999999999999:+99999:+0 -&bgcd -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0 -+0:+1:+1 -+1:+0:+1 -+1:+1:+1 -+2:+3:+1 -+3:+2:+1 -+100:+625:+25 -+4096:+81:+1 diff --git a/lib/bigrat.pl b/lib/bigrat.pl deleted file mode 100644 index aaf1713..0000000 --- a/lib/bigrat.pl +++ /dev/null @@ -1,159 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -package bigrat; -require "bigint.pl"; -# -# This library is no longer being maintained, and is included for backward -# compatibility with Perl 4 programs which may require it. -# This legacy library is deprecated and will be removed in a future -# release of perl. -# -# In particular, this should not be used as an example of modern Perl -# programming techniques. -# -# Arbitrary size rational math package - -# by Mark Biggar -# -# Input values to these routines consist of strings of the form -# m|^\s*[+-]?[\d\s]+(/[\d\s]+)?$|. -# Examples: -# "+0/1" canonical zero value -# "3" canonical value "+3/1" -# " -123/123 123" canonical value "-1/1001" -# "123 456/7890" canonical value "+20576/1315" -# Output values always include a sign and no leading zeros or -# white space. -# This package makes use of the bigint package. -# The string 'NaN' is used to represent the result when input arguments -# that are not numbers, as well as the result of dividing by zero and -# the sqrt of a negative number. -# Extremely naive algorithms are used. -# -# Routines provided are: -# -# rneg(RAT) return RAT negation -# rabs(RAT) return RAT absolute value -# rcmp(RAT,RAT) return CODE compare numbers (undef,<0,=0,>0) -# radd(RAT,RAT) return RAT addition -# rsub(RAT,RAT) return RAT subtraction -# rmul(RAT,RAT) return RAT multiplication -# rdiv(RAT,RAT) return RAT division -# rmod(RAT) return (RAT,RAT) integer and fractional parts -# rnorm(RAT) return RAT normalization -# rsqrt(RAT, cycles) return RAT square root - -# Convert a number to the canonical string form m|^[+-]\d+/\d+|. -sub main'rnorm { #(string) return rat_num - local($_) = @_; - s/\s+//g; - if (m#^([+-]?\d+)(/(\d*[1-9]0*))?$#) { - &norm($1, $3 ? $3 : '+1'); - } else { - 'NaN'; - } -} - -# Normalize by reducing to lowest terms -sub norm { #(bint, bint) return rat_num - local($num,$dom) = @_; - if ($num eq 'NaN') { - 'NaN'; - } elsif ($dom eq 'NaN') { - 'NaN'; - } elsif ($dom =~ /^[+-]?0+$/) { - 'NaN'; - } else { - local($gcd) = &'bgcd($num,$dom); - $gcd =~ s/^-/+/; - if ($gcd ne '+1') { - $num = &'bdiv($num,$gcd); - $dom = &'bdiv($dom,$gcd); - } else { - $num = &'bnorm($num); - $dom = &'bnorm($dom); - } - substr($dom,0,1) = ''; - "$num/$dom"; - } -} - -# negation -sub main'rneg { #(rat_num) return rat_num - local($_) = &'rnorm(@_); - tr/-+/+-/ if ($_ ne '+0/1'); - $_; -} - -# absolute value -sub main'rabs { #(rat_num) return $rat_num - local($_) = &'rnorm(@_); - substr($_,0,1) = '+' unless $_ eq 'NaN'; - $_; -} - -# multipication -sub main'rmul { #(rat_num, rat_num) return rat_num - local($xn,$xd) = split('/',&'rnorm($_[0])); - local($yn,$yd) = split('/',&'rnorm($_[1])); - &norm(&'bmul($xn,$yn),&'bmul($xd,$yd)); -} - -# division -sub main'rdiv { #(rat_num, rat_num) return rat_num - local($xn,$xd) = split('/',&'rnorm($_[0])); - local($yn,$yd) = split('/',&'rnorm($_[1])); - &norm(&'bmul($xn,$yd),&'bmul($xd,$yn)); -} - -# addition -sub main'radd { #(rat_num, rat_num) return rat_num - local($xn,$xd) = split('/',&'rnorm($_[0])); - local($yn,$yd) = split('/',&'rnorm($_[1])); - &norm(&'badd(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd)); -} - -# subtraction -sub main'rsub { #(rat_num, rat_num) return rat_num - local($xn,$xd) = split('/',&'rnorm($_[0])); - local($yn,$yd) = split('/',&'rnorm($_[1])); - &norm(&'bsub(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd)); -} - -# comparison -sub main'rcmp { #(rat_num, rat_num) return cond_code - local($xn,$xd) = split('/',&'rnorm($_[0])); - local($yn,$yd) = split('/',&'rnorm($_[1])); - &bigint'cmp(&'bmul($xn,$yd),&'bmul($yn,$xd)); -} - -# int and frac parts -sub main'rmod { #(rat_num) return (rat_num,rat_num) - local($xn,$xd) = split('/',&'rnorm(@_)); - local($i,$f) = &'bdiv($xn,$xd); - if (wantarray) { - ("$i/1", "$f/$xd"); - } else { - "$i/1"; - } -} - -# square root by Newtons method. -# cycles specifies the number of iterations default: 5 -sub main'rsqrt { #(fnum_str[, cycles]) return fnum_str - local($x, $scale) = (&'rnorm($_[0]), $_[1]); - if ($x eq 'NaN') { - 'NaN'; - } elsif ($x =~ /^-/) { - 'NaN'; - } else { - local($gscale, $guess) = (0, '+1/1'); - $scale = 5 if (!$scale); - while ($gscale++ < $scale) { - $guess = &'rmul(&'radd($guess,&'rdiv($x,$guess)),"+1/2"); - } - "$guess"; # quotes necessary due to perl bug - } -} - -1; diff --git a/lib/cacheout.pl b/lib/cacheout.pl deleted file mode 100644 index a5da453..0000000 --- a/lib/cacheout.pl +++ /dev/null @@ -1,59 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -# -# This library is no longer being maintained, and is included for backward -# compatibility with Perl 4 programs which may require it. -# This legacy library is deprecated and will be removed in a future -# release of perl. -# -# In particular, this should not be used as an example of modern Perl -# programming techniques. -# -# Suggested alternative: FileCache - -# Open in their package. - -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 { - package cacheout; - - ($file) = @_; - if (!$isopen{$file}) { - if (++$numopen > $maxopen) { - local(@lru) = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen); - splice(@lru, $maxopen / 3); - $numopen -= @lru; - for (@lru) { &close($_); delete $isopen{$_}; } - } - &open($file, ($saw{$file}++ ? '>>' : '>') . $file) - || die "Can't create $file: $!\n"; - } - $isopen{$file} = ++$seq; -} - -package cacheout; - -$seq = 0; -$numopen = 0; - -if (open(PARAM,'/usr/include/sys/param.h')) { - local($_, $.); - while () { - $maxopen = $1 - 4 if /^\s*#\s*define\s+NOFILE\s+(\d+)/; - } - close PARAM; -} -$maxopen = 16 unless $maxopen; - -1; diff --git a/lib/complete.pl b/lib/complete.pl deleted file mode 100644 index 9ed041c..0000000 --- a/lib/complete.pl +++ /dev/null @@ -1,124 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -;# -# -# This library is no longer being maintained, and is included for backward -# compatibility with Perl 4 programs which may require it. -# This legacy library is deprecated and will be removed in a future -# release of perl. -# -# In particular, this should not be used as an example of modern Perl -# programming techniques. -# -# Suggested alternative: Term::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: { - package Complete; - - $complete = "\004"; - $kill = "\025"; - $erase1 = "\177"; - $erase2 = "\010"; -} - -sub Complete { - package Complete; - - local($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r); - if ($_[1] =~ /^StB\0/) { - ($prompt, *_) = @_; - } - else { - $prompt = shift(@_); - } - @cmp_lst = sort(@_); - - system('stty raw -echo'); - LOOP: { - print($prompt, $return); - while (($_ = getc(STDIN)) ne "\r") { - CASE: { - # (TAB) attempt completion - $_ eq "\t" && do { - @match = grep(/^$return/, @cmp_lst); - $l = length($test = shift(@match)); - unless ($#match < 0) { - foreach $cmp (@match) { - until (substr($cmp, 0, $l) eq substr($test, 0, $l)) { - $l--; - } - } - print("\a"); - } - print($test = substr($test, $r, $l - $r)); - $r = length($return .= $test); - last CASE; - }; - - # (^D) completion list - $_ eq $complete && do { - print(join("\r\n", '', grep(/^$return/, @cmp_lst)), "\r\n"); - redo LOOP; - }; - - # (^U) kill - $_ eq $kill && do { - if ($r) { - undef $r; - undef $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/ctime.pl b/lib/ctime.pl deleted file mode 100644 index aa00d00..0000000 --- a/lib/ctime.pl +++ /dev/null @@ -1,63 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -;# ctime.pl is a simple Perl emulation for the well known ctime(3C) function. -# -# This library is no longer being maintained, and is included for backward -# compatibility with Perl 4 programs which may require it. -# This legacy library is deprecated and will be removed in a future -# release of perl. -# -# In particular, this should not be used as an example of modern Perl -# programming techniques. -# -# Suggested alternative: the POSIX ctime function - -;# -;# Waldemar Kebsch, Federal Republic of Germany, November 1988 -;# kebsch.pad@nixpbe.UUCP -;# Modified March 1990, Feb 1991 to properly handle timezones -;# $RCSfile: ctime.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:47 $ -;# Marion Hakanson (hakanson@cse.ogi.edu) -;# Oregon Graduate Institute of Science and Technology -;# -;# usage: -;# -;# #include # see the -P and -I option in perl.man -;# $Date = &ctime(time); - -CONFIG: { - package ctime; - - @DoW = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat'); - @MoY = ('Jan','Feb','Mar','Apr','May','Jun', - 'Jul','Aug','Sep','Oct','Nov','Dec'); -} - -sub ctime { - package ctime; - - local($time) = @_; - local($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst); - - # Determine what time zone is in effect. - # Use GMT if TZ is defined as null, local time if TZ undefined. - # There's no portable way to find the system default timezone. - - $TZ = defined($ENV{'TZ'}) ? ( $ENV{'TZ'} ? $ENV{'TZ'} : 'GMT' ) : ''; - ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = - ($TZ eq 'GMT') ? gmtime($time) : localtime($time); - - # Hack to deal with 'PST8PDT' format of TZ - # Note that this can't deal with all the esoteric forms, but it - # does recognize the most common: [:]STDoff[DST[off][,rule]] - - if($TZ=~/^([^:\d+\-,]{3,})([+-]?\d{1,2}(:\d{1,2}){0,2})([^\d+\-,]{3,})?/){ - $TZ = $isdst ? $4 : $1; - } - $TZ .= ' ' unless $TZ eq ''; - - $year += 1900; - sprintf("%s %s %2d %2d:%02d:%02d %s%4d\n", - $DoW[$wday], $MoY[$mon], $mday, $hour, $min, $sec, $TZ, $year); -} -1; diff --git a/lib/dotsh.pl b/lib/dotsh.pl deleted file mode 100644 index 92f1f4c..0000000 --- a/lib/dotsh.pl +++ /dev/null @@ -1,78 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -# -# @(#)dotsh.pl 03/19/94 -# -# This library is no longer being maintained, and is included for backward -# compatibility with Perl 4 programs which may require it. -# This legacy library is deprecated and will be removed in a future -# release of perl. -# -# In particular, this should not be used as an example of modern Perl -# programming techniques. -# -# 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 ('/foo/bar', 'arg1'); -# &dotsh ('/foo/bar'); -# &dotsh ('/foo/bar arg1 ... argN'); -# - -sub dotsh { - local(@sh) = @_; - local($tmp,$key,$shell,$command,$args,$vars) = ''; - local(*dotsh); - undef *dotsh; - $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$|\/bash$|\/csh$/) { - $shell = "$ENV{'SHELL'} -c"; - } else { - print "SHELL not recognized!\nUsing /bin/sh...\n"; - $shell = "/bin/sh -c"; - } - } - if (length($vars) > 0) { - open (_SH_ENV, "$shell \"$vars && . $command $args && set \" |") || die; - } else { - open (_SH_ENV, "$shell \". $command $args && set \" |") || die; - } - - while (<_SH_ENV>) { - chop; - m/^([^=]*)=(.*)/s; - $ENV{$1} = $2; - } - close (_SH_ENV); - - foreach $key (keys(%ENV)) { - $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/; - } - eval $tmp; -} -1; diff --git a/lib/exceptions.pl b/lib/exceptions.pl deleted file mode 100644 index 8af64c8..0000000 --- a/lib/exceptions.pl +++ /dev/null @@ -1,64 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -# exceptions.pl -# tchrist@convex.com -# -# This library is no longer being maintained, and is included for backward -# compatibility with Perl 4 programs which may require it. -# This legacy library is deprecated and will be removed in a future -# release of perl. -# -# In particular, this should not be used as an example of modern Perl -# programming techniques. - -# Here's a little code I use for exception handling. It's really just -# glorified eval/die. The way to use use it is when you might otherwise -# exit, use &throw to raise an exception. The first enclosing &catch -# handler looks at the exception and decides whether it can catch this kind -# (catch takes a list of regexps to catch), and if so, it returns the one it -# caught. If it *can't* catch it, then it will reraise the exception -# for someone else to possibly see, or to die otherwise. -# -# I use oddly named variables in order to make darn sure I don't conflict -# with my caller. I also hide in my own package, and eval the code in his. -# -# The EXCEPTION: prefix is so you can tell whether it's a user-raised -# exception or a perl-raised one (eval error). -# -# --tom -# -# examples: -# if (&catch('/$user_input/', 'regexp', 'syntax error') { -# warn "oops try again"; -# redo; -# } -# -# if ($error = &catch('&subroutine()')) { # catches anything -# -# &throw('bad input') if /^$/; - -sub catch { - package exception; - local($__code__, @__exceptions__) = @_; - local($__package__) = caller; - local($__exception__); - - eval "package $__package__; $__code__"; - if ($__exception__ = &'thrown) { - for (@__exceptions__) { - return $__exception__ if /$__exception__/; - } - &'throw($__exception__); - } -} - -sub throw { - local($exception) = @_; - die "EXCEPTION: $exception\n"; -} - -sub thrown { - $@ =~ /^(EXCEPTION: )+(.+)/ && $2; -} - -1; diff --git a/lib/fastcwd.pl b/lib/fastcwd.pl deleted file mode 100644 index 70007a1..0000000 --- a/lib/fastcwd.pl +++ /dev/null @@ -1,47 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -# By John Bazik -# -# This library is no longer being maintained, and is included for backward -# compatibility with Perl 4 programs which may require it. -# This legacy library is deprecated and will be removed in a future -# release of perl. -# -# In particular, this should not be used as an example of modern Perl -# programming techniques. -# -# Suggested alternative: Cwd - -# Usage: $cwd = &fastcwd; -# -# This is a faster version of getcwd. It's also more dangerous because -# you might chdir out of a directory that you can't chdir back into. - -sub fastcwd { - local($odev, $oino, $cdev, $cino, $tdev, $tino); - local(@path, $path); - local(*DIR); - - ($cdev, $cino) = stat('.'); - for (;;) { - ($odev, $oino) = ($cdev, $cino); - chdir('..'); - ($cdev, $cino) = stat('.'); - last if $odev == $cdev && $oino == $cino; - opendir(DIR, '.'); - for (;;) { - $_ = readdir(DIR); - next if $_ eq '.'; - next if $_ eq '..'; - - last unless $_; - ($tdev, $tino) = lstat($_); - last unless $tdev != $odev || $tino != $oino; - } - closedir(DIR); - unshift(@path, $_); - } - chdir($path = '/' . join('/', @path)); - $path; -} -1; diff --git a/lib/find.pl b/lib/find.pl deleted file mode 100644 index 8e1b42c..0000000 --- a/lib/find.pl +++ /dev/null @@ -1,54 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -# This library is deprecated and unmaintained. It is included for -# compatibility with Perl 4 scripts which may use it, but it will be -# removed in a future version of Perl. Please use the File::Find module -# instead. - -# Usage: -# require "find.pl"; -# -# &find('/foo','/bar'); -# -# sub wanted { ... } -# where wanted does whatever you want. $dir contains the -# current directory name, and $_ the current filename within -# that directory. $name contains "$dir/$_". You are cd'ed -# to $dir when the function is called. The function may -# set $prune to prune the tree. -# -# For example, -# -# find / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune -# -# corresponds to 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. - -use File::Find (); - -*name = *File::Find::name; -*prune = *File::Find::prune; -*dir = *File::Find::dir; -*topdir = *File::Find::topdir; -*topdev = *File::Find::topdev; -*topino = *File::Find::topino; -*topmode = *File::Find::topmode; -*topnlink = *File::Find::topnlink; - -sub find { - &File::Find::find(\&wanted, @_); -} - -1; diff --git a/lib/finddepth.pl b/lib/finddepth.pl deleted file mode 100644 index 479905f..0000000 --- a/lib/finddepth.pl +++ /dev/null @@ -1,53 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -# This library is deprecated and unmaintained. It is included for -# compatibility with Perl 4 scripts which may use it, but it will be -# removed in a future version of Perl. Please use the File::Find module -# instead. - -# Usage: -# require "finddepth.pl"; -# -# &finddepth('/foo','/bar'); -# -# sub wanted { ... } -# where wanted does whatever you want. $dir contains the -# current directory name, and $_ the current filename within -# that directory. $name contains "$dir/$_". You are cd'ed -# to $dir when the function is called. The function may -# set $prune to prune the tree. -# -# For example, -# -# find / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune -# -# corresponds to 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); -# } - - -use File::Find (); - -*name = *File::Find::name; -*prune = *File::Find::prune; -*dir = *File::Find::dir; -*topdir = *File::Find::topdir; -*topdev = *File::Find::topdev; -*topino = *File::Find::topino; -*topmode = *File::Find::topmode; -*topnlink = *File::Find::topnlink; - -sub finddepth { - &File::Find::finddepth(\&wanted, @_); -} - -1; diff --git a/lib/flush.pl b/lib/flush.pl deleted file mode 100644 index c427976..0000000 --- a/lib/flush.pl +++ /dev/null @@ -1,36 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -# -# This library is no longer being maintained, and is included for backward -# compatibility with Perl 4 programs which may require it. -# This legacy library is deprecated and will be removed in a future -# release of perl. -# -# In particular, this should not be used as an example of modern Perl -# programming techniques. -# -# Suggested alternative: IO::Handle - -;# Usage: &flush(FILEHANDLE) -;# flushes the named filehandle - -;# Usage: &printflush(FILEHANDLE, "prompt: ") -;# prints arguments and flushes filehandle - -sub flush { - local($old) = select(shift); - $| = 1; - print ""; - $| = 0; - select($old); -} - -sub printflush { - local($old) = select(shift); - $| = 1; - print @_; - $| = 0; - select($old); -} - -1; diff --git a/lib/getcwd.pl b/lib/getcwd.pl deleted file mode 100644 index 77b2442..0000000 --- a/lib/getcwd.pl +++ /dev/null @@ -1,74 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -# By Brandon S. Allbery -# -# This library is no longer being maintained, and is included for backward -# compatibility with Perl 4 programs which may require it. -# This legacy library is deprecated and will be removed in a future -# release of perl. -# In particular, this should not be used as an example of modern Perl -# programming techniques. -# -# Suggested alternative: Cwd - -# -# Usage: $cwd = &getcwd; - -sub getcwd -{ - local($dotdots, $cwd, @pst, @cst, $dir, @tst); - - unless (@cst = stat('.')) - { - warn "stat(.): $!"; - return ''; - } - $cwd = ''; - do - { - $dotdots .= '/' if $dotdots; - $dotdots .= '..'; - @pst = @cst; - unless (opendir(getcwd'PARENT, $dotdots)) #')) - { - warn "opendir($dotdots): $!"; - return ''; - } - unless (@cst = stat($dotdots)) - { - warn "stat($dotdots): $!"; - closedir(getcwd'PARENT); #'); - return ''; - } - if ($pst[0] == $cst[0] && $pst[1] == $cst[1]) - { - $dir = ''; - } - else - { - do - { - unless (defined ($dir = readdir(getcwd'PARENT))) #')) - { - warn "readdir($dotdots): $!"; - closedir(getcwd'PARENT); #'); - return ''; - } - unless (@tst = lstat("$dotdots/$dir")) - { - # warn "lstat($dotdots/$dir): $!"; - # closedir(getcwd'PARENT); #'); - # return ''; - } - } - while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] || - $tst[1] != $pst[1]); - } - $cwd = "$dir/$cwd"; - closedir(getcwd'PARENT); #'); - } while ($dir ne ''); - chop($cwd); - $cwd; -} - -1; diff --git a/lib/getopt.pl b/lib/getopt.pl deleted file mode 100644 index 1d4008a..0000000 --- a/lib/getopt.pl +++ /dev/null @@ -1,52 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -;# $RCSfile: getopt.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:58 $ -# -# This library is no longer being maintained, and is included for backward -# compatibility with Perl 4 programs which may require it. -# This legacy library is deprecated and will be removed in a future -# release of perl. -# -# In particular, this should not be used as an example of modern Perl -# programming techniques. -# -# Suggested alternatives: Getopt::Long or Getopt::Std - -;# Process single-character switches with switch clustering. Pass one argument -;# which is a string containing all switches that take an argument. For each -;# switch found, sets $opt_x (where x is the switch name) to the value of the -;# argument, or 1 if no argument. Switches which take an argument don't care -;# whether there is a space between the switch and the argument. - -;# Usage: -;# do Getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect. - -sub Getopt { - local($argumentative) = @_; - local($_,$first,$rest); - - while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { - ($first,$rest) = ($1,$2); - if (index($argumentative,$first) >= 0) { - if ($rest ne '') { - shift(@ARGV); - } - else { - shift(@ARGV); - $rest = shift(@ARGV); - } - ${"opt_$first"} = $rest; - } - else { - ${"opt_$first"} = 1; - if ($rest ne '') { - $ARGV[0] = "-$rest"; - } - else { - shift(@ARGV); - } - } - } -} - -1; diff --git a/lib/getopts.pl b/lib/getopts.pl deleted file mode 100644 index 37ecb4a..0000000 --- a/lib/getopts.pl +++ /dev/null @@ -1,67 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -;# getopts.pl - a better getopt.pl -# -# This library is no longer being maintained, and is included for backward -# compatibility with Perl 4 programs which may require it. -# -# In particular, this should not be used as an example of modern Perl -# programming techniques. -# -# Suggested alternatives: Getopt::Long or Getopt::Std - -;# Usage: -;# do Getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a -;# # side effect. - -sub Getopts { - local($argumentative) = @_; - local(@args,$_,$first,$rest); - local($errs) = 0; - - @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 " - push(\@opt_$first, \$rest); - if (!defined \$opt_$first or \$opt_$first eq '') { - \$opt_$first = \$rest; - } - else { - \$opt_$first .= ' ' . \$rest; - } - "; - } - else { - eval "\$opt_$first = 1"; - if($rest eq '') { - shift(@ARGV); - } - else { - $ARGV[0] = "-$rest"; - } - } - } - else { - print STDERR "Unknown option: $first\n"; - ++$errs; - if($rest ne '') { - $ARGV[0] = "-$rest"; - } - else { - shift(@ARGV); - } - } - } - $errs == 0; -} - -1; diff --git a/lib/hostname.pl b/lib/hostname.pl deleted file mode 100644 index f57375e..0000000 --- a/lib/hostname.pl +++ /dev/null @@ -1,35 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -# From: asherman@fmrco.com (Aaron Sherman) -# -# This library is no longer being maintained, and is included for backward -# compatibility with Perl 4 programs which may require it. -# This legacy library is deprecated and will be removed in a future -# release of perl. -# -# In particular, this should not be used as an example of modern Perl -# programming techniques. -# -# Suggested alternative: Sys::Hostname - -sub hostname -{ - local(*P,@tmp,$hostname,$_); - if (open(P,"hostname 2>&1 |") && (@tmp =

) && close(P)) - { - chop($hostname = $tmp[$#tmp]); - } - elsif (open(P,"uname -n 2>&1 |") && (@tmp =

) && close(P)) - { - chop($hostname = $tmp[$#tmp]); - } - else - { - die "$0: Cannot get hostname from 'hostname' or 'uname -n'\n"; - } - @tmp = (); - close P; # Just in case we failed in an odd spot.... - $hostname; -} - -1; diff --git a/lib/importenv.pl b/lib/importenv.pl deleted file mode 100644 index 625edf6..0000000 --- a/lib/importenv.pl +++ /dev/null @@ -1,21 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -# This library is no longer being maintained, and is included for backward -# compatibility with Perl 4 programs which may require it. -# This legacy library is deprecated and will be removed in a future -# release of perl. - -;# This file, when interpreted, pulls the environment into normal variables. -;# Usage: -;# require 'importenv.pl'; -;# or -;# #include - -local($tmp,$key) = ''; - -foreach $key (keys(%ENV)) { - $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/; -} -eval $tmp; - -1; diff --git a/lib/look.pl b/lib/look.pl deleted file mode 100644 index 7be55b2..0000000 --- a/lib/look.pl +++ /dev/null @@ -1,54 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -;# Usage: &look(*FILEHANDLE,$key,$dict,$fold) -# -# This library is no longer being maintained, and is included for backward -# compatibility with Perl 4 programs which may require it. -# This legacy library is deprecated and will be removed in a future -# release of perl. -# -# In particular, this should not be used as an example of modern Perl -# programming techniques. - -;# 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 = lc $key if $fold; - $max = int($size / $blksize); - while ($max - $min > 1) { - $mid = int(($max + $min) / 2); - seek(FH,$mid * $blksize,0); - $_ = if $mid; # probably a partial line - $_ = ; - chop; - s/[^\w\s]//g if $dict; - $_ = lc $_ if $fold; - if ($_ lt $key) { - $min = $mid; - } - else { - $max = $mid; - } - } - $min *= $blksize; - seek(FH,$min,0); - if $min; - while () { - chop; - s/[^\w\s]//g if $dict; - $_ = lc $_ if $fold; - last if $_ ge $key; - $min = tell(FH); - } - seek(FH,$min,0); - $min; -} - -1; diff --git a/lib/newgetopt.pl b/lib/newgetopt.pl deleted file mode 100644 index 4ac9470..0000000 --- a/lib/newgetopt.pl +++ /dev/null @@ -1,77 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -# This library is no longer being maintained, and is included for backward -# compatibility with Perl 4 programs which may require it. -# It is now just a wrapper around the Getopt::Long module. -# This legacy library is deprecated and will be removed in a future -# release of perl. -# -# In particular, this should not be used as an example of modern Perl -# programming techniques. -# -# Suggested alternative: Getopt::Long - -{ package newgetopt; - - # Values for $order. See GNU getopt.c for details. - $REQUIRE_ORDER = 0; - $PERMUTE = 1; - $RETURN_IN_ORDER = 2; - - # Handle POSIX compliance. - if ( defined $ENV{"POSIXLY_CORRECT"} ) { - $autoabbrev = 0; # no automatic abbrev of options (???) - $getopt_compat = 0; # disallow '+' to start options - $option_start = "(--|-)"; - $order = $REQUIRE_ORDER; - $bundling = 0; - $passthrough = 0; - } - else { - $autoabbrev = 1; # automatic abbrev of options - $getopt_compat = 1; # allow '+' to start options - $option_start = "(--|-|\\+)"; - $order = $PERMUTE; - $bundling = 0; - $passthrough = 0; - } - - # Other configurable settings. - $debug = 0; # for debugging - $ignorecase = 1; # ignore case when matching options - $argv_end = "--"; # don't change this! -} - -use Getopt::Long; - -################ Subroutines ################ - -sub NGetOpt { - - $Getopt::Long::debug = $newgetopt::debug - if defined $newgetopt::debug; - $Getopt::Long::autoabbrev = $newgetopt::autoabbrev - if defined $newgetopt::autoabbrev; - $Getopt::Long::getopt_compat = $newgetopt::getopt_compat - if defined $newgetopt::getopt_compat; - $Getopt::Long::option_start = $newgetopt::option_start - if defined $newgetopt::option_start; - $Getopt::Long::order = $newgetopt::order - if defined $newgetopt::order; - $Getopt::Long::bundling = $newgetopt::bundling - if defined $newgetopt::bundling; - $Getopt::Long::ignorecase = $newgetopt::ignorecase - if defined $newgetopt::ignorecase; - $Getopt::Long::ignorecase = $newgetopt::ignorecase - if defined $newgetopt::ignorecase; - $Getopt::Long::passthrough = $newgetopt::passthrough - if defined $newgetopt::passthrough; - - &GetOptions; -} - -################ Package return ################ - -1; - -################ End of newgetopt.pl ################ diff --git a/lib/open2.pl b/lib/open2.pl deleted file mode 100644 index ceb5653..0000000 --- a/lib/open2.pl +++ /dev/null @@ -1,17 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -# This legacy library is deprecated and will be removed in a future -# release of perl. -# -# This is a compatibility interface to IPC::Open2. New programs should -# do -# -# use IPC::Open2; -# -# instead of -# -# require 'open2.pl'; - -package main; -use IPC::Open2 'open2'; -1 diff --git a/lib/open3.pl b/lib/open3.pl deleted file mode 100644 index 9f4d5a4..0000000 --- a/lib/open3.pl +++ /dev/null @@ -1,17 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -# This legacy library is deprecated and will be removed in a future -# release of perl. -# -# This is a compatibility interface to IPC::Open3. New programs should -# do -# -# use IPC::Open3; -# -# instead of -# -# require 'open3.pl'; - -package main; -use IPC::Open3 'open3'; -1 diff --git a/lib/pwd.pl b/lib/pwd.pl deleted file mode 100644 index bd8123b..0000000 --- a/lib/pwd.pl +++ /dev/null @@ -1,71 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -;# pwd.pl - keeps track of current working directory in PWD environment var -;# -# -# This library is no longer being maintained, and is included for backward -# compatibility with Perl 4 programs which may require it. -# This legacy library is deprecated and will be removed in a future -# release of perl. -# -# In particular, this should not be used as an example of modern Perl -# programming techniques. -# -# Suggested alternative: Cwd - -;# $RCSfile: pwd.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:11 $ -;# -;# $Log: pwd.pl,v $ -;# -;# Usage: -;# require "pwd.pl"; -;# &initpwd; -;# ... -;# &chdir($newdir); - -package pwd; - -sub main'initpwd { - if ($ENV{'PWD'}) { - local($dd,$di) = stat('.'); - local($pd,$pi) = stat($ENV{'PWD'}); - if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) { - chop($ENV{'PWD'} = `pwd`); - } - } - else { - chop($ENV{'PWD'} = `pwd`); - } - if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) { - local($pd,$pi) = stat($2); - local($dd,$di) = stat($1); - if (defined $pd and defined $dd and $di == $pi and $dd == $pd) { - $ENV{'PWD'}="$2$3"; - } - } -} - -sub main'chdir { - local($newdir) = shift; - $newdir =~ s|/{2,}|/|g; - if (chdir $newdir) { - if ($newdir =~ m#^/#) { - $ENV{'PWD'} = $newdir; - } - else { - local(@curdir) = split(m#/#,$ENV{'PWD'}); - @curdir = '' unless @curdir; - foreach $component (split(m#/#, $newdir)) { - next if $component eq '.'; - pop(@curdir),next if $component eq '..'; - push(@curdir,$component); - } - $ENV{'PWD'} = join('/',@curdir) || '/'; - } - } - else { - 0; - } -} - -1; diff --git a/lib/shellwords.pl b/lib/shellwords.pl deleted file mode 100644 index b562f5f..0000000 --- a/lib/shellwords.pl +++ /dev/null @@ -1,19 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -;# This legacy library is deprecated and will be removed in a future -;# release of perl. -;# -;# shellwords.pl -;# -;# Usage: -;# require 'shellwords.pl'; -;# @words = shellwords($line); -;# or -;# @words = shellwords(@lines); -;# or -;# @words = shellwords(); # defaults to $_ (and clobbers it) - -require Text::ParseWords; -*shellwords = \&Text::ParseWords::old_shellwords; - -1; diff --git a/lib/stat.pl b/lib/stat.pl deleted file mode 100644 index feda273..0000000 --- a/lib/stat.pl +++ /dev/null @@ -1,35 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -;# This legacy library is deprecated and will be removed in a future -;# release of perl. -;# -;# Usage: -;# require 'stat.pl'; -;# @ary = stat(foo); -;# $st_dev = @ary[$ST_DEV]; -;# - -$ST_DEV = 0; -$ST_INO = 1; -$ST_MODE = 2; -$ST_NLINK = 3; -$ST_UID = 4; -$ST_GID = 5; -$ST_RDEV = 6; -$ST_SIZE = 7; -$ST_ATIME = 8; -$ST_MTIME = 9; -$ST_CTIME = 10; -$ST_BLKSIZE = 11; -$ST_BLOCKS = 12; - -;# Usage: -;# require 'stat.pl'; -;# do Stat('foo'); # sets st_* as a side effect -;# -sub Stat { - ($st_dev,$st_ino,$st_mode,$st_nlink,$st_uid,$st_gid,$st_rdev,$st_size, - $st_atime,$st_mtime,$st_ctime,$st_blksize,$st_blocks) = stat(shift(@_)); -} - -1; diff --git a/lib/syslog.pl b/lib/syslog.pl deleted file mode 100644 index 7504a5d..0000000 --- a/lib/syslog.pl +++ /dev/null @@ -1,201 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -# -# syslog.pl -# -# $Log: syslog.pl,v $ -# -# tom christiansen -# modified to use sockets by Larry Wall -# NOTE: openlog now takes three arguments, just like openlog(3) -# -# call syslog() with a string priority and a list of printf() args -# like syslog(3) -# -# usage: require 'syslog.pl'; -# -# then (put these all in a script to test function) -# -# -# do openlog($program,'cons,pid','user'); -# do syslog('info','this is another test'); -# do syslog('mail|warning','this is a better test: %d', time); -# do closelog(); -# -# do syslog('debug','this is the last test'); -# do openlog("$program $$",'ndelay','user'); -# do syslog('notice','fooprogram: this is really done'); -# -# $! = 55; -# do syslog('info','problem was %m'); # %m == $! in syslog(3) - -package syslog; - -use warnings::register; - -$host = 'localhost' unless $host; # set $syslog'host to change - -if ($] >= 5 && warnings::enabled()) { - warnings::warn("You should 'use Sys::Syslog' instead; continuing"); -} - -require 'syslog.ph'; - - eval 'use Socket; 1' || - eval { require "socket.ph" } || - require "sys/socket.ph"; - -$maskpri = &LOG_UPTO(&LOG_DEBUG); - -sub main'openlog { - ($ident, $logopt, $facility) = @_; # package vars - $lo_pid = $logopt =~ /\bpid\b/; - $lo_ndelay = $logopt =~ /\bndelay\b/; - $lo_cons = $logopt =~ /\bcons\b/; - $lo_nowait = $logopt =~ /\bnowait\b/; - &connect if $lo_ndelay; -} - -sub main'closelog { - $facility = $ident = ''; - &disconnect; -} - -sub main'setlogmask { - local($oldmask) = $maskpri; - $maskpri = shift; - $oldmask; -} - -sub main'syslog { - local($priority) = shift; - local($mask) = shift; - local($message, $whoami); - local(@words, $num, $numpri, $numfac, $sum); - local($facility) = $facility; # may need to change temporarily. - - die "syslog: expected both priority and mask" unless $mask && $priority; - - @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility". - undef $numpri; - undef $numfac; - foreach (@words) { - $num = &xlate($_); # Translate word to number. - if (/^kern$/ || $num < 0) { - die "syslog: invalid level/facility: $_\n"; - } - elsif ($num <= &LOG_PRIMASK) { - die "syslog: too many levels given: $_\n" if defined($numpri); - $numpri = $num; - return 0 unless &LOG_MASK($numpri) & $maskpri; - } - else { - die "syslog: too many facilities given: $_\n" if defined($numfac); - $facility = $_; - $numfac = $num; - } - } - - die "syslog: level must be given\n" unless defined($numpri); - - if (!defined($numfac)) { # Facility not specified in this call. - $facility = 'user' unless $facility; - $numfac = &xlate($facility); - } - - &connect unless $connected; - - $whoami = $ident; - - if (!$ident && $mask =~ /^(\S.*):\s?(.*)/) { - $whoami = $1; - $mask = $2; - } - - unless ($whoami) { - ($whoami = getlogin) || - ($whoami = getpwuid($<)) || - ($whoami = 'syslog'); - } - - $whoami .= "[$$]" if $lo_pid; - - $mask =~ s/%m/$!/g; - $mask .= "\n" unless $mask =~ /\n$/; - $message = sprintf ($mask, @_); - - $sum = $numpri + $numfac; - unless (send(SYSLOG,"<$sum>$whoami: $message",0)) { - if ($lo_cons) { - if ($pid = fork) { - unless ($lo_nowait) { - do {$died = wait;} until $died == $pid || $died < 0; - } - } - else { - open(CONS,">/dev/console"); - print CONS "<$facility.$priority>$whoami: $message\r"; - exit if defined $pid; # if fork failed, we're parent - close CONS; - } - } - } -} - -sub xlate { - local($name) = @_; - $name = uc $name; - $name = "LOG_$name" unless $name =~ /^LOG_/; - $name = "syslog'$name"; - defined &$name ? &$name : -1; -} - -sub connect { - $pat = 'S n C4 x8'; - - $af_unix = &AF_UNIX; - $af_inet = &AF_INET; - - $stream = &SOCK_STREAM; - $datagram = &SOCK_DGRAM; - - ($name,$aliases,$proto) = getprotobyname('udp'); - $udp = $proto; - - ($name,$aliases,$port,$proto) = getservbyname('syslog','udp'); - $syslog = $port; - - if (chop($myname = `hostname`)) { - ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($myname); - die "Can't lookup $myname\n" unless $name; - @bytes = unpack("C4",$addrs[0]); - } - else { - @bytes = (0,0,0,0); - } - $this = pack($pat, $af_inet, 0, @bytes); - - if ($host =~ /^\d+\./) { - @bytes = split(/\./,$host); - } - else { - ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($host); - die "Can't lookup $host\n" unless $name; - @bytes = unpack("C4",$addrs[0]); - } - $that = pack($pat,$af_inet,$syslog,@bytes); - - socket(SYSLOG,$af_inet,$datagram,$udp) || die "socket: $!\n"; - bind(SYSLOG,$this) || die "bind: $!\n"; - connect(SYSLOG,$that) || die "connect: $!\n"; - - local($old) = select(SYSLOG); $| = 1; select($old); - $connected = 1; -} - -sub disconnect { - close SYSLOG; - $connected = 0; -} - -1; diff --git a/lib/tainted.pl b/lib/tainted.pl deleted file mode 100644 index e88bca1..0000000 --- a/lib/tainted.pl +++ /dev/null @@ -1,14 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -# This legacy library is deprecated and will be removed in a future -# release of perl. -# This subroutine returns true if its argument is tainted, false otherwise. -# - -sub tainted { - local($@); - eval { kill 0 * $_[0] }; - $@ =~ /^Insecure/; -} - -1; diff --git a/lib/termcap.pl b/lib/termcap.pl deleted file mode 100644 index a84cba3..0000000 --- a/lib/termcap.pl +++ /dev/null @@ -1,183 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -;# $RCSfile: termcap.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:16 $ -# -# This library is no longer being maintained, and is included for backward -# compatibility with Perl 4 programs which may require it. -# This legacy library is deprecated and will be removed in a future -# release of perl. -# -# In particular, this should not be used as an example of modern Perl -# programming techniques. -# -# Suggested alternative: Term::Cap -# - -;# -;# Usage: -;# require 'ioctl.pl'; -;# ioctl(TTY,$TIOCGETP,$foo); -;# ($ispeed,$ospeed) = unpack('cc',$foo); -;# require 'termcap.pl'; -;# &Tgetent('vt100'); # sets $TC{'cm'}, etc. -;# &Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE'); -;# &Tputs($TC{'dl'},$affcnt,'FILEHANDLE'); -;# -sub Tgetent { - local($TERM) = @_; - local($TERMCAP,$_,$entry,$loop,$field); - - # warn "Tgetent: no ospeed set" unless $ospeed; - foreach $key (keys %TC) { - delete $TC{$key}; - } - $TERM = $ENV{'TERM'} unless $TERM; - $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') || die \"Can't open $TERMCAP\"; - while () { - next if /^#/; - next if /^\t/; - if (/(^|\\|)${TERM}[:\\|]/) { - chop; - while (chop eq '\\\\') { - \$_ .= ; - chop; - } - \$_ .= ':'; - last; - } - } - close TERMCAP; - \$entry .= \$_; - "; - eval $loop; - } while s/:tc=([^:]+):/:/ && ($TERM = $1); - $TERMCAP = $entry; - } - - foreach $field (split(/:[\s:\\]*/,$TERMCAP)) { - if ($field =~ /^\w\w$/) { - $TC{$field} = 1; - } - elsif ($field =~ /^(\w\w)#(.*)/) { - $TC{$1} = $2 if $TC{$1} eq ''; - } - elsif ($field =~ /^(\w\w)=(.*)/) { - $entry = $1; - $_ = $2; - s/\\E/\033/g; - s/\\(200)/pack('c',0)/eg; # NUL character - s/\\(0\d\d)/pack('c',oct($1))/eg; # octal - s/\\(0x[0-9A-Fa-f][0-9A-Fa-f])/pack('c',hex($1))/eg; # hex - s/\\(\d\d\d)/pack('c',$1 & 0177)/eg; - s/\\n/\n/g; - s/\\r/\r/g; - s/\\t/\t/g; - s/\\b/\b/g; - s/\\f/\f/g; - s/\\\^/\377/g; - s/\^\?/\177/g; - s/\^(.)/pack('c',ord($1) & 31)/eg; - s/\\(.)/$1/g; - s/\377/^/g; - $TC{$entry} = $_ if $TC{$entry} eq ''; - } - } - $TC{'pc'} = "\0" if $TC{'pc'} eq ''; - $TC{'bc'} = "\b" if $TC{'bc'} eq ''; -} - -@Tputs = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2); - -sub Tputs { - local($string,$affcnt,$FH) = @_; - local($ms); - if ($string =~ /(^[\d.]+)(\*?)(.*)$/) { - $ms = $1; - $ms *= $affcnt if $2; - $string = $3; - $decr = $Tputs[$ospeed]; - if ($decr > .1) { - $ms += $decr / 2; - $string .= $TC{'pc'} x ($ms / $decr); - } - } - print $FH $string if $FH; - $string; -} - -sub Tgoto { - local($string) = shift(@_); - local($result) = ''; - local($after) = ''; - local($code,$tmp) = @_; - local(@tmp); - @tmp = ($tmp,$code); - local($online) = 0; - while ($string =~ /^([^%]*)%(.)(.*)/) { - $result .= $1; - $code = $2; - $string = $3; - if ($code eq 'd') { - $result .= sprintf("%d",shift(@tmp)); - } - elsif ($code eq '.') { - $tmp = shift(@tmp); - if ($tmp == 0 || $tmp == 4 || $tmp == 10) { - if ($online) { - ++$tmp, $after .= $TC{'up'} if $TC{'up'}; - } - else { - ++$tmp, $after .= $TC{'bc'}; - } - } - $result .= sprintf("%c",$tmp); - $online = !$online; - } - elsif ($code eq '+') { - $result .= sprintf("%c",shift(@tmp)+ord($string)); - $string = substr($string,1,99); - $online = !$online; - } - elsif ($code eq 'r') { - ($code,$tmp) = @tmp; - @tmp = ($tmp,$code); - $online = !$online; - } - elsif ($code eq '>') { - ($code,$tmp,$string) = unpack("CCa99",$string); - if ($tmp[0] > $code) { - $tmp[0] += $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/timelocal.pl b/lib/timelocal.pl deleted file mode 100644 index fefb9da..0000000 --- a/lib/timelocal.pl +++ /dev/null @@ -1,23 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -;# timelocal.pl -;# -;# Usage: -;# $time = timelocal($sec,$min,$hours,$mday,$mon,$year); -;# $time = timegm($sec,$min,$hours,$mday,$mon,$year); - -;# This file has been superseded by the Time::Local library module. -;# It is implemented as a call to that module for backwards compatibility -;# with code written for perl4; new code should use Time::Local directly. -;# This legacy library is deprecated and will be removed in a future -;# release of perl. - -;# The current implementation shares with the original the questionable -;# behavior of defining the timelocal() and timegm() functions in the -;# namespace of whatever package was current when the first instance of -;# C was executed in a program. - -use Time::Local; - -*timelocal::cheat = \&Time::Local::cheat; - diff --git a/lib/validate.pl b/lib/validate.pl deleted file mode 100644 index fc2d16a..0000000 --- a/lib/validate.pl +++ /dev/null @@ -1,104 +0,0 @@ -warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; - -;# The validate routine takes a single multiline string consisting of -;# lines containing a filename plus a file test to try on it. (The -;# file test may also be a 'cd', causing subsequent relative filenames -;# to be interpreted relative to that directory.) After the file test -;# you may put '|| die' to make it a fatal error if the file test fails. -;# The default is '|| warn'. The file test may optionally have a ! prepended -;# to test for the opposite condition. If you do a cd and then list some -;# relative filenames, you may want to indent them slightly for readability. -;# If you supply your own "die" or "warn" message, you can use $file to -;# interpolate the filename. - -;# Filetests may be bunched: -rwx tests for all of -r, -w and -x. -;# Only the first failed test of the bunch will produce a warning. - -;# The routine returns the number of warnings issued. - -;# Usage: -;# require "validate.pl"; -;# $warnings += do validate(' -;# /vmunix -e || die -;# /boot -e || die -;# /bin cd -;# csh -ex -;# csh !-ug -;# sh -ex -;# sh !-ug -;# /usr -d || warn "What happened to $file?\n" -;# '); - -sub validate { - local($file,$test,$warnings,$oldwarnings); - foreach $check (split(/\n/,$_[0])) { - next if $check =~ /^#/; - next if $check =~ /^$/; - ($file,$test) = split(' ',$check,2); - if ($test =~ s/^(!?-)(\w{2,}\b)/$1Z/) { - $testlist = $2; - @testlist = split(//,$testlist); - } - else { - @testlist = ('Z'); - } - $oldwarnings = $warnings; - foreach $one (@testlist) { - $this = $test; - $this =~ s/(-\w\b)/$1 \$file/g; - $this =~ s/-Z/-$one/; - $this .= ' || warn' unless $this =~ /\|\|/; - $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || do valmess('$2','$1')/; - $this =~ s/\bcd\b/chdir (\$cwd = \$file)/g; - eval $this; - last if $warnings > $oldwarnings; - } - } - $warnings; -} - -sub valmess { - local($disposition,$this) = @_; - $file = $cwd . '/' . $file unless $file =~ m|^/|; - if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) { - $neg = $1; - $tmp = $2; - $tmp eq 'r' && ($mess = "$file is not readable by uid $>."); - $tmp eq 'w' && ($mess = "$file is not writable by uid $>."); - $tmp eq 'x' && ($mess = "$file is not executable by uid $>."); - $tmp eq 'o' && ($mess = "$file is not owned by uid $>."); - $tmp eq 'R' && ($mess = "$file is not readable by you."); - $tmp eq 'W' && ($mess = "$file is not writable by you."); - $tmp eq 'X' && ($mess = "$file is not executable by you."); - $tmp eq 'O' && ($mess = "$file is not owned by you."); - $tmp eq 'e' && ($mess = "$file does not exist."); - $tmp eq 'z' && ($mess = "$file does not have zero size."); - $tmp eq 's' && ($mess = "$file does not have non-zero size."); - $tmp eq 'f' && ($mess = "$file is not a plain file."); - $tmp eq 'd' && ($mess = "$file is not a directory."); - $tmp eq 'l' && ($mess = "$file is not a symbolic link."); - $tmp eq 'p' && ($mess = "$file is not a named pipe (FIFO)."); - $tmp eq 'S' && ($mess = "$file is not a socket."); - $tmp eq 'b' && ($mess = "$file is not a block special file."); - $tmp eq 'c' && ($mess = "$file is not a character special file."); - $tmp eq 'u' && ($mess = "$file does not have the setuid bit set."); - $tmp eq 'g' && ($mess = "$file does not have the setgid bit set."); - $tmp eq 'k' && ($mess = "$file does not have the sticky bit set."); - $tmp eq 'T' && ($mess = "$file is not a text file."); - $tmp eq 'B' && ($mess = "$file is not a binary file."); - if ($neg eq '!') { - $mess =~ s/ is not / should not be / || - $mess =~ s/ does not / should not / || - $mess =~ s/ not / /; - } - print STDERR $mess,"\n"; - } - else { - $this =~ s/\$file/'$file'/g; - print STDERR "Can't do $this.\n"; - } - if ($disposition eq 'die') { exit 1; } - ++$warnings; -} - -1; -- 2.7.4