summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorFlorian Schlichting <fsfs@debian.org>2017-11-15 22:34:10 +0100
committerFlorian Schlichting <fsfs@debian.org>2017-11-15 22:34:10 +0100
commitad2f3f1b10fab5e7feba0cb10af73e9c89699a3a (patch)
treeb9cb13334ce9a6a1d88c1659594d6ee939115c41
Import libperl4-corelibs-perl_0.004.orig.tar.gz
[dgit import orig libperl4-corelibs-perl_0.004.orig.tar.gz]
Diffstat
-rw-r--r--.gitignore11
-rw-r--r--Build.PL76
-rw-r--r--Changes62
-rw-r--r--MANIFEST55
-rw-r--r--META.json88
-rw-r--r--META.yml63
-rw-r--r--README61
-rw-r--r--SIGNATURE77
-rw-r--r--lib/Perl4/CoreLibs.pm236
-rw-r--r--lib/abbrev.pl42
-rw-r--r--lib/assert.pl55
-rw-r--r--lib/bigfloat.pl254
-rw-r--r--lib/bigint.pl320
-rw-r--r--lib/bigrat.pl155
-rw-r--r--lib/cacheout.pl55
-rw-r--r--lib/chat2.pl379
-rw-r--r--lib/complete.pl120
-rw-r--r--lib/ctime.pl58
-rw-r--r--lib/dotsh.pl74
-rw-r--r--lib/exceptions.pl61
-rw-r--r--lib/fastcwd.pl43
-rw-r--r--lib/find.pl47
-rw-r--r--lib/finddepth.pl46
-rw-r--r--lib/flush.pl32
-rw-r--r--lib/ftp.pl1086
-rw-r--r--lib/getcwd.pl71
-rw-r--r--lib/getopt.pl48
-rw-r--r--lib/getopts.pl65
-rw-r--r--lib/hostname.pl31
-rw-r--r--lib/importenv.pl14
-rw-r--r--lib/look.pl50
-rw-r--r--lib/newgetopt.pl75
-rw-r--r--lib/open2.pl12
-rw-r--r--lib/open3.pl12
-rw-r--r--lib/pwd.pl67
-rw-r--r--lib/shellwords.pl14
-rw-r--r--lib/stat.pl29
-rw-r--r--lib/syslog.pl199
-rw-r--r--lib/tainted.pl9
-rw-r--r--lib/termcap.pl178
-rw-r--r--lib/timelocal.pl18
-rw-r--r--lib/validate.pl102
-rw-r--r--t/abbrev.t35
-rw-r--r--t/bigfloat.t408
-rw-r--r--t/bigint.t282
-rw-r--r--t/getopt.t31
-rw-r--r--t/getopts.t42
-rw-r--r--t/hostname.t15
-rw-r--r--t/newgetopt.t30
-rw-r--r--t/open2.t51
-rw-r--r--t/open3.t168
-rw-r--r--t/pod_cvg.t9
-rw-r--r--t/pod_syn.t8
-rw-r--r--t/shellwords.t44
-rw-r--r--t/timelocal.t110
55 files changed, 5783 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..4594861
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,11 @@
+/Build
+/Makefile
+/_build
+/blib
+/META.json
+/META.yml
+/MYMETA.json
+/MYMETA.yml
+/Makefile.PL
+/SIGNATURE
+/Perl4-CoreLibs-*
diff --git a/Build.PL b/Build.PL
new file mode 100644
index 0000000..ec140d1
--- /dev/null
+++ b/Build.PL
@@ -0,0 +1,76 @@
+{ 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 <tchrist\@convex.com>",
+ "Alexandr Ciornii (alexchorny at gmail.com)",
+ "Charles Collins",
+ "Joe Doupnik <JRD\@CC.USU.EDU>",
+ "Marion Hakanson <hakanson\@cse.ogi.edu>",
+ "Marc Horowitz <marc\@mit.edu>",
+ "Waldemar Kebsch <kebsch.pad\@nixpbe.UUCP>",
+ "Lee McLoughlin <lmjm\@doc.ic.ac.uk>",
+ "<A.Macpherson\@bnr.co.uk>",
+ "Dave Rolsky <autarch\@urth.org>",
+ "Randal L. Schwartz <merlyn\@stonehenge.com>",
+ "Aaron Sherman <asherman\@fmrco.com>",
+ "David Sundstrom <sunds\@asictest.sc.ti.com>",
+ "Wayne Thompson",
+ "Larry Wall <lwall\@jpl-devvax.jpl.nasa.gov>",
+ "Ilya Zakharevich",
+ "Andrew Main (Zefram) <zefram\@fysh.org>",
+ ],
+ 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;
diff --git a/Changes b/Changes
new file mode 100644
index 0000000..8cd6af9
--- /dev/null
+++ b/Changes
@@ -0,0 +1,62 @@
+version 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
diff --git a/MANIFEST b/MANIFEST
new file mode 100644
index 0000000..0fd0de8
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,55 @@
+.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
diff --git a/META.json b/META.json
new file mode 100644
index 0000000..3287947
--- /dev/null
+++ b/META.json
@@ -0,0 +1,88 @@
+{
+ "abstract" : "libraries historically supplied with Perl 4",
+ "author" : [
+ "Brandon S. Allbery",
+ "John Bazik",
+ "Tom Christiansen <tchrist@convex.com>",
+ "Alexandr Ciornii (alexchorny at gmail.com)",
+ "Charles Collins",
+ "Joe Doupnik <JRD@CC.USU.EDU>",
+ "Marion Hakanson <hakanson@cse.ogi.edu>",
+ "Marc Horowitz <marc@mit.edu>",
+ "Waldemar Kebsch <kebsch.pad@nixpbe.UUCP>",
+ "Lee McLoughlin <lmjm@doc.ic.ac.uk>",
+ "<A.Macpherson@bnr.co.uk>",
+ "Dave Rolsky <autarch@urth.org>",
+ "Randal L. Schwartz <merlyn@stonehenge.com>",
+ "Aaron Sherman <asherman@fmrco.com>",
+ "David Sundstrom <sunds@asictest.sc.ti.com>",
+ "Wayne Thompson",
+ "Larry Wall <lwall@jpl-devvax.jpl.nasa.gov>",
+ "Ilya Zakharevich",
+ "Andrew Main (Zefram) <zefram@fysh.org>"
+ ],
+ "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"
+}
diff --git a/META.yml b/META.yml
new file mode 100644
index 0000000..4c003d3
--- /dev/null
+++ b/META.yml
@@ -0,0 +1,63 @@
+---
+abstract: 'libraries historically supplied with Perl 4'
+author:
+ - 'Brandon S. Allbery'
+ - 'John Bazik'
+ - 'Tom Christiansen <tchrist@convex.com>'
+ - 'Alexandr Ciornii (alexchorny at gmail.com)'
+ - 'Charles Collins'
+ - 'Joe Doupnik <JRD@CC.USU.EDU>'
+ - 'Marion Hakanson <hakanson@cse.ogi.edu>'
+ - 'Marc Horowitz <marc@mit.edu>'
+ - 'Waldemar Kebsch <kebsch.pad@nixpbe.UUCP>'
+ - 'Lee McLoughlin <lmjm@doc.ic.ac.uk>'
+ - <A.Macpherson@bnr.co.uk>
+ - 'Dave Rolsky <autarch@urth.org>'
+ - 'Randal L. Schwartz <merlyn@stonehenge.com>'
+ - 'Aaron Sherman <asherman@fmrco.com>'
+ - 'David Sundstrom <sunds@asictest.sc.ti.com>'
+ - 'Wayne Thompson'
+ - 'Larry Wall <lwall@jpl-devvax.jpl.nasa.gov>'
+ - 'Ilya Zakharevich'
+ - 'Andrew Main (Zefram) <zefram@fysh.org>'
+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'
diff --git a/README b/README
new file mode 100644
index 0000000..ec62f94
--- /dev/null
+++ b/README
@@ -0,0 +1,61 @@
+NAME
+
+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 <tchrist@convex.com>,
+Charles Collins, Joe Doupnik <JRD@CC.USU.EDU>, Marion Hakanson
+<hakanson@cse.ogi.edu>, Waldemar Kebsch <kebsch.pad@nixpbe.UUCP>,
+Lee McLoughlin <lmjm@doc.ic.ac.uk>, <A.Macpherson@bnr.co.uk>, Randal
+L. Schwartz <merlyn@stonehenge.com>, Aaron Sherman <asherman@fmrco.com>,
+Wayne Thompson, Larry Wall <lwall@jpl-devvax.jpl.nasa.gov>, 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 <tchrist@convex.com>, Alexandr Ciornii (alexchorny at
+gmail.com), Marc Horowitz <marc@mit.edu>, Dave Rolsky <autarch@urth.org>,
+and David Sundstrom <sunds@asictest.sc.ti.com>.
+
+Andrew Main (Zefram) <zefram@fysh.org> built the Perl4::CoreLibs package.
+
+COPYRIGHT
+
+Copyright (C) 1987-2009 Larry Wall et al
+
+Copyright (C) 2010, 2011, 2017 Andrew Main (Zefram) <zefram@fysh.org>
+
+LICENSE
+
+This module is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
diff --git a/SIGNATURE b/SIGNATURE
new file mode 100644
index 0000000..040f85f
--- /dev/null
+++ b/SIGNATURE
@@ -0,0 +1,77 @@
+This 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-----
diff --git a/lib/Perl4/CoreLibs.pm b/lib/Perl4/CoreLibs.pm
new file mode 100644
index 0000000..26e1fe2
--- /dev/null
+++ b/lib/Perl4/CoreLibs.pm
@@ -0,0 +1,236 @@
+=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<Text::Abbrev>.
+
+=item assert.pl
+
+Assertion checking with stack trace upon assertion failure.
+
+=item bigfloat.pl
+
+Arbitrary precision decimal floating point arithmetic.
+Prefer L<Math::BigFloat>.
+
+=item bigint.pl
+
+Arbitrary precision integer arithmetic.
+Prefer L<Math::BigInt>.
+
+=item bigrat.pl
+
+Arbitrary precision rational arithmetic.
+Prefer L<Math::BigRat>.
+
+=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<IO::Socket::INET>.
+
+=item complete.pl
+
+Interactive line input with word completion.
+Prefer L<Term::Complete>.
+
+=item ctime.pl
+
+One form of textual representation of time.
+Prefer C<scalar(localtime())> or L<POSIX/ctime>.
+
+=item dotsh.pl
+
+Inhale shell variables set by a shell script.
+
+=item exceptions.pl
+
+String-based exception handling built on C<eval> and C<die>.
+Prefer L<Try::Tiny> or L<TryCatch>.
+
+=item fastcwd.pl
+
+Determine current directory.
+Prefer L<Cwd>.
+
+=item find.pl
+
+Historical interface for a way of searching for files.
+Prefer L<File::Find>.
+
+=item finddepth.pl
+
+Historical interface for a way of searching for files.
+Prefer L<File::Find>.
+
+=item flush.pl
+
+Flush an I/O handle's output buffer.
+Prefer L<IO::Handle/flush>.
+
+=item ftp.pl
+
+File Transfer Protocol (FTP) over IP.
+Prefer L<Net::FTP>.
+
+=item getcwd.pl
+
+Determine current directory.
+Prefer L<Cwd>.
+
+=item getopt.pl
+
+Unix-like option processing with all option taking arguments.
+Prefer L<Getopt::Std>.
+
+=item getopts.pl
+
+Full Unix-like option processing.
+Prefer L<Getopt::Std>.
+
+=item hostname.pl
+
+Determine host's hostname.
+Prefer L<Sys::Hostname>.
+
+=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<Getopt::Long>.
+
+=item open2.pl
+
+Open a subprocess for both reading and writing.
+Prefer L<IPC::Open2>.
+
+=item open3.pl
+
+Open a subprocess for reading, writing, and error handling.
+Prefer L<IPC::Open3>.
+
+=item pwd.pl
+
+Track changes of current directory in C<$ENV{PWD}>.
+
+=item shellwords.pl
+
+Interpret shell quoting.
+Prefer L<Text::ParseWords>.
+
+=item stat.pl
+
+Access fields of a L<stat|perldoc/stat> structure by name.
+Prefer L<File::stat>.
+
+=item syslog.pl
+
+Write to Unix system log.
+Prefer L<Sys::Syslog>.
+
+=item tainted.pl
+
+Determine whether data is tainted.
+Prefer L<Taint::Util>.
+
+=item termcap.pl
+
+Generate escape sequences to control arbitrary terminal.
+Prefer L<Term::Cap>.
+
+=item timelocal.pl
+
+Generate time number from broken-down time.
+Prefer L<Time::Local>.
+
+=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 <tchrist@convex.com>,
+Charles Collins, Joe Doupnik <JRD@CC.USU.EDU>, Marion Hakanson
+<hakanson@cse.ogi.edu>, Waldemar Kebsch <kebsch.pad@nixpbe.UUCP>,
+Lee McLoughlin <lmjm@doc.ic.ac.uk>, <A.Macpherson@bnr.co.uk>, Randal
+L. Schwartz <merlyn@stonehenge.com>, Aaron Sherman <asherman@fmrco.com>,
+Wayne Thompson, Larry Wall <lwall@jpl-devvax.jpl.nasa.gov>, 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 <tchrist@convex.com>, Alexandr Ciornii (alexchorny at
+gmail.com), Marc Horowitz <marc@mit.edu>, Dave Rolsky <autarch@urth.org>,
+and David Sundstrom <sunds@asictest.sc.ti.com>.
+
+Andrew Main (Zefram) <zefram@fysh.org> built the Perl4::CoreLibs package.
+
+=head1 COPYRIGHT
+
+Copyright (C) 1987-2009 Larry Wall et al
+
+Copyright (C) 2010, 2011, 2017 Andrew Main (Zefram) <zefram@fysh.org>
+
+=head1 LICENSE
+
+This module is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1;
diff --git a/lib/abbrev.pl b/lib/abbrev.pl
new file mode 100644
index 0000000..ca281ac
--- /dev/null
+++ b/lib/abbrev.pl
@@ -0,0 +1,42 @@
+;# 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;
diff --git a/lib/assert.pl b/lib/assert.pl
new file mode 100644
index 0000000..93e39ce
--- /dev/null
+++ b/lib/assert.pl
@@ -0,0 +1,55 @@
+# assert.pl
+# tchrist@convex.com (Tom Christiansen)
+#
+# Usage:
+#
+# &assert('@x > @y');
+# &assert('$var > 10', $var, $othervar, @various_info);
+#
+# That is, if the first expression evals false, we blow up. The
+# rest of the args, if any, are nice to know because they will
+# be printed out by &panic, which is just the stack-backtrace
+# routine shamelessly borrowed from the perl debugger.
+
+sub assert {
+ &panic("ASSERTION BOTCHED: $_[0]",$@) unless eval $_[0];
+}
+
+sub panic {
+ package DB;
+
+ select(STDERR);
+
+ print "\npanic: @_\n";
+
+ exit 1 if $] <= 4.003; # caller broken
+
+ # stack traceback gratefully borrowed from perl debugger
+
+ local $_;
+ my $i;
+ my ($p,$f,$l,$s,$h,$a,@a,@frames);
+ for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
+ @a = @args;
+ for (@a) {
+ if (/^StB\000/ && length($_) == length($_main{'_main'})) {
+ $_ = sprintf("%s",$_);
+ }
+ else {
+ s/'/\\'/g;
+ s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
+ s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+ s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
+ }
+ }
+ $w = $w ? '@ = ' : '$ = ';
+ $a = $h ? '(' . join(', ', @a) . ')' : '';
+ push(@frames, "$w&$s$a from file $f line $l\n");
+ }
+ for ($i=0; $i <= $#frames; $i++) {
+ print $frames[$i];
+ }
+ exit 1;
+}
+
+1;
diff --git a/lib/bigfloat.pl b/lib/bigfloat.pl
new file mode 100644
index 0000000..82eb188
--- /dev/null
+++ b/lib/bigfloat.pl
@@ -0,0 +1,254 @@
+package bigfloat;
+require "bigint.pl";
+#
+# This library is no longer being maintained, and is included for backward
+# compatibility with Perl 4 programs which may require it.
+#
+# In particular, this should not be used as an example of modern Perl
+# programming techniques.
+#
+# Suggested alternative: Math::BigFloat
+#
+# Arbitrary length float math package
+#
+# by Mark Biggar
+#
+# number format
+# canonical strings have the form /[+-]\d+E[+-]\d+/
+# Input values can have embedded whitespace
+# Error returns
+# 'NaN' An input parameter was "Not a Number" or
+# divide by zero or sqrt of negative number
+# Division is computed to
+# max($div_scale,length(dividend)+length(divisor))
+# digits by default.
+# Also used for default sqrt scale
+
+$div_scale = 40;
+
+# Rounding modes one of 'even', 'odd', '+inf', '-inf', 'zero' or 'trunc'.
+
+$rnd_mode = 'even';
+
+# bigfloat routines
+#
+# fadd(NSTR, NSTR) return NSTR addition
+# fsub(NSTR, NSTR) return NSTR subtraction
+# fmul(NSTR, NSTR) return NSTR multiplication
+# fdiv(NSTR, NSTR[,SCALE]) returns NSTR division to SCALE places
+# fneg(NSTR) return NSTR negation
+# fabs(NSTR) return NSTR absolute value
+# fcmp(NSTR,NSTR) return CODE compare undef,<0,=0,>0
+# fround(NSTR, SCALE) return NSTR round to SCALE digits
+# ffround(NSTR, SCALE) return NSTR round at SCALEth place
+# fnorm(NSTR) return (NSTR) normalize
+# fsqrt(NSTR[, SCALE]) return NSTR sqrt to SCALE places
+
+# Convert a number to canonical string form.
+# Takes something that looks like a number and converts it to
+# the form /^[+-]\d+E[+-]\d+$/.
+sub main'fnorm { #(string) return fnum_str
+ local($_) = @_;
+ s/\s+//g; # strip white space
+ if (/^([+-]?)(\d*)(\.(\d*))?([Ee]([+-]?\d+))?$/
+ && ($2 ne '' || defined($4))) {
+ my $x = defined($4) ? $4 : '';
+ &norm(($1 ? "$1$2$x" : "+$2$x"), (($x ne '') ? $6-length($x) : $6));
+ } else {
+ 'NaN';
+ }
+}
+
+# normalize number -- for internal use
+sub norm { #(mantissa, exponent) return fnum_str
+ local($_, $exp) = @_;
+ if ($_ eq 'NaN') {
+ 'NaN';
+ } else {
+ s/^([+-])0+/$1/; # strip leading zeros
+ if (length($_) == 1) {
+ '+0E+0';
+ } else {
+ $exp += length($1) if (s/(0+)$//); # strip trailing zeros
+ sprintf("%sE%+ld", $_, $exp);
+ }
+ }
+}
+
+# negation
+sub main'fneg { #(fnum_str) return fnum_str
+ local($_) = &'fnorm($_[0]);
+ vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0E+0'; # flip sign
+ if ( ord("\t") == 9 ) { # ascii
+ s/^H/N/;
+ }
+ else { # ebcdic character set
+ s/\373/N/;
+ }
+ $_;
+}
+
+# absolute value
+sub main'fabs { #(fnum_str) return fnum_str
+ local($_) = &'fnorm($_[0]);
+ s/^-/+/; # mash sign
+ $_;
+}
+
+# multiplication
+sub main'fmul { #(fnum_str, fnum_str) return fnum_str
+ local($x,$y) = (&'fnorm($_[0]),&'fnorm($_[1]));
+ if ($x eq 'NaN' || $y eq 'NaN') {
+ 'NaN';
+ } else {
+ local($xm,$xe) = split('E',$x);
+ local($ym,$ye) = split('E',$y);
+ &norm(&'bmul($xm,$ym),$xe+$ye);
+ }
+}
+
+# addition
+sub main'fadd { #(fnum_str, fnum_str) return fnum_str
+ local($x,$y) = (&'fnorm($_[0]),&'fnorm($_[1]));
+ if ($x eq 'NaN' || $y eq 'NaN') {
+ 'NaN';
+ } else {
+ local($xm,$xe) = split('E',$x);
+ local($ym,$ye) = split('E',$y);
+ ($xm,$xe,$ym,$ye) = ($ym,$ye,$xm,$xe) if ($xe < $ye);
+ &norm(&'badd($ym,$xm.('0' x ($xe-$ye))),$ye);
+ }
+}
+
+# subtraction
+sub main'fsub { #(fnum_str, fnum_str) return fnum_str
+ &'fadd($_[0],&'fneg($_[1]));
+}
+
+# division
+# args are dividend, divisor, scale (optional)
+# result has at most max(scale, length(dividend), length(divisor)) digits
+sub main'fdiv #(fnum_str, fnum_str[,scale]) return fnum_str
+{
+ local($x,$y,$scale) = (&'fnorm($_[0]),&'fnorm($_[1]),$_[2]);
+ if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0E+0') {
+ 'NaN';
+ } else {
+ local($xm,$xe) = split('E',$x);
+ local($ym,$ye) = split('E',$y);
+ $scale = $div_scale if (!$scale);
+ $scale = length($xm)-1 if (length($xm)-1 > $scale);
+ $scale = length($ym)-1 if (length($ym)-1 > $scale);
+ $scale = $scale + length($ym) - length($xm);
+ &norm(&round(&'bdiv($xm.('0' x $scale),$ym),&'babs($ym)),
+ $xe-$ye-$scale);
+ }
+}
+
+# round int $q based on fraction $r/$base using $rnd_mode
+sub round { #(int_str, int_str, int_str) return int_str
+ local($q,$r,$base) = @_;
+ if ($q eq 'NaN' || $r eq 'NaN') {
+ 'NaN';
+ } elsif ($rnd_mode eq 'trunc') {
+ $q; # just truncate
+ } else {
+ local($cmp) = &'bcmp(&'bmul($r,'+2'),$base);
+ if ( $cmp < 0 ||
+ ($cmp == 0 &&
+ ( $rnd_mode eq 'zero' ||
+ ($rnd_mode eq '-inf' && (substr($q,0,1) eq '+')) ||
+ ($rnd_mode eq '+inf' && (substr($q,0,1) eq '-')) ||
+ ($rnd_mode eq 'even' && $q =~ /[24680]$/) ||
+ ($rnd_mode eq 'odd' && $q =~ /[13579]$/) )) ) {
+ $q; # round down
+ } else {
+ &'badd($q, ((substr($q,0,1) eq '-') ? '-1' : '+1'));
+ # round up
+ }
+ }
+}
+
+# round the mantissa of $x to $scale digits
+sub main'fround { #(fnum_str, scale) return fnum_str
+ local($x,$scale) = (&'fnorm($_[0]),$_[1]);
+ if ($x eq 'NaN' || $scale <= 0) {
+ $x;
+ } else {
+ local($xm,$xe) = split('E',$x);
+ if (length($xm)-1 <= $scale) {
+ $x;
+ } else {
+ &norm(&round(substr($xm,0,$scale+1),
+ "+0".substr($xm,$scale+1,1),"+10"),
+ $xe+length($xm)-$scale-1);
+ }
+ }
+}
+
+# round $x at the 10 to the $scale digit place
+sub main'ffround { #(fnum_str, scale) return fnum_str
+ local($x,$scale) = (&'fnorm($_[0]),$_[1]);
+ if ($x eq 'NaN') {
+ 'NaN';
+ } else {
+ local($xm,$xe) = split('E',$x);
+ if ($xe >= $scale) {
+ $x;
+ } else {
+ $xe = length($xm)+$xe-$scale;
+ if ($xe < 1) {
+ '+0E+0';
+ } elsif ($xe == 1) {
+ # The first substr preserves the sign, which means that
+ # we'll pass a non-normalized "-0" to &round when rounding
+ # -0.006 (for example), purely so that &round won't lose
+ # the sign.
+ &norm(&round(substr($xm,0,1).'0',
+ "+0".substr($xm,1,1),"+10"), $scale);
+ } else {
+ &norm(&round(substr($xm,0,$xe),
+ "+0".substr($xm,$xe,1),"+10"), $scale);
+ }
+ }
+ }
+}
+
+# compare 2 values returns one of undef, <0, =0, >0
+# returns undef if either or both input value are not numbers
+sub main'fcmp #(fnum_str, fnum_str) return cond_code
+{
+ local($x, $y) = (&'fnorm($_[0]),&'fnorm($_[1]));
+ if ($x eq "NaN" || $y eq "NaN") {
+ undef;
+ } else {
+ ord($y) <=> ord($x)
+ ||
+ ( local($xm,$xe,$ym,$ye) = split('E', $x."E$y"),
+ (($xe <=> $ye) * (substr($x,0,1).'1')
+ || &bigint'cmp($xm,$ym))
+ );
+ }
+}
+
+# square root by Newtons method.
+sub main'fsqrt { #(fnum_str[, scale]) return fnum_str
+ local($x, $scale) = (&'fnorm($_[0]), $_[1]);
+ if ($x eq 'NaN' || $x =~ /^-/) {
+ 'NaN';
+ } elsif ($x eq '+0E+0') {
+ '+0E+0';
+ } else {
+ local($xm, $xe) = split('E',$x);
+ $scale = $div_scale if (!$scale);
+ $scale = length($xm)-1 if ($scale < length($xm)-1);
+ local($gs, $guess) = (1, sprintf("1E%+d", (length($xm)+$xe-1)/2));
+ while ($gs < 2*$scale) {
+ $guess = &'fmul(&'fadd($guess,&'fdiv($x,$guess,$gs*2)),".5");
+ $gs *= 2;
+ }
+ &'fround($guess, $scale);
+ }
+}
+
+1;
diff --git a/lib/bigint.pl b/lib/bigint.pl
new file mode 100644
index 0000000..56727d5
--- /dev/null
+++ b/lib/bigint.pl
@@ -0,0 +1,320 @@
+package bigint;
+#
+# This library is no longer being maintained, and is included for backward
+# compatibility with Perl 4 programs which may require it.
+#
+# In particular, this should not be used as an example of modern Perl
+# programming techniques.
+#
+# 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;
diff --git a/lib/bigrat.pl b/lib/bigrat.pl
new file mode 100644
index 0000000..eb54794
--- /dev/null
+++ b/lib/bigrat.pl
@@ -0,0 +1,155 @@
+package bigrat;
+require "bigint.pl";
+#
+# This library is no longer being maintained, and is included for backward
+# compatibility with Perl 4 programs which may require it.
+#
+# 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;
diff --git a/lib/cacheout.pl b/lib/cacheout.pl
new file mode 100644
index 0000000..d2669a1
--- /dev/null
+++ b/lib/cacheout.pl
@@ -0,0 +1,55 @@
+#
+# 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 (<PARAM>) {
+ $maxopen = $1 - 4 if /^\s*#\s*define\s+NOFILE\s+(\d+)/;
+ }
+ close PARAM;
+}
+$maxopen = 16 unless $maxopen;
+
+1;
diff --git a/lib/chat2.pl b/lib/chat2.pl
new file mode 100644
index 0000000..504fa7e
--- /dev/null
+++ b/lib/chat2.pl
@@ -0,0 +1,379 @@
+# 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 <merlyn@stonehenge.com>)
+# multihome additions by A.Macpherson@bnr.co.uk
+# allow for /dev/pts based systems by Joe Doupnik <JRD@CC.USU.EDU>
+
+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;
diff --git a/lib/complete.pl b/lib/complete.pl
new file mode 100644
index 0000000..925ce86
--- /dev/null
+++ b/lib/complete.pl
@@ -0,0 +1,120 @@
+;#
+#
+# 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;
diff --git a/lib/ctime.pl b/lib/ctime.pl
new file mode 100644
index 0000000..c56ac48
--- /dev/null
+++ b/lib/ctime.pl
@@ -0,0 +1,58 @@
+;# 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 <ctime.pl> # see the -P and -I option in perl.man
+;# $Date = &ctime(time);
+
+CONFIG: {
+ package ctime;
+
+ @DoW = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat');
+ @MoY = ('Jan','Feb','Mar','Apr','May','Jun',
+ 'Jul','Aug','Sep','Oct','Nov','Dec');
+}
+
+sub ctime {
+ package ctime;
+
+ local($time) = @_;
+ local($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst);
+
+ # Determine what time zone is in effect.
+ # Use GMT if TZ is defined as null, local time if TZ undefined.
+ # There's no portable way to find the system default timezone.
+
+ $TZ = defined($ENV{'TZ'}) ? ( $ENV{'TZ'} ? $ENV{'TZ'} : 'GMT' ) : '';
+ ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) =
+ ($TZ eq 'GMT') ? gmtime($time) : localtime($time);
+
+ # Hack to deal with 'PST8PDT' format of TZ
+ # Note that this can't deal with all the esoteric forms, but it
+ # does recognize the most common: [:]STDoff[DST[off][,rule]]
+
+ if($TZ=~/^([^:\d+\-,]{3,})([+-]?\d{1,2}(:\d{1,2}){0,2})([^\d+\-,]{3,})?/){
+ $TZ = $isdst ? $4 : $1;
+ }
+ $TZ .= ' ' unless $TZ eq '';
+
+ $year += 1900;
+ sprintf("%s %s %2d %2d:%02d:%02d %s%4d\n",
+ $DoW[$wday], $MoY[$mon], $mday, $hour, $min, $sec, $TZ, $year);
+}
+1;
diff --git a/lib/dotsh.pl b/lib/dotsh.pl
new file mode 100644
index 0000000..810ebc4
--- /dev/null
+++ b/lib/dotsh.pl
@@ -0,0 +1,74 @@
+#
+# @(#)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;
diff --git a/lib/exceptions.pl b/lib/exceptions.pl
new file mode 100644
index 0000000..ed1f927
--- /dev/null
+++ b/lib/exceptions.pl
@@ -0,0 +1,61 @@
+# 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;
diff --git a/lib/fastcwd.pl b/lib/fastcwd.pl
new file mode 100644
index 0000000..ecd87c8
--- /dev/null
+++ b/lib/fastcwd.pl
@@ -0,0 +1,43 @@
+# 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;
diff --git a/lib/find.pl b/lib/find.pl
new file mode 100644
index 0000000..ee5dc5d
--- /dev/null
+++ b/lib/find.pl
@@ -0,0 +1,47 @@
+# 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;
diff --git a/lib/finddepth.pl b/lib/finddepth.pl
new file mode 100644
index 0000000..bfa44bb
--- /dev/null
+++ b/lib/finddepth.pl
@@ -0,0 +1,46 @@
+# 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;
diff --git a/lib/flush.pl b/lib/flush.pl
new file mode 100644
index 0000000..8aa6d55
--- /dev/null
+++ b/lib/flush.pl
@@ -0,0 +1,32 @@
+#
+# 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;
diff --git a/lib/ftp.pl b/lib/ftp.pl
new file mode 100644
index 0000000..3f0af1a
--- /dev/null
+++ b/lib/ftp.pl
@@ -0,0 +1,1086 @@
+#-*-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 <lmjm@doc.ic.ac.uk>
+# based on original version by Alan R. Martello <al@ee.pitt.edu>
+# 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 <err@cinops.xerox.com>
+# Added ftp'delete from Aaron Wohl <aw0g+@andrew.cmu.edu>
+#
+# 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 (<NS>) {
+# 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 (<FH>) {
+ 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 <somestring>";
+ }
+ 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;
diff --git a/lib/getcwd.pl b/lib/getcwd.pl
new file mode 100644
index 0000000..3cac4d9
--- /dev/null
+++ b/lib/getcwd.pl
@@ -0,0 +1,71 @@
+# 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;
diff --git a/lib/getopt.pl b/lib/getopt.pl
new file mode 100644
index 0000000..771db38
--- /dev/null
+++ b/lib/getopt.pl
@@ -0,0 +1,48 @@
+;# $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;
diff --git a/lib/getopts.pl b/lib/getopts.pl
new file mode 100644
index 0000000..5b18fe0
--- /dev/null
+++ b/lib/getopts.pl
@@ -0,0 +1,65 @@
+;# getopts.pl - a better getopt.pl
+#
+# This library is no longer being maintained, and is included for backward
+# compatibility with Perl 4 programs which may require it.
+#
+# In particular, this should not be used as an example of modern Perl
+# programming techniques.
+#
+# Suggested alternatives: Getopt::Long or Getopt::Std
+#
+;# Usage:
+;# do Getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a
+;# # side effect.
+
+sub Getopts {
+ local($argumentative) = @_;
+ local(@args,$_,$first,$rest);
+ local($errs) = 0;
+
+ @args = split( / */, $argumentative );
+ while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
+ ($first,$rest) = ($1,$2);
+ $pos = index($argumentative,$first);
+ if($pos >= 0) {
+ if($args[$pos+1] eq ':') {
+ shift(@ARGV);
+ if($rest eq '') {
+ ++$errs unless(@ARGV);
+ $rest = shift(@ARGV);
+ }
+ eval "
+ push(\@opt_$first, \$rest);
+ if (!defined \$opt_$first or \$opt_$first eq '') {
+ \$opt_$first = \$rest;
+ }
+ else {
+ \$opt_$first .= ' ' . \$rest;
+ }
+ ";
+ }
+ else {
+ eval "\$opt_$first = 1";
+ if($rest eq '') {
+ shift(@ARGV);
+ }
+ else {
+ $ARGV[0] = "-$rest";
+ }
+ }
+ }
+ else {
+ print STDERR "Unknown option: $first\n";
+ ++$errs;
+ if($rest ne '') {
+ $ARGV[0] = "-$rest";
+ }
+ else {
+ shift(@ARGV);
+ }
+ }
+ }
+ $errs == 0;
+}
+
+1;
diff --git a/lib/hostname.pl b/lib/hostname.pl
new file mode 100644
index 0000000..63eea8f
--- /dev/null
+++ b/lib/hostname.pl
@@ -0,0 +1,31 @@
+# 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 = <P>) && close(P))
+ {
+ chop($hostname = $tmp[$#tmp]);
+ }
+ elsif (open(P,"uname -n 2>&1 |") && (@tmp = <P>) && close(P))
+ {
+ chop($hostname = $tmp[$#tmp]);
+ }
+ else
+ {
+ die "$0: Cannot get hostname from 'hostname' or 'uname -n'\n";
+ }
+ @tmp = ();
+ close P; # Just in case we failed in an odd spot....
+ $hostname;
+}
+
+1;
diff --git a/lib/importenv.pl b/lib/importenv.pl
new file mode 100644
index 0000000..0401127
--- /dev/null
+++ b/lib/importenv.pl
@@ -0,0 +1,14 @@
+;# This file, when interpreted, pulls the environment into normal variables.
+;# Usage:
+;# require 'importenv.pl';
+;# or
+;# #include <importenv.pl>
+
+local($tmp,$key) = '';
+
+foreach $key (keys(%ENV)) {
+ $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/;
+}
+eval $tmp;
+
+1;
diff --git a/lib/look.pl b/lib/look.pl
new file mode 100644
index 0000000..ccc9b61
--- /dev/null
+++ b/lib/look.pl
@@ -0,0 +1,50 @@
+;# 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);
+ $_ = <FH> if $mid; # probably a partial line
+ $_ = <FH>;
+ chop;
+ s/[^\w\s]//g if $dict;
+ $_ = lc $_ if $fold;
+ if ($_ lt $key) {
+ $min = $mid;
+ }
+ else {
+ $max = $mid;
+ }
+ }
+ $min *= $blksize;
+ seek(FH,$min,0);
+ <FH> if $min;
+ while (<FH>) {
+ chop;
+ s/[^\w\s]//g if $dict;
+ $_ = lc $_ if $fold;
+ last if $_ ge $key;
+ $min = tell(FH);
+ }
+ seek(FH,$min,0);
+ $min;
+}
+
+1;
diff --git a/lib/newgetopt.pl b/lib/newgetopt.pl
new file mode 100644
index 0000000..1de6a6e
--- /dev/null
+++ b/lib/newgetopt.pl
@@ -0,0 +1,75 @@
+# $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 ################
diff --git a/lib/open2.pl b/lib/open2.pl
new file mode 100644
index 0000000..8cf08c2
--- /dev/null
+++ b/lib/open2.pl
@@ -0,0 +1,12 @@
+# This is a compatibility interface to IPC::Open2. New programs should
+# do
+#
+# use IPC::Open2;
+#
+# instead of
+#
+# require 'open2.pl';
+
+package main;
+use IPC::Open2 'open2';
+1
diff --git a/lib/open3.pl b/lib/open3.pl
new file mode 100644
index 0000000..7fcc931
--- /dev/null
+++ b/lib/open3.pl
@@ -0,0 +1,12 @@
+# This is a compatibility interface to IPC::Open3. New programs should
+# do
+#
+# use IPC::Open3;
+#
+# instead of
+#
+# require 'open3.pl';
+
+package main;
+use IPC::Open3 'open3';
+1
diff --git a/lib/pwd.pl b/lib/pwd.pl
new file mode 100644
index 0000000..6b429eb
--- /dev/null
+++ b/lib/pwd.pl
@@ -0,0 +1,67 @@
+;# 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;
diff --git a/lib/shellwords.pl b/lib/shellwords.pl
new file mode 100644
index 0000000..86365e1
--- /dev/null
+++ b/lib/shellwords.pl
@@ -0,0 +1,14 @@
+;# 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;
diff --git a/lib/stat.pl b/lib/stat.pl
new file mode 100644
index 0000000..5faa541
--- /dev/null
+++ b/lib/stat.pl
@@ -0,0 +1,29 @@
+;# Usage:
+;# require 'stat.pl';
+;# @ary = stat(foo);
+;# $st_dev = @ary[$ST_DEV];
+;#
+$ST_DEV = 0;
+$ST_INO = 1;
+$ST_MODE = 2;
+$ST_NLINK = 3;
+$ST_UID = 4;
+$ST_GID = 5;
+$ST_RDEV = 6;
+$ST_SIZE = 7;
+$ST_ATIME = 8;
+$ST_MTIME = 9;
+$ST_CTIME = 10;
+$ST_BLKSIZE = 11;
+$ST_BLOCKS = 12;
+
+;# Usage:
+;# require 'stat.pl';
+;# do Stat('foo'); # sets st_* as a side effect
+;#
+sub Stat {
+ ($st_dev,$st_ino,$st_mode,$st_nlink,$st_uid,$st_gid,$st_rdev,$st_size,
+ $st_atime,$st_mtime,$st_ctime,$st_blksize,$st_blocks) = stat(shift(@_));
+}
+
+1;
diff --git a/lib/syslog.pl b/lib/syslog.pl
new file mode 100644
index 0000000..f0dbb1c
--- /dev/null
+++ b/lib/syslog.pl
@@ -0,0 +1,199 @@
+#
+# syslog.pl
+#
+# $Log: syslog.pl,v $
+#
+# tom christiansen <tchrist@convex.com>
+# modified to use sockets by Larry Wall <lwall@jpl-devvax.jpl.nasa.gov>
+# NOTE: openlog now takes three arguments, just like openlog(3)
+#
+# call syslog() with a string priority and a list of printf() args
+# like syslog(3)
+#
+# usage: require 'syslog.pl';
+#
+# then (put these all in a script to test function)
+#
+#
+# do openlog($program,'cons,pid','user');
+# do syslog('info','this is another test');
+# do syslog('mail|warning','this is a better test: %d', time);
+# do closelog();
+#
+# do syslog('debug','this is the last test');
+# do openlog("$program $$",'ndelay','user');
+# do syslog('notice','fooprogram: this is really done');
+#
+# $! = 55;
+# do syslog('info','problem was %m'); # %m == $! in syslog(3)
+
+package syslog;
+
+use warnings::register;
+
+$host = 'localhost' unless $host; # set $syslog'host to change
+
+if ($] >= 5 && warnings::enabled()) {
+ warnings::warn("You should 'use Sys::Syslog' instead; continuing");
+}
+
+require 'syslog.ph';
+
+ eval 'use Socket; 1' ||
+ eval { require "socket.ph" } ||
+ require "sys/socket.ph";
+
+$maskpri = &LOG_UPTO(&LOG_DEBUG);
+
+sub main'openlog {
+ ($ident, $logopt, $facility) = @_; # package vars
+ $lo_pid = $logopt =~ /\bpid\b/;
+ $lo_ndelay = $logopt =~ /\bndelay\b/;
+ $lo_cons = $logopt =~ /\bcons\b/;
+ $lo_nowait = $logopt =~ /\bnowait\b/;
+ &connect if $lo_ndelay;
+}
+
+sub main'closelog {
+ $facility = $ident = '';
+ &disconnect;
+}
+
+sub main'setlogmask {
+ local($oldmask) = $maskpri;
+ $maskpri = shift;
+ $oldmask;
+}
+
+sub main'syslog {
+ local($priority) = shift;
+ local($mask) = shift;
+ local($message, $whoami);
+ local(@words, $num, $numpri, $numfac, $sum);
+ local($facility) = $facility; # may need to change temporarily.
+
+ die "syslog: expected both priority and mask" unless $mask && $priority;
+
+ @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility".
+ undef $numpri;
+ undef $numfac;
+ foreach (@words) {
+ $num = &xlate($_); # Translate word to number.
+ if (/^kern$/ || $num < 0) {
+ die "syslog: invalid level/facility: $_\n";
+ }
+ elsif ($num <= &LOG_PRIMASK) {
+ die "syslog: too many levels given: $_\n" if defined($numpri);
+ $numpri = $num;
+ return 0 unless &LOG_MASK($numpri) & $maskpri;
+ }
+ else {
+ die "syslog: too many facilities given: $_\n" if defined($numfac);
+ $facility = $_;
+ $numfac = $num;
+ }
+ }
+
+ die "syslog: level must be given\n" unless defined($numpri);
+
+ if (!defined($numfac)) { # Facility not specified in this call.
+ $facility = 'user' unless $facility;
+ $numfac = &xlate($facility);
+ }
+
+ &connect unless $connected;
+
+ $whoami = $ident;
+
+ if (!$ident && $mask =~ /^(\S.*):\s?(.*)/) {
+ $whoami = $1;
+ $mask = $2;
+ }
+
+ unless ($whoami) {
+ ($whoami = getlogin) ||
+ ($whoami = getpwuid($<)) ||
+ ($whoami = 'syslog');
+ }
+
+ $whoami .= "[$$]" if $lo_pid;
+
+ $mask =~ s/%m/$!/g;
+ $mask .= "\n" unless $mask =~ /\n$/;
+ $message = sprintf ($mask, @_);
+
+ $sum = $numpri + $numfac;
+ unless (send(SYSLOG,"<$sum>$whoami: $message",0)) {
+ if ($lo_cons) {
+ if ($pid = fork) {
+ unless ($lo_nowait) {
+ do {$died = wait;} until $died == $pid || $died < 0;
+ }
+ }
+ else {
+ open(CONS,">/dev/console");
+ print CONS "<$facility.$priority>$whoami: $message\r";
+ exit if defined $pid; # if fork failed, we're parent
+ close CONS;
+ }
+ }
+ }
+}
+
+sub xlate {
+ local($name) = @_;
+ $name = uc $name;
+ $name = "LOG_$name" unless $name =~ /^LOG_/;
+ $name = "syslog'$name";
+ defined &$name ? &$name : -1;
+}
+
+sub connect {
+ $pat = 'S n C4 x8';
+
+ $af_unix = &AF_UNIX;
+ $af_inet = &AF_INET;
+
+ $stream = &SOCK_STREAM;
+ $datagram = &SOCK_DGRAM;
+
+ ($name,$aliases,$proto) = getprotobyname('udp');
+ $udp = $proto;
+
+ ($name,$aliases,$port,$proto) = getservbyname('syslog','udp');
+ $syslog = $port;
+
+ if (chop($myname = `hostname`)) {
+ ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($myname);
+ die "Can't lookup $myname\n" unless $name;
+ @bytes = unpack("C4",$addrs[0]);
+ }
+ else {
+ @bytes = (0,0,0,0);
+ }
+ $this = pack($pat, $af_inet, 0, @bytes);
+
+ if ($host =~ /^\d+\./) {
+ @bytes = split(/\./,$host);
+ }
+ else {
+ ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($host);
+ die "Can't lookup $host\n" unless $name;
+ @bytes = unpack("C4",$addrs[0]);
+ }
+ $that = pack($pat,$af_inet,$syslog,@bytes);
+
+ socket(SYSLOG,$af_inet,$datagram,$udp) || die "socket: $!\n";
+ bind(SYSLOG,$this) || die "bind: $!\n";
+ connect(SYSLOG,$that) || die "connect: $!\n";
+
+ local($old) = select(SYSLOG); $| = 1; select($old);
+ $connected = 1;
+}
+
+sub disconnect {
+ close SYSLOG;
+ $connected = 0;
+}
+
+1;
diff --git a/lib/tainted.pl b/lib/tainted.pl
new file mode 100644
index 0000000..6e24867
--- /dev/null
+++ b/lib/tainted.pl
@@ -0,0 +1,9 @@
+# This subroutine returns true if its argument is tainted, false otherwise.
+
+sub tainted {
+ local($@);
+ eval { kill 0 * $_[0] };
+ $@ =~ /^Insecure/;
+}
+
+1;
diff --git a/lib/termcap.pl b/lib/termcap.pl
new file mode 100644
index 0000000..676d973
--- /dev/null
+++ b/lib/termcap.pl
@@ -0,0 +1,178 @@
+;# $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 (<TERMCAP>) {
+ next if /^#/;
+ next if /^\t/;
+ if (/(^|\\|)${TERM}[:\\|]/) {
+ chop;
+ while (chop eq '\\\\') {
+ \$_ .= <TERMCAP>;
+ chop;
+ }
+ \$_ .= ':';
+ last;
+ }
+ }
+ close TERMCAP;
+ \$entry .= \$_;
+ ";
+ eval $loop;
+ } while s/:tc=([^:]+):/:/ && ($TERM = $1);
+ $TERMCAP = $entry;
+ }
+
+ foreach $field (split(/:[\s:\\]*/,$TERMCAP)) {
+ if ($field =~ /^\w\w$/) {
+ $TC{$field} = 1;
+ }
+ elsif ($field =~ /^(\w\w)#(.*)/) {
+ $TC{$1} = $2 if $TC{$1} eq '';
+ }
+ elsif ($field =~ /^(\w\w)=(.*)/) {
+ $entry = $1;
+ $_ = $2;
+ s/\\E/\033/g;
+ s/\\(200)/pack('c',0)/eg; # NUL character
+ s/\\(0\d\d)/pack('c',oct($1))/eg; # octal
+ s/\\(0x[0-9A-Fa-f][0-9A-Fa-f])/pack('c',hex($1))/eg; # hex
+ s/\\(\d\d\d)/pack('c',$1 & 0177)/eg;
+ s/\\n/\n/g;
+ s/\\r/\r/g;
+ s/\\t/\t/g;
+ s/\\b/\b/g;
+ s/\\f/\f/g;
+ s/\\\^/\377/g;
+ s/\^\?/\177/g;
+ s/\^(.)/pack('c',ord($1) & 31)/eg;
+ s/\\(.)/$1/g;
+ s/\377/^/g;
+ $TC{$entry} = $_ if $TC{$entry} eq '';
+ }
+ }
+ $TC{'pc'} = "\0" if $TC{'pc'} eq '';
+ $TC{'bc'} = "\b" if $TC{'bc'} eq '';
+}
+
+@Tputs = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2);
+
+sub Tputs {
+ local($string,$affcnt,$FH) = @_;
+ local($ms);
+ if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
+ $ms = $1;
+ $ms *= $affcnt if $2;
+ $string = $3;
+ $decr = $Tputs[$ospeed];
+ if ($decr > .1) {
+ $ms += $decr / 2;
+ $string .= $TC{'pc'} x ($ms / $decr);
+ }
+ }
+ print $FH $string if $FH;
+ $string;
+}
+
+sub Tgoto {
+ local($string) = shift(@_);
+ local($result) = '';
+ local($after) = '';
+ local($code,$tmp) = @_;
+ local(@tmp);
+ @tmp = ($tmp,$code);
+ local($online) = 0;
+ while ($string =~ /^([^%]*)%(.)(.*)/) {
+ $result .= $1;
+ $code = $2;
+ $string = $3;
+ if ($code eq 'd') {
+ $result .= sprintf("%d",shift(@tmp));
+ }
+ elsif ($code eq '.') {
+ $tmp = shift(@tmp);
+ if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
+ if ($online) {
+ ++$tmp, $after .= $TC{'up'} if $TC{'up'};
+ }
+ else {
+ ++$tmp, $after .= $TC{'bc'};
+ }
+ }
+ $result .= sprintf("%c",$tmp);
+ $online = !$online;
+ }
+ elsif ($code eq '+') {
+ $result .= sprintf("%c",shift(@tmp)+ord($string));
+ $string = substr($string,1,99);
+ $online = !$online;
+ }
+ elsif ($code eq 'r') {
+ ($code,$tmp) = @tmp;
+ @tmp = ($tmp,$code);
+ $online = !$online;
+ }
+ elsif ($code eq '>') {
+ ($code,$tmp,$string) = unpack("CCa99",$string);
+ if ($tmp[0] > $code) {
+ $tmp[0] += $tmp;
+ }
+ }
+ elsif ($code eq '2') {
+ $result .= sprintf("%02d",shift(@tmp));
+ $online = !$online;
+ }
+ elsif ($code eq '3') {
+ $result .= sprintf("%03d",shift(@tmp));
+ $online = !$online;
+ }
+ elsif ($code eq 'i') {
+ ($code,$tmp) = @tmp;
+ @tmp = ($code+1,$tmp+1);
+ }
+ else {
+ return "OOPS";
+ }
+ }
+ $result . $string . $after;
+}
+
+1;
diff --git a/lib/timelocal.pl b/lib/timelocal.pl
new file mode 100644
index 0000000..ad32275
--- /dev/null
+++ b/lib/timelocal.pl
@@ -0,0 +1,18 @@
+;# 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<require 'timelocal.pl';> was executed in a program.
+
+use Time::Local;
+
+*timelocal::cheat = \&Time::Local::cheat;
diff --git a/lib/validate.pl b/lib/validate.pl
new file mode 100644
index 0000000..c655872
--- /dev/null
+++ b/lib/validate.pl
@@ -0,0 +1,102 @@
+;# 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;
diff --git a/t/abbrev.t b/t/abbrev.t
new file mode 100644
index 0000000..d98019a
--- /dev/null
+++ b/t/abbrev.t
@@ -0,0 +1,35 @@
+use 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;
diff --git a/t/bigfloat.t b/t/bigfloat.t
new file mode 100644
index 0000000..54b25c0
--- /dev/null
+++ b/t/bigfloat.t
@@ -0,0 +1,408 @@
+use warnings;
+use strict;
+
+use Test::More tests => 356;
+
+$^W = 0;
+require_ok "bigfloat.pl";
+
+my $f;
+while (<DATA>) {
+ 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
diff --git a/t/bigint.t b/t/bigint.t
new file mode 100644
index 0000000..49da029
--- /dev/null
+++ b/t/bigint.t
@@ -0,0 +1,282 @@
+use warnings;
+use strict;
+
+use Test::More tests => 247;
+
+$^W = 0;
+require_ok "bigint.pl";
+
+my $f;
+while (<DATA>) {
+ 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
diff --git a/t/getopt.t b/t/getopt.t
new file mode 100644
index 0000000..edf6222
--- /dev/null
+++ b/t/getopt.t
@@ -0,0 +1,31 @@
+use 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;
diff --git a/t/getopts.t b/t/getopts.t
new file mode 100644
index 0000000..7be445e
--- /dev/null
+++ b/t/getopts.t
@@ -0,0 +1,42 @@
+use 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;
diff --git a/t/hostname.t b/t/hostname.t
new file mode 100644
index 0000000..c868452
--- /dev/null
+++ b/t/hostname.t
@@ -0,0 +1,15 @@
+use 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;
diff --git a/t/newgetopt.t b/t/newgetopt.t
new file mode 100644
index 0000000..a15eaff
--- /dev/null
+++ b/t/newgetopt.t
@@ -0,0 +1,30 @@
+use 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;
diff --git a/t/open2.t b/t/open2.t
new file mode 100644
index 0000000..96e23ea
--- /dev/null
+++ b/t/open2.t
@@ -0,0 +1,51 @@
+use 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 <STDIN>'));
+ok $pid;
+ok print(WRITE "hi kid\n");
+like scalar(<READ>), qr/\Ahi kid\r?\n\z/;
+ok close(WRITE);
+ok close(READ);
+$reaped_pid = waitpid $pid, 0;
+is $reaped_pid, $pid;
+is $?, 0;
+
+1;
diff --git a/t/open3.t b/t/open3.t
new file mode 100644
index 0000000..9fd2d0d
--- /dev/null
+++ b/t/open3.t
@@ -0,0 +1,168 @@
+use 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 <STDIN>;
+ print STDERR "hi error\n";
+EOF
+ok $pid;
+print WRITE "hi kid\n";
+like scalar(<READ>), qr/\Ahi kid\r?\n\z/;
+like scalar(<ERROR>), 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 <STDIN>;
+ print STDERR scalar <STDIN>;
+EOF
+print WRITE "wibble\n";
+like scalar(<READ>), qr/\Awibble\r?\n\z/;
+print WRITE "wobble\n";
+like scalar(<READ>), 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 <STDIN>;
+ print STDERR scalar <STDIN>;
+EOF
+print WRITE "wibble\n";
+like scalar(<READ>), qr/\Awibble\r?\n\z/;
+print WRITE "wobble\n";
+like scalar(<READ>), 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 <STDIN>');
+close PIPE_READ;
+print PIPE_WRITE "wibble\n";
+close PIPE_WRITE;
+like scalar(<READ>), 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 <STDIN>'));
+ print WRITE "wibble\n";
+ waitpid $pid, 0;
+EOF
+like scalar(<READ>), 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 <STDIN>'));
+ print WRITE "wibble\n";
+ waitpid $pid, 0;
+EOF
+like scalar(<READ>), 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 <STDIN>; print STDERR scalar <STDIN>'));
+ print WRITE "wibble\n";
+ print WRITE "wobble\n";
+ waitpid $pid, 0;
+EOF
+like scalar(<READ>), qr/\Awibble\r?\n\z/;
+like scalar(<READ>), 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 <STDIN>; print STDERR scalar <STDIN>'));
+ print WRITE "wibble\n";
+ print WRITE "wobble\n";
+ waitpid $pid, 0;
+EOF
+like scalar(<READ>), qr/\Awibble\r?\n\z/;
+like scalar(<READ>), 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(<STDIN>))';
+$cmd = $Config{'sh'} =~ /sh/ ? "'$cmd'" : cmd_line($cmd);
+eval{$pid = &open3('WRITE', 'READ', 'ERROR', "$^X -e " . $cmd); };
+is $@, "";
+print WRITE "wibble\n";
+like scalar(<READ>), qr/\Awibble\r?\n\z/;
+waitpid $pid, 0;
+
+1;
diff --git a/t/pod_cvg.t b/t/pod_cvg.t
new file mode 100644
index 0000000..64f6c48
--- /dev/null
+++ b/t/pod_cvg.t
@@ -0,0 +1,9 @@
+use 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;
diff --git a/t/pod_syn.t b/t/pod_syn.t
new file mode 100644
index 0000000..6f004ac
--- /dev/null
+++ b/t/pod_syn.t
@@ -0,0 +1,8 @@
+use 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;
diff --git a/t/shellwords.t b/t/shellwords.t
new file mode 100644
index 0000000..e0c9dbe
--- /dev/null
+++ b/t/shellwords.t
@@ -0,0 +1,44 @@
+use 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;
diff --git a/t/timelocal.t b/t/timelocal.t
new file mode 100644
index 0000000..6a99dfb
--- /dev/null
+++ b/t/timelocal.t
@@ -0,0 +1,110 @@
+use 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;
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-02 15:02:01 +0000