Perl4-CoreLibs-0.004000755001750001750 013137277717 14155 5ustar00zeframzefram000000000000Perl4-CoreLibs-0.004/.gitignore000444001750001750 16713137277711 16260 0ustar00zeframzefram000000000000/Build /Makefile /_build /blib /META.json /META.yml /MYMETA.json /MYMETA.yml /Makefile.PL /SIGNATURE /Perl4-CoreLibs-* Perl4-CoreLibs-0.004/Build.PL000444001750001750 342713137277711 15606 0ustar00zeframzefram000000000000{ use 5.006; } use warnings; use strict; use Module::Build 0.26; my $build = Module::Build->new( module_name => "Perl4::CoreLibs", license => "perl", dist_author => [ "Brandon S. Allbery", "John Bazik", "Tom Christiansen ", "Alexandr Ciornii (alexchorny at gmail.com)", "Charles Collins", "Joe Doupnik ", "Marion Hakanson ", "Marc Horowitz ", "Waldemar Kebsch ", "Lee McLoughlin ", "", "Dave Rolsky ", "Randal L. Schwartz ", "Aaron Sherman ", "David Sundstrom ", "Wayne Thompson", "Larry Wall ", "Ilya Zakharevich", "Andrew Main (Zefram) ", ], configure_requires => { "Module::Build" => "0.26", "perl" => "5.006", "strict" => 0, "warnings" => 0, }, build_requires => { "Config" => 0, "IO::Handle" => 0, "Module::Build" => "0.26", "Test::More" => 0, "perl" => "5.006", "strict" => 0, "warnings" => 0, }, requires => { "File::Find" => 0, "Getopt::Long" => 0, "IPC::Open2" => 0, "IPC::Open3" => 0, "Socket" => 0, "Text::ParseWords" => "3.25", "Time::Local" => 0, "perl" => "5.006", "strict" => 0, "warnings" => 0, "warnings::register" => 0, }, dynamic_config => 0, meta_add => { distribution_type => "module" }, meta_merge => { "meta-spec" => { version => "2" }, resources => { bugtracker => { mailto => "bug-Perl4-CoreLibs\@rt.cpan.org", web => "https://rt.cpan.org/Public/Dist/". "Display.html?Name=Perl4-CoreLibs", }, }, }, sign => 1, ); $build->add_build_element("pl"); $build->create_build_script; 1; Perl4-CoreLibs-0.004/Changes000444001750001750 347413137277711 15607 0ustar00zeframzefram000000000000version 0.004; 2017-07-30 * in doc, note when core versions started warning and were removed * no longer include a Makefile.PL in the distribution * in META.{yml,json}, point to public bug tracker * include META.json in distribution * correct a typo in documentation * convert .cvsignore to .gitignore * add MYMETA.json to .cvsignore version 0.003; 2011-03-18 * bugfix: in shellwords.pl, require Text::ParseWords 3.25, because earlier versions have a bug that causes an infinite loop on some inputs * use full stricture in test suite * in Build.PL, complete declaration of configure-time requirements * in Build.PL, declare appropriate version on Module::Build dependency version 0.002; 2010-05-19 * remove all uses of $[, both reads and writes, from library code, where it has been obsolete since perl 5.000 * for option parsing libraries, test behaviour with "--" argument * in t/shellwords.t, remove unnecessary timeout that caused false test failures * in test suite, consistently use strictures and Test::More * revise test code style version 0.001; 2010-04-10 * revise statement about deprecation of the modules, to be more complete and accurate and to reflect the latest nuances to their status * in documentation, list the bundled libraries, with very short descriptions * add tests for several of the libraries based on the core's tests for more modern replacements: abbrev.pl from Text::Abbrev, getopt.pl and getopts.pl from Getopt::Std, hostname.pl from Sys::Hostname, open2.pl from IPC::Open2, open3.pl from IPC::Open3, shellwords.pl from Text::ParseWords, timelocal.pl from Time::Local * in titular version-number-supplying module, check for required Perl version at runtime version 0.000; 2010-03-30 * initial released version Perl4-CoreLibs-0.004/MANIFEST000444001750001750 137213137277711 15440 0ustar00zeframzefram000000000000.gitignore Build.PL Changes MANIFEST META.json META.yml README lib/Perl4/CoreLibs.pm lib/abbrev.pl lib/assert.pl lib/bigfloat.pl lib/bigint.pl lib/bigrat.pl lib/cacheout.pl lib/chat2.pl lib/complete.pl lib/ctime.pl lib/dotsh.pl lib/exceptions.pl lib/fastcwd.pl lib/find.pl lib/finddepth.pl lib/flush.pl lib/ftp.pl lib/getcwd.pl lib/getopt.pl lib/getopts.pl lib/hostname.pl lib/importenv.pl lib/look.pl lib/newgetopt.pl lib/open2.pl lib/open3.pl lib/pwd.pl lib/shellwords.pl lib/stat.pl lib/syslog.pl lib/tainted.pl lib/termcap.pl lib/timelocal.pl lib/validate.pl t/abbrev.t t/bigfloat.t t/bigint.t t/getopt.t t/getopts.t t/hostname.t t/newgetopt.t t/open2.t t/open3.t t/pod_cvg.t t/pod_syn.t t/shellwords.t t/timelocal.t SIGNATURE Added here by Module::Build Perl4-CoreLibs-0.004/META.json000444001750001750 473713137277711 15740 0ustar00zeframzefram000000000000{ "abstract" : "libraries historically supplied with Perl 4", "author" : [ "Brandon S. Allbery", "John Bazik", "Tom Christiansen ", "Alexandr Ciornii (alexchorny at gmail.com)", "Charles Collins", "Joe Doupnik ", "Marion Hakanson ", "Marc Horowitz ", "Waldemar Kebsch ", "Lee McLoughlin ", "", "Dave Rolsky ", "Randal L. Schwartz ", "Aaron Sherman ", "David Sundstrom ", "Wayne Thompson", "Larry Wall ", "Ilya Zakharevich", "Andrew Main (Zefram) " ], "dynamic_config" : 0, "generated_by" : "Module::Build version 0.4224", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Perl4-CoreLibs", "prereqs" : { "build" : { "requires" : { "Config" : "0", "IO::Handle" : "0", "Module::Build" : "0.26", "Test::More" : "0", "perl" : "5.006", "strict" : "0", "warnings" : "0" } }, "configure" : { "requires" : { "Module::Build" : "0.26", "perl" : "5.006", "strict" : "0", "warnings" : "0" } }, "runtime" : { "requires" : { "File::Find" : "0", "Getopt::Long" : "0", "IPC::Open2" : "0", "IPC::Open3" : "0", "Socket" : "0", "Text::ParseWords" : "3.25", "Time::Local" : "0", "perl" : "5.006", "strict" : "0", "warnings" : "0", "warnings::register" : "0" } } }, "provides" : { "Perl4::CoreLibs" : { "file" : "lib/Perl4/CoreLibs.pm", "version" : "0.004" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-Perl4-CoreLibs@rt.cpan.org", "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Perl4-CoreLibs" }, "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.004", "x_serialization_backend" : "JSON::PP version 2.93" } Perl4-CoreLibs-0.004/META.yml000444001750001750 330213137277711 15553 0ustar00zeframzefram000000000000--- abstract: 'libraries historically supplied with Perl 4' author: - 'Brandon S. Allbery' - 'John Bazik' - 'Tom Christiansen ' - 'Alexandr Ciornii (alexchorny at gmail.com)' - 'Charles Collins' - 'Joe Doupnik ' - 'Marion Hakanson ' - 'Marc Horowitz ' - 'Waldemar Kebsch ' - 'Lee McLoughlin ' - - 'Dave Rolsky ' - 'Randal L. Schwartz ' - 'Aaron Sherman ' - 'David Sundstrom ' - 'Wayne Thompson' - 'Larry Wall ' - 'Ilya Zakharevich' - 'Andrew Main (Zefram) ' build_requires: Config: '0' IO::Handle: '0' Module::Build: '0.26' Test::More: '0' perl: '5.006' strict: '0' warnings: '0' configure_requires: Module::Build: '0.26' perl: '5.006' strict: '0' warnings: '0' dynamic_config: 0 generated_by: 'Module::Build version 0.4224, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Perl4-CoreLibs provides: Perl4::CoreLibs: file: lib/Perl4/CoreLibs.pm version: '0.004' requires: File::Find: '0' Getopt::Long: '0' IPC::Open2: '0' IPC::Open3: '0' Socket: '0' Text::ParseWords: '3.25' Time::Local: '0' perl: '5.006' strict: '0' warnings: '0' warnings::register: '0' resources: bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Perl4-CoreLibs license: http://dev.perl.org/licenses/ version: '0.004' x_serialization_backend: 'CPAN::Meta::YAML version 0.012' Perl4-CoreLibs-0.004/README000444001750001750 456013137277711 15171 0ustar00zeframzefram000000000000NAME Perl4::CoreLibs - libraries historically supplied with Perl 4 DESCRIPTION This is a collection of ".pl" files that were bundled with the Perl core until core version 5.15.1. Relying on their presence in the core distribution is deprecated; they should be acquired from this CPAN distribution instead. From core version 5.13.3 until their removal, the core versions of these libraries emit a deprecation warning when loaded. The CPAN version does not emit such a warning. The entire Perl 4 approach to libraries was largely superseded in Perl 5.000 by the system of module namespaces and ".pm" files. Most of the libraries in this collection predate Perl 5.000, but a handful were first introduced in that version. Functionally, most have been directly superseded by modules in the Perl 5 style. These libraries should not be used by new code. This collection exists to support old Perl programs that predates satisfactory replacements. Most of these libraries have not been substantially maintained in the course of Perl 5 development. They are now very antiquated in style, making no use of the language facilities introduced since Perl 4. They should therefore not be used as programming examples. INSTALLATION perl Build.PL ./Build ./Build test ./Build install AUTHOR Known contributing authors for the libraries in this package are Brandon S. Allbery, John Bazik, Tom Christiansen , Charles Collins, Joe Doupnik , Marion Hakanson , Waldemar Kebsch , Lee McLoughlin , , Randal L. Schwartz , Aaron Sherman , Wayne Thompson, Larry Wall , and Ilya Zakharevich. (Most of these email addresses are probably out of date.) Known contributing authors for the tests in this package are Tom Christiansen , Alexandr Ciornii (alexchorny at gmail.com), Marc Horowitz , Dave Rolsky , and David Sundstrom . Andrew Main (Zefram) built the Perl4::CoreLibs package. COPYRIGHT Copyright (C) 1987-2009 Larry Wall et al Copyright (C) 2010, 2011, 2017 Andrew Main (Zefram) LICENSE This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Perl4-CoreLibs-0.004/SIGNATURE000644001750001750 752013137277717 15604 0ustar00zeframzefram000000000000This file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.81. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA1 SHA1 b62e2957b124b85389dc7c6006674bdd6ad71d80 .gitignore SHA1 6c4f1a89b50e415af9d5f1f52fe35378aa81e453 Build.PL SHA1 5381ffa20c2adfcceb6177f443c2fbdd9351e89f Changes SHA1 490c4e56b47b0412e92446963876eec6a26a0fc9 MANIFEST SHA1 45c93214eaf890d277fe2d121ea79fd5d4bda868 META.json SHA1 aa5c914ef1a1260f17e57cd58d7104231d7089be META.yml SHA1 e4b5e2d752168d5be5b89e64934019299c8ceedb README SHA1 b3a813a4e87c2f39c133247db86772749f20994d lib/Perl4/CoreLibs.pm SHA1 d34f3092d7fa015b1d79da59ba2ef6d1750c3235 lib/abbrev.pl SHA1 e7baaba3c82cb56da45e12cf10e020df80403b89 lib/assert.pl SHA1 e471939828ca3bcddc12e4642be4a2caffedf9f1 lib/bigfloat.pl SHA1 e37f3486d2f8332bc79827d95d59675af60659cf lib/bigint.pl SHA1 17bde82d2827efd5cd8109ea3fb4097b8c3c6acc lib/bigrat.pl SHA1 d3ca8191fd7393ef5030693de34508f29f09acac lib/cacheout.pl SHA1 ef9df026eaabadf4fdecbc6b098b104075eb116d lib/chat2.pl SHA1 657351c7a4568e8f90b48806d0f47609bdb07dac lib/complete.pl SHA1 2f2a1ea2e975c4bf5c4555288c303def01cfccf3 lib/ctime.pl SHA1 a2f6ce5616df363b84e25cb2b836c510f66b8f25 lib/dotsh.pl SHA1 6b1b3535825fc6e15183b951d3d7eb1c76dedd7d lib/exceptions.pl SHA1 e47bb82e8c5ff31ac2ff5d949217188dfa211f5f lib/fastcwd.pl SHA1 1dd888d493b32e37a8aed5cbba943b5a256547c8 lib/find.pl SHA1 d027422019db280d71a372621d9f5cf2a593c267 lib/finddepth.pl SHA1 05e69a428de4882694dc403651d42b5e09fbc17c lib/flush.pl SHA1 0f0037bd2b4becff2b03dda38f687f9a6c4efa0a lib/ftp.pl SHA1 f8f08a10b0674e6600d555707d3a92ddedd2679f lib/getcwd.pl SHA1 8282dc3ff054c7e0c35fdc0f8eda6ae867410e49 lib/getopt.pl SHA1 a562c6c5187a51fa4d8ff324b52fa1f5e5f4b7ac lib/getopts.pl SHA1 d819110dbdc1ccdefe67d6bf857564ce4f8bc01c lib/hostname.pl SHA1 bd8cfacf15c0f37a15c2d92bff595b6c0f287521 lib/importenv.pl SHA1 cb87ad59e87c53073ae0d76e07279d4b27c92900 lib/look.pl SHA1 d85b349f2273f8d08758d273e0feaec4a87a4205 lib/newgetopt.pl SHA1 790620173473d02a94d5f71c961022b4d1a0305e lib/open2.pl SHA1 a91b4032acf3921f37c812ca4ee56aaee0f9b168 lib/open3.pl SHA1 b4471fd6239028bd94b3b941307b55509cfc1bc8 lib/pwd.pl SHA1 97e226d3e297d0c6694d66b8ba893b588649819c lib/shellwords.pl SHA1 4c65b2e93e1f40e336fd53e4213ee9f63fd59b26 lib/stat.pl SHA1 7c2f990ba81f58c9e6525c2166407985b834e68d lib/syslog.pl SHA1 eb33cfea8616e3cdf65c22536080651daca2b392 lib/tainted.pl SHA1 17cbc392057ec8334b32c1448e003a0a96f3eaa0 lib/termcap.pl SHA1 66d26c4a6ed5d4da8a5a8775ab9d54510b072d30 lib/timelocal.pl SHA1 5d843e4eb829903350356374cb518e8677700c8e lib/validate.pl SHA1 40f230ec0bb17dada0cf2be172939d2dacd2c99a t/abbrev.t SHA1 99ea24386425a5eb1c8344bb67aa68a6bb78161f t/bigfloat.t SHA1 26fbda818a5f5bbb207813132ad058dcbe88f251 t/bigint.t SHA1 e06652dc0380006d2840932048ee19d3606a2b21 t/getopt.t SHA1 93a46b0734c4f1d38eb5a5216686ff4545dead45 t/getopts.t SHA1 f0a534fd2d52bfc88152dee7c818e3f25e70703c t/hostname.t SHA1 3799e8dd6c2dab99863be5bd68fc17f593759e7f t/newgetopt.t SHA1 6fd35abd4558d8787f5bb979e106b654af624eac t/open2.t SHA1 8de9df6d39b090717ef7d5f2bae04e1bf46fb9be t/open3.t SHA1 904d9a4f76525e2303e4b0c168c68230f223c8de t/pod_cvg.t SHA1 65c75abdef6f01a5d1588a307f2ddfe2333dc961 t/pod_syn.t SHA1 089234273a73f10e3bf39d636f7dbd21fb413060 t/shellwords.t SHA1 4a3269c9d997504a12fc561088eff53d4cc61600 t/timelocal.t -----BEGIN PGP SIGNATURE----- Version: GnuPG v1 iEYEARECAAYFAll9f8kACgkQOV9mt2VyAVEtEACeOlwYTBGd2JKvxj1cfMboCpEM uGYAnjeq6pKvrRbvc27fWSMj/BkfP3Iq =FOYv -----END PGP SIGNATURE----- Perl4-CoreLibs-0.004/lib000755001750001750 013137277711 14715 5ustar00zeframzefram000000000000Perl4-CoreLibs-0.004/lib/abbrev.pl000444001750001750 146313137277711 16654 0ustar00zeframzefram000000000000;# 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. # # 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; Perl4-CoreLibs-0.004/lib/assert.pl000444001750001750 242013137277711 16706 0ustar00zeframzefram000000000000# 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; Perl4-CoreLibs-0.004/lib/bigfloat.pl000444001750001750 1622313137277711 17222 0ustar00zeframzefram000000000000package 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. # # 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; Perl4-CoreLibs-0.004/lib/bigint.pl000444001750001750 2132713137277711 16710 0ustar00zeframzefram000000000000package 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. # # 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 -- Euclids algorithm Knuth Vol 2 pg 296 sub main'bgcd { #(num_str, num_str) return num_str local($x,$y) = (&'bnorm($_[0]),&'bnorm($_[1])); if ($x eq 'NaN' || $y eq 'NaN') { 'NaN'; } else { ($x, $y) = ($y,&'bmod($x,$y)) while $y ne '+0'; $x; } } # routine to add two base 1e5 numbers # stolen from Knuth Vol 2 Algorithm A pg 231 # there are separate routines to add and sub as per Kunth pg 233 sub add { #(int_num_array, int_num_array) return int_num_array local(*x, *y) = @_; $car = 0; for $x (@x) { last unless @y || $car; $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5) ? 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; Perl4-CoreLibs-0.004/lib/bigrat.pl000444001750001750 1054213137277711 16701 0ustar00zeframzefram000000000000package 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. # # 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. # Extreamly naive algorthims are used. # # Routines provided are: # # rneg(RAT) return RAT negation # rabs(RAT) return RAT absolute value # rcmp(RAT,RAT) return CODE compare numbers (undef,<0,=0,>0) # radd(RAT,RAT) return RAT addition # rsub(RAT,RAT) return RAT subtraction # rmul(RAT,RAT) return RAT multiplication # rdiv(RAT,RAT) return RAT division # rmod(RAT) return (RAT,RAT) integer and fractional parts # rnorm(RAT) return RAT normalization # rsqrt(RAT, cycles) return RAT square root # Convert a number to the canonical string form m|^[+-]\d+/\d+|. sub main'rnorm { #(string) return rat_num local($_) = @_; s/\s+//g; if (m#^([+-]?\d+)(/(\d*[1-9]0*))?$#) { &norm($1, $3 ? $3 : '+1'); } else { 'NaN'; } } # Normalize by reducing to lowest terms sub norm { #(bint, bint) return rat_num local($num,$dom) = @_; if ($num eq 'NaN') { 'NaN'; } elsif ($dom eq 'NaN') { 'NaN'; } elsif ($dom =~ /^[+-]?0+$/) { 'NaN'; } else { local($gcd) = &'bgcd($num,$dom); $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; Perl4-CoreLibs-0.004/lib/cacheout.pl000444001750001750 214213137277711 17201 0ustar00zeframzefram000000000000# # 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 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; Perl4-CoreLibs-0.004/lib/chat2.pl000444001750001750 2335413137277711 16437 0ustar00zeframzefram000000000000# chat.pl: chat with a server # # 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 alternative: Socket # # Based on: V2.01.alpha.7 91/06/16 # Randal L. Schwartz (was ) # multihome additions by A.Macpherson@bnr.co.uk # allow for /dev/pts based systems by Joe Doupnik package chat; require 'sys/socket.ph'; if( defined( &main'PF_INET ) ){ $pf_inet = &main'PF_INET; $sock_stream = &main'SOCK_STREAM; local($name, $aliases, $proto) = getprotobyname( 'tcp' ); $tcp_proto = $proto; } else { # XXX hardwired $PF_INET, $SOCK_STREAM, 'tcp' # but who the heck would change these anyway? (:-) $pf_inet = 2; $sock_stream = 1; $tcp_proto = 6; } $sockaddr = 'S n a4 x8'; chop($thishost = `hostname`); # *S = symbol for current I/O, gets assigned *chatsymbol.... $next = "chatsymbol000000"; # next one $nextpat = "^chatsymbol"; # patterns that match next++, ++, ++, ++ ## $handle = &chat'open_port("server.address",$port_number); ## opens a named or numbered TCP server sub open_port { ## public local($server, $port) = @_; local($serveraddr,$serverproc); # We may be multi-homed, start with 0, fixup once connexion is made $thisaddr = "\0\0\0\0" ; $thisproc = pack($sockaddr, 2, 0, $thisaddr); *S = ++$next; if ($server =~ /^(\d+)+\.(\d+)\.(\d+)\.(\d+)$/) { $serveraddr = pack('C4', $1, $2, $3, $4); } else { local(@x) = gethostbyname($server); return undef unless @x; $serveraddr = $x[4]; } $serverproc = pack($sockaddr, 2, $port, $serveraddr); unless (socket(S, $pf_inet, $sock_stream, $tcp_proto)) { ($!) = ($!, close(S)); # close S while saving $! return undef; } unless (bind(S, $thisproc)) { ($!) = ($!, close(S)); # close S while saving $! return undef; } unless (connect(S, $serverproc)) { ($!) = ($!, close(S)); # close S while saving $! return undef; } # We opened with the local address set to ANY, at this stage we know # which interface we are using. This is critical if our machine is # multi-homed, with IP forwarding off, so fix-up. local($fam,$lport); ($fam,$lport,$thisaddr) = unpack($sockaddr, getsockname(S)); $thisproc = pack($sockaddr, 2, 0, $thisaddr); # end of post-connect fixup select((select(S), $| = 1)[0]); $next; # return symbol for switcharound } ## ($host, $port, $handle) = &chat'open_listen([$port_number]); ## opens a TCP port on the current machine, ready to be listened to ## if $port_number is absent or zero, pick a default port number ## process must be uid 0 to listen to a low port number sub open_listen { ## public *S = ++$next; local($thisport) = shift || 0; local($thisproc_local) = pack($sockaddr, 2, $thisport, $thisaddr); local(*NS) = "__" . time; unless (socket(NS, $pf_inet, $sock_stream, $tcp_proto)) { ($!) = ($!, close(NS)); return undef; } unless (bind(NS, $thisproc_local)) { ($!) = ($!, close(NS)); return undef; } unless (listen(NS, 1)) { ($!) = ($!, close(NS)); return undef; } select((select(NS), $| = 1)[0]); local($family, $port, @myaddr) = unpack("S n C C C C x8", getsockname(NS)); $S{"needs_accept"} = *NS; # so expect will open it (@myaddr, $port, $next); # returning this } ## $handle = &chat'open_proc("command","arg1","arg2",...); ## opens a /bin/sh on a pseudo-tty sub open_proc { ## public local(@cmd) = @_; *S = ++$next; local(*TTY) = "__TTY" . time; local($pty,$tty) = &_getpty(S,TTY); die "Cannot find a new pty" unless defined $pty; $pid = fork; die "Cannot fork: $!" unless defined $pid; unless ($pid) { close STDIN; close STDOUT; close STDERR; setpgrp(0,$$); if (open(DEVTTY, "/dev/tty")) { ioctl(DEVTTY,0x20007471,0); # XXX s/b &TIOCNOTTY close DEVTTY; } open(STDIN,"<&TTY"); open(STDOUT,">&TTY"); open(STDERR,">&STDOUT"); die "Oops" unless fileno(STDERR) == 2; # sanity close(S); exec @cmd; die "Cannot exec @cmd: $!"; } close(TTY); $next; # return symbol for switcharound } # $S is the read-ahead buffer ## $return = &chat'expect([$handle,] $timeout_time, ## $pat1, $body1, $pat2, $body2, ... ) ## $handle is from previous &chat'open_*(). ## $timeout_time is the time (either relative to the current time, or ## absolute, ala time(2)) at which a timeout event occurs. ## $pat1, $pat2, and so on are regexs which are matched against the input ## stream. If a match is found, the entire matched string is consumed, ## and the corresponding body eval string is evaled. ## ## Each pat is a regular-expression (probably enclosed in single-quotes ## in the invocation). ^ and $ will work, respecting the current value of $*. ## If pat is 'TIMEOUT', the body is executed if the timeout is exceeded. ## If pat is 'EOF', the body is executed if the process exits before ## the other patterns are seen. ## ## Pats are scanned in the order given, so later pats can contain ## general defaults that won't be examined unless the earlier pats ## have failed. ## ## The result of eval'ing body is returned as the result of ## the invocation. Recursive invocations are not thought ## through, and may work only accidentally. :-) ## ## undef is returned if either a timeout or an eof occurs and no ## corresponding body has been defined. ## I/O errors of any sort are treated as eof. $nextsubname = "expectloop000000"; # used for subroutines sub expect { ## public if ($_[0] =~ /$nextpat/) { *S = shift; } local($endtime) = shift; local($timeout,$eof) = (1,1); local($caller) = caller; local($rmask, $nfound, $timeleft, $thisbuf); local($cases, $pattern, $action, $subname); $endtime += time if $endtime < 600_000_000; if (defined $S{"needs_accept"}) { # is it a listen socket? local(*NS) = $S{"needs_accept"}; delete $S{"needs_accept"}; $S{"needs_close"} = *NS; unless(accept(S,NS)) { ($!) = ($!, close(S), close(NS)); return undef; } select((select(S), $| = 1)[0]); } # now see whether we need to create a new sub: unless ($subname = $expect_subname{$caller,@_}) { # nope. make a new one: $expect_subname{$caller,@_} = $subname = $nextsubname++; $cases .= <<"EDQ"; # header is funny to make everything elsif's sub $subname { LOOP: { if (0) { ; } EDQ while (@_) { ($pattern,$action) = splice(@_,0,2); if ($pattern =~ /^eof$/i) { $cases .= <<"EDQ"; elsif (\$eof) { package $caller; $action; } EDQ $eof = 0; } elsif ($pattern =~ /^timeout$/i) { $cases .= <<"EDQ"; elsif (\$timeout) { package $caller; $action; } EDQ $timeout = 0; } else { $pattern =~ s#/#\\/#g; $cases .= <<"EDQ"; elsif (\$S =~ /$pattern/) { \$S = \$'; package $caller; $action; } EDQ } } $cases .= <<"EDQ" if $eof; elsif (\$eof) { undef; } EDQ $cases .= <<"EDQ" if $timeout; elsif (\$timeout) { undef; } EDQ $cases .= <<'ESQ'; else { $rmask = ""; vec($rmask,fileno(S),1) = 1; ($nfound, $rmask) = select($rmask, undef, undef, $endtime - time); if ($nfound) { $nread = sysread(S, $thisbuf, 1024); if ($nread > 0) { $S .= $thisbuf; } else { $eof++, redo LOOP; # any error is also eof } } else { $timeout++, redo LOOP; # timeout } redo LOOP; } } } ESQ eval $cases; die "$cases:\n$@" if $@; } $eof = $timeout = 0; do $subname(); } ## &chat'print([$handle,] @data) ## $handle is from previous &chat'open(). ## like print $handle @data sub print { ## public if ($_[0] =~ /$nextpat/) { *S = shift; } local $out = join $, , @_; syswrite(S, $out, length $out); if( $chat'debug ){ print STDERR "printed:"; print STDERR @_; } } ## &chat'close([$handle,]) ## $handle is from previous &chat'open(). ## like close $handle sub close { ## public if ($_[0] =~ /$nextpat/) { *S = shift; } close(S); if (defined $S{"needs_close"}) { # is it a listen socket? local(*NS) = $S{"needs_close"}; delete $S{"needs_close"}; close(NS); } } ## @ready_handles = &chat'select($timeout, @handles) ## select()'s the handles with a timeout value of $timeout seconds. ## Returns an array of handles that are ready for I/O. ## Both user handles and chat handles are supported (but beware of ## stdio's buffering for user handles). sub select { ## public local($timeout) = shift; local(@handles) = @_; local(%handlename) = (); local(%ready) = (); local($caller) = caller; local($rmask) = ""; for (@handles) { if (/$nextpat/o) { # one of ours... see if ready local(*SYM) = $_; if (length($SYM)) { $timeout = 0; # we have a winner $ready{$_}++; } $handlename{fileno($_)} = $_; } else { $handlename{fileno(/'/ ? $_ : "$caller\'$_")} = $_; } } for (sort keys %handlename) { vec($rmask, $_, 1) = 1; } select($rmask, undef, undef, $timeout); for (sort keys %handlename) { $ready{$handlename{$_}}++ if vec($rmask,$_,1); } sort keys %ready; } # ($pty,$tty) = $chat'_getpty(PTY,TTY): # internal procedure to get the next available pty. # opens pty on handle PTY, and matching tty on handle TTY. # returns undef if can't find a pty. # Modify "/dev/pty" to "/dev/pts" for Dell Unix v2.2 (aka SVR4.04). Joe Doupnik. sub _getpty { ## private local($_PTY,$_TTY) = @_; $_PTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e; $_TTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e; local($pty, $tty, $kind); if( -e "/dev/pts000" ){ ## mods by Joe Doupnik Dec 1992 $kind = "pts"; ## SVR4 Streams } else { $kind = "pty"; ## BSD Clist stuff } for $bank (112..127) { next unless -e sprintf("/dev/$kind%c0", $bank); for $unit (48..57) { $pty = sprintf("/dev/$kind%c%c", $bank, $unit); open($_PTY,"+>$pty") || next; select((select($_PTY), $| = 1)[0]); ($tty = $pty) =~ s/pty/tty/; open($_TTY,"+>$tty") || next; select((select($_TTY), $| = 1)[0]); system "stty nl>$tty"; return ($pty,$tty); } } undef; } 1; Perl4-CoreLibs-0.004/lib/complete.pl000444001750001750 616713137277711 17231 0ustar00zeframzefram000000000000;# # # 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 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; Perl4-CoreLibs-0.004/lib/ctime.pl000444001750001750 366613137277711 16523 0ustar00zeframzefram000000000000;# 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. # # 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; Perl4-CoreLibs-0.004/lib/dotsh.pl000444001750001750 417713137277711 16541 0ustar00zeframzefram000000000000# # @(#)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. # # 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; Perl4-CoreLibs-0.004/lib/exceptions.pl000444001750001750 331013137277711 17565 0ustar00zeframzefram000000000000# 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. # # 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 # glorfied eval/die. The way to use use it is when you might otherwise # exit, use &throw to raise an exception. The first enclosing &catch # handler looks at the exception and decides whether it can catch this kind # (catch takes a list of regexps to catch), and if so, it returns the one it # caught. If it *can't* catch it, then it will reraise the exception # for someone else to possibly see, or to die otherwise. # # I use oddly named variables in order to make darn sure I don't conflict # with my caller. I also hide in my own package, and eval the code in his. # # The EXCEPTION: prefix is so you can tell whether it's a user-raised # exception or a perl-raised one (eval error). # # --tom # # examples: # if (&catch('/$user_input/', 'regexp', 'syntax error') { # warn "oops try again"; # redo; # } # # if ($error = &catch('&subroutine()')) { # catches anything # # &throw('bad input') if /^$/; sub catch { package exception; local($__code__, @__exceptions__) = @_; local($__package__) = caller; local($__exception__); eval "package $__package__; $__code__"; if ($__exception__ = &'thrown) { for (@__exceptions__) { return $__exception__ if /$__exception__/; } &'throw($__exception__); } } sub throw { local($exception) = @_; die "EXCEPTION: $exception\n"; } sub thrown { $@ =~ /^(EXCEPTION: )+(.+)/ && $2; } 1; Perl4-CoreLibs-0.004/lib/fastcwd.pl000444001750001750 177313137277711 17052 0ustar00zeframzefram000000000000# By John Bazik # # 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 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; Perl4-CoreLibs-0.004/lib/find.pl000444001750001750 224113137277711 16326 0ustar00zeframzefram000000000000# Usage: # require "find.pl"; # # &find('/foo','/bar'); # # sub wanted { ... } # where wanted does whatever you want. $dir contains the # current directory name, and $_ the current filename within # that directory. $name contains "$dir/$_". You are cd'ed # to $dir when the function is called. The function may # set $prune to prune the tree. # # This library is primarily for find2perl, which, when fed # # find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune # # spits out something like this # # sub wanted { # /^\.nfs.*$/ && # (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && # int(-M _) > 7 && # unlink($_) # || # ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) && # $dev < 0 && # ($prune = 1); # } # # 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; Perl4-CoreLibs-0.004/lib/finddepth.pl000444001750001750 215213137277711 17354 0ustar00zeframzefram000000000000# Usage: # require "finddepth.pl"; # # &finddepth('/foo','/bar'); # # sub wanted { ... } # where wanted does whatever you want. $dir contains the # current directory name, and $_ the current filename within # that directory. $name contains "$dir/$_". You are cd'ed # to $dir when the function is called. The function may # set $prune to prune the tree. # # This library is primarily for find2perl, which, when fed # # find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune # # spits out something like this # # sub wanted { # /^\.nfs.*$/ && # (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && # int(-M _) > 7 && # unlink($_) # || # ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) && # $dev < 0 && # ($prune = 1); # } 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; Perl4-CoreLibs-0.004/lib/flush.pl000444001750001750 120213137277711 16523 0ustar00zeframzefram000000000000# # 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 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; Perl4-CoreLibs-0.004/lib/ftp.pl000444001750001750 5703713137277711 16234 0ustar00zeframzefram000000000000#-*-perl-*- # # 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 alternative: Net::FTP # # This is a wrapper to the chat2.pl routines that make life easier # to do ftp type work. # Mostly by Lee McLoughlin # based on original version by Alan R. Martello # And by A.Macpherson@bnr.co.uk for multi-homed hosts # # $Header: /a/swan/home/swan/staff/csg/lmjm/src/perl/mirror/RCS/ftp.pl,v 1.17 1993/04/21 10:06:54 lmjm Exp lmjm $ # $Log: ftp.pl,v $ # Revision 1.17 1993/04/21 10:06:54 lmjm # Send all status reports to STDERR not to STDOUT (to allow use by ftpcat). # Allow target file to be '-' meaning STDOUT # Added ftp'quote # # Revision 1.16 1993/01/28 18:59:05 lmjm # Allow socket arguemtns to come from main. # Minor cleanups - removed old comments. # # Revision 1.15 1992/11/25 21:09:30 lmjm # Added another REST return code. # # Revision 1.14 1992/08/12 14:33:42 lmjm # Fail ftp'write if out of space. # # Revision 1.13 1992/03/20 21:01:03 lmjm # Added in the proxy ftp code from Edwards Reed # Added ftp'delete from Aaron Wohl # # Revision 1.12 1992/02/06 23:25:56 lmjm # Moved code around so can use this as a lib for both mirror and ftpmail. # Time out opens. In case Unix doesn't bother to. # # Revision 1.11 1991/11/27 22:05:57 lmjm # Match the response code number at the start of a line allowing # for any leading junk. # # Revision 1.10 1991/10/23 22:42:20 lmjm # Added better timeout code. # Tried to optimise file transfer # Moved open/close code to not leak file handles. # Cleaned up the alarm code. # Added $fatalerror to show wether the ftp link is really dead. # # Revision 1.9 1991/10/07 18:30:35 lmjm # Made the timeout-read code work. # Added restarting file gets. # Be more verbose if ever have to call die. # # Revision 1.8 1991/09/17 22:53:16 lmjm # Spot when open_data_socket fails and return a failure rather than dying. # # Revision 1.7 1991/09/12 22:40:25 lmjm # Added Andrew Macpherson's patches for hosts without ip forwarding. # # Revision 1.6 1991/09/06 19:53:52 lmjm # Relaid out the code the way I like it! # Changed the debuggin to produce more "appropriate" messages # Fixed bugs in the ordering of put and dir listing. # Allow for hash printing when getting files (a la ftp). # Added the new commands from Al. # Don't print passwords in debugging. # # Revision 1.5 1991/08/29 16:23:49 lmjm # Timeout reads from the remote ftp server. # No longer call die expect on fatal errors. Just return fail codes. # Changed returns so higher up routines can tell whats happening. # Get expect/accept in correct order for dir listing. # When ftp_show is set then print hashes every 1k transferred (like ftp). # Allow for stripping returns out of incoming data. # Save last error in a global string. # # Revision 1.4 1991/08/14 21:04:58 lmjm # ftp'get now copes with ungetable files. # ftp'expect code changed such that the string_to_print is # ignored and the string sent back from the remote system is printed # instead. # Implemented patches from al. Removed spuiours tracing statements. # # Revision 1.3 1991/08/09 21:32:18 lmjm # Allow for another ok code on cwd's # Rejigger the log levels # Send \r\n for some odd ftp daemons # # Revision 1.2 1991/08/09 18:07:37 lmjm # Don't print messages unless ftp_show says to. # # Revision 1.1 1991/08/08 20:31:00 lmjm # Initial revision # require 'chat2.pl'; # into main eval "require 'socket.ph'" || eval "require 'sys/socket.ph'" || die "socket.ph missing: $!\n"; package ftp; if( defined( &main'PF_INET ) ){ $pf_inet = &main'PF_INET; $sock_stream = &main'SOCK_STREAM; local($name, $aliases, $proto) = getprotobyname( 'tcp' ); $tcp_proto = $proto; } else { # XXX hardwired $PF_INET, $SOCK_STREAM, 'tcp' # but who the heck would change these anyway? (:-) $pf_inet = 2; $sock_stream = 1; $tcp_proto = 6; } # If the remote ftp daemon doesn't respond within this time presume its dead # or something. $timeout = 30; # Timeout a read if I don't get data back within this many seconds $timeout_read = 20 * $timeout; # Timeout an open $timeout_open = $timeout; # This is a "global" it contains the last response from the remote ftp server # for use in error messages $ftp'response = ""; # Also ftp'NS is the socket containing the data coming in from the remote ls # command. # The size of block to be read or written when talking to the remote # ftp server $ftp'ftpbufsize = 4096; # How often to print a hash out, when debugging $ftp'hashevery = 1024; # Output a newline after this many hashes to prevent outputing very long lines $ftp'hashnl = 70; # If a proxy connection then who am I really talking to? $real_site = ""; # This is just a tracing aid. $ftp_show = 0; sub ftp'debug { $ftp_show = $_[0]; # if( $ftp_show ){ # print STDERR "ftp debugging on\n"; # } } sub ftp'set_timeout { $timeout = $_[0]; $timeout_open = $timeout; $timeout_read = 20 * $timeout; if( $ftp_show ){ print STDERR "ftp timeout set to $timeout\n"; } } sub ftp'open_alarm { die "timeout: open"; } sub ftp'timed_open { local( $site, $ftp_port, $retry_call, $attempts ) = @_; local( $connect_site, $connect_port ); local( $res ); alarm( $timeout_open ); while( $attempts-- ){ if( $ftp_show ){ print STDERR "proxy connecting via $proxy_gateway [$proxy_ftp_port]\n" if $proxy; print STDERR "Connecting to $site"; if( $ftp_port != 21 ){ print STDERR " [port $ftp_port]"; } print STDERR "\n"; } if( $proxy ) { if( ! $proxy_gateway ) { # if not otherwise set $proxy_gateway = "internet-gateway"; } if( $debug ) { print STDERR "using proxy services of $proxy_gateway, "; print STDERR "at $proxy_ftp_port\n"; } $connect_site = $proxy_gateway; $connect_port = $proxy_ftp_port; $real_site = $site; } else { $connect_site = $site; $connect_port = $ftp_port; } if( ! &chat'open_port( $connect_site, $connect_port ) ){ if( $retry_call ){ print STDERR "Failed to connect\n" if $ftp_show; next; } else { print STDERR "proxy connection failed " if $proxy; print STDERR "Cannot open ftp to $connect_site\n" if $ftp_show; return 0; } } $res = &ftp'expect( $timeout, 120, "service unavailable to $site", 0, 220, "ready for login to $site", 1, 421, "service unavailable to $site, closing connection", 0); if( ! $res ){ &chat'close(); next; } return 1; } continue { print STDERR "Pausing between retries\n"; sleep( $retry_pause ); } return 0; } sub ftp'open { local( $site, $ftp_port, $retry_call, $attempts ) = @_; $SIG{ 'ALRM' } = "ftp\'open_alarm"; local( $ret ) = eval "&timed_open( '$site', $ftp_port, $retry_call, $attempts )"; alarm( 0 ); if( $@ =~ /^timeout/ ){ return -1; } return $ret; } sub ftp'login { local( $remote_user, $remote_password ) = @_; if( $proxy ){ &ftp'send( "USER $remote_user\@$site" ); } else { &ftp'send( "USER $remote_user" ); } local( $val ) = &ftp'expect($timeout, 230, "$remote_user logged in", 1, 331, "send password for $remote_user", 2, 500, "syntax error", 0, 501, "syntax error", 0, 530, "not logged in", 0, 332, "account for login not supported", 0, 421, "service unavailable, closing connection", 0); if( $val == 1 ){ return 1; } if( $val == 2 ){ # A password is needed &ftp'send( "PASS $remote_password" ); $val = &ftp'expect( $timeout, 230, "$remote_user logged in", 1, 202, "command not implemented", 0, 332, "account for login not supported", 0, 530, "not logged in", 0, 500, "syntax error", 0, 501, "syntax error", 0, 503, "bad sequence of commands", 0, 421, "service unavailable, closing connection", 0); if( $val == 1){ # Logged in return 1; } } # If I got here I failed to login return 0; } sub ftp'close { &ftp'quit(); &chat'close(); } # Change directory # return 1 if successful # 0 on a failure sub ftp'cwd { local( $dir ) = @_; &ftp'send( "CWD $dir" ); return &ftp'expect( $timeout, 200, "working directory = $dir", 1, 250, "working directory = $dir", 1, 500, "syntax error", 0, 501, "syntax error", 0, 502, "command not implemented", 0, 530, "not logged in", 0, 550, "cannot change directory", 0, 421, "service unavailable, closing connection", 0 ); } # Get a full directory listing: # &ftp'dir( remote LIST options ) # Start a list goin with the given options. # Presuming that the remote deamon uses the ls command to generate the # data to send back then then you can send it some extra options (eg: -lRa) # return 1 if sucessful and 0 on a failure sub ftp'dir_open { local( $options ) = @_; local( $ret ); if( ! &ftp'open_data_socket() ){ return 0; } if( $options ){ &ftp'send( "LIST $options" ); } else { &ftp'send( "LIST" ); } $ret = &ftp'expect( $timeout, 150, "reading directory", 1, 125, "data connection already open?", 0, 450, "file unavailable", 0, 500, "syntax error", 0, 501, "syntax error", 0, 502, "command not implemented", 0, 530, "not logged in", 0, 421, "service unavailable, closing connection", 0 ); if( ! $ret ){ &ftp'close_data_socket; return 0; } # # the data should be coming at us now # # now accept accept(NS,S) || die "accept failed $!"; return 1; } # Close down reading the result of a remote ls command # return 1 if successful and 0 on failure sub ftp'dir_close { local( $ret ); # read the close # $ret = &ftp'expect($timeout, 226, "", 1, # transfer complete, closing connection 250, "", 1, # action completed 425, "can't open data connection", 0, 426, "connection closed, transfer aborted", 0, 451, "action aborted, local error", 0, 421, "service unavailable, closing connection", 0); # shut down our end of the socket &ftp'close_data_socket; if( ! $ret ){ return 0; } return 1; } # Quit from the remote ftp server # return 1 if successful and 0 on failure sub ftp'quit { $site_command_check = 0; @site_command_list = (); &ftp'send("QUIT"); return &ftp'expect($timeout, 221, "Goodbye", 1, # transfer complete, closing connection 500, "error quitting??", 0); } sub ftp'read_alarm { die "timeout: read"; } sub ftp'timed_read { alarm( $timeout_read ); return sysread( NS, $buf, $ftpbufsize ); } sub ftp'read { $SIG{ 'ALRM' } = "ftp\'read_alarm"; local( $ret ) = eval '&timed_read()'; alarm( 0 ); if( $@ =~ /^timeout/ ){ return -1; } return $ret; } # Get a remote file back into a local file. # If no loc_fname passed then uses rem_fname. # returns 1 on success and 0 on failure sub ftp'get { local($rem_fname, $loc_fname, $restart ) = @_; if ($loc_fname eq "") { $loc_fname = $rem_fname; } if( ! &ftp'open_data_socket() ){ print STDERR "Cannot open data socket\n"; return 0; } if( $loc_fname ne '-' ){ # Find the size of the target file local( $restart_at ) = &ftp'filesize( $loc_fname ); if( $restart && $restart_at > 0 && &ftp'restart( $restart_at ) ){ $restart = 1; # Make sure the file can be updated chmod( 0644, $loc_fname ); } else { $restart = 0; unlink( $loc_fname ); } } &ftp'send( "RETR $rem_fname" ); local( $ret ) = &ftp'expect($timeout, 150, "receiving $rem_fname", 1, 125, "data connection already open?", 0, 450, "file unavailable", 2, 550, "file unavailable", 2, 500, "syntax error", 0, 501, "syntax error", 0, 530, "not logged in", 0, 421, "service unavailable, closing connection", 0); if( $ret != 1 ){ print STDERR "Failure on RETR command\n"; # shut down our end of the socket &ftp'close_data_socket; return 0; } # # the data should be coming at us now # # now accept accept(NS,S) || die "accept failed: $!"; # # open the local fname # concatenate on the end if restarting, else just overwrite if( !open(FH, ($restart ? '>>' : '>') . $loc_fname) ){ print STDERR "Cannot create local file $loc_fname\n"; # shut down our end of the socket &ftp'close_data_socket; return 0; } # while () { # print FH ; # } local( $start_time ) = time; local( $bytes, $lasthash, $hashes ) = (0, 0, 0); while( ($len = &ftp'read()) > 0 ){ $bytes += $len; if( $strip_cr ){ $ftp'buf =~ s/\r//g; } if( $ftp_show ){ while( $bytes > ($lasthash + $ftp'hashevery) ){ print STDERR '#'; $lasthash += $ftp'hashevery; $hashes++; if( ($hashes % $ftp'hashnl) == 0 ){ print STDERR "\n"; } } } if( ! print FH $ftp'buf ){ print STDERR "\nfailed to write data"; return 0; } } close( FH ); # shut down our end of the socket &ftp'close_data_socket; if( $len < 0 ){ print STDERR "\ntimed out reading data!\n"; return 0; } if( $ftp_show ){ if( $hashes && ($hashes % $ftp'hashnl) != 0 ){ print STDERR "\n"; } local( $secs ) = (time - $start_time); if( $secs <= 0 ){ $secs = 1; # To avoid a divide by zero; } local( $rate ) = int( $bytes / $secs ); print STDERR "Got $bytes bytes ($rate bytes/sec)\n"; } # # read the close # $ret = &ftp'expect($timeout, 226, "Got file", 1, # transfer complete, closing connection 250, "Got file", 1, # action completed 110, "restart not supported", 0, 425, "can't open data connection", 0, 426, "connection closed, transfer aborted", 0, 451, "action aborted, local error", 0, 421, "service unavailable, closing connection", 0); return $ret; } sub ftp'delete { local( $rem_fname, $val ) = @_; &ftp'send("DELE $rem_fname" ); $val = &ftp'expect( $timeout, 250,"Deleted $rem_fname", 1, 550,"Permission denied",0 ); return $val == 1; } sub ftp'deldir { local( $fname ) = @_; # not yet implemented # RMD } # UPDATE ME!!!!!! # Add in the hash printing and newline conversion sub ftp'put { local( $loc_fname, $rem_fname ) = @_; local( $strip_cr ); if ($loc_fname eq "") { $loc_fname = $rem_fname; } if( ! &ftp'open_data_socket() ){ return 0; } &ftp'send("STOR $rem_fname"); # # the data should be coming at us now # local( $ret ) = &ftp'expect($timeout, 150, "sending $loc_fname", 1, 125, "data connection already open?", 0, 450, "file unavailable", 0, 532, "need account for storing files", 0, 452, "insufficient storage on system", 0, 553, "file name not allowed", 0, 500, "syntax error", 0, 501, "syntax error", 0, 530, "not logged in", 0, 421, "service unavailable, closing connection", 0); if( $ret != 1 ){ # shut down our end of the socket &ftp'close_data_socket; return 0; } # # the data should be coming at us now # # now accept accept(NS,S) || die "accept failed: $!"; # # open the local fname # if( !open(FH, "<$loc_fname") ){ print STDERR "Cannot open local file $loc_fname\n"; # shut down our end of the socket &ftp'close_data_socket; return 0; } while () { print NS ; } close(FH); # shut down our end of the socket to signal EOF &ftp'close_data_socket; # # read the close # $ret = &ftp'expect($timeout, 226, "file put", 1, # transfer complete, closing connection 250, "file put", 1, # action completed 110, "restart not supported", 0, 425, "can't open data connection", 0, 426, "connection closed, transfer aborted", 0, 451, "action aborted, local error", 0, 551, "page type unknown", 0, 552, "storage allocation exceeded", 0, 421, "service unavailable, closing connection", 0); if( ! $ret ){ print STDERR "error putting $loc_fname\n"; } return $ret; } sub ftp'restart { local( $restart_point, $ret ) = @_; &ftp'send("REST $restart_point"); # # see what they say $ret = &ftp'expect($timeout, 350, "restarting at $restart_point", 1, 500, "syntax error", 0, 501, "syntax error", 0, 502, "REST not implemented", 2, 530, "not logged in", 0, 554, "REST not implemented", 2, 421, "service unavailable, closing connection", 0); return $ret; } # Set the file transfer type sub ftp'type { local( $type ) = @_; &ftp'send("TYPE $type"); # # see what they say $ret = &ftp'expect($timeout, 200, "file type set to $type", 1, 500, "syntax error", 0, 501, "syntax error", 0, 504, "Invalid form or byte size for type $type", 0, 421, "service unavailable, closing connection", 0); return $ret; } $site_command_check = 0; @site_command_list = (); # routine to query the remote server for 'SITE' commands supported sub ftp'site_commands { local( $ret ); # if we havent sent a 'HELP SITE', send it now if( !$site_command_check ){ $site_command_check = 1; &ftp'send( "HELP SITE" ); # assume the line in the HELP SITE response with the 'HELP' # command is the one for us $ret = &ftp'expect( $timeout, ".*HELP.*", "", "\$1", 214, "", "0", 202, "", "0" ); if( $ret eq "0" ){ print STDERR "No response from HELP SITE\n" if( $ftp_show ); } @site_command_list = split(/\s+/, $ret); } return @site_command_list; } # return the pwd, or null if we can't get the pwd sub ftp'pwd { local( $ret, $cwd ); &ftp'send( "PWD" ); # # see what they say $ret = &ftp'expect( $timeout, 257, "working dir is", 1, 500, "syntax error", 0, 501, "syntax error", 0, 502, "PWD not implemented", 0, 550, "file unavailable", 0, 421, "service unavailable, closing connection", 0 ); if( $ret ){ if( $ftp'response =~ /^257\s"(.*)"\s.*$/ ){ $cwd = $1; } } return $cwd; } # return 1 for success, 0 for failure sub ftp'mkdir { local( $path ) = @_; local( $ret ); &ftp'send( "MKD $path" ); # # see what they say $ret = &ftp'expect( $timeout, 257, "made directory $path", 1, 500, "syntax error", 0, 501, "syntax error", 0, 502, "MKD not implemented", 0, 530, "not logged in", 0, 550, "file unavailable", 0, 421, "service unavailable, closing connection", 0 ); return $ret; } # return 1 for success, 0 for failure sub ftp'chmod { local( $path, $mode ) = @_; local( $ret ); &ftp'send( sprintf( "SITE CHMOD %o $path", $mode ) ); # # see what they say $ret = &ftp'expect( $timeout, 200, "chmod $mode $path succeeded", 1, 500, "syntax error", 0, 501, "syntax error", 0, 502, "CHMOD not implemented", 0, 530, "not logged in", 0, 550, "file unavailable", 0, 421, "service unavailable, closing connection", 0 ); return $ret; } # rename a file sub ftp'rename { local( $old_name, $new_name ) = @_; local( $ret ); &ftp'send( "RNFR $old_name" ); # # see what they say $ret = &ftp'expect( $timeout, 350, "", 1, 500, "syntax error", 0, 501, "syntax error", 0, 502, "RNFR not implemented", 0, 530, "not logged in", 0, 550, "file unavailable", 0, 450, "file unavailable", 0, 421, "service unavailable, closing connection", 0); # check if the "rename from" occurred ok if( $ret ) { &ftp'send( "RNTO $new_name" ); # # see what they say $ret = &ftp'expect( $timeout, 250, "rename $old_name to $new_name", 1, 500, "syntax error", 0, 501, "syntax error", 0, 502, "RNTO not implemented", 0, 503, "bad sequence of commands", 0, 530, "not logged in", 0, 532, "need account for storing files", 0, 553, "file name not allowed", 0, 421, "service unavailable, closing connection", 0); } return $ret; } sub ftp'quote { local( $cmd ) = @_; &ftp'send( $cmd ); return &ftp'expect( $timeout, 200, "Remote '$cmd' OK", 1, 500, "error in remote '$cmd'", 0 ); } # ------------------------------------------------------------------------------ # These are the lower level support routines sub ftp'expectgot { ($ftp'response, $ftp'fatalerror) = @_; if( $ftp_show ){ print STDERR "$ftp'response\n"; } } # # create the list of parameters for chat'expect # # ftp'expect(time_out, {value, string_to_print, return value}); # if the string_to_print is "" then nothing is printed # the last response is stored in $ftp'response # # NOTE: lmjm has changed this code such that the string_to_print is # ignored and the string sent back from the remote system is printed # instead. # sub ftp'expect { local( $ret ); local( $time_out ); local( $expect_args ); $ftp'response = ''; $ftp'fatalerror = 0; @expect_args = (); $time_out = shift(@_); while( @_ ){ local( $code ) = shift( @_ ); local( $pre ) = '^'; if( $code =~ /^\d/ ){ $pre =~ "[.|\n]*^"; } push( @expect_args, "$pre(" . $code . " .*)\\015\\n" ); shift( @_ ); push( @expect_args, "&ftp'expectgot( \$1, 0 ); " . shift( @_ ) ); } # Treat all unrecognised lines as continuations push( @expect_args, "^(.*)\\015\\n" ); push( @expect_args, "&ftp'expectgot( \$1, 0 ); 100" ); # add patterns TIMEOUT and EOF push( @expect_args, 'TIMEOUT' ); push( @expect_args, "&ftp'expectgot( \"timed out\", 1 ); 0" ); push( @expect_args, 'EOF' ); push( @expect_args, "&ftp'expectgot( \"remote server gone away\", 1 ); 0" ); if( $ftp_show > 9 ){ &printargs( $time_out, @expect_args ); } $ret = &chat'expect( $time_out, @expect_args ); if( $ret == 100 ){ # we saw a continuation line, wait for the end push( @expect_args, "^.*\n" ); push( @expect_args, "100" ); while( $ret == 100 ){ $ret = &chat'expect( $time_out, @expect_args ); } } return $ret; } # # opens NS for io # sub ftp'open_data_socket { local( $ret ); local( $hostname ); local( $sockaddr, $name, $aliases, $proto, $port ); local( $type, $len, $thisaddr, $myaddr, $a, $b, $c, $d ); local( $mysockaddr, $family, $hi, $lo ); $sockaddr = 'S n a4 x8'; chop( $hostname = `hostname` ); $port = "ftp"; ($name, $aliases, $proto) = getprotobyname( 'tcp' ); ($name, $aliases, $port) = getservbyname( $port, 'tcp' ); # ($name, $aliases, $type, $len, $thisaddr) = # gethostbyname( $hostname ); ($a,$b,$c,$d) = unpack( 'C4', $chat'thisaddr ); # $this = pack( $sockaddr, &main'AF_INET, 0, $thisaddr ); $this = $chat'thisproc; socket(S, $pf_inet, $sock_stream, $proto ) || die "socket: $!"; bind(S, $this) || die "bind: $!"; # get the port number $mysockaddr = getsockname(S); ($family, $port, $myaddr) = unpack( $sockaddr, $mysockaddr ); $hi = ($port >> 8) & 0x00ff; $lo = $port & 0x00ff; # # we MUST do a listen before sending the port otherwise # the PORT may fail # listen( S, 5 ) || die "listen"; &ftp'send( "PORT $a,$b,$c,$d,$hi,$lo" ); return &ftp'expect($timeout, 200, "PORT command successful", 1, 250, "PORT command successful", 1 , 500, "syntax error", 0, 501, "syntax error", 0, 530, "not logged in", 0, 421, "service unavailable, closing connection", 0); } sub ftp'close_data_socket { close(NS); } sub ftp'send { local($send_cmd) = @_; if( $send_cmd =~ /\n/ ){ print STDERR "ERROR, \\n in send string for $send_cmd\n"; } if( $ftp_show ){ local( $sc ) = $send_cmd; if( $send_cmd =~ /^PASS/){ $sc = "PASS "; } print STDERR "---> $sc\n"; } &chat'print( "$send_cmd\r\n" ); } sub ftp'printargs { while( @_ ){ print STDERR shift( @_ ) . "\n"; } } sub ftp'filesize { local( $fname ) = @_; if( ! -f $fname ){ return -1; } return (stat( _ ))[ 7 ]; } # make this package return true 1; Perl4-CoreLibs-0.004/lib/getcwd.pl000444001750001750 257313137277711 16673 0ustar00zeframzefram000000000000# 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. # # 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; Perl4-CoreLibs-0.004/lib/getopt.pl000444001750001750 242613137277711 16715 0ustar00zeframzefram000000000000;# $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. # # 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; Perl4-CoreLibs-0.004/lib/getopts.pl000444001750001750 255213137277711 17100 0ustar00zeframzefram000000000000;# 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; Perl4-CoreLibs-0.004/lib/hostname.pl000444001750001750 132713137277711 17230 0ustar00zeframzefram000000000000# 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. # # 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; Perl4-CoreLibs-0.004/lib/importenv.pl000444001750001750 43313137277711 17412 0ustar00zeframzefram000000000000;# 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; Perl4-CoreLibs-0.004/lib/look.pl000444001750001750 234713137277711 16361 0ustar00zeframzefram000000000000;# 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. # # 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; Perl4-CoreLibs-0.004/lib/newgetopt.pl000444001750001750 424513137277711 17430 0ustar00zeframzefram000000000000# $Id: newgetopt.pl,v 1.18 2001/09/21 13:34:59 jv Exp $ # 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. # # 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 compliancy. if ( defined $ENV{"POSIXLY_CORRECT"} ) { $autoabbrev = 0; # no automatic abbrev of options (???) $getopt_compat = 0; # disallow '+' to start options $option_start = "(--|-)"; $order = $REQUIRE_ORDER; $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 ################ Perl4-CoreLibs-0.004/lib/open2.pl000444001750001750 27113137277711 16412 0ustar00zeframzefram000000000000# 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 Perl4-CoreLibs-0.004/lib/open3.pl000444001750001750 27113137277711 16413 0ustar00zeframzefram000000000000# 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 Perl4-CoreLibs-0.004/lib/pwd.pl000444001750001750 270613137277711 16206 0ustar00zeframzefram000000000000;# 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. # # 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; Perl4-CoreLibs-0.004/lib/shellwords.pl000444001750001750 43013137277711 17552 0ustar00zeframzefram000000000000;# shellwords.pl ;# ;# Usage: ;# require 'shellwords.pl'; ;# @words = shellwords($line); ;# or ;# @words = shellwords(@lines); ;# or ;# @words = shellwords(); # defaults to $_ (and clobbers it) use Text::ParseWords 3.25 (); *shellwords = \&Text::ParseWords::old_shellwords; 1; Perl4-CoreLibs-0.004/lib/stat.pl000444001750001750 101513137277711 16357 0ustar00zeframzefram000000000000;# 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; Perl4-CoreLibs-0.004/lib/syslog.pl000444001750001750 1130613137277711 16750 0ustar00zeframzefram000000000000# # 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; Perl4-CoreLibs-0.004/lib/tainted.pl000444001750001750 24413137277711 17017 0ustar00zeframzefram000000000000# This subroutine returns true if its argument is tainted, false otherwise. sub tainted { local($@); eval { kill 0 * $_[0] }; $@ =~ /^Insecure/; } 1; Perl4-CoreLibs-0.004/lib/termcap.pl000444001750001750 1002013137277711 17053 0ustar00zeframzefram000000000000;# $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. # # 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; Perl4-CoreLibs-0.004/lib/timelocal.pl000444001750001750 126213137277711 17361 0ustar00zeframzefram000000000000;# 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. ;# 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; Perl4-CoreLibs-0.004/lib/validate.pl000444001750001750 722313137277711 17204 0ustar00zeframzefram000000000000;# 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; Perl4-CoreLibs-0.004/lib/Perl4000755001750001750 013137277711 15703 5ustar00zeframzefram000000000000Perl4-CoreLibs-0.004/lib/Perl4/CoreLibs.pm000444001750001750 1237013137277711 20123 0ustar00zeframzefram000000000000=head1 NAME Perl4::CoreLibs - libraries historically supplied with Perl 4 =head1 DESCRIPTION This is a collection of C<.pl> files that were bundled with the Perl core until core version 5.15.1. Relying on their presence in the core distribution is deprecated; they should be acquired from this CPAN distribution instead. From core version 5.13.3 until their removal, the core versions of these libraries emit a deprecation warning when loaded. The CPAN version does not emit such a warning. The entire Perl 4 approach to libraries was largely superseded in Perl 5.000 by the system of module namespaces and C<.pm> files. Most of the libraries in this collection predate Perl 5.000, but a handful were first introduced in that version. Functionally, most have been directly superseded by modules in the Perl 5 style. These libraries should not be used by new code. This collection exists to support old Perl programs that predate satisfactory replacements. Most of these libraries have not been substantially maintained in the course of Perl 5 development. They are now very antiquated in style, making no use of the language facilities introduced since Perl 4. They should therefore not be used as programming examples. =head1 LIBRARIES The libraries in this collection are: =over =item abbrev.pl Build a dictionary of unambiguous abbreviations for a group of words. Prefer L. =item assert.pl Assertion checking with stack trace upon assertion failure. =item bigfloat.pl Arbitrary precision decimal floating point arithmetic. Prefer L. =item bigint.pl Arbitrary precision integer arithmetic. Prefer L. =item bigrat.pl Arbitrary precision rational arithmetic. Prefer L. =item cacheout.pl Manage output to a large number of files to avoid running out of file descriptors. =item chat2.pl Framework for partial automation of communication with a remote process over IP. Prefer L. =item complete.pl Interactive line input with word completion. Prefer L. =item ctime.pl One form of textual representation of time. Prefer C or L. =item dotsh.pl Inhale shell variables set by a shell script. =item exceptions.pl String-based exception handling built on C and C. Prefer L or L. =item fastcwd.pl Determine current directory. Prefer L. =item find.pl Historical interface for a way of searching for files. Prefer L. =item finddepth.pl Historical interface for a way of searching for files. Prefer L. =item flush.pl Flush an I/O handle's output buffer. Prefer L. =item ftp.pl File Transfer Protocol (FTP) over IP. Prefer L. =item getcwd.pl Determine current directory. Prefer L. =item getopt.pl Unix-like option processing with all option taking arguments. Prefer L. =item getopts.pl Full Unix-like option processing. Prefer L. =item hostname.pl Determine host's hostname. Prefer L. =item importenv.pl Import environment variables as Perl package variables. =item look.pl Data-based seek within regular file. =item newgetopt.pl GNU-like option processing. Prefer L. =item open2.pl Open a subprocess for both reading and writing. Prefer L. =item open3.pl Open a subprocess for reading, writing, and error handling. Prefer L. =item pwd.pl Track changes of current directory in C<$ENV{PWD}>. =item shellwords.pl Interpret shell quoting. Prefer L. =item stat.pl Access fields of a L structure by name. Prefer L. =item syslog.pl Write to Unix system log. Prefer L. =item tainted.pl Determine whether data is tainted. Prefer L. =item termcap.pl Generate escape sequences to control arbitrary terminal. Prefer L. =item timelocal.pl Generate time number from broken-down time. Prefer L. =item validate.pl Check permissions on a group of files. =back =cut package Perl4::CoreLibs; { use 5.006; } use warnings; use strict; our $VERSION = "0.004"; =head1 AUTHOR Known contributing authors for the libraries in this package are Brandon S. Allbery, John Bazik, Tom Christiansen , Charles Collins, Joe Doupnik , Marion Hakanson , Waldemar Kebsch , Lee McLoughlin , , Randal L. Schwartz , Aaron Sherman , Wayne Thompson, Larry Wall , and Ilya Zakharevich. (Most of these email addresses are probably out of date.) Known contributing authors for the tests in this package are Tom Christiansen , Alexandr Ciornii (alexchorny at gmail.com), Marc Horowitz , Dave Rolsky , and David Sundstrom . Andrew Main (Zefram) built the Perl4::CoreLibs package. =head1 COPYRIGHT Copyright (C) 1987-2009 Larry Wall et al Copyright (C) 2010, 2011, 2017 Andrew Main (Zefram) =head1 LICENSE This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; Perl4-CoreLibs-0.004/t000755001750001750 013137277711 14412 5ustar00zeframzefram000000000000Perl4-CoreLibs-0.004/t/abbrev.t000444001750001750 102013137277711 16166 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More tests => 2; require_ok "abbrev.pl"; our %x; my @z = qw(list edit send abort gripe listen); &abbrev(*x, @z); is_deeply \%x, { a => "abort", ab => "abort", abo => "abort", abor => "abort", abort => "abort", e => "edit", ed => "edit", edi => "edit", edit => "edit", g => "gripe", gr => "gripe", gri => "gripe", grip => "gripe", gripe => "gripe", list => "list", liste => "listen", listen => "listen", s => "send", se => "send", sen => "send", send => "send", }; 1; Perl4-CoreLibs-0.004/t/bigfloat.t000444001750001750 1771613137277711 16557 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More tests => 356; $^W = 0; require_ok "bigfloat.pl"; my $f; while () { chomp; if (/^&/) { $f = $_; } elsif (/^\$.*/) { eval "$_;"; } else { my @args = split(/:/,$_,-1); my $ans = pop(@args); my $try = "$f('" . join("','", @args) . "');"; my $got = eval($try); $got = "" if !defined($got); is $got, $ans; } } 1; __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 Perl4-CoreLibs-0.004/t/bigint.t000444001750001750 1033413137277711 16231 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More tests => 247; $^W = 0; require_ok "bigint.pl"; my $f; while () { chomp; if (/^&/) { $f = $_; } else { my @args = split(/:/,$_,99); my $ans = pop(@args); my $try = "$f('" . join("','", @args) . "');"; my $got = eval($try); $got = "" if !defined($got); is $got, $ans; } } 1; __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 Perl4-CoreLibs-0.004/t/getopt.t000444001750001750 141013137277711 16232 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More tests => 13; require_ok "getopt.pl"; our($opt_f, $opt_h, $opt_i, $opt_l, $opt_o, $opt_x, $opt_y); @ARGV = qw(-xo -f foo -y file); &Getopt("f"); is_deeply \@ARGV, [qw(file)], "options removed from \@ARGV (1)"; ok $opt_x, "option -x set"; ok $opt_o, "option -o set"; ok $opt_y, "option -y set"; is $opt_f, "foo", "option -f set correctly"; @ARGV = qw(-hij k -- -l m -n); &Getopt("il"); is_deeply \@ARGV, [qw(k -- -l m -n)], "options removed from \@ARGV (2)"; ok $opt_h, "option -h set"; is $opt_i, "j", "option -i set correctly"; ok !defined($opt_l), "option -l not set"; @ARGV = qw(-h -- -i j); &Getopt(""); is_deeply \@ARGV, [qw(j)], "options removed from \@ARGV (3)"; ok $opt_h, "option -h set"; ok $opt_i, "option -i set"; 1; Perl4-CoreLibs-0.004/t/getopts.t000444001750001750 221513137277711 16421 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More tests => 15; require_ok "getopts.pl"; our($opt_f, $opt_h, $opt_i, $opt_k, $opt_o); $opt_o = $opt_i = $opt_f = undef; @ARGV = qw(-foi -i file); ok &Getopts("oif:"), "Getopts succeeded (1)"; is_deeply \@ARGV, [qw(file)], "options removed from \@ARGV (1)"; ok $opt_i, "option -i set"; is $opt_f, "oi", "option -f set correctly"; ok !defined($opt_o), "option -o not set"; $opt_h = $opt_i = $opt_k = undef; @ARGV = qw(-hij -k p -- -l m); ok &Getopts("hi:kl"), "Getopts succeeded (2)"; is_deeply \@ARGV, [qw(p -- -l m)], "options removed from \@ARGV (2)"; ok $opt_h, "option -h set"; ok $opt_k, "option -k set"; is $opt_i, "j", "option -i set correctly"; SKIP: { skip "can't capture stderr", 4 unless "$]" >= 5.008; my $warning = ""; close(STDERR); open(STDERR, ">", \$warning); @ARGV = qw(-h help); ok !Getopts("xf:y"), "Getopts fails for an illegal option"; is $warning, "Unknown option: h\n", "user warned"; $warning = ""; close(STDERR); open(STDERR, ">", \$warning); @ARGV = qw(-h -- -i j); ok !Getopts("hiy"), "Getopts fails for an illegal option"; is $warning, "Unknown option: -\n", "user warned"; } 1; Perl4-CoreLibs-0.004/t/hostname.t000444001750001750 26413137277711 16534 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More tests => 2; require_ok "hostname.pl"; my $host = eval { &hostname }; if($@) { like $@, qr/Cannot get host name/; } else { ok 1; } 1; Perl4-CoreLibs-0.004/t/newgetopt.t000444001750001750 105413137277711 16750 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More tests => 11; require_ok "newgetopt.pl"; our($opt_foo, $opt_Foo, $opt_bar, $opt_baR); @ARGV = qw(-Foo -baR --foo bar); $newgetopt::ignorecase = 0; $newgetopt::ignorecase = 0; undef $opt_baR; undef $opt_bar; ok NGetOpt("foo", "Foo=s"); is $opt_foo, 1; is $opt_Foo, "-baR"; is_deeply \@ARGV, [ "bar" ]; ok !defined($opt_baR); ok !defined($opt_bar); @ARGV = qw(--foo -- --bar j); undef $opt_foo; undef $opt_bar; ok NGetOpt("foo", "bar"); is_deeply \@ARGV, [qw(--bar j)]; is $opt_foo, 1; ok !defined($opt_bar); 1; Perl4-CoreLibs-0.004/t/open2.t000444001750001750 162413137277711 15762 0ustar00zeframzefram000000000000use warnings; use strict; use Config; BEGIN { # open2/3 supported on win32, but not Borland due to CRT bugs if(!$Config{d_fork} && (($^O ne 'MSWin32' && $^O ne 'NetWare') || $Config{cc} =~ /^bcc/i)) { require Test::More; Test::More->import(skip_all => "open2/3 not available with MSWin32+Netware+cc=bcc"); } } BEGIN { # make warnings fatal $SIG{__WARN__} = sub { die @_ }; } use IO::Handle; use Test::More tests => 8; require_ok "open2.pl"; my $perl = $^X; sub cmd_line { if ($^O eq 'MSWin32' || $^O eq 'NetWare') { return qq/"$_[0]"/; } else { return $_[0]; } } my ($pid, $reaped_pid); STDOUT->autoflush; STDERR->autoflush; $pid = &open2('READ', 'WRITE', $^X, '-e', cmd_line('print scalar ')); ok $pid; ok print(WRITE "hi kid\n"); like scalar(), qr/\Ahi kid\r?\n\z/; ok close(WRITE); ok close(READ); $reaped_pid = waitpid $pid, 0; is $reaped_pid, $pid; is $?, 0; 1; Perl4-CoreLibs-0.004/t/open3.t000444001750001750 1042213137277711 15777 0ustar00zeframzefram000000000000use warnings; use strict; use Config; BEGIN { # open2/3 supported on win32, but not Borland due to CRT bugs if(!$Config{d_fork} && (($^O ne 'MSWin32' && $^O ne 'NetWare') || $Config{cc} =~ /^bcc/i)) { require Test::More; Test::More->import(skip_all => "open2/3 not available with MSWin32+Netware+cc=bcc"); } } BEGIN { # make warnings fatal $SIG{__WARN__} = sub { die @_ }; } use IO::Handle; use Test::More tests => 23; require_ok "open3.pl"; sub cmd_line { if ($^O eq 'MSWin32' || $^O eq 'NetWare') { my $cmd = shift; $cmd =~ tr/\r\n//d; $cmd =~ s/"/\\"/g; return qq/"$cmd"/; } else { return $_[0]; } } my ($pid, $reaped_pid); STDOUT->autoflush; STDERR->autoflush; # basic $pid = &open3('WRITE', 'READ', 'ERROR', $^X, '-e', cmd_line(<<'EOF')); $| = 1; print scalar ; print STDERR "hi error\n"; EOF ok $pid; print WRITE "hi kid\n"; like scalar(), qr/\Ahi kid\r?\n\z/; like scalar(), qr/\Ahi error\r?\n\z/; ok close(WRITE); ok close(READ); ok close(ERROR); $reaped_pid = waitpid $pid, 0; is $reaped_pid, $pid; is $?, 0; # read and error together, both named $pid = &open3('WRITE', 'READ', 'READ', $^X, '-e', cmd_line(<<'EOF')); $| = 1; print scalar ; print STDERR scalar ; EOF print WRITE "wibble\n"; like scalar(), qr/\Awibble\r?\n\z/; print WRITE "wobble\n"; like scalar(), qr/\Awobble\r?\n\z/; waitpid $pid, 0; # read and error together, error empty $pid = &open3('WRITE', 'READ', '', $^X, '-e', cmd_line(<<'EOF')); $| = 1; print scalar ; print STDERR scalar ; EOF print WRITE "wibble\n"; like scalar(), qr/\Awibble\r?\n\z/; print WRITE "wobble\n"; like scalar(), qr/\Awobble\r?\n\z/; waitpid $pid, 0; # dup writer ok pipe(PIPE_READ, PIPE_WRITE); $pid = &open3('<&PIPE_READ', 'READ', '', $^X, '-e', 'print scalar '); close PIPE_READ; print PIPE_WRITE "wibble\n"; close PIPE_WRITE; like scalar(), qr/\Awibble\r?\n\z/; waitpid $pid, 0; # dup reader $pid = &open3('WRITE', 'READ', 'ERROR', $^X, '-e', cmd_line(<<'EOF')); $| = 1; sub cmd_line { $^O eq 'MSWin32' || $^O eq 'NetWare' ? qq/"$_[0]"/ : $_[0]; } require "open3.pl"; $pid = &open3('WRITE', '>&STDOUT', 'ERROR', $^X, '-e', cmd_line('print scalar ')); print WRITE "wibble\n"; waitpid $pid, 0; EOF like scalar(), qr/\Awibble\r?\n\z/; waitpid $pid, 0; # dup error: This particular case, duping stderr onto the existing # stdout but putting stdout somewhere else, is a good case because it # used not to work. $pid = &open3('WRITE', 'READ', 'ERROR', $^X, '-e', cmd_line(<<'EOF')); $| = 1; sub cmd_line { $^O eq 'MSWin32' || $^O eq 'NetWare' ? qq/"$_[0]"/ : $_[0]; } require "open3.pl"; $pid = &open3('WRITE', 'READ', '>&STDOUT', $^X, '-e', cmd_line('print STDERR scalar ')); print WRITE "wibble\n"; waitpid $pid, 0; EOF like scalar(), qr/\Awibble\r?\n\z/; waitpid $pid, 0; # dup reader and error together, both named $pid = &open3('WRITE', 'READ', 'ERROR', $^X, '-e', cmd_line(<<'EOF')); $| = 1; sub cmd_line { $^O eq 'MSWin32' || $^O eq 'NetWare' ? qq/"$_[0]"/ : $_[0]; } require "open3.pl"; $pid = &open3('WRITE', '>&STDOUT', '>&STDOUT', $^X, '-e', cmd_line('$|=1; print STDOUT scalar ; print STDERR scalar ')); print WRITE "wibble\n"; print WRITE "wobble\n"; waitpid $pid, 0; EOF like scalar(), qr/\Awibble\r?\n\z/; like scalar(), qr/\Awobble\r?\n\z/; waitpid $pid, 0; # dup reader and error together, error empty $pid = &open3('WRITE', 'READ', 'ERROR', $^X, '-e', cmd_line(<<'EOF')); $| = 1; sub cmd_line { $^O eq 'MSWin32' || $^O eq 'NetWare' ? qq/"$_[0]"/ : $_[0]; } require "open3.pl"; $pid = &open3('WRITE', '>&STDOUT', '', $^X, '-e', cmd_line('$|=1; print STDOUT scalar ; print STDERR scalar ')); print WRITE "wibble\n"; print WRITE "wobble\n"; waitpid $pid, 0; EOF like scalar(), qr/\Awibble\r?\n\z/; like scalar(), qr/\Awobble\r?\n\z/; waitpid $pid, 0; # command line in single parameter variant of open3 # for understanding of Config{'sh'} test see exec description in camel book my $cmd = 'print(scalar())'; $cmd = $Config{'sh'} =~ /sh/ ? "'$cmd'" : cmd_line($cmd); eval{$pid = &open3('WRITE', 'READ', 'ERROR', "$^X -e " . $cmd); }; is $@, ""; print WRITE "wibble\n"; like scalar(), qr/\Awibble\r?\n\z/; waitpid $pid, 0; 1; Perl4-CoreLibs-0.004/t/pod_cvg.t000444001750001750 27313137277711 16337 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More; plan skip_all => "Test::Pod::Coverage not available" unless eval "use Test::Pod::Coverage; 1"; Test::Pod::Coverage::all_pod_coverage_ok(); 1; Perl4-CoreLibs-0.004/t/pod_syn.t000444001750001750 23613137277711 16370 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More; plan skip_all => "Test::Pod not available" unless eval "use Test::Pod 1.00; 1"; Test::Pod::all_pod_files_ok(); 1; Perl4-CoreLibs-0.004/t/shellwords.t000444001750001750 205613137277711 17125 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More tests => 11; require_ok "shellwords.pl"; my $unmatched_quote; $SIG{__WARN__} = sub { if($_[0] =~ /\AUnmatched double quote/) { $unmatched_quote = 1; } else { die "WARNING: $_[0]"; } }; $unmatched_quote = 0; is_deeply [ &shellwords(qq(foo "bar quiz" zoo)) ], [ "foo", "bar quiz", "zoo" ]; ok !$unmatched_quote; # Now test error return $unmatched_quote = 0; is_deeply [ &shellwords('foo bar baz"bach blech boop') ], []; ok $unmatched_quote; # missing quote after matching regex used to hang after change #22997 $unmatched_quote = 0; "1234" =~ /(1)(2)(3)(4)/; is_deeply [ &shellwords(qq{"missing quote}) ], []; ok $unmatched_quote; # make sure shellwords strips out leading whitespace and trailng undefs # from parse_line, so it's behavior is more like /bin/sh $unmatched_quote = 0; is_deeply [ &shellwords(" aa \\ \\ bb ", " \\ ", "cc dd ee\\ ") ], [ "aa", " ", " bb", " ", "cc", "dd", "ee " ]; ok !$unmatched_quote; $unmatched_quote = 0; is_deeply [ &shellwords("foo\\") ], [ "foo" ]; ok !$unmatched_quote; 1; Perl4-CoreLibs-0.004/t/timelocal.t000444001750001750 612613137277711 16712 0ustar00zeframzefram000000000000use warnings; use strict; use Config; use Test::More tests => 135; require_ok "timelocal.pl"; foreach( #year,mon,day,hour,min,sec [1950, 4, 12, 9, 30, 31], [1969, 12, 31, 16, 59, 59], [1970, 1, 2, 00, 00, 00], [1980, 2, 28, 12, 00, 00], [1980, 2, 29, 12, 00, 00], [1999, 12, 31, 23, 59, 59], [2000, 1, 1, 00, 00, 00], [2010, 10, 12, 14, 13, 12], [2020, 2, 29, 12, 59, 59], [2030, 7, 4, 17, 07, 06], ) { my($year, $mon, $mday, $hour, $min, $sec) = @$_; $year -= 1900; $mon--; # Test timelocal() { my $year_in = $year < 70 ? $year + 1900 : $year; my $time = &timelocal($sec,$min,$hour,$mday,$mon,$year_in); my($s,$m,$h,$D,$M,$Y) = localtime($time); is $s, $sec, "timelocal second for @$_"; is $m, $min, "timelocal minute for @$_"; is $h, $hour, "timelocal hour for @$_"; is $D, $mday, "timelocal day for @$_"; is $M, $mon, "timelocal month for @$_"; is $Y, $year, "timelocal year for @$_"; } # Test timegm() { my $year_in = $year < 70 ? $year + 1900 : $year; my $time = &timegm($sec,$min,$hour,$mday,$mon,$year_in); my($s,$m,$h,$D,$M,$Y) = gmtime($time); is $s, $sec, "timegm second for @$_"; is $m, $min, "timegm minute for @$_"; is $h, $hour, "timegm hour for @$_"; is $D, $mday, "timegm day for @$_"; is $M, $mon, "timegm month for @$_"; is $Y, $year, "timegm year for @$_"; } } foreach( # month too large [1995, 13, 01, 01, 01, 01], # day too large [1995, 02, 30, 01, 01, 01], # hour too large [1995, 02, 10, 25, 01, 01], # minute too large [1995, 02, 10, 01, 60, 01], # second too large [1995, 02, 10, 01, 01, 60], ) { my($year, $mon, $mday, $hour, $min, $sec) = @$_; $year -= 1900; $mon--; eval { &timegm($sec,$min,$hour,$mday,$mon,$year) }; like $@, qr/.*out of range.*/, 'invalid time caused an error'; } is &timelocal(0,0,1,1,0,90) - &timelocal(0,0,0,1,0,90), 3600, 'one hour difference between two calls to timelocal'; is &timelocal(1,2,3,1,0,100) - &timelocal(1,2,3,31,11,99), 24 * 3600, 'one day difference between two calls to timelocal'; # Diff beween Jan 1, 1980 and Mar 1, 1980 = (31 + 29 = 60 days) is &timegm(0,0,0, 1, 2, 80) - &timegm(0,0,0, 1, 0, 80), 60 * 24 * 3600, '60 day difference between two calls to timegm'; # bugid #19393 # At a DST transition, the clock skips forward, eg from 01:59:59 to # 03:00:00. In this case, 02:00:00 is an invalid time, and should be # treated like 03:00:00 rather than 01:00:00 - negative zone offsets used # to do the latter { my $hour = (localtime(&timelocal(0, 0, 2, 7, 3, 102)))[2]; # testers in US/Pacific should get 3, # other testers should get 2 ok $hour == 2 || $hour == 3, 'hour should be 2 or 3'; } eval { &timegm(0,0,0,29,1,1900) }; like $@, qr/Day '29' out of range 1\.\.28/, 'does not accept leap day in 1900'; eval { &timegm(0,0,0,29,1,0) }; is $@, '', 'no error with leap day of 2000 (year passed as 0)'; eval { &timegm(0,0,0,29,1,1904) }; is $@, '', 'no error with leap day of 1904'; eval { &timegm(0,0,0,29,1,4) }; is $@, '', 'no error with leap day of 2004 (year passed as 4)'; eval { &timegm(0,0,0,29,1,96) }; is $@, '', 'no error with leap day of 1996 (year passed as 96)'; 1;