This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[inseparable changes from patch from perl5.003_12 to perl5.003_13]
authorPerl 5 Porters <perl5-porters@africa.nicoh.com>
Thu, 19 Dec 1996 23:14:00 +0000 (11:14 +1200)
committerChip Salzenberg <chip@atlantic.net>
Thu, 19 Dec 1996 23:14:00 +0000 (11:14 +1200)
 DOCUMENTATION

Subject: small doc tweaks for _12
Date: Thu, 19 Dec 1996 11:05:57 -0500
From: Roderick Schertler <roderick@gate.net>
Files: lib/UNIVERSAL.pm pod/perldiag.pod pod/perltie.pod
Msg-ID: <1826.851011557@eeyore.ibcinc.com>

    (applied based on p5p patch as commit 3314ffc68a11690bd9977cbdd7ea0601ad6ced13)

 PORTABILITY

Subject: Add missing backslash in Configure
From: Chip Salzenberg <chip@atlantic.net>
Files: Configure

 UTILITIES, LIBRARY, AND EXTENSIONS

Subject: Include libnet-1.01 instead of old Net::FTP
From: Graham Barr <Graham.Barr@tiuk.ti.com>
Files: MANIFEST lib/Net/Cmd.pm lib/Net/Domain.pm lib/Net/DummyInetd.pm lib/Net/FTP.pm lib/Net/NNTP.pm lib/Net/Netrc.pm lib/Net/POP3.pm lib/Net/SMTP.pm lib/Net/SNPP.pm lib/Net/Socket.pm lib/Net/Telnet.pm lib/Net/Time.pm pod/perlmod.pod

Subject: Use binmode when doing binary FTP
From: Ilya Zakharevich <ilya@math.ohio-state.edu>
Files: lib/Net/FTP.pm

Subject: Re: Open3.pm tries to close unopened file handle
Date: 18 Dec 1996 22:19:54 -0500
From: Roderick Schertler <roderick@gate.net>
Files: MANIFEST lib/IPC/Open2.pm lib/IPC/Open3.pm lib/open2.pl lib/open3.pl pod/perldiag.pod pod/perlfunc.pod t/lib/open2.t t/lib/open3.t
Msg-ID: <pzloavmd9h.fsf@eeyore.ibcinc.com>

    (applied based on p5p patch as commit 982b4e8fc47473059e209787b589853f4c8f8f9e)

Subject: Long-standing problem in Socket module
Date: Wed, 18 Dec 1996 23:18:14 -0500
From: Spider Boardman <spider@orb.nashua.nh.us>
Files: Configure Porting/Glossary config_H config_h.SH ext/Socket/Socket.pm ext/Socket/Socket.xs
Msg-ID: <199612190418.XAA07291@Orb.Nashua.NH.US>

    (applied based on p5p patch as commit 3e6a22d2723daf415793f9a4fc1b57f4d8a576fd)

Subject: flock() constants
Date: Thu, 19 Dec 1996 01:37:17 -0500
From: Roderick Schertler <roderick@gate.net>
Files: ext/Fcntl/Fcntl.pm ext/Fcntl/Fcntl.xs pod/perlfunc.pod
Msg-ID: <26669.850977437@eeyore.ibcinc.com>

    (applied based on p5p patch as commit 3dea0e15e4684f6defe2f25a16bc696b96697ac2)

34 files changed:
Changes
Configure
MANIFEST
Porting/Glossary
config_H
config_h.SH
ext/Fcntl/Fcntl.pm
ext/Fcntl/Fcntl.xs
ext/IO/lib/IO/Pipe.pm
ext/Socket/Socket.pm
ext/Socket/Socket.xs
lib/IPC/Open2.pm
lib/IPC/Open3.pm
lib/Net/Cmd.pm [new file with mode: 0644]
lib/Net/Domain.pm [new file with mode: 0644]
lib/Net/DummyInetd.pm [new file with mode: 0644]
lib/Net/FTP.pm
lib/Net/NNTP.pm [new file with mode: 0644]
lib/Net/Netrc.pm
lib/Net/POP3.pm [new file with mode: 0644]
lib/Net/SMTP.pm [new file with mode: 0644]
lib/Net/SNPP.pm [new file with mode: 0644]
lib/Net/Telnet.pm [new file with mode: 0644]
lib/Net/Time.pm [new file with mode: 0644]
lib/UNIVERSAL.pm
lib/open2.pl
lib/open3.pl
patchlevel.h
pod/perldiag.pod
pod/perlfunc.pod
pod/perlmod.pod
pod/perltie.pod
t/lib/open2.t
t/lib/open3.t

diff --git a/Changes b/Changes
index dff8dff..26c4ad8 100644 (file)
--- a/Changes
+++ b/Changes
@@ -8,6 +8,96 @@ or in the .../src/5/0/unsupported directory for sub-version
 releases.)
 
 ----------------
+Version 5.003_13
+----------------
+
+The watchword here is "synchronization."  There were a couple of
+show-stopper bugs in 5.003_12, so I'm issuing this patch to bring
+everyone up to a common working base.
+
+ CORE LANGUAGE CHANGES
+
+  Title:  "Disallow labels named q, qq, qw, qx, s, y, and tr"
+   From:  Chip Salzenberg <chip@atlantic.net>
+  Files:  toke.c
+
+  Title:  "Make evals' lexicals visible to nested evals"
+   From:  Chip Salzenberg <chip@atlantic.net>
+  Files:  pp_ctl.c
+
+ OTHER CORE CHANGES
+
+  Title:  "Fix core dump bug with anoncode"
+   From:  Chip Salzenberg <chip@atlantic.net>
+  Files:  op.c
+
+  Title:  "Allow DESTROY to make refs to dying objects"
+   From:  Chip Salzenberg <chip@atlantic.net>
+  Files:  sv.c
+
+ PORTABILITY
+
+  Title:  "Add missing backslash in Configure"
+   From:  Chip Salzenberg <chip@atlantic.net>
+  Files:  Configure
+
+ UTILITIES, LIBRARY, AND EXTENSIONS
+
+  Title:  "Include libnet-1.01 instead of old Net::FTP"
+   From:  Graham Barr <Graham.Barr@tiuk.ti.com>
+  Files:  MANIFEST lib/Net/Cmd.pm lib/Net/Domain.pm
+          lib/Net/DummyInetd.pm lib/Net/FTP.pm lib/Net/NNTP.pm
+          lib/Net/Netrc.pm lib/Net/POP3.pm lib/Net/SMTP.pm
+          lib/Net/SNPP.pm lib/Net/Socket.pm lib/Net/Telnet.pm
+          lib/Net/Time.pm pod/perlmod.pod
+
+  Title:  "Use binmode when doing binary FTP"
+   From:  Ilya Zakharevich
+  Files:  lib/Net/FTP.pm
+
+  Title:  "Re: Open3.pm tries to close unopened file handle"
+   From:  Roderick Schertler <roderick@gate.net>
+ Msg-ID:  <pzloavmd9h.fsf@eeyore.ibcinc.com>
+   Date:  18 Dec 1996 22:19:54 -0500
+  Files:  MANIFEST lib/IPC/Open2.pm lib/IPC/Open3.pm lib/open2.pl
+          lib/open3.pl pod/perldiag.pod pod/perlfunc.pod t/lib/open2.t
+          t/lib/open3.t
+
+  Title:  "Long-standing problem in Socket module"
+   From:  Spider Boardman <spider@orb.nashua.nh.us>
+ Msg-ID:  <199612190418.XAA07291@Orb.Nashua.NH.US>
+   Date:  Wed, 18 Dec 1996 23:18:14 -0500
+  Files:  Configure Porting/Glossary config_H config_h.SH
+          ext/Socket/Socket.pm ext/Socket/Socket.xs
+
+  Title:  "flock() constants"
+   From:  Roderick Schertler <roderick@gate.net>
+ Msg-ID:  <26669.850977437@eeyore.ibcinc.com>
+   Date:  Thu, 19 Dec 1996 01:37:17 -0500
+  Files:  ext/Fcntl/Fcntl.pm ext/Fcntl/Fcntl.xs pod/perlfunc.pod
+
+  Title:  "Re: find2perl . -xdev BROKEN still"
+   From:  Roderick Schertler <roderick@gate.net>
+ Msg-ID:  <pzvi9yig3h.fsf@eeyore.ibcinc.com>
+   Date:  19 Dec 1996 12:44:34 -0500
+  Files:  lib/File/Find.pm lib/find.pl lib/finddepth.pl
+
+ DOCUMENTATION
+
+  Title:  "small doc tweaks for _12"
+   From:  Roderick Schertler <roderick@gate.net>
+ Msg-ID:  <1826.851011557@eeyore.ibcinc.com>
+   Date:  Thu, 19 Dec 1996 11:05:57 -0500
+  Files:  lib/UNIVERSAL.pm pod/perldiag.pod pod/perltie.pod
+
+  Title:  "Re: missing E<> POD directive in perlpod.pod"
+   From:  Roderick Schertler <roderick@gate.net>
+ Msg-ID:  <pzwwueimak.fsf@eeyore.ibcinc.com>
+   Date:  19 Dec 1996 10:30:43 -0500
+  Files:  pod/perlpod.pod pod/pod2html.PL
+
+
+----------------
 Version 5.003_12
 ----------------
 
index c8ee9f6..d22b009 100755 (executable)
--- a/Configure
+++ b/Configure
@@ -304,6 +304,7 @@ d_getppid=''
 d_getprior=''
 d_gnulibc=''
 d_htonl=''
+d_inetaton=''
 d_isascii=''
 d_killpg=''
 d_link=''
@@ -2025,7 +2026,7 @@ if xxx=`./loc arch blurfl $pth`; $test -f "$xxx"; then
        tarch=`arch`"-$osname"
 elif xxx=`./loc uname blurfl $pth`; $test -f "$xxx" ; then
        if uname -m > tmparch 2>&1 ; then
-               tarch=`$sed -e 's/ *$//' -e 's/ /_/g'
+               tarch=`$sed -e 's/ *$//' -e 's/ /_/g' \
                        -e 's/$/'"-$osname/" tmparch`
        else
                tarch="$osname"
@@ -6628,6 +6629,10 @@ set d_strchr; eval $setvar
 val="$vali"
 set d_index; eval $setvar
 
+: check whether inet_aton exists
+set inet_aton d_inetaton
+eval $inlibc
+
 : Look for isascii
 echo " "
 $cat >isascii.c <<'EOCP'
@@ -9926,6 +9931,7 @@ d_gettimeod='$d_gettimeod'
 d_gnulibc='$d_gnulibc'
 d_htonl='$d_htonl'
 d_index='$d_index'
+d_inetaton='$d_inetaton'
 d_isascii='$d_isascii'
 d_killpg='$d_killpg'
 d_link='$d_link'
index ce57721..79e9203 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -302,7 +302,7 @@ lib/File/Compare.pm Emulation of cmp command
 lib/File/Copy.pm       Emulation of cp command
 lib/File/Find.pm       Routines to do a find
 lib/File/Path.pm       A module to do things like `mkdir -p' and `rm -r'
-lib/File/stat.pm       Object-oriented wrapper around CORE::stat
+lib/File/stat.pm       By-name interface to Perl's built-in stat
 lib/FileCache.pm       Keep more files open than the system permits
 lib/FileHandle.pm      Backward-compatible front end to IO extension
 lib/FindBin.pm         Find name of currently executing program
@@ -314,14 +314,22 @@ lib/IPC/Open3.pm  Open a three-ended pipe!
 lib/Math/BigFloat.pm   An arbitrary precision floating-point arithmetic package
 lib/Math/BigInt.pm     An arbitrary precision integer arithmetic package
 lib/Math/Complex.pm    A Complex package
-lib/Net/FTP.pm         File Transfer Protocol client
-lib/Net/Netrc.pm       Parser for ".netrc" file a la Berkeley UNIX
-lib/Net/Ping.pm                Ping methods
-lib/Net/Socket.pm      Support class for Net::FTP
-lib/Net/hostent.pm     Object-oriented wrapper around CORE::gethost*
-lib/Net/netent.pm      Object-oriented wrapper around CORE::getnet*
-lib/Net/protoent.pm    Object-oriented wrapper around CORE::getproto*
-lib/Net/servent.pm     Object-oriented wrapper around CORE::getserv*
+lib/Net/Cmd.pm         Base class for command-based protocols (libnet-1.01)
+lib/Net/Domain.pm      DNS Domain name lookup (libnet-1.01)
+lib/Net/DummyInetd.pm  Place holder for future Net::Inetd (libnet-1.01)
+lib/Net/FTP.pm         File Transfer Protocol client (libnet-1.01)
+lib/Net/NNTP.pm                Network News Transfer Protocol (libnet-1.01)
+lib/Net/Netrc.pm       .netrc lookup routines (libnet-1.01)
+lib/Net/POP3.pm                Post Office Protocol (libnet-1.01)
+lib/Net/Ping.pm                Hello, anybody home?
+lib/Net/SMTP.pm                Simple Mail Transfer Protocol client (libnet-1.01)
+lib/Net/SNPP.pm                Simple Network Pager Protocol client (libnet-1.01)
+lib/Net/Telnet.pm      Telnet client (libnet-1.01)
+lib/Net/Time.pm                Time & NetTime protocols (libnet-1.01)
+lib/Net/hostent.pm     By-name interface to Perl's built-in gethost*
+lib/Net/netent.pm      By-name interface to Perl's built-in getnet*
+lib/Net/protoent.pm    By-name interface to Perl's built-in getproto*
+lib/Net/servent.pm     By-name interface to Perl's built-in getserv*
 lib/Pod/Functions.pm   used by pod/splitpod
 lib/Pod/Text.pm                Convert POD data to formatted ASCII text
 lib/Search/Dict.pm     A module to do binary search on dictionaries
@@ -345,12 +353,12 @@ lib/Tie/RefHash.pm        Base class for tied hashes with references as keys
 lib/Tie/Scalar.pm      Base class for tied scalars
 lib/Tie/SubstrHash.pm  Compact hash for known key, value and table size
 lib/Time/Local.pm      Reverse translation of localtime, gmtime
-lib/Time/gmtime.pm     Object-oriented wrapper around CORE::gmtime
-lib/Time/localtime.pm  Object-oriented wrapper around CORE::localtime
-lib/Time/tm.pm         Perl implementation of "struct tm" for {gm,local}time
+lib/Time/gmtime.pm     By-name interface to Perl's built-in gmtime
+lib/Time/localtime.pm  By-name interface to Perl's built-in localtime
+lib/Time/tm.pm         Internal oject for Time::{gm,local}time
 lib/UNIVERSAL.pm       Base class for ALL classes.
-lib/User/grent.pm      Object-oriented wrapper around CORE::getgr*
-lib/User/pwent.pm      Object-oriented wrapper around CORE::getpw*
+lib/User/grent.pm      By-name interface to Perl's built-in getgr*
+lib/User/pwent.pm      By-name interface to Perl's built-in getpw*
 lib/abbrev.pl          An abbreviation table builder
 lib/assert.pl          assertion and panic with stack trace
 lib/bigfloat.pl                An arbitrary precision floating point package
@@ -612,6 +620,8 @@ t/lib/io_xs.t               See if XSUB methods from IO work
 t/lib/ndbm.t           See if NDBM_File works
 t/lib/odbm.t           See if ODBM_File works
 t/lib/opcode.t         See if Opcode works
+t/lib/open2.t          See if IPC::Open3 works
+t/lib/open3.t          See if IPC::Open2 works
 t/lib/ops.t            See if Opcode works
 t/lib/parsewords.t     See if Text::ParseWords works
 t/lib/posix.t          See if POSIX works
index da02084..58f2cac 100644 (file)
@@ -34,6 +34,10 @@ bin (bin.U):
        is most often a local directory such as /usr/local/bin. Programs using
        this variable must be prepared to deal with ~name substitution.
 
+bincompat3 (bincompat3.U):
+       This variable contains y if Perl 5.004 should be binary-compatible
+       with Perl 5.003.
+
 byteorder (byteorder.U):
        This variable holds the byte order. In the following, larger digits
        indicate more significance.  The variable byteorder is either 4321
@@ -133,6 +137,11 @@ d_bcopy (d_bcopy.U):
        This variable conditionally defines the HAS_BCOPY symbol if
        the bcopy() routine is available to copy strings.
 
+d_bincompat3 (bincompat3.U):
+       This variable conditionally defines BINCOMPAT3 so that embed.h
+       can take special action if Perl 5.004 should be binary-compatible
+       with Perl 5.003.
+
 d_bsdgetpgrp (d_getpgrp.U):
        This variable conditionally defines USE_BSD_GETPGRP if
        getpgrp needs one arguments whereas USG one needs none.
@@ -272,10 +281,20 @@ d_fsetpos (d_fsetpos.U):
        This variable conditionally defines HAS_FSETPOS if fsetpos() is
        available to set the file position indicator.
 
+d_ftime (d_ftime.U):
+       This variable conditionally defines the HAS_FTIME symbol, which
+       indicates that the ftime() routine exists.  The ftime() routine is
+       basically a sub-second accuracy clock.
+
 d_gethent (d_gethent.U):
        This variable conditionally defines HAS_GETHOSTENT if gethostent() is
        available to dup file descriptors.
 
+d_gettimeod (d_ftime.U):
+       This variable conditionally defines the HAS_GETTIMEOFDAY symbol, which
+       indicates that the gettimeofday() system call exists (to obtain a
+       sub-second accuracy clock).
+
 d_getlogin (d_getlogin.U):
        This variable conditionally defines the HAS_GETLOGIN symbol, which
        indicates to the C program that the getlogin() routine is available
@@ -312,6 +331,11 @@ d_index (d_strchr.U):
        This variable conditionally defines HAS_INDEX if index() and
        rindex() are available for string searching.
 
+d_inetaton (d_inetaton.U):
+       This variable conditionally defines the HAS_INET_ATON symbol, which
+       indicates to the C program that the inet_aton() function is available
+       to parse IP address "dotted-quad" strings.
+
 d_isascii (d_isascii.U):
        This variable conditionally defines the HAS_ISASCII constant,
        which indicates to the C program that isascii() is available.
@@ -483,6 +507,11 @@ d_safemcpy (d_safemcpy.U):
        This variable conditionally defines the HAS_SAFE_MEMCPY symbol if
        the memcpy() routine can do overlapping copies.
 
+d_sanemcmp (d_sanemcmp.U):
+       This variable conditionally defines the HAS_SANE_MEMCMP symbol if
+       the memcpy() routine is available and can be used to compare relative
+       magnitudes of chars with their high bits set.
+
 d_seekdir (d_readdir.U):
        This variable conditionally defines HAS_SEEKDIR if seekdir() is
        available.
@@ -643,6 +672,21 @@ d_strerror (d_strerror.U):
        This variable conditionally defines HAS_STRERROR if strerror() is
        available to translate error numbers to strings.
 
+d_strtod (d_strtod.U):
+       This variable conditionally defines the HAS_STRTOD symbol, which
+       indicates to the C program that the strtod() routine is available
+       to provide better numeric string conversion than atof().
+
+d_strtol (d_strtol.U):
+       This variable conditionally defines the HAS_STRTOL symbol, which
+       indicates to the C program that the strtol() routine is available
+       to provide better numeric string conversion than atoi() and friends.
+
+d_strtoul (d_strtoul.U):
+       This variable conditionally defines the HAS_STRTOUL symbol, which
+       indicates to the C program that the strtoul() routine is available
+       to provide conversion of strings to unsigned long.
+
 d_strxfrm (d_strxfrm.U):
        This variable conditionally defines HAS_STRXFRM if strxfrm() is
        available to transform strings.
@@ -1175,6 +1219,11 @@ path_sep (Unix.U):
 perladmin (perladmin.U):
        Electronic mail address of the perl5 administrator.
 
+perlpath (perlpath.U):
+       This variable contains the eventual value of the PERLPATH symbol,
+       which contains the name of the perl interpreter to be used in
+       shell scripts and in the "eval 'exec'" idiom.
+
 prefix (prefix.U):
        This variable holds the name of the directory below which the
        user will install the package.  Usually, this is /usr/local, and
index 11e9033..cec8188 100644 (file)
--- a/config_H
+++ b/config_H
 #define HAS_NTOHL              /**/
 #define HAS_NTOHS              /**/
 
+/* HAS_INET_ATON:
+ *     This symbol, if defined, indicates to the C program that the
+ *     inet_aton() function is available to parse IP address "dotted-quad"
+ *     strings.
+ */
+#define HAS_INET_ATON          /**/
+
 /* HAS_ISASCII:
  *     This manifest constant lets the C program know that isascii 
  *     is available.
index dd73771..c6d662a 100755 (executable)
@@ -349,6 +349,13 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un-
 #$d_htonl HAS_NTOHL            /**/
 #$d_htonl HAS_NTOHS            /**/
 
+/* HAS_INET_ATON:
+ *     This symbol, if defined, indicates to the C program that the
+ *     inet_aton() function is available to parse IP address "dotted-quad"
+ *     strings.
+ */
+#$d_inetaton HAS_INET_ATON             /**/
+
 /* HAS_ISASCII:
  *     This manifest constant lets the C program know that isascii 
  *     is available.
index 9d000a1..4898534 100644 (file)
@@ -7,6 +7,7 @@ Fcntl - load the C Fcntl.h defines
 =head1 SYNOPSIS
 
     use Fcntl;
+    use Fcntl qw(:DEFAULT :flock);
 
 =head1 DESCRIPTION
 
@@ -21,14 +22,21 @@ far more likely chance of getting the numbers right.
 Only C<#define> symbols get translated; you must still correctly
 pack up your own arguments to pass as args for locking functions, etc.
 
+=head1 EXPORTED SYMBOLS
+
+By default your system's F_* and O_* constants (eg, F_DUPFD and O_CREAT)
+are exported into your namespace.  You can request that the flock()
+constants (LOCK_SH, LOCK_EX, LOCK_NB and LOCK_UN) be provided by using
+the tag C<:flock>.  See L<Exporter>.
+
 =cut
 
-use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD);
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD);
 
 require Exporter;
 require DynaLoader;
 @ISA = qw(Exporter DynaLoader);
-$VERSION = "1.00";
+$VERSION = "1.01";
 # Items to export into callers namespace by default
 # (move infrequently used names to @EXPORT_OK below)
 @EXPORT =
@@ -42,6 +50,11 @@ $VERSION = "1.00";
      );
 # Other items we are prepared to export if requested
 @EXPORT_OK = qw(
+    LOCK_SH LOCK_EX LOCK_NB LOCK_UN
+);
+# Named groups of exports
+%EXPORT_TAGS = (
+    'flock' => [qw(LOCK_SH LOCK_EX LOCK_NB LOCK_UN)],
 );
 
 sub AUTOLOAD {
index 90f3af5..0f51b10 100644 (file)
@@ -115,6 +115,37 @@ int arg;
            goto not_there;
 #endif
        break;
+    case 'L':
+       if (strnEQ(name, "LOCK_", 5)) {
+           /* We support flock() on systems which don't have it, so
+              always supply the constants. */
+           if (strEQ(name, "LOCK_SH"))
+#ifdef LOCK_SH
+               return LOCK_SH;
+#else
+               return 1;
+#endif
+           if (strEQ(name, "LOCK_EX"))
+#ifdef LOCK_EX
+               return LOCK_EX;
+#else
+               return 2;
+#endif
+           if (strEQ(name, "LOCK_NB"))
+#ifdef LOCK_NB
+               return LOCK_NB;
+#else
+               return 4;
+#endif
+           if (strEQ(name, "LOCK_UN"))
+#ifdef LOCK_UN
+               return LOCK_UN;
+#else
+               return 8;
+#endif
+       } else
+         goto not_there;
+       break;
     case 'O':
        if (strnEQ(name, "O_", 2)) {
            if (strEQ(name, "O_CREAT"))
index 27fe7f1..9ec8b64 100644 (file)
@@ -4,7 +4,7 @@ package IO::Pipe;
 
 =head1 NAME
 
-IO::pipe - supply object methods for pipes
+IO::Pipe - supply object methods for pipes
 
 =head1 SYNOPSIS
 
index 9872d03..e04689d 100644 (file)
@@ -1,7 +1,7 @@
 package Socket;
 
 use vars qw($VERSION @ISA @EXPORT);
-$VERSION = "1.5";
+$VERSION = "1.6";
 
 =head1 NAME
 
@@ -52,7 +52,8 @@ In addition, some structure manipulation functions are available:
 Takes a string giving the name of a host, and translates that
 to the 4-byte string (structure). Takes arguments of both
 the 'rtfm.mit.edu' type and '18.181.0.24'. If the host name
-cannot be resolved, returns undef.
+cannot be resolved, returns undef. For multi-homed hosts (hosts
+with more than one address), the first address found is returned.
 
 =item inet_ntoa IP_ADDRESS
 
@@ -72,6 +73,15 @@ a particular network interface. This wildcard address
 allows you to bind to all of them simultaneously.)
 Normally equivalent to inet_aton('0.0.0.0').
 
+=item INADDR_BROADCAST
+
+Note: does not return a number, but a packed string.
+
+Returns the 4-byte 'this-lan' ip broadcast address.
+This can be useful for some protocols to solicit information
+from all servers on the same LAN cable.
+Normally equivalent to inet_aton('255.255.255.255').
+
 =item INADDR_LOOPBACK
 
 Note - does not return a number.
@@ -83,7 +93,7 @@ to inet_aton('localhost').
 
 Note - does not return a number.
 
-Returns the 4-byte invalid ip address. Normally equivalent
+Returns the 4-byte 'invalid' ip address. Normally equivalent
 to inet_aton('255.255.255.255').
 
 =item sockaddr_in PORT, ADDRESS
@@ -145,7 +155,7 @@ require DynaLoader;
        inet_aton inet_ntoa pack_sockaddr_in unpack_sockaddr_in
        pack_sockaddr_un unpack_sockaddr_un
        sockaddr_in sockaddr_un
-       INADDR_ANY INADDR_LOOPBACK INADDR_NONE
+       INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE
        AF_802
        AF_APPLETALK
        AF_CCITT
index 6c39557..7e3e3b3 100644 (file)
 #ifndef INADDR_NONE
 #define INADDR_NONE    0xffffffff
 #endif /* INADDR_NONE */
+#ifndef INADDR_BROADCAST
+#define INADDR_BROADCAST       0xffffffff
+#endif /* INADDR_BROADCAST */
 #ifndef INADDR_LOOPBACK
 #define INADDR_LOOPBACK         0x7F000001
 #endif /* INADDR_LOOPBACK */
 
+#ifndef HAS_INET_ATON
+
+/* 
+ * Check whether "cp" is a valid ascii representation
+ * of an Internet address and convert to a binary address.
+ * Returns 1 if the address is valid, 0 if not.
+ * This replaces inet_addr, the return value from which
+ * cannot distinguish between failure and a local broadcast address.
+ */
+static int
+my_inet_aton(cp, addr)
+register const char *cp;
+struct in_addr *addr;
+{
+       register unsigned long val;
+       register int base;
+       register char c;
+       int nparts;
+       const char *s;
+       unsigned int parts[4];
+       register unsigned int *pp = parts;
+
+       for (;;) {
+               /*
+                * Collect number up to ``.''.
+                * Values are specified as for C:
+                * 0x=hex, 0=octal, other=decimal.
+                */
+               val = 0; base = 10;
+               if (*cp == '0') {
+                       if (*++cp == 'x' || *cp == 'X')
+                               base = 16, cp++;
+                       else
+                               base = 8;
+               }
+               while ((c = *cp) != '\0') {
+                       if (isDIGIT(c)) {
+                               val = (val * base) + (c - '0');
+                               cp++;
+                               continue;
+                       }
+                       if (base == 16 && (s=strchr(hexdigit,c))) {
+                               val = (val << 4) + 
+                                       ((s - hexdigit) & 15);
+                               cp++;
+                               continue;
+                       }
+                       break;
+               }
+               if (*cp == '.') {
+                       /*
+                        * Internet format:
+                        *      a.b.c.d
+                        *      a.b.c   (with c treated as 16-bits)
+                        *      a.b     (with b treated as 24 bits)
+                        */
+                       if (pp >= parts + 3 || val > 0xff)
+                               return 0;
+                       *pp++ = val, cp++;
+               } else
+                       break;
+       }
+       /*
+        * Check for trailing characters.
+        */
+       if (*cp && !isSPACE(*cp))
+               return 0;
+       /*
+        * Concoct the address according to
+        * the number of parts specified.
+        */
+       nparts = pp - parts + 1;        /* force to an int for switch() */
+       switch (nparts) {
+
+       case 1:                         /* a -- 32 bits */
+               break;
+
+       case 2:                         /* a.b -- 8.24 bits */
+               if (val > 0xffffff)
+                       return 0;
+               val |= parts[0] << 24;
+               break;
+
+       case 3:                         /* a.b.c -- 8.8.16 bits */
+               if (val > 0xffff)
+                       return 0;
+               val |= (parts[0] << 24) | (parts[1] << 16);
+               break;
+
+       case 4:                         /* a.b.c.d -- 8.8.8.8 bits */
+               if (val > 0xff)
+                       return 0;
+               val |= (parts[0] << 24) | (parts[1] << 16) | (parts[2] << 8);
+               break;
+       }
+       addr->s_addr = htonl(val);
+       return 1;
+}
+
+#undef inet_aton
+#define inet_aton my_inet_aton
+
+#endif /* ! HAS_INET_ATON */
+
 
 static int
 not_here(s)
@@ -595,15 +702,17 @@ inet_aton(host)
        {
        struct in_addr ip_address;
        struct hostent * phe;
+       int ok;
 
        if (phe = gethostbyname(host)) {
                Copy( phe->h_addr, &ip_address, phe->h_length, char );
+               ok = 1;
        } else {
-               ip_address.s_addr = inet_addr(host);
+               ok = inet_aton(host, &ip_address);
        }
 
        ST(0) = sv_newmortal();
-       if(ip_address.s_addr != INADDR_NONE) {
+       if (ok) {
                sv_setpvn( ST(0), (char *)&ip_address, sizeof ip_address );
        }
        }
@@ -748,3 +857,12 @@ INADDR_NONE()
        ip_address.s_addr = htonl(INADDR_NONE);
        ST(0) = sv_2mortal(newSVpv((char *)&ip_address,sizeof ip_address));
        }
+
+void
+INADDR_BROADCAST()
+       CODE:
+       {
+       struct in_addr  ip_address;
+       ip_address.s_addr = htonl(INADDR_BROADCAST);
+       ST(0) = sv_2mortal(newSVpv((char *)&ip_address,sizeof ip_address));
+       }
index 35bb0d1..cfd15a8 100644 (file)
@@ -1,7 +1,14 @@
 package IPC::Open2;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT);
+
 require 5.000;
 require Exporter;
-use Carp;
+
+$VERSION       = 1.01;
+@ISA           = qw(Exporter);
+@EXPORT                = qw(open2);
 
 =head1 NAME
 
@@ -22,6 +29,13 @@ when you try
 
     open(HANDLE, "|cmd args|");
 
+If $rdr is a string (that is, a bareword filehandle rather than a glob
+or a reference) and it begins with ">&", then the child will send output
+directly to that file handle.  If $wtr is a string that begins with
+"<&", then WTR will be closed in the parent, and the child will read
+from it directly.  In both cases, there will be a dup(2) instead of a
+pipe(2) made.
+
 open2() returns the process ID of the child process.  It doesn't return on
 failure: it just raises an exception matching C</^open2:/>.
 
@@ -44,13 +58,11 @@ read and write a line from it.
 
 =head1 SEE ALSO
 
-See L<open3> for an alternative that handles STDERR as well.
+See L<IPC::Open3> for an alternative that handles STDERR as well.  This
+function is really just a wrapper around open3().
 
 =cut
 
-@ISA = qw(Exporter);
-@EXPORT = qw(open2);
-
 # &open2: tom christiansen, <tchrist@convex.com>
 #
 # usage: $pid = open2('rdr', 'wtr', 'some cmd and args');
@@ -67,41 +79,15 @@ See L<open3> for an alternative that handles STDERR as well.
 # 
 # abort program if
 #      rdr or wtr are null
-#      pipe or fork or exec fails
+#      a system call fails
 
-$fh = 'FHOPEN000';  # package static in case called more than once
+require IPC::Open3;
 
 sub open2 {
-    local($kidpid);
-    local($dad_rdr, $dad_wtr, @cmd) = @_;
-
-    $dad_rdr ne ''             || croak "open2: rdr should not be null";
-    $dad_wtr ne ''             || croak "open2: wtr should not be null";
-
-    # force unqualified filehandles into callers' package
-    local($package) = caller;
-    $dad_rdr =~ s/^([^']+$)/$package'$1/ unless ref $dad_rdr;
-    $dad_wtr =~ s/^([^']+$)/$package'$1/ unless ref $dad_wtr;
-
-    local($kid_rdr) = ++$fh;
-    local($kid_wtr) = ++$fh;
-
-    pipe($dad_rdr, $kid_wtr)   || croak "open2: pipe 1 failed: $!";
-    pipe($kid_rdr, $dad_wtr)   || croak "open2: pipe 2 failed: $!";
-
-    if (($kidpid = fork) < 0) {
-       croak "open2: fork failed: $!";
-    } elsif ($kidpid == 0) {
-       close $dad_rdr; close $dad_wtr;
-       open(STDIN,  "<&$kid_rdr");
-       open(STDOUT, ">&$kid_wtr");
-       warn "execing @cmd\n" if $debug;
-       exec @cmd
-           or croak "open2: exec of @cmd failed";   
-    } 
-    close $kid_rdr; close $kid_wtr;
-    select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
-    $kidpid;
+    my ($read, $write, @cmd) = @_;
+    local $Carp::CarpLevel = $Carp::CarpLevel + 1;
+    return IPC::Open3::_open3('open2', scalar caller,
+                               $write, $read, '>&STDERR', @cmd);
 }
-1; # so require is happy
 
+1
index d416ae7..5d85458 100644 (file)
@@ -1,7 +1,18 @@
 package IPC::Open3;
+
+use strict;
+no strict 'refs'; # because users pass me bareword filehandles
+use vars qw($VERSION @ISA @EXPORT $Fh $Me);
+
 require 5.001;
 require Exporter;
+
 use Carp;
+use Symbol 'qualify';
+
+$VERSION       = 1.01;
+@ISA           = qw(Exporter);
+@EXPORT                = qw(open3);
 
 =head1 NAME
 
@@ -9,7 +20,7 @@ IPC::Open3, open3 - open a process for reading, writing, and error handling
 
 =head1 SYNOPSIS
 
-    $pid = open3(\*WTRFH, \*RDRFH, \*ERRFH 
+    $pid = open3(\*WTRFH, \*RDRFH, \*ERRFH
                    'some cmd and args', 'optarg', ...);
 
 =head1 DESCRIPTION
@@ -29,12 +40,28 @@ writer, you'll have problems with blocking, which means you'll
 want to use select(), which means you'll have to use sysread() instead
 of normal stuff.
 
-All caveats from open2() continue to apply.  See L<open2> for details.
+open3() returns the process ID of the child process.  It doesn't return on
+failure: it just raises an exception matching C</^open3:/>.
 
-=cut
+=head1 WARNING
+
+It will not create these file handles for you.  You have to do this
+yourself.  So don't pass it empty variables expecting them to get filled
+in for you.
 
-@ISA = qw(Exporter);
-@EXPORT = qw(open3);
+Additionally, this is very dangerous as you may block forever.  It
+assumes it's going to talk to something like B<bc>, both writing to it
+and reading from it.  This is presumably safe because you "know" that
+commands like B<bc> will read a line at a time and output a line at a
+time.  Programs like B<sort> that read their entire input stream first,
+however, are quite apt to cause deadlock.
+
+The big problem with this approach is that if you don't have control
+over source code being run in the the child process, you can't control
+what it does with pipe buffering.  Thus you can't just open a pipe to
+C<cat -v> and continually read and write a line from it.
+
+=cut
 
 # &open3: Marc Horowitz <marc@mit.edu>
 # derived mostly from &open2 by tom christiansen, <tchrist@convex.com>
@@ -48,7 +75,7 @@ All caveats from open2() continue to apply.  See L<open2> for details.
 # reading, wtr for writing, and err for errors.
 # if err is '', or the same as rdr, then stdout and
 # stderr of the child are on the same fh.  returns pid
-# of child, or 0 on failure.
+# of child (or dies on failure).
 
 
 # if wtr begins with '<&', then wtr will be closed in the parent, and
@@ -64,17 +91,41 @@ All caveats from open2() continue to apply.  See L<open2> for details.
 #
 # abort program if
 #   rdr or wtr are null
-#   pipe or fork or exec fails
+#   a system call fails
 
-$fh = 'FHOPEN000';  # package static in case called more than once
+$Fh = 'FHOPEN000';     # package static in case called more than once
+$Me = 'open3 (bug)';   # you should never see this, it's always localized
 
-sub open3 {
-    my($kidpid);
-    my($dad_wtr, $dad_rdr, $dad_err, @cmd) = @_;
-    my($dup_wtr, $dup_rdr, $dup_err);
+# Fatal.pm needs to be fixed WRT prototypes.
+
+sub xfork {
+    my $pid = fork;
+    defined $pid or croak "$Me: fork failed: $!";
+    return $pid;
+}
+
+sub xpipe {
+    pipe $_[0], $_[1] or croak "$Me: pipe($_[0], $_[1]) failed: $!";
+}
+
+# I tried using a * prototype character for the filehandle but it still
+# disallows a bearword while compiling under strict subs.
 
-    $dad_wtr                   || croak "open3: wtr should not be null";
-    $dad_rdr                   || croak "open3: rdr should not be null";
+sub xopen {
+    open $_[0], $_[1] or croak "$Me: open($_[0], $_[1]) failed: $!";
+}
+
+sub xclose {
+    close $_[0] or croak "$Me: close($_[0]) failed: $!";
+}
+
+sub _open3 {
+    local $Me = shift;
+    my($package, $dad_wtr, $dad_rdr, $dad_err, @cmd) = @_;
+    my($dup_wtr, $dup_rdr, $dup_err, $kidpid);
+
+    $dad_wtr                   or croak "$Me: wtr should not be null";
+    $dad_rdr                   or croak "$Me: rdr should not be null";
     $dad_err = $dad_rdr if ($dad_err eq '');
 
     $dup_wtr = ($dad_wtr =~ s/^[<>]&//);
@@ -82,28 +133,29 @@ sub open3 {
     $dup_err = ($dad_err =~ s/^[<>]&//);
 
     # force unqualified filehandles into callers' package
-    my($package) = caller;
-    $dad_wtr =~ s/^([^:]+$)/$package\:\:$1/ unless ref $dad_wtr;
-    $dad_rdr =~ s/^([^:]+$)/$package\:\:$1/ unless ref $dad_rdr;
-    $dad_err =~ s/^([^:]+$)/$package\:\:$1/ unless ref $dad_err;
-
-    my($kid_rdr) = ++$fh;
-    my($kid_wtr) = ++$fh;
-    my($kid_err) = ++$fh;
-
-    if (!$dup_wtr) {
-       pipe($kid_rdr, $dad_wtr)    || croak "open3: pipe 1 (stdin) failed: $!";
-    }
-    if (!$dup_rdr) {
-       pipe($dad_rdr, $kid_wtr)    || croak "open3: pipe 2 (stdout) failed: $!";
-    }
-    if ($dad_err ne $dad_rdr && !$dup_err) {
-       pipe($dad_err, $kid_err)    || croak "open3: pipe 3 (stderr) failed: $!";
-    }
+    $dad_wtr = qualify $dad_wtr, $package;
+    $dad_rdr = qualify $dad_rdr, $package;
+    $dad_err = qualify $dad_err, $package;
+
+    my $kid_rdr = ++$Fh;
+    my $kid_wtr = ++$Fh;
+    my $kid_err = ++$Fh;
+
+    xpipe $kid_rdr, $dad_wtr if !$dup_wtr;
+    xpipe $dad_rdr, $kid_wtr if !$dup_rdr;
+    xpipe $dad_err, $kid_err if !$dup_err && $dad_err ne $dad_rdr;
+
+    $kidpid = xfork;
+    if ($kidpid == 0) {
+       # If she wants to dup the kid's stderr onto her stdout I need to
+       # save a copy of her stdout before I put something else there.
+       if ($dad_rdr ne $dad_err && $dup_err
+               && fileno($dad_err) == fileno(STDOUT)) {
+           my $tmp = ++$Fh;
+           xopen($tmp, ">&$dad_err");
+           $dad_err = $tmp;
+       }
 
-    if (($kidpid = fork) < 0) {
-        croak "open3: fork failed: $!";
-    } elsif ($kidpid == 0) {
        if ($dup_wtr) {
            open(STDIN,  "<&$dad_wtr") if (fileno(STDIN) != fileno($dad_wtr));
        } else {
@@ -132,13 +184,19 @@ sub open3 {
            or croak "open3: exec of @cmd failed";
     }
 
-    close $kid_rdr; close $kid_wtr; close $kid_err;
-    if ($dup_wtr) {
-       close($dad_wtr);
-    }
+    xclose $kid_rdr if !$dup_wtr;
+    xclose $kid_wtr if !$dup_rdr;
+    xclose $kid_err if !$dup_err && $dad_rdr ne $dad_err;
+    # If the write handle is a dup give it away entirely, close my copy
+    # of it.
+    xclose $dad_wtr if $dup_wtr;
 
     select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
     $kidpid;
 }
+
+sub open3 {
+    return _open3 'open3', scalar caller, @_
+}
 1; # so require is happy
 
diff --git a/lib/Net/Cmd.pm b/lib/Net/Cmd.pm
new file mode 100644 (file)
index 0000000..6697ad1
--- /dev/null
@@ -0,0 +1,529 @@
+# Net::Cmd.pm
+#
+# Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
+# reserved. This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Net::Cmd;
+
+=head1 NAME
+
+Net::Cmd - Network Command class (as used by FTP, SMTP etc)
+
+=head1 SYNOPSIS
+
+    use Net::Cmd;
+    
+    @ISA = qw(Net::Cmd);
+
+=head1 DESCRIPTION
+
+C<Net::Cmd> is a collection of methods that can be inherited by a sub class
+of C<IO::Handle>. These methods implement the functionality required for a
+command based protocol, for example FTP and SMTP.
+
+=head1 USER METHODS
+
+These methods provide a user interface to the C<Net::Cmd> object.
+
+=over 4
+
+=item debug ( VALUE )
+
+Set the level of debug information for this object. If C<VALUE> is not given
+then the current state is returned. Otherwise the state is changed to 
+C<VALUE> and the previous state returned. If C<VALUE> is C<undef> then
+the debug level will be set to the default debug level for the class.
+
+This method can also be called as a I<static> method to set/get the default
+debug level for a given class.
+
+=item message ()
+
+Returns the text message returned from the last command
+
+=item code ()
+
+Returns the 3-digit code from the last command. If a command is pending
+then the value 0 is returned
+
+=item ok ()
+
+Returns non-zero if the last code value was greater than zero and
+less than 400. This holds true for most command servers. Servers
+where this does not hold may override this method.
+
+=item status ()
+
+Returns the most significant digit of the current status code. If a command
+is pending then C<CMD_PENDING> is returned.
+
+=item datasend ( DATA )
+
+Send data to the remote server, delimiting lines with CRLF. Any lin starting
+with a '.' will be prefixed with another '.'.
+
+=item dataend ()
+
+End the sending of data to the remote server. This is done by ensureing that
+the data already sent ends with CRLF then sending '.CRLF' to end the
+transmission. Once this data has been sent C<dataend> calls C<response> and
+returns true if C<response> returns CMD_OK.
+
+=back
+
+=head1 CLASS METHODS
+
+These methods are not intended to be called by the user, but used or 
+over-ridden by a sub-class of C<Net::Cmd>
+
+=over 4
+
+=item debug_print ( DIR, TEXT )
+
+Print debugging information. C<DIR> denotes the direction I<true> being
+data being sent to the server. Calls C<debug_text> before printing to
+STDERR.
+
+=item debug_text ( TEXT )
+
+This method is called to print debugging information. TEXT is
+the text being sent. The method should return the text to be printed
+
+This is primarily meant for the use of modules such as FTP where passwords
+are sent, but we do not want to display them in the debugging information.
+
+=item command ( CMD [, ARGS, ... ])
+
+Send a command to the command server. All arguments a first joined with
+a space character and CRLF is appended, this string is then sent to the
+command server.
+
+Returns undef upon failure
+
+=item unsupported ()
+
+Sets the status code to 580 and the response text to 'Unsupported command'.
+Returns zero.
+
+=item responce ()
+
+Obtain a responce from the server. Upon success the most significant digit
+of the status code is returned. Upon failure, timeout etc., I<undef> is
+returned.
+
+=item parse_response ( TEXT )
+
+This method is called by C<response> as a method with one argument. It should
+return an array of 2 values, the 3-digit status code and a flag which is true
+when this is part of a multi-line response and this line is not the list.
+
+=item getline ()
+
+Retreive one line, delimited by CRLF, from the remote server. Returns I<undef>
+upon failure.
+
+B<NOTE>: If you do use this method for any reason, please remember to add
+some C<debug_print> calls into your method.
+
+=item ungetline ( TEXT )
+
+Unget a line of text from the server.
+
+=item read_until_dot ()
+
+Read data from the remote server until a line consisting of a single '.'.
+Any lines starting with '..' will have one of the '.'s removed.
+
+Returns a reference to a list containing the lines, or I<undef> upon failure.
+
+=back
+
+=head1 EXPORTS
+
+C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>,
+C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR> ,correspond to possible results
+of C<response> and C<status>. The sixth is C<CMD_PENDING>.
+
+=head1 AUTHOR
+
+Graham Barr <Graham.Barr@tiuk.ti.com>
+
+=head1 REVISION
+
+$Revision: 2.2 $
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
+software; you can redistribute it and/or modify it under the same terms
+as Perl itself.
+
+=cut
+
+require 5.001;
+require Exporter;
+
+use strict;
+use vars qw(@ISA @EXPORT $VERSION);
+use Carp;
+
+$VERSION = sprintf("%d.%02d", q$Revision: 2.2 $ =~ /(\d+)\.(\d+)/);
+@ISA     = qw(Exporter);
+@EXPORT  = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING);
+
+sub CMD_INFO   { 1 }
+sub CMD_OK     { 2 }
+sub CMD_MORE   { 3 }
+sub CMD_REJECT { 4 }
+sub CMD_ERROR  { 5 }
+sub CMD_PENDING { 0 }
+
+my %debug = ();
+
+sub _print_isa
+{
+ no strict qw(refs);
+
+ my $pkg = shift;
+ my $cmd = $pkg;
+
+ $debug{$pkg} ||= 0;
+
+ my %done = ();
+ my @do   = ($pkg);
+ my %spc = ( $pkg , "");
+
+ print STDERR "\n";
+ while ($pkg = shift @do)
+  {
+   next if defined $done{$pkg};
+
+   $done{$pkg} = 1;
+
+   my $v = defined ${"${pkg}::VERSION"}
+                ? "(" . ${"${pkg}::VERSION"} . ")"
+                : "";
+
+   my $spc = $spc{$pkg};
+   print STDERR "$cmd: ${spc}${pkg}${v}\n";
+
+   if(defined @{"${pkg}::ISA"})
+    {
+     @spc{@{"${pkg}::ISA"}} = ("  " . $spc{$pkg}) x @{"${pkg}::ISA"};
+     unshift(@do, @{"${pkg}::ISA"});
+    }
+  }
+
+ print STDERR "\n";
+}
+
+sub debug
+{
+ @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])';
+
+ my($cmd,$level) = @_;
+ my $pkg = ref($cmd) || $cmd;
+ my $oldval = 0;
+
+ if(ref($cmd))
+  {
+   $oldval = ${*$cmd}{'net_cmd_debug'} || 0;
+  }
+ else
+  {
+   $oldval = $debug{$pkg} || 0;
+  }
+
+ return $oldval
+    unless @_ == 2;
+
+ $level = $debug{$pkg} || 0
+    unless defined $level;
+
+ _print_isa($pkg)
+    if($level && !exists $debug{$pkg});
+
+ if(ref($cmd))
+  {
+   ${*$cmd}{'net_cmd_debug'} = $level;
+  }
+ else
+  {
+   $debug{$pkg} = $level;
+  }
+
+ $oldval;
+}
+
+sub message
+{
+ @_ == 1 or croak 'usage: $obj->message()';
+
+ my $cmd = shift;
+
+ wantarray ? @{${*$cmd}{'net_cmd_resp'}}
+          : join("", @{${*$cmd}{'net_cmd_resp'}});
+}
+
+sub debug_text { $_[2] }
+
+sub debug_print
+{
+ my($cmd,$out,$text) = @_;
+ print STDERR $cmd,($out ? '>>> ' : '<<< '), $cmd->debug_text($out,$text);
+}
+
+sub code
+{
+ @_ == 1 or croak 'usage: $obj->code()';
+
+ my $cmd = shift;
+
+ ${*$cmd}{'net_cmd_code'};
+}
+
+sub status
+{
+ @_ == 1 or croak 'usage: $obj->code()';
+
+ my $cmd = shift;
+
+ substr(${*$cmd}{'net_cmd_code'},0,1);
+}
+
+sub set_status
+{
+ @_ == 3 or croak 'usage: $obj->set_status( CODE, MESSAGE)';
+
+ my $cmd = shift;
+
+ (${*$cmd}{'net_cmd_code'},${*$cmd}{'net_cmd_resp'}) = @_;
+
+ 1;
+}
+
+sub command
+{
+ my $cmd = shift;
+
+ $cmd->dataend()
+    if(exists ${*$cmd}{'net_cmd_lastch'});
+
+ if (scalar(@_))
+  {
+   my $str = join(" ", @_) . "\015\012";
+
+   syswrite($cmd,$str,length $str);
+
+   $cmd->debug_print(1,$str)
+       if($cmd->debug);
+
+   ${*$cmd}{'net_cmd_resp'} = [];      # the responce
+   ${*$cmd}{'net_cmd_code'} = "000";   # Made this one up :-)
+  }
+
+ $cmd;
+}
+
+sub ok
+{
+ @_ == 1 or croak 'usage: $obj->ok()';
+
+ my $code = $_[0]->code;
+ 0 < $code && $code < 400;
+}
+
+sub unsupported
+{
+ my $cmd = shift;
+
+ ${*$cmd}{'net_cmd_resp'} = [ 'Unsupported command' ];
+ ${*$cmd}{'net_cmd_code'} = 580;
+ 0;
+}
+
+sub getline
+{
+ my $cmd = shift;
+
+ ${*$cmd}{'net_cmd_lines'} ||= [];
+
+ return shift @{${*$cmd}{'net_cmd_lines'}}
+    if scalar(@{${*$cmd}{'net_cmd_lines'}});
+
+ my $partial = ${*$cmd}{'net_cmd_partial'} || "";
+
+ my $rin = "";
+ vec($rin,fileno($cmd),1) = 1;
+
+ my $buf;
+
+ until(scalar(@{${*$cmd}{'net_cmd_lines'}}))
+  {
+   my $timeout = $cmd->timeout || undef;
+   my $rout;
+   if (select($rout=$rin, undef, undef, $timeout))
+    {
+     unless (sysread($cmd, $buf="", 1024))
+      {
+       carp ref($cmd) . ": Unexpected EOF on command channel";
+       return undef;
+      } 
+
+     substr($buf,0,0) = $partial;      ## prepend from last sysread
+
+     my @buf = split(/\015?\012/, $buf);       ## break into lines
+
+     $partial = length($buf) == 0 || substr($buf, -1, 1) eq "\012"
+               ? ''
+               : pop(@buf);
+
+     map { $_ .= "\n" } @buf;
+
+     push(@{${*$cmd}{'net_cmd_lines'}},@buf);
+
+    }
+   else
+    {
+     carp "$cmd: Timeout" if($cmd->debug);
+     return undef;
+    }
+  }
+
+ ${*$cmd}{'net_cmd_partial'} = $partial;
+
+ shift @{${*$cmd}{'net_cmd_lines'}};
+}
+
+sub ungetline
+{
+ my($cmd,$str) = @_;
+
+ ${*$cmd}{'net_cmd_lines'} ||= [];
+ unshift(@{${*$cmd}{'net_cmd_lines'}}, $str);
+}
+
+sub parse_response
+{
+ return ()
+    unless $_[1] =~ s/^(\d\d\d)(.)//o;
+ ($1, $2 eq "-");
+}
+
+sub response
+{
+ my $cmd = shift;
+ my($code,$more) = (undef) x 2;
+
+ ${*$cmd}{'net_cmd_resp'} ||= [];
+
+ while(1)
+  {
+   my $str = $cmd->getline();
+
+   $cmd->debug_print(0,$str)
+     if ($cmd->debug);
+   if($str =~ s/^(\d\d\d)(.?)//o)
+    {
+     ($code,$more) = ($1,$2 && $2 eq "-");
+    }
+   elsif(!$more)
+    {
+     $cmd->ungetline($str);
+     last;
+    }
+
+   push(@{${*$cmd}{'net_cmd_resp'}},$str);
+
+   last unless($more);
+  } 
+
+ ${*$cmd}{'net_cmd_code'} = $code;
+
+ substr($code,0,1);
+}
+
+sub read_until_dot
+{
+ my $cmd = shift;
+ my $arr = [];
+
+ while(1)
+  {
+   my $str = $cmd->getline();
+
+   $cmd->debug_print(0,$str)
+     if ($cmd->debug & 4);
+
+   last if($str =~ /^\.\n/o);
+
+   $str =~ s/^\.\././o;
+
+   push(@$arr,$str);
+  }
+
+ $arr;
+}
+
+sub datasend
+{
+ my $cmd = shift;
+ my $lch = exists ${*$cmd}{'net_cmd_lastch'} ? ${*$cmd}{'net_cmd_lastch'}
+                                             : " ";
+ my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
+ my $line = $lch . join("" ,@$arr);
+
+ ${*$cmd}{'net_cmd_lastch'} = substr($line,-1,1);
+
+ return 1
+    unless length($line) > 1;
+
+ if($cmd->debug)
+  {
+   my $ln = substr($line,1);
+   my $b = "$cmd>>> ";
+   print STDERR $b,join("\n$b",split(/\n/,$ln)),"\n";
+  }
+
+ $line =~ s/\n/\015\012/sgo;
+ $line =~ s/(?=\012\.)/./sgo;
+ my $len = length($line) - 1;
+
+ return $len < 1 ||
+       syswrite($cmd, $line, $len, 1) == $len;
+}
+
+sub dataend
+{
+ my $cmd = shift;
+
+ return 1
+    unless(exists ${*$cmd}{'net_cmd_lastch'});
+
+ if(${*$cmd}{'net_cmd_lastch'} eq "\015")
+  {
+   syswrite($cmd,"\012",1);
+   print STDERR "\n"
+    if($cmd->debug);
+  }
+ elsif(${*$cmd}{'net_cmd_lastch'} ne "\012")
+  {
+   syswrite($cmd,"\015\012",2);
+   print STDERR "\n"
+    if($cmd->debug);
+  }
+
+ print STDERR "$cmd>>> .\n"
+    if($cmd->debug);
+
+ syswrite($cmd,".\015\012",3);
+
+ delete ${*$cmd}{'net_cmd_lastch'};
+
+ $cmd->response() == CMD_OK;
+}
+
+1;
diff --git a/lib/Net/Domain.pm b/lib/Net/Domain.pm
new file mode 100644 (file)
index 0000000..558b7f3
--- /dev/null
@@ -0,0 +1,245 @@
+# Net::Domain.pm
+#
+# Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
+# reserved. This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Net::Domain;
+
+=head1 NAME
+
+Net::Domain - Attempt to evaluate the current host's internet name and domain
+
+=head1 SYNOPSIS
+
+    use Net::Domain qw(hostname hostfqdn hostdomain);
+
+=head1 DESCRIPTION
+
+Using various methods B<attempt> to find the Fully Qualified Domain Name (FQDN)
+of the current host. From this determine the host-name and the host-domain.
+
+Each of the functions will return I<undef> if the FQDN cannot be determined.
+
+=over 4
+
+=item hostfqdn ()
+
+Identify and return the FQDN of the current host.
+
+=item hostname ()
+
+Returns the smallest part of the FQDN which can be used to identify the host.
+
+=item hostdomain ()
+
+Returns the remainder of the FQDN after the I<hostname> has been removed.
+
+=back
+
+=head1 AUTHOR
+
+Graham Barr <bodg@tiuk.ti.com>.
+Adapted from Sys::Hostname by David Sundstrom <sunds@asictest.sc.ti.com>
+
+=head1 REVISION
+
+$Revision: 2.0 $
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995 Graham Barr. All rights reserved.
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
+
+require Exporter;
+
+use Carp;
+use strict;
+use vars qw($VERSION @ISA @EXPORT_OK);
+
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(hostname hostdomain hostfqdn domainname);
+
+$VERSION = sprintf("%d.%02d", q$Revision: 2.0 $ =~ /(\d+)\.(\d+)/);
+
+my($host,$domain,$fqdn) = (undef,undef,undef);
+
+# Try every conceivable way to get hostname.
+
+sub _hostname {
+
+    # method 1 - we already know it
+    return $host
+       if(defined $host);
+
+    # method 2 - syscall is preferred since it avoids tainting problems
+    eval {
+       {
+           package main;
+           require "syscall.ph";
+       }
+       my $tmp = "\0" x 65; ## preload scalar
+       $host = (syscall(&main::SYS_gethostname, $tmp, 65) == 0) ? $tmp : undef;
+    }
+
+
+    # method 3 - trusty old hostname command
+    || eval {
+       chop($host = `(hostname) 2>/dev/null`); # BSD'ish
+    }
+
+    # method 4 - sysV/POSIX uname command (may truncate)
+    || eval {
+       chop($host = `uname -n 2>/dev/null`); ## SYSV'ish && POSIX'ish
+    }
+
+    # method 5 - Apollo pre-SR10
+    || eval {
+       $host = (split(/[:\. ]/,`/com/host`,6))[0];
+    }
+
+    || eval {
+       $host = "";
+    };
+    # remove garbage 
+    $host =~ s/[\0\r\n]+//go;
+    $host =~ s/(\A\.+|\.+\Z)//go;
+    $host =~ s/\.\.+/\./go;
+
+    $host;
+}
+
+sub _hostdomain {
+
+    # method 1 - we already know it
+    return $domain
+       if(defined $domain);
+
+    # method 2 - just try hostname and system calls
+
+    my $host = _hostname();
+    my($dom,$site,@hosts);
+    local($_);
+
+    @hosts = ($host,"localhost");
+
+    unless($host =~ /\./) {
+       chop($dom = `domainname 2>/dev/null`);
+       unshift(@hosts, "$host.$dom")
+           if (defined $dom && $dom ne "");
+    }
+
+    # Attempt to locate FQDN
+
+    foreach (@hosts) {
+       my @info = gethostbyname($_);
+
+       next unless @info;
+
+       # look at real name & aliases
+       foreach $site ($info[0], split(/ /,$info[1])) { 
+           if(rindex($site,".") > 0) {
+
+               # Extract domain from FQDN
+
+               ($domain = $site) =~ s/\A[^\.]+\.//; 
+               return $domain;
+           }
+       }
+    }
+
+    # try looking in /etc/resolv.conf
+
+    local *RES;
+
+    if(open(RES,"/etc/resolv.conf")) {
+       while(<RES>) {
+           $domain = $1
+               if(/\A\s*(?:domain|search)\s+(\S+)/);
+       }
+       close(RES);
+
+       return $domain
+           if(defined $domain);
+    }
+
+    # Look for environment variable
+
+    $domain ||= $ENV{DOMAIN} || undef;
+
+    if(defined $domain) {
+       $domain =~ s/[\r\n\0]+//g;
+       $domain =~ s/(\A\.+|\.+\Z)//g;
+       $domain =~ s/\.\.+/\./g;
+    }
+
+    $domain;
+}
+
+sub domainname {
+
+    return $fqdn
+       if(defined $fqdn);
+
+    _hostname();
+    _hostdomain();
+
+    my @host   = split(/\./, $host);
+    my @domain = split(/\./, $domain);
+    my @fqdn   = ();
+
+    # Determine from @host & @domain the FQDN
+
+    my @d = @domain;
+LOOP:
+    while(1) {
+       my @h = @host;
+       while(@h) {
+           my $tmp = join(".",@h,@d);
+           if((gethostbyname($tmp))[0]) {
+               @fqdn = (@h,@d);
+               $fqdn = $tmp;
+             last LOOP;
+           }
+           pop @h;
+       }
+       last unless shift @d;
+    }
+
+    if(@fqdn) {
+       $host = shift @fqdn;
+       until((gethostbyname($host))[0]) {
+           $host .= "." . shift @fqdn;
+       }
+       $domain = join(".", @fqdn);
+    }
+    else {
+       undef $host;
+       undef $domain;
+       undef $fqdn;
+    }
+
+    $fqdn;
+}
+
+sub hostfqdn { domainname() }
+
+sub hostname {
+    domainname()
+       unless(defined $host);
+    return $host;
+}
+
+sub hostdomain {
+    domainname()
+       unless(defined $domain);
+    return $domain;
+}
+
+1; # Keep require happy
diff --git a/lib/Net/DummyInetd.pm b/lib/Net/DummyInetd.pm
new file mode 100644 (file)
index 0000000..8dddc90
--- /dev/null
@@ -0,0 +1,156 @@
+# Net::DummyInetd.pm
+#
+# Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
+# reserved. This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Net::DummyInetd;
+
+=head1 NAME
+
+Net::DummyInetd - A dummy Inetd server
+
+=head1 SYNOPSIS
+
+    use Net::DummyInetd;
+    use Net::SMTP;
+    
+    $inetd = new Net::DummyInetd qw(/usr/lib/sendmail -ba -bs);
+    
+    $smtp  = Net::SMTP->new('localhost', Port => $inetd->port);
+
+=head1 DESCRIPTION
+
+C<Net::DummyInetd> is just what it's name says, it is a dummy inetd server.
+Creation of a C<Net::DummyInetd> will cause a child process to be spawned off
+which will listen to a socket. When a connection arrives on this socket
+the specified command is fork'd and exec'd with STDIN and STDOUT file
+descriptors duplicated to the new socket.
+
+This package was added as an example of how to use C<Net::SMTP> to connect
+to a C<sendmail> process, which is not the default, via SIDIN and STDOUT.
+A C<Net::Inetd> package will be avaliable in the next release of C<libnet>
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( CMD )
+
+Creates a new object and spawns a child process which listens to a socket.
+C<CMD> is a list, which will be passed to C<exec> when a new process needs
+to be created.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item port
+
+Returns the port number on which the I<DummyInet> object is listening
+
+=back
+
+=head1 AUTHOR
+
+Graham Barr <Graham.Barr@tiuk.ti.com>
+
+=head1 REVISION
+
+$Revision: 1.2 $
+
+The VERSION is derived from the revision by changing each number after the
+first dot into a 2 digit number so
+
+       Revision 1.8   => VERSION 1.08
+       Revision 1.2.3 => VERSION 1.0203
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
+software; you can redistribute it and/or modify it under the same terms
+as Perl itself.
+
+=cut
+
+require 5.002;
+
+use IO::Handle;
+use IO::Socket;
+use strict;
+use vars qw($VERSION);
+use Carp;
+
+$VERSION = do{my @r=(q$Revision: 1.2 $=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r};
+
+
+sub _process
+{
+ my $listen = shift;
+ my @cmd = @_;
+ my $vec = '';
+ my $r;
+
+ vec($vec,fileno($listen),1) = 1;
+
+ while(select($r=$vec,undef,undef,undef))
+  {
+   my $sock = $listen->accept;
+   my $pid;
+
+   if($pid = fork())
+    {
+     sleep 1;
+     close($sock);
+    }
+   elsif(defined $pid)
+    {
+     my $x =  IO::Handle->new_from_fd($sock,"r");
+     open(STDIN,"<&=".fileno($x)) || die "$! $@";
+     close($x);
+
+     my $y = IO::Handle->new_from_fd($sock,"w");
+     open(STDOUT,">&=".fileno($y)) || die "$! $@";
+     close($y);
+
+     close($sock);
+     exec(@cmd) || carp "$! $@";
+    }
+   else
+    {
+     close($sock);
+     carp $!;
+    }
+  }
+ exit -1; 
+}
+
+sub new
+{
+ my $self = shift;
+ my $type = ref($self) || $self;
+
+ my $listen = IO::Socket::INET->new(Listen => 5, Proto => 'tcp');
+ my $pid;
+
+ return bless [ $listen->sockport, $pid ]
+       if($pid = fork());
+
+ _process($listen,@_);
+}
+
+sub port
+{
+ my $self = shift;
+ $self->[0];
+}
+
+sub DESTROY
+{
+ my $self = shift;
+ kill 9, $self->[1];
+}
+
+1;
index 64b21fe..d635f00 100644 (file)
@@ -1,16 +1,8 @@
-;# Net::FTP.pm
-;#
-;# Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
-;# reserved. This program is free software; you can redistribute it and/or
-;# modify it under the same terms as Perl itself.
-
-;#Notes
-;# should I have a dataconn::close sub which calls response ??
-;# FTP should hold state reguarding cmds sent
-;# A::read needs some more thought
-;# A::write What is previous pkt ended in \r or not ??
-;# need to do some heavy tidy-ing up !!!!
-;# need some documentation
+# Net::FTP.pm
+#
+# Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
+# reserved. This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
 
 package Net::FTP;
 
@@ -20,277 +12,649 @@ Net::FTP - FTP Client class
 
 =head1 SYNOPSIS
 
require Net::FTP;
-
- $ftp = Net::FTP->new("some.host.name");
- $ftp->login("anonymous","me@here.there");
- $ftp->cwd("/pub");
- $ftp->get("that.file");
- $ftp->quit;
   use Net::FTP;
+    
   $ftp = Net::FTP->new("some.host.name");
   $ftp->login("anonymous","me@here.there");
   $ftp->cwd("/pub");
   $ftp->get("that.file");
   $ftp->quit;
 
 =head1 DESCRIPTION
 
 C<Net::FTP> is a class implementing a simple FTP client in Perl as described
 in RFC959
 
-=head2 TO BE CONTINUED ...
+C<Net::FTP> provides methods that will perform various operations. These methods
+could be split into groups depending the level of interface the user requires.
 
-=cut
+=head1 CONSTRUCTOR
 
-require 5.001;
-use Socket 1.3;
-use Carp;
-use Net::Socket;
+=over 4
 
-@ISA = qw(Net::Socket);
+=item new (HOST [,OPTIONS])
 
-$VERSION = sprintf("%d.%02d", q$Revision: 1.18 $ =~ /(\d+)\.(\d+)/);
-sub Version { $VERSION }
+This is the constructor for a new Net::SMTP object. C<HOST> is the
+name of the remote host to which a FTP connection is required.
 
-use strict;
+C<OPTIONS> are passed in a hash like fasion, using key and value pairs.
+Possible options are:
+
+B<Firewall> - The name of a machine which acts as a FTP firewall. This can be
+overridden by an environment variable C<FTP_FIREWALL>. If specified, and the
+given host cannot be directly connected to, then the
+connection is made to the firwall machine and the string C<@hostname> is
+appended to the login identifier.
+
+B<Port> - The port number to connect to on the remote machine for the
+FTP connection
+
+B<Timeout> - Set a timeout value (defaults to 120)
+
+B<Debug> - Debug level
+
+B<Passive> - If set to I<true> then all data transfers will be done using 
+passive mode. This is required for some I<dumb> servers.
+
+=back
 
 =head1 METHODS
 
-All methods return 0 or undef upon failure
+Unless otherwise stated all methods return either a I<true> or I<false>
+value, with I<true> meaning that the operation was a success. When a method
+states that it returns a value, falure will be returned as I<undef> or an
+empty list.
+
+=over 4
+
+=item login ([LOGIN [,PASSWORD [, ACCOUNT] ] ])
+
+Log into the remote FTP server with the given login information. If
+no arguments are given then the C<Net::FTP> uses the C<Net::Netrc>
+package to lookup the login information for the connected host.
+If no information is found then a login of I<anonymous> is used.
+If no password is given and the login is I<anonymous> then the users
+Email address will be used for a password.
+
+If the connection is via a firewall then the C<authorize> method will
+be called with no arguments.
+
+=item authorize ( [AUTH [, RESP]])
+
+This is a protocol used by some firewall ftp proxies. It is used
+to authorise the user to send data out.  If both arguments are not specified
+then C<authorize> uses C<Net::Netrc> to do a lookup.
+
+=item type (TYPE [, ARGS])
+
+This method will send the TYPE command to the remote FTP server
+to change the type of data transfer. The return value is the previous
+value.
+
+=item ascii ([ARGS]) binary([ARGS]) ebcdic([ARGS]) byte([ARGS])
+
+Synonyms for C<type> with the first arguments set correctly
+
+B<NOTE> ebcdic and byte are not fully supported.
+
+=item rename ( OLDNAME, NEWNAME )
+
+Rename a file on the remote FTP server from C<OLDNAME> to C<NEWNAME>. This
+is done by sending the RNFR and RNTO commands.
+
+=item delete ( FILENAME )
+
+Send a request to the server to delete C<FILENAME>.
+
+=item cwd ( [ DIR ] )
+
+Change the current working directory to C<DIR>, or / if not given.
+
+=item cdup ()
+
+Change directory to the parent of the current directory.
+
+=item pwd ()
+
+Returns the full pathname of the current directory.
+
+=item rmdir ( DIR )
+
+Remove the directory with the name C<DIR>.
+
+=item mkdir ( DIR [, RECURSE ])
+
+Create a new directory with the name C<DIR>. If C<RECURSE> is I<true> then
+C<mkdir> will attempt to create all the directories in the given path.
+
+Returns the full pathname to the new directory.
+
+=item ls ( [ DIR ] )
+
+Get a directory listing of C<DIR>, or the current directory.
+
+Returns a reference to a list of lines returned from the server.
+
+=item dir ( [ DIR ] )
+
+Get a directory listing of C<DIR>, or the current directory in long format.
+
+Returns a reference to a list of lines returned from the server.
+
+=item get ( REMOTE_FILE [, LOCAL_FILE ] )
+
+Get C<REMOTE_FILE> from the server and store locally. C<LOCAL_FILE> may be
+a filename or a filehandle. If not specified the the file will be stored in
+the current directory with the same leafname as the remote file.
+
+Returns C<LOCAL_FILE>, or the generated local file name if C<LOCAL_FILE>
+is not given.
+
+=item put ( LOCAL_FILE [, REMOTE_FILE ] )
+
+Put a file on the remote server. C<LOCAL_FILE> may be a name or a filehandle.
+If C<LOCAL_FILE> is a filehandle then C<REMOTE_FILE> must be specified. If
+C<REMOTE_FILE> is not specified then the file will be stored in the current
+directory with the same leafname as C<LOCAL_FILE>.
+
+Returns C<REMOTE_FILE>, or the generated remote filename if C<REMOTE_FILE>
+is not given.
+
+=item put_unique ( LOCAL_FILE [, REMOTE_FILE ] )
+
+Same as put but uses the C<STOU> command.
+
+Returns the name of the file on the server.
+
+=item append ( LOCAL_FILE [, REMOTE_FILE ] )
+
+Same as put but appends to the file on the remote server.
+
+Returns C<REMOTE_FILE>, or the generated remote filename if C<REMOTE_FILE>
+is not given.
+
+=item unique_name ()
+
+Returns the name of the last file stored on the server using the
+C<STOU> command.
+
+=item mdtm ( FILE )
+
+Returns the I<modification time> of the given file
+
+=item size ( FILE )
+
+Returns the size in bytes for the given file.
+
+=back
+
+The following methods can return different results depending on
+how they are called. If the user explicitly calls either
+of the C<pasv> or C<port> methods then these methods will
+return a I<true> or I<false> value. If the user does not
+call either of these methods then the result will be a
+reference to a C<Net::FTP::dataconn> based object.
+
+=over 4
+
+=item nlst ( [ DIR ] )
+
+Send a C<NLST> command to the server, with an optional parameter.
+
+=item list ( [ DIR ] )
+
+Same as C<nlst> but using the C<LIST> command
+
+=item retr ( FILE )
+
+Begin the retrieval of a file called C<FILE> from the remote server.
+
+=item stor ( FILE )
+
+Tell the server that you wish to store a file. C<FILE> is the
+name of the new file that should be created.
+
+=item stou ( FILE )
+
+Same as C<stor> but using the C<STOU> command. The name of the unique
+file which was created on the server will be avalaliable via the C<unique_name>
+method after the data connection has been closed.
+
+=item appe ( FILE )
+
+Tell the server that we want to append some data to the end of a file
+called C<FILE>. If this file does not exist then create it.
+
+=back
+
+If for some reason you want to have complete control over the data connection,
+this includes generating it and calling the C<response> method when required,
+then the user can use these methods to do so.
+
+However calling these methods only affects the use of the methods above that
+can return a data connection. They have no effect on methods C<get>, C<put>,
+C<put_unique> and those that do not require data connections.
+
+=over 4
+
+=item port ( [ PORT ] )
+
+Send a C<PORT> command to the server. If C<PORT> is specified then it is sent
+to the server. If not the a listen socket is created and the correct information
+sent to the server.
+
+=item pasv ()
+
+Tell the server to go into passive mode. Returns the text that represents the
+port on which the server is listening, this text is in a suitable form to
+sent to another ftp server using the C<port> method.
+
+=back
 
-=head2 * new($host [, option => value [,...]] )
+The following methods can be used to transfer files between two remote
+servers, providing that these two servers can connect directly to each other.
 
-Constructor for the FTP client. It will create the connection to the
-remote host. Possible options are:
+=over 4
 
- Port   => port to use for FTP connection
- Timeout => set timeout value (defaults to 120)
- Debug  => debug level
+=item pasv_xfer ( SRC_FILE, DEST_SERVER [, DEST_FILE ] )
+
+This method will do a file transfer between two remote ftp servers. If
+C<DEST_FILE> is omitted then the leaf name of C<SRC_FILE> will be used.
+
+=item pasv_wait ( NON_PASV_SERVER )
+
+This method can be used to wait for a transfer to complete between a passive
+server and a non-passive server. The method should be called on the passive
+server with the C<Net::FTP> object for the non-passive server passed as an
+argument.
+
+=item abort ()
+
+Abort the current data transfer.
+
+=item quit ()
+
+Send the QUIT command to the remote FTP server and close the socket connection.
+
+=back
+
+=head2 Methods for the adventurous
+
+C<Net::FTP> inherits from C<Net::Cmd> so methods defined in C<Net::Cmd> may
+be used to send commands to the remote FTP server.
+
+=over 4
+
+=item quot (CMD [,ARGS])
+
+Send a command, that Net::FTP does not directly support, to the remote
+server and wait for a response.
+
+Returns most significant digit of the response code.
+
+B<WARNING> This call should only be used on commands that do not require
+data connections. Misuse of this method can hang the connection.
+
+=back
+
+=head1 THE dataconn CLASS
+
+Some of the methods defined in C<Net::FTP> return an object which will
+be derived from this class.The dataconn class itself is derived from
+the C<IO::Socket::INET> class, so any normal IO operations can be performed.
+However the following methods are defined in the dataconn class and IO should
+be performed using these.
+
+=over 4
+
+=item read ( BUFFER, SIZE [, TIMEOUT ] )
+
+Read C<SIZE> bytes of data from the server and place it into C<BUFFER>, also
+performing any <CRLF> translation necessary. C<TIMEOUT> is optional, if not
+given the the timeout value from the command connection will be used.
+
+Returns the number of bytes read before any <CRLF> translation.
+
+=item write ( BUFFER, SIZE [, TIMEOUT ] )
+
+Write C<SIZE> bytes of data from C<BUFFER> to the server, also
+performing any <CRLF> translation necessary. C<TIMEOUT> is optional, if not
+given the the timeout value from the command connection will be used.
+
+Returns the number of bytes written before any <CRLF> translation.
+
+=item abort ()
+
+Abort the current data transfer.
+
+=item close ()
+
+Close the data connection and get a response from the FTP server. Returns
+I<true> if the connection was closed sucessfully and the first digit of
+the response from the server was a '2'.
+
+=back
+
+=head1 AUTHOR
+
+Graham Barr <Graham.Barr@tiuk.ti.com>
+
+=head1 REVISION
+
+$Revision: 2.8 $
+$Date: 1996/09/05 06:53:58 $
+
+The VERSION is derived from the revision by changing each number after the
+first dot into a 2 digit number so
+
+       Revision 1.8   => VERSION 1.08
+       Revision 1.2.3 => VERSION 1.0203
+
+=head1 SEE ALSO
+
+L<Net::Netrc>
+L<Net::Cmd>
+
+=head1 CREDITS
+
+Henry Gabryjelski <henryg@WPI.EDU> - for the suggestion of creating directories
+recursively.
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
+software; you can redistribute it and/or modify it under the same terms
+as Perl itself.
 
 =cut
 
-sub FTP_READY    { 0 } # Ready 
-sub FTP_RESPONSE { 1 } # Waiting for a response
-sub FTP_XFER     { 2 } # Doing data xfer
+require 5.001;
 
-sub new {
+use strict;
+use vars qw(@ISA $VERSION);
+use Carp;
+
+use Socket 1.3;
+use IO::Socket;
+use Time::Local;
+use Net::Cmd;
+use Net::Telnet qw(TELNET_IAC TELNET_IP TELNET_DM);
+
+$VERSION = do{my @r=(q$Revision: 2.8 $=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r};
+@ISA     = qw(Exporter Net::Cmd IO::Socket::INET);
+
+sub new
+{
  my $pkg  = shift;
- my $host = shift;
+ my $peer = shift;
  my %arg  = @_; 
- my $me = bless Net::Socket->new(Peer  => $host, 
-                               Service => 'ftp', 
-                               Port    => $arg{Port} || 'ftp'
-                               ), $pkg;
-
- ${*$me} = "";                                 # partial response text
- @{*$me} = ();                                 # Last response text
-
- %{*$me} = (%{*$me},                           # Copy current values
-           Code    => 0,                       # Last response code
-           Type    => 'A',                     # Ascii/Binary/etc mode
-           Timeout => $arg{Timeout} || 120,    # Timeout value
-           Debug   => $arg{Debug}   || 0,      # Output debug information
-           FtpHost => $host,                   # Remote hostname
-           State   => FTP_RESPONSE,            # Current state
-
-           ##############################################################
-           # Other elements used during the lifetime of the object are
-           #
-           # LISTEN  Listen socket
-           # DATA    Data socket
-          );
-
- $me->autoflush(1);
-
- $me->debug($arg{Debug})
-   if(exists $arg{Debug});
-
- unless(2 == $me->response())
+
+ my $host = $peer;
+ my $fire = undef;
+
+ unless(defined inet_aton($peer))
   {
-   $me->close();
-   undef $me;
+   $fire = $ENV{FTP_FIREWALL} || $arg{Firewall} || undef;
+   if(defined $fire)
+    {
+     $peer = $fire;
+     delete $arg{Port};
+    }
   }
 
- $me;
-}
+ my $ftp = $pkg->SUPER::new(PeerAddr => $peer, 
+                           PeerPort => $arg{Port} || 'ftp(21)',
+                           Proto    => 'tcp',
+                           Timeout  => defined $arg{Timeout}
+                                               ? $arg{Timeout}
+                                               : 120
+                          ) or return undef;
 
-##
-## User interface methods
-##
+ ${*$ftp}{'net_ftp_passive'} = $arg{Passive} || 0;  # Always use pasv mode
+ ${*$ftp}{'net_ftp_host'}    = $host;               # Remote hostname
+ ${*$ftp}{'net_ftp_type'}    = 'A';                # ASCII/binary/etc mode
 
-=head2 * debug( $value )
+ ${*$ftp}{'net_ftp_firewall'} = $fire
+    if defined $fire;
 
-Set the level of debug information for this object. If no argument is given
-then the current state is returned. Otherwise the state is changed to 
-C<$value>and the previous state returned.
+ $ftp->autoflush(1);
 
-=cut
+ $ftp->debug(exists $arg{Debug} ? $arg{Debug} : undef);
 
-sub debug {
- my $me = shift;
- my $debug = ${*$me}{Debug};
- if(@_)
+ unless ($ftp->response() == CMD_OK)
   {
-   ${*$me}{Debug} = 0 + shift;
-
-   printf STDERR "\n$me VERSION %s\n", $Net::FTP::VERSION
-     if(${*$me}{Debug});
+   $ftp->SUPER::close();
+   undef $ftp;
   }
 
- $debug;
+ $ftp;
 }
 
-=head2 quit
-
-Send the QUIT command to the remote FTP server and close the socket connection.
-
-=cut
-
-sub quit {
- my $me = shift;
-
- return undef
-       unless $me->QUIT;
+##
+## User interface methods
+##
 
- close($me);
+sub quit
+{
+ my $ftp = shift;
 
- return 1;
+ $ftp->_QUIT
+    && $ftp->SUPER::close;
 }
 
-=head2 ascii/ebcdic/binary/byte
+sub close
+{
+ my $ftp = shift;
 
-Put the remote FTP server ant the FTP package into the given mode
-of data transfer.
+ ref($ftp) 
+    && defined fileno($ftp)
+    && $ftp->quit;
+}
 
-=cut
+sub DESTROY { shift->close }
 
 sub ascii  { shift->type('A',@_); }
-sub ebcdic { shift->type('E',@_); }
 sub binary { shift->type('I',@_); }
-sub byte   { shift->type('L',@_); }
+
+sub ebcdic
+{
+ carp "TYPE E is unsupported, shall default to I";
+ shift->type('E',@_);
+}
+
+sub byte
+{
+ carp "TYPE L is unsupported, shall default to I";
+ shift->type('L',@_);
+}
 
 # Allow the user to send a command directly, BE CAREFUL !!
 
-sub quot  { 
- my $me = shift;
+sub quot
+{ 
+ my $ftp = shift;
  my $cmd = shift;
 
- $me->send_cmd( uc $cmd, @_);
-
- $me->response();
+ $ftp->command( uc $cmd, @_);
+ $ftp->response();
 }
 
-=head2 login([$login [, $password [, $account]]])
+sub mdtm
+{
+ my $ftp  = shift;
+ my $file = shift;
 
-Log into the remote FTP server with the given login information. If
-no arguments are given then the users $HOME/.netrc file is searched
-for the remote server's hostname. If no information is found then
-a login of I<anonymous> is used. If no password is given and the login
-is anonymous then the users Email address will be used for a password
+ return undef
+       unless $ftp->_MDTM($file);
 
-=cut
+ my @gt = reverse ($ftp->message =~ /(\d{4})(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/);
+ $gt[5] -= 1;
+ timegm(@gt);
+}
 
-sub login {
- my $me = shift;
- my $user = shift;
- my $pass = shift if(defined $user);
- my $acct = shift if(defined $pass);
- my $ok;
+sub size
+{
+ my $ftp  = shift;
+ my $file = shift;
+
+ $ftp->_SIZE($file)
+       ? ($ftp->message =~ /(\d+)/)[0]
+       : undef;
+}
+
+sub login
+{
+ my($ftp,$user,$pass,$acct) = @_;
+ my($ok,$ruser);
 
- unless(defined $user)
+ unless (defined $user)
   {
    require Net::Netrc;
-   my $rc = Net::Netrc->lookup(${*$me}{FtpHost});
+
+   my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'});
 
    ($user,$pass,$acct) = $rc->lpa()
-       if $rc;
+       if ($rc);
   }
 
- $user = "anonymous"
      unless defined $user;
+ $user ||= "anonymous";
$ruser = $user;
 
- $pass = "-" . (getpwuid($>))[0] . "@" 
-       if !defined $pass && $user eq "anonymous";
+ if(defined ${*$ftp}{'net_ftp_firewall'})
+  {
+   $user .= "@" . ${*$ftp}{'net_ftp_host'};
+  }
 
- $ok = $me->USER($user);
+ $ok = $ftp->_USER($user);
 
- $ok = $me->PASS($pass)
-       if $ok == 3;
+ # Some dumb firewall's don't prefix the connection messages
+ $ok = $ftp->response()
+       if($ok == CMD_OK && $ftp->code == 220 && $user =~ /\@/);
 
- $ok = $me->ACCT($acct || "")
-       if $ok == 3;
+ if ($ok == CMD_MORE)
+  {
+   unless(defined $pass)
+    {
+     require Net::Netrc;
 
- $ok == 2;
-}
+     my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'}, $ruser);
 
-=head2 authorise($auth, $resp)
+     ($ruser,$pass,$acct) = $rc->lpa()
+       if ($rc);
 
-This is a protocol used by some firewall ftp proxies. It is used
-to authorise the user to send data out.
+     $pass = "-" . (getpwuid($>))[0] . "@" 
+        if (!defined $pass && $ruser =~ /^anonymous/o);
+    }
 
-=cut
+   $ok = $ftp->_PASS($pass || "");
+  }
 
-sub authorise {
- my($me,$auth,$resp) = @_;
- my $ok;
+ $ok = $ftp->_ACCT($acct || "")
+       if ($ok == CMD_MORE);
 
- carp "Net::FTP::authorise <auth> <resp>\n"
-       unless defined $auth && defined $resp;
+ $ftp->authorize()
+    if($ok == CMD_OK && defined ${*$ftp}{'net_ftp_firewall'});
 
- $ok = $me->AUTH($auth);
+ $ok == CMD_OK;
+}
 
- $ok = $me->RESP($resp)
-       if $ok == 3;
+sub authorize
+{
+ @_ >= 1 || @_ <= 3 or croak 'usage: $ftp->authorize( [AUTH [, RESP]])';
 
- $ok == 2;
-}
+ my($ftp,$auth,$resp) = @_;
 
-=head2 rename( $oldname, $newname)
+ unless(defined $resp)
+  {
+   require Net::Netrc;
 
-Rename a file on the remote FTP server from C<$oldname> to C<$newname>
+   $auth ||= (getpwuid($>))[0];
 
-=cut
+   my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}, $auth)
+        || Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});
 
-sub rename {
- my($me,$from,$to) = @_;
+   ($auth,$resp) = $rc->lpa()
+     if($rc);
+  }
+
+ my $ok = $ftp->_AUTH($auth || "");
+
+ $ok = $ftp->_RESP($resp || "")
+       if ($ok == CMD_MORE);
+
+ $ok == CMD_OK;
+}
+
+sub rename
+{
+ @_ == 3 or croak 'usage: $ftp->rename(FROM, TO)';
 
- croak "Net::FTP:rename <from> <to>\n"
-       unless defined $from && defined $to;
+ my($ftp,$from,$to) = @_;
 
- $me->RNFR($from) and $me->RNTO($to);
+ $ftp->_RNFR($from)
+    && $ftp->_RNTO($to);
 }
 
-sub type {
- my $me          = shift;
+sub type
+{
+ my $ftp = shift;
  my $type = shift;
- my $ok          = 0;
+ my $oldval = ${*$ftp}{'net_ftp_type'};
 
- return ${*$me}{Type}
-       unless defined $type;
+ return $oldval
+       unless (defined $type);
 
  return undef
-       unless($me->TYPE($type,@_));
+       unless ($ftp->_TYPE($type,@_));
 
- ${*$me}{Type} = join(" ",$type,@_);
+ ${*$ftp}{'net_ftp_type'} = join(" ",$type,@_);
+
+ $oldval;
 }
 
-sub abort {
- my $me = shift;
+sub abort
+{
+ my $ftp = shift;
+
+ send($ftp,pack("CC",TELNET_IAC,TELNET_IP),0);
+ send($ftp,pack("C", TELNET_IAC),MSG_OOB);
+ send($ftp,pack("C", TELNET_DM),0);
+
+ $ftp->command("ABOR");
+
+ defined ${*$ftp}{'net_ftp_dataconn'}
+    ? ${*$ftp}{'net_ftp_dataconn'}->close()
+    : $ftp->response();
+
+ $ftp->response()
+    if $ftp->status == CMD_REJECT;
 
- ${*$me}{DATA}->abort()
-       if defined ${*$me}{DATA};
+ $ftp->status == CMD_OK;
 }
 
-sub get {
- my $me = shift;
- my $remote = shift;
- my $local  = shift;
- my $where  = shift || 0;
+sub get
+{
+ my($ftp,$remote,$local,$where) = @_;
+
  my($loc,$len,$buf,$resp,$localfd,$data);
  local *FD;
 
  $localfd = ref($local) ? fileno($local)
-                       : 0;
+                       : undef;
+
+ ($local = $remote) =~ s#^.*/##
+       unless(defined $local);
+
+ ${*$ftp}{'net_ftp_rest'} = $where
+       if ($where);
 
- ($local = $remote) =~ s#^.*/## unless(defined $local);
+ delete ${*$ftp}{'net_ftp_port'};
+ delete ${*$ftp}{'net_ftp_pasv'};
 
- if($localfd)
+ $data = $ftp->retr($remote) or
+       return undef;
+
+ if(defined $localfd)
   {
    $loc = $local;
   }
@@ -301,18 +665,15 @@ sub get {
    unless(($where) ? open($loc,">>$local") : open($loc,">$local"))
     {
      carp "Cannot open Local file $local: $!\n";
+     $data->abort;
      return undef;
     }
   }
-
- if ($where) {   
-   $data = $me->rest_cmd($where,$remote) or
-       return undef; 
- }
- else {
-   $data = $me->retr($remote) or
-     return undef;
- }
+  if ($ftp->binary && !binmode($loc))
+   {
+    carp "Cannot binmode Local file $local: $!\n";
+    return undef;
+   }
 
  $buf = '';
 
@@ -323,57 +684,116 @@ sub get {
  while($len > 0 && syswrite($loc,$buf,$len) == $len);
 
  close($loc)
-       unless $localfd;
+       unless defined $localfd;
  
- $data->close() == 2; # implied $me->response
+ $data->close(); # implied $ftp->response
+
+ return $local;
+}
+
+sub cwd
+{
+ @_ == 2 || @_ == 3 or croak 'usage: $ftp->cwd( [ DIR ] )';
+
+ my($ftp,$dir) = @_;
+
+ $dir ||= "/";
+
+ $dir eq ".."
+    ? $ftp->_CDUP()
+    : $ftp->_CWD($dir);
+}
+
+sub cdup
+{
+ @_ == 1 or croak 'usage: $ftp->cdup()';
+ $_[0]->_CDUP;
 }
 
-sub cwd {
- my $me = shift;
- my $dir = shift || "/";
+sub pwd
+{
+ @_ == 1 || croak 'usage: $ftp->pwd()';
+ my $ftp = shift;
+
+ $ftp->_PWD();
+ $ftp->_extract_path;
+}
+
+sub rmdir
+{
+ @_ == 2 || croak 'usage: $ftp->rmdir( DIR )';
+
+ $_[0]->_RMD($_[1]);
+}
+
+sub mkdir
+{
+ @_ == 2 || @_ == 3 or croak 'usage: $ftp->mkdir( DIR [, RECURSE ] )';
+
+ my($ftp,$dir,$recurse) = @_;
 
- return $dir eq ".." ? $me->CDUP()
-                    : $me->CWD($dir);
+ $ftp->_MKD($dir) || $recurse or
+    return undef;
+
+ my $path = undef;
+ unless($ftp->ok)
+  {
+   my @path = split(m#(?=/+)#, $dir);
+
+   $path = "";
+
+   while(@path)
+    {
+     $path .= shift @path;
+
+     $ftp->_MKD($path);
+     $path = $ftp->_extract_path($path);
+
+     # 521 means directory already exists
+     last
+        unless $ftp->ok || $ftp->code == 521;
+    }
+  }
+
+ $ftp->_extract_path($path);
 }
 
-sub pwd {
- my $me = shift;
+sub delete
+{
+ @_ == 2 || croak 'usage: $ftp->delete( FILENAME )';
 
- $me->PWD() ? ($me->message =~ /\"([^\"]+)/)[0]
-            : undef;
+ $_[0]->_DELE($_[1]);
 }
 
-sub put               { shift->send("stor",@_) }
-sub put_unique { shift->send("stou",@_) }
-sub append     { shift->send("appe",@_) }
+sub put        { shift->_store_cmd("stor",@_) }
+sub put_unique { shift->_store_cmd("stou",@_) }
+sub append     { shift->_store_cmd("appe",@_) }
 
-sub nlst { shift->data_cmd("NLST",@_) }
-sub list { shift->data_cmd("LIST",@_) }
-sub retr { shift->data_cmd("RETR",@_) }
-sub stor { shift->data_cmd("STOR",@_) }
-sub stou { shift->data_cmd("STOU",@_) }
-sub appe { shift->data_cmd("APPE",@_) }
+sub nlst { shift->_data_cmd("NLST",@_) }
+sub list { shift->_data_cmd("LIST",@_) }
+sub retr { shift->_data_cmd("RETR",@_) }
+sub stor { shift->_data_cmd("STOR",@_) }
+sub stou { shift->_data_cmd("STOU",@_) }
+sub appe { shift->_data_cmd("APPE",@_) }
 
-sub send {
- my $me            = shift;
- my $cmd    = shift;
- my $local  = shift;
- my $remote = shift;
+sub _store_cmd 
+{
+ my($ftp,$cmd,$local,$remote) = @_;
  my($loc,$sock,$len,$buf,$localfd);
  local *FD;
 
  $localfd = ref($local) ? fileno($local)
-                       : 0;
+                       : undef;
 
  unless(defined $remote)
   {
-   croak "Must specify remote filename with stream input\n"
-       if $localfd;
+   croak 'Must specify remote filename with stream input'
+       if defined $localfd;
 
    ($remote = $local) =~ s%.*/%%;
   }
 
- if($localfd)
+ if(defined $localfd)
   {
    $loc = $local;
   }
@@ -386,134 +806,175 @@ sub send {
      carp "Cannot open Local file $local: $!\n";
      return undef;
     }
+   if ($ftp->binary && !binmode($loc))
+    {
+     carp "Cannot binmode Local file $local: $!\n";
+     return undef;
+    }
   }
 
- $cmd = lc $cmd;
+ delete ${*$ftp}{'net_ftp_port'};
+ delete ${*$ftp}{'net_ftp_pasv'};
 
- $sock = $me->$cmd($remote) or
+ $sock = $ftp->_data_cmd($cmd, $remote) or 
        return undef;
 
  do
   {
-   $len = sysread($loc,$buf,1024);
+   $len = sysread($loc,$buf="",1024);
   }
  while($len && $sock->write($buf,$len) == $len);
 
  close($loc)
-       unless $localfd;
+       unless defined $localfd;
 
  $sock->close();
 
- ($remote) = $me->message =~ /unique file name:\s*(\S*)\s*\)/
-       if $cmd eq 'stou' ;
+ ($remote) = $ftp->message =~ /unique file name:\s*(\S*)\s*\)/
+       if ('STOU' eq uc $cmd);
 
  return $remote;
 }
 
-sub port {
- my $me = shift;
- my $port = shift;
+sub port
+{
+ @_ == 1 || @_ == 2 or croak 'usage: $ftp->port([PORT])';
+
+ my($ftp,$port) = @_;
  my $ok;
 
+ delete ${*$ftp}{'net_ftp_intern_port'};
+
  unless(defined $port)
   {
-   my $listen;
-
-   if(defined ${*$me}{LISTEN})
-    {
-     ${*$me}{LISTEN}->close();
-     delete ${*$me}{LISTEN};
-    }
-
    # create a Listen socket at same address as the command socket
 
-   $listen = Net::Socket->new(Listen  => 5,
-                            Service => 'ftp',
-                            Addr    => $me->sockhost, 
-                           );
+   ${*$ftp}{'net_ftp_listen'} ||= IO::Socket::INET->new(Listen    => 5,
+                                                       Proto     => 'tcp',
+                                                       LocalAddr => $ftp->sockhost, 
+                                                      );
   
-   ${*$me}{LISTEN} = $listen;
+   my $listen = ${*$ftp}{'net_ftp_listen'};
 
    my($myport, @myaddr) = ($listen->sockport, split(/\./,$listen->sockhost));
 
    $port = join(',', @myaddr, $myport >> 8, $myport & 0xff);
+
+   ${*$ftp}{'net_ftp_intern_port'} = 1;
   }
 
- $ok = $me->PORT($port);
+ $ok = $ftp->_PORT($port);
 
- ${*$me}{Port} = $port;
+ ${*$ftp}{'net_ftp_port'} = $port;
 
  $ok;
 }
 
-sub ls { shift->list_cmd("NLST",@_); }
-sub lsl { shift->list_cmd("LIST",@_); }
+sub ls  { shift->_list_cmd("NLST",@_); }
+sub dir { shift->_list_cmd("LIST",@_); }
 
-sub pasv {
- my $me = shift;
my $hostport;
+sub pasv
+{
@_ == 1 or croak 'usage: $ftp->pasv()';
 
- return undef
-       unless $me->PASV();
+ my $ftp = shift;
+
+ delete ${*$ftp}{'net_ftp_intern_port'};
 
- ($hostport) = $me->message =~ /(\d+(,\d+)+)/;
+ $ftp->_PASV && $ftp->message =~ /(\d+(,\d+)+)/
+    ? ${*$ftp}{'net_ftp_pasv'} = $1
+    : undef;    
+}
 
- ${*$me}{Pasv} = $hostport;
+sub unique_name
+{
+ my $ftp = shift;
+ ${*$ftp}{'net_ftp_unique'} || undef;
 }
 
 ##
-## Communication methods
+## Depreciated methods
 ##
 
-sub timeout {
- my $me = shift;
- my $timeout = ${*$me}{Timeout};
-
- ${*$me}{Timeout} = 0 + shift if(@_);
-
- $timeout;
+sub lsl
+{
+ carp "Use of Net::FTP::lsl depreciated, use 'dir'"
+    if $^W;
+ goto &dir;
 }
 
-sub accept {
- my $me = shift;
+sub authorise
+{
+ carp "Use of Net::FTP::authorise depreciated, use 'authorize'"
+    if $^W;
+ goto &authorize;
+}
 
- return undef unless defined ${*$me}{LISTEN};
 
- my $data = ${*$me}{LISTEN}->accept;
+##
+## Private methods
+##
 
- ${*$me}{LISTEN}->close();
- delete ${*$me}{LISTEN};
+sub _extract_path
+{
+ my($ftp, $path) = @_;
 
- ${*$data}{Timeout} = ${*$me}{Timeout};
- ${*$data}{Cmd} = $me;
${*$data} = "";
+ $ftp->ok &&
+    $ftp->message =~ /\s\"(.*)\"\s/o &&
   ($path = $1) =~ s/\"\"/\"/g;
 
- ${*$me}{State} = FTP_XFER;
- ${*$me}{DATA}  = bless $data, "Net::FTP::" . ${*$me}{Type};
+ $path;
 }
 
-sub message {
- my $me = shift;
- join("\n", @{*$me});
-}
+##
+## Communication methods
+##
 
-sub ok {
- my $me = shift;
- my $code = ${*$me}{Code} || 0;
+sub _dataconn
+{
+ my $ftp = shift;
+ my $data = undef;
+ my $pkg = "Net::FTP::" . $ftp->type;
 
- 0 < $code && $code < 400;
-}
+ $pkg =~ s/ /_/g;
+
+ delete ${*$ftp}{'net_ftp_dataconn'};
 
-sub code {
- my $me = shift;
+ if(defined ${*$ftp}{'net_ftp_pasv'})
+  {
+   my @port = split(/,/,${*$ftp}{'net_ftp_pasv'});
 
- ${*$me}{Code};
+   $data = $pkg->new(PeerAddr => join(".",@port[0..3]),
+                    PeerPort => $port[4] * 256 + $port[5],
+                    Proto    => 'tcp'
+                   );
+  }
+ elsif(defined ${*$ftp}{'net_ftp_listen'})
+  {
+   $data = ${*$ftp}{'net_ftp_listen'}->accept($pkg);
+   close(delete ${*$ftp}{'net_ftp_listen'});
+  }
+
+ if($data)
+  {
+   ${*$data} = "";
+   $data->timeout($ftp->timeout);
+   ${*$ftp}{'net_ftp_dataconn'} = $data;
+   ${*$data}{'net_ftp_cmd'} = $ftp;
+  }
+
+ $data;
 }
 
-sub list_cmd {
- my $me = shift;
- my $cmd = lc shift;
- my $data = $me->$cmd(@_);
+sub _list_cmd
+{
+ my $ftp = shift;
+ my $cmd = uc shift;
+
+ delete ${*$ftp}{'net_ftp_port'};
+ delete ${*$ftp}{'net_ftp_pasv'};
+
+ my $data = $ftp->_data_cmd($cmd,@_);
 
  return undef
        unless(defined $data);
@@ -523,99 +984,137 @@ sub list_cmd {
  my $databuf = '';
  my $buf = '';
 
- while($data->read($databuf,1024)) {
+ while($data->read($databuf,1024))
+  {
    $buf .= $databuf;
- }
 }
 
  my $list = [ split(/\n/,$buf) ];
 
  $data->close();
 
- wantarray ? @{$list} : $list;
+ wantarray ? @{$list}
+           : $list;
 }
 
-sub data_cmd {
- my $me = shift;
+sub _data_cmd
+{
+ my $ftp = shift;
  my $cmd = uc shift;
  my $ok = 1;
- my $pasv = defined ${*$me}{Pasv} ? 1 : 0;
+ my $where = delete ${*$ftp}{'net_ftp_rest'} || 0;
 
- $ok = $me->port
-       unless $pasv || defined ${*$me}{Port};
+ if(${*$ftp}{'net_ftp_passive'} &&
+     !defined ${*$ftp}{'net_ftp_pasv'} &&
+     !defined ${*$ftp}{'net_ftp_port'})
+  {
+   my $data = undef;
 
- $ok = $me->$cmd(@_)
-       if $ok;
+   $ok = defined $ftp->pasv;
+   $ok = $ftp->_REST($where)
+       if $ok && $where;
 
- return $pasv ? $ok
-             : $ok ? $me->accept()
-                   : undef;
-}
+   if($ok)
+    {
+     $ftp->command($cmd,@_);
+     $data = $ftp->_dataconn();
+     $ok = CMD_INFO == $ftp->response();
+    }
+   return $ok ? $data
+             : undef;
+  }
 
-sub rest_cmd {
- my $me = shift;
- my $ok = 1;
- my $pasv = defined ${*$me}{Pasv} ? 1 : 0;
- my $where = shift;
- my $file = shift;
+ $ok = $ftp->port
+    unless (defined ${*$ftp}{'net_ftp_port'} ||
+            defined ${*$ftp}{'net_ftp_pasv'});
 
- $ok = $me->port
-       unless $pasv || defined ${*$me}{Port};
+ $ok = $ftp->_REST($where)
+    if $ok && $where;
 
- $ok = $me->REST($where)
-       if $ok;
+ return undef
+    unless $ok;
+
+ $ftp->command($cmd,@_);
+
+ return 1
+    if(defined ${*$ftp}{'net_ftp_pasv'});
 
- $ok = $me->RETR($file)
-       if $ok;
+ $ok = CMD_INFO == $ftp->response();
 
- return $pasv ? $ok
-             : $ok ? $me->accept()
-                   : undef;
+ return $ok 
+    unless exists ${*$ftp}{'net_ftp_intern_port'};
+
+ $ok ? $ftp->_dataconn()
+     : undef;
 }
 
-sub cmd {
- my $me = shift;
+##
+## Over-ride methods (Net::Cmd)
+##
 
- $me->send_cmd(@_);
- $me->response();
+sub debug_text { $_[2] =~ /^(pass|resp)/i ? "$1 ....\n" : $_[2]; }
+
+sub command
+{
+ my $ftp = shift;
+
+ delete ${*$ftp}{'net_ftp_port'};
+ $ftp->SUPER::command(@_);
 }
 
-sub send_cmd {
- my $me = shift;
+sub response
+{
+ my $ftp = shift;
+ my $code = $ftp->SUPER::response();
+
+ delete ${*$ftp}{'net_ftp_pasv'}
+    if ($code != CMD_MORE && $code != CMD_INFO);
+
+ $code;
+}
 
- if(scalar(@_)) {     
-  my $cmd = join(" ", @_) . "\r\n";
+##
+## Allow 2 servers to talk directly
+##
 
-  delete ${*$me}{Pasv};
-  delete ${*$me}{Port};
+sub pasv_xfer
+{
+ my($sftp,$sfile,$dftp,$dfile) = @_;
 
-  syswrite($me,$cmd,length $cmd);
+ ($dfile = $sfile) =~ s#.*/##
+    unless(defined $dfile);
 
-  ${*$me}{State} = FTP_RESPONSE;
+ my $port = $sftp->pasv or
+    return undef;
 
-  printf STDERR "\n$me>> %s", $cmd=~/^(pass|resp)/i ? "$1 ....\n" : $cmd
-       if $me->debug;
- }
+ unless($dftp->port($port) && $sftp->retr($sfile) && $dftp->stou($dfile))
+  {
+   $sftp->abort;
+   $dftp->abort;
+   return undef;
+  }
 
- $me;
+ $dftp->pasv_wait($sftp);
 }
 
-sub pasv_wait {
- my $me = shift;
- my $non_pasv = shift;
- my $file;
+sub pasv_wait
+{
+ @_ == 2 or croak 'usage: $ftp->pasv_wait(NON_PASV_FTP)';
+
+ my($ftp, $non_pasv) = @_;
+ my($file,$rin,$rout);
 
- my($rin,$rout);
- vec($rin,fileno($me),1) = 1;
+ vec($rin,fileno($ftp),1) = 1;
  select($rout=$rin, undef, undef, undef);
 
- $me->response();
+ $ftp->response();
  $non_pasv->response();
 
  return undef
-       unless $me->ok() && $non_pasv->ok();
+       unless $ftp->ok() && $non_pasv->ok();
 
  return $1
-       if $me->message =~ /unique file name:\s*(\S*)\s*\)/;
+       if $ftp->message =~ /unique file name:\s*(\S*)\s*\)/;
 
  return $1
        if $non_pasv->message =~ /unique file name:\s*(\S*)\s*\)/;
@@ -623,152 +1122,102 @@ sub pasv_wait {
  return 1;
 }
 
-sub response {
- my $me = shift;
- my $timeout = ${*$me}{Timeout};
- my($code,$more,$rin,$rout,$partial,$buf) = (undef,0,'','','','');
+sub cmd { shift->command(@_)->responce() }
+
+########################################
+#
+# RFC959 commands
+#
+
+sub _ABOR { shift->command("ABOR")->response()  == CMD_OK }
+sub _CDUP { shift->command("CDUP")->response()  == CMD_OK }
+sub _NOOP { shift->command("NOOP")->response()  == CMD_OK }
+sub _PASV { shift->command("PASV")->response()  == CMD_OK }
+sub _QUIT { shift->command("QUIT")->response()  == CMD_OK }
+sub _DELE { shift->command("DELE",@_)->response() == CMD_OK }
+sub _CWD  { shift->command("CWD", @_)->response() == CMD_OK }
+sub _PORT { shift->command("PORT",@_)->response() == CMD_OK }
+sub _RMD  { shift->command("RMD", @_)->response() == CMD_OK }
+sub _MKD  { shift->command("MKD", @_)->response() == CMD_OK }
+sub _PWD  { shift->command("PWD", @_)->response() == CMD_OK }
+sub _TYPE { shift->command("TYPE",@_)->response() == CMD_OK }
+sub _RNTO { shift->command("RNTO",@_)->response() == CMD_OK }
+sub _ACCT { shift->command("ACCT",@_)->response() == CMD_OK }
+sub _RESP { shift->command("RESP",@_)->response() == CMD_OK }
+sub _MDTM { shift->command("MDTM",@_)->response() == CMD_OK }
+sub _SIZE { shift->command("SIZE",@_)->response() == CMD_OK }
+sub _APPE { shift->command("APPE",@_)->response() == CMD_INFO }
+sub _LIST { shift->command("LIST",@_)->response() == CMD_INFO }
+sub _NLST { shift->command("NLST",@_)->response() == CMD_INFO }
+sub _RETR { shift->command("RETR",@_)->response() == CMD_INFO }
+sub _STOR { shift->command("STOR",@_)->response() == CMD_INFO }
+sub _STOU { shift->command("STOU",@_)->response() == CMD_INFO }
+sub _RNFR { shift->command("RNFR",@_)->response() == CMD_MORE }
+sub _REST { shift->command("REST",@_)->response() == CMD_MORE }
+sub _USER { shift->command("user",@_)->response() } # A certain brain dead firewall :-)
+sub _PASS { shift->command("PASS",@_)->response() }
+sub _AUTH { shift->command("AUTH",@_)->response() }
+
+sub _ALLO { shift->unsupported(@_) }
+sub _SMNT { shift->unsupported(@_) }
+sub _HELP { shift->unsupported(@_) }
+sub _MODE { shift->unsupported(@_) }
+sub _SITE { shift->unsupported(@_) }
+sub _SYST { shift->unsupported(@_) }
+sub _STAT { shift->unsupported(@_) }
+sub _STRU { shift->unsupported(@_) }
+sub _REIN { shift->unsupported(@_) }
 
- @{*$me} = (); # the responce
- $buf = ${*$me};
- my @buf = ();
-
- vec($rin,fileno($me),1) = 1;
-
- do
-  {
-   if(length($buf) || ($timeout==0) || select($rout=$rin, undef, undef, $timeout))
-    {
-     unless(length($buf) || sysread($me, $buf, 1024))
-      {
-       carp "Unexpected EOF on command channel";
-       return undef;
-      } 
-
-     substr($buf,0,0) = $partial;    ## prepend from last sysread
-
-     @buf = split(/\r?\n/, $buf);  ## break into lines
-
-     $partial = (substr($buf, -1, 1) eq "\n") ? ''
-                                             : pop(@buf); 
-
-     $buf = "";
-
-     while (@buf)
-      {
-       my $cmd = shift @buf;
-       print STDERR "$me<< $cmd\n"
-        if $me->debug;
-       ($code,$more) = ($1,$2)
-       if $cmd =~ /^(\d\d\d)(.)/;
-
-       push(@{*$me},$');
-
-       last unless(defined $more && $more eq "-");
-      } 
-    }
-   else
-    {
-     carp "$me: Timeout" if($me->debug);
-     return undef;
-    }
-  }
- while((scalar(@{*$me}) == 0) || (defined $more && $more eq "-"));
-
- ${*$me} = @buf ? join("\n",@buf,"") : "";
- ${*$me} .= $partial;
-
- ${*$me}{Code} = $code;
- ${*$me}{State} = FTP_READY;
-
- substr($code,0,1);
-}
-
-;########################################
-;#
-;# RFC959 commands
-;#
-
-sub no_imp { croak "Not implemented\n"; }
-
-sub ABOR { shift->send_cmd("ABOR")->response() == 2}
-sub CDUP { shift->send_cmd("CDUP")->response() == 2}
-sub NOOP { shift->send_cmd("NOOP")->response() == 2}
-sub PASV { shift->send_cmd("PASV")->response() == 2}
-sub QUIT { shift->send_cmd("QUIT")->response() == 2}
-sub DELE { shift->send_cmd("DELE",@_)->response() == 2}
-sub CWD  { shift->send_cmd("CWD", @_)->response() == 2}
-sub PORT { shift->send_cmd("PORT",@_)->response() == 2}
-sub RMD  { shift->send_cmd("RMD", @_)->response() == 2}
-sub MKD  { shift->send_cmd("MKD", @_)->response() == 2}
-sub PWD  { shift->send_cmd("PWD", @_)->response() == 2}
-sub TYPE { shift->send_cmd("TYPE",@_)->response() == 2}
-sub APPE { shift->send_cmd("APPE",@_)->response() == 1}
-sub LIST { shift->send_cmd("LIST",@_)->response() == 1}
-sub NLST { shift->send_cmd("NLST",@_)->response() == 1}
-sub RETR { shift->send_cmd("RETR",@_)->response() == 1}
-sub STOR { shift->send_cmd("STOR",@_)->response() == 1}
-sub STOU { shift->send_cmd("STOU",@_)->response() == 1}
-sub RNFR { shift->send_cmd("RNFR",@_)->response() == 3}
-sub RNTO { shift->send_cmd("RNTO",@_)->response() == 2}
-sub ACCT { shift->send_cmd("ACCT",@_)->response() == 2}
-sub RESP { shift->send_cmd("RESP",@_)->response() == 2}
-sub REST { shift->send_cmd("REST",@_)->response() == 3}
-sub USER { my $ok = shift->send_cmd("USER",@_)->response();($ok == 2 || $ok == 3) ? $ok : 0;}
-sub PASS { my $ok = shift->send_cmd("PASS",@_)->response();($ok == 2 || $ok == 3) ? $ok : 0;}
-sub AUTH { my $ok = shift->send_cmd("AUTH",@_)->response();($ok == 2 || $ok == 3) ? $ok : 0;}
-
-sub ALLO { no_imp; }
-sub SMNT { no_imp; }
-sub HELP { no_imp; }
-sub MODE { no_imp; }
-sub SITE { no_imp; }
-sub SYST { no_imp; }
-sub STAT { no_imp; }
-sub STRU { no_imp; }
-sub REIN { no_imp; }
+##
+## Generic data connection package
+##
 
 package Net::FTP::dataconn;
+
 use Carp;
-no strict 'vars';
+use vars qw(@ISA $timeout);
+use Net::Cmd;
 
-sub abort {
- my $fd = shift;
- my $ftp = ${*$fd}{Cmd};
+@ISA = qw(IO::Socket::INET);
 
- $ftp->send_cmd("ABOR");
- $fd->close();
-}
+sub abort
+{
+ my $data = shift;
+ my $ftp  = ${*$data}{'net_ftp_cmd'};
 
-sub close {
- my $fd = shift;
- my $ftp = ${*$fd}{Cmd};
+ $ftp->abort; # this will close me
+}
 
- $fd->Net::Socket::close();
- delete ${*$ftp}{DATA};
+sub close
+{
+ my $data = shift;
+ my $ftp  = ${*$data}{'net_ftp_cmd'};
 
- $ftp->response();
-}
+ $data->SUPER::close();
 
-sub timeout {
- my $me = shift;
my $timeout = ${*$me}{Timeout};
+ delete ${*$ftp}{'net_ftp_dataconn'}
+    if exists ${*$ftp}{'net_ftp_dataconn'} &&
       $data == ${*$ftp}{'net_ftp_dataconn'};
 
- ${*$me}{Timeout} = 0 + shift if(@_);
+ $ftp->response() == CMD_OK &&
+    $ftp->message =~ /unique file name:\s*(\S*)\s*\)/ &&
+    (${*$ftp}{'net_ftp_unique'} = $1);
 
- $timeout;
+ $ftp->status == CMD_OK;
 }
 
-sub _select {
- my $fd = shift;
+sub _select
+{
+ my    $data   = shift;
  local *timeout = \$_[0]; shift;
- my $rw = shift;
+ my    $rw     = shift;
+
  my($rin,$win);
 
  return 1 unless $timeout;
 
  $rin = '';
- vec($rin,fileno($fd),1) = 1;
+ vec($rin,fileno($data),1) = 1;
 
  $win = $rw ? undef : $rin;
  $rin = undef unless $rw;
@@ -781,43 +1230,51 @@ sub _select {
  return $nfound;
 }
 
-sub can_read {
- my $fd = shift;
+sub can_read
+{
+ my    $data    = shift;
  local *timeout = \$_[0];
 
- $fd->_select($timeout,1);
+ $data->_select($timeout,1);
 }
 
-sub can_write {
- my $fd = shift;
+sub can_write
+{
+ my    $data    = shift;
  local *timeout = \$_[0];
 
- $fd->_select($timeout,0);
+ $data->_select($timeout,0);
 }
 
-sub cmd {
- my $me = shift;
+sub cmd
+{
+ my $ftp = shift;
 
- ${*$me}{Cmd};
+ ${*$ftp}{'net_ftp_cmd'};
 }
 
 
 @Net::FTP::L::ISA = qw(Net::FTP::I);
 @Net::FTP::E::ISA = qw(Net::FTP::I);
 
+##
+## Package to read/write on ASCII data connections
+##
+
 package Net::FTP::A;
-@Net::FTP::A::ISA = qw(Net::FTP::dataconn);
+
+use vars qw(@ISA $buf);
 use Carp;
 
-no strict 'vars';
+@ISA = qw(Net::FTP::dataconn);
 
-sub read {
- my $fd = shift;
local *buf = \$_[0]; shift;
my $size = shift || croak 'read($buf,$size,[$offset])';
- my $offset = shift || 0;
- my $timeout = ${*$fd}{Timeout};
- my $l;
+sub read
+{
my    $data   = shift;
local *buf    = \$_[0]; shift;
+ my    $size   = shift || croak 'read($buf,$size,[$offset])';
+ my    $offset         = shift || 0;
+ my    $timeout = $data->timeout;
 
  croak "Bad offset"
        if($offset < 0);
@@ -825,61 +1282,61 @@ sub read {
  $offset = length $buf
        if($offset > length $buf);
 
- $l = 0;
+ ${*$data} ||= "";
+ my $l = 0;
+
  READ:
   {
-   $fd->can_read($timeout) or
+   $data->can_read($timeout) or
        croak "Timeout";
 
-   my $n = sysread($fd, ${*$fd}, $size, length ${*$fd});
+   my $n = sysread($data, ${*$data}, $size, length ${*$data});
 
    return $n
        unless($n >= 0);
 
-#   my $lf = substr(${*$fd},-1,1) eq "\r" ? chop(${*$fd})
-#                                       : "";
-
-   my $lf = (length ${*$fd} > 0 && substr(${*$fd},-1,1) eq "\r") ? chop(${*$fd})
-                     : "";
+   ${*$data} =~ s/(\015)?(?!\012)\Z//so;
+   my $lf = $1 || "";
 
-   ${*$fd} =~ s/\r\n/\n/go;
+   ${*$data} =~ s/\015\012/\n/sgo;
 
-   substr($buf,$offset) = ${*$fd};
+   substr($buf,$offset) = ${*$data};
 
-   $l += length(${*$fd});
-   $offset += length(${*$fd});
+   $l += length(${*$data});
+   $offset += length(${*$data});
 
-   ${*$fd} = $lf;
+   ${*$data} = $lf;
    
    redo READ
      if($l == 0 && $n > 0);
 
    if($n == 0 && $l == 0)
     {
-     substr($buf,$offset) = ${*$fd};
-     ${*$fd} = "";
+     substr($buf,$offset) = ${*$data};
+     ${*$data} = "";
     }
   }
 
  return $l;
 }
 
-sub write {
- my $fd = shift;
- local *buf = \$_[0]; shift;
- my $size = shift || croak 'write($buf,$size,[$timeout])';
- my $timeout = @_ ? shift : ${*$fd}{Timeout};
+sub write
+{
+ my    $data   = shift;
+ local *buf    = \$_[0]; shift;
+ my    $size   = shift || croak 'write($buf,$size,[$timeout])';
+ my    $timeout = @_ ? shift : $data->timeout;
 
- $fd->can_write($timeout) or
+ $data->can_write($timeout) or
        croak "Timeout";
 
- # What is previous pkt ended in \r or not ??
+ # What is previous pkt ended in \015 or not ??
 
  my $tmp;
- ($tmp = $buf) =~ s/(?!\r)\n/\r\n/g;
+ ($tmp = $buf) =~ s/(?!\015)\012/\015\012/sg;
 
  my $len = $size + length($tmp) - length($buf);
- my $wrote = syswrite($fd, $tmp, $len);
+ my $wrote = syswrite($data, $tmp, $len);
 
  if($wrote >= 0)
   {
@@ -890,54 +1347,45 @@ sub write {
  return $wrote;
 }
 
+##
+## Package to read/write on BINARY data connections
+##
+
 package Net::FTP::I;
-@Net::FTP::I::ISA = qw(Net::FTP::dataconn);
+
+use vars qw(@ISA $buf);
 use Carp;
 
-no strict 'vars';
+@ISA = qw(Net::FTP::dataconn);
 
-sub read {
- my $fd = shift;
- local *buf = \$_[0]; shift;
- my $size = shift || croak 'read($buf,$size,[$timeout])';
- my $timeout = @_ ? shift : ${*$fd}{Timeout};
+sub read
+{
+ my    $data   = shift;
+ local *buf    = \$_[0]; shift;
+ my    $size    = shift || croak 'read($buf,$size,[$timeout])';
+ my    $timeout = @_ ? shift : $data->timeout;
 
- $fd->can_read($timeout) or
+ $data->can_read($timeout) or
        croak "Timeout";
 
- my $n = sysread($fd, $buf, $size);
+ my $n = sysread($data, $buf, $size);
 
  $n;
 }
 
-sub write {
- my $fd = shift;
- local *buf = \$_[0]; shift;
- my $size = shift || croak 'write($buf,$size,[$timeout])';
- my $timeout = @_ ? shift : ${*$fd}{Timeout};
+sub write
+{
+ my    $data    = shift;
+ local *buf     = \$_[0]; shift;
+ my    $size    = shift || croak 'write($buf,$size,[$timeout])';
+ my    $timeout = @_ ? shift : $data->timeout;
 
- $fd->can_write($timeout) or
+ $data->can_write($timeout) or
        croak "Timeout";
 
- syswrite($fd, $buf, $size);
+ syswrite($data, $buf, $size);
 }
 
-=head2 AUTHOR
-
-Graham Barr <Graham.Barr@tiuk.ti.com>
-
-=head2 REVISION
-
-$Revision: 1.17 $
-
-=head2 COPYRIGHT
-
-Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
-software; you can redistribute it and/or modify it under the same terms
-as Perl itself.
-
-=cut
-
 
 1;
 
diff --git a/lib/Net/NNTP.pm b/lib/Net/NNTP.pm
new file mode 100644 (file)
index 0000000..a23b9bb
--- /dev/null
@@ -0,0 +1,996 @@
+# Net::NNTP.pm
+#
+# Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
+# reserved. This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Net::NNTP;
+
+=head1 NAME
+
+Net::NNTP - NNTP Client class
+
+=head1 SYNOPSIS
+
+    use Net::NNTP;
+    
+    $nntp = Net::NNTP->new("some.host.name");
+    $nntp->quit;
+
+=head1 DESCRIPTION
+
+C<Net::NNTP> is a class implementing a simple NNTP client in Perl as described
+in RFC977. C<Net::NNTP> inherits its communication methods from C<Net::Cmd>
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( [ HOST ] [, OPTIONS ])
+
+This is the constructor for a new Net::NNTP object. C<HOST> is the
+name of the remote host to which a NNTP connection is required. If not
+given two environment variables are checked, first C<NNTPSERVER> then
+C<NEWSHOST>, if neither are set C<news> is used.
+
+C<OPTIONS> are passed in a hash like fasion, using key and value pairs.
+Possible options are:
+
+B<Timeout> - Maximum time, in seconds, to wait for a response from the
+NNTP server, a value of zero will cause all IO operations to block.
+(default: 120)
+
+B<Debug> - Enable the printing of debugging information to STDERR
+
+=back
+
+=head1 METHODS
+
+Unless otherwise stated all methods return either a I<true> or I<false>
+value, with I<true> meaning that the operation was a success. When a method
+states that it returns a value, falure will be returned as I<undef> or an
+empty list.
+
+=over 4
+
+=item article ( [ MSGID|MSGNUM ] )
+
+Retreive the header, a blank line, then the body (text) of the
+specified article. 
+
+If no arguments are passed then the current aricle in the current
+newsgroup is returned.
+
+C<MSGNUM> is a numeric id of an article in the
+current newsgroup, and will change the current article pointer.
+C<MSGID> is the message id of an article as
+shown in that article's header.  It is anticipated that the client
+will obtain the C<MSGID> from a list provided by the C<newnews>
+command, from references contained within another article, or from
+the message-id provided in the response to some other commands.
+
+Returns a reference to an array containing the article.
+
+=item body ( [ MSGID|MSGNUM ] )
+
+Retreive the body (text) of the specified article. 
+
+Takes the same arguments as C<article>
+
+Returns a reference to an array containing the body of the article.
+
+=item head ( [ MSGID|MSGNUM ] )
+
+Retreive the header of the specified article. 
+
+Takes the same arguments as C<article>
+
+Returns a reference to an array containing the header of the article.
+
+=item nntpstat ( [ MSGID|MSGNUM ] )
+
+The C<nntpstat> command is similar to the C<article> command except that no
+text is returned.  When selecting by message number within a group,
+the C<nntpstat> command serves to set the "current article pointer" without
+sending text.
+
+Using the C<nntpstat> command to
+select by message-id is valid but of questionable value, since a
+selection by message-id does B<not> alter the "current article pointer".
+
+Returns the message-id of the "current article".
+
+=item group ( [ GROUP ] )
+
+Set and/or get the current group. If C<GROUP> is not given then information
+is returned on the current group.
+
+In a scalar context it returns the group name.
+
+In an array context the return value is a list containing, the number
+of articles in the group, the number of the first article, the number
+of the last article and the group name.
+
+=item ihave ( MSGID [, MESSAGE ])
+
+The C<ihave> command informs the server that the client has an article
+whose id is C<MSGID>.  If the server desires a copy of that
+article, and C<MESSAGE> has been given the it will be sent.
+
+Returns I<true> if the server desires the article and C<MESSAGE> was
+successfully sent,if specified.
+
+If C<MESSAGE> is not specified then the message must be sent using the
+C<datasend> and C<dataend> methods from L<Net::Cmd>
+
+C<MESSAGE> can be either an array of lines or a reference to an array.
+
+=item last ()
+
+Set the "current article pointer" to the previous article in the current
+newsgroup.
+
+Returns the message-id of the article.
+
+=item date ()
+
+Returns the date on the remote server. This date will be in a UNIX time
+format (seconds since 1970)
+
+=item postok ()
+
+C<postok> will return I<true> if the servers initial response indicated
+that it will allow posting.
+
+=item authinfo ( USER, PASS )
+
+=item list ()
+
+Obtain information about all the active newsgroups. The results is a reference
+to a hash where the key is a group name and each value is a reference to an
+array. The elements in this array are:- the first article number in the group,
+the last article number in the group and any information flags about the group.
+
+=item newgroups ( SINCE [, DISTRIBUTIONS ])
+
+C<SINCE> is a time value and C<DISTRIBUTIONS> is either a distribution
+pattern or a reference to a list of distribution patterns.
+The result is the same as C<list>, but the
+groups return will be limited to those created after C<SINCE> and, if
+specified, in one of the distribution areas in C<DISTRIBUTIONS>. 
+
+=item newnews ( SINCE [, GROUPS [, DISTRIBUTIONS ]])
+
+C<SINCE> is a time value. C<GROUPS> is either a group pattern or a reference
+to a list of group patterns. C<DISTRIBUTIONS> is either a distribution
+pattern or a reference to a list of distribution patterns.
+
+Returns a reference to a list which contains the message-ids of all news posted
+after C<SINCE>, that are in a groups which matched C<GROUPS> and a
+distribution which matches C<DISTRIBUTIONS>.
+
+=item next ()
+
+Set the "current article pointer" to the next article in the current
+newsgroup.
+
+Returns the message-id of the article.
+
+=item post ( [ MESSAGE ] )
+
+Post a new article to the news server. If C<MESSAGE> is specified and posting
+is allowed then the message will be sent.
+
+If C<MESSAGE> is not specified then the message must be sent using the
+C<datasend> and C<dataend> methods from L<Net::Cmd>
+
+C<MESSAGE> can be either an array of lines or a reference to an array.
+
+=item slave ()
+
+Tell the remote server that I am not a user client, but probably another
+news server.
+
+=item quit ()
+
+Quit the remote server and close the socket connection.
+
+=back
+
+=head2 Extension methods
+
+These methods use commands that are not part of the RFC977 documentation. Some
+servers may not support all of them.
+
+=over 4
+
+=item newsgroups ( [ PATTERN ] )
+
+Returns a reference to a hash where the keys are all the group names which
+match C<PATTERN>, or all of the groups if no pattern is specified, and
+each value contains the description text for the group.
+
+=item distributions ()
+
+Returns a reference to a hash where the keys are all the possible
+distribution names and the values are the distribution descriptions.
+
+=item subscriptions ()
+
+Returns a reference to a list which contains a list of groups which
+are reccomended for a new user to subscribe to.
+
+=item overview_fmt ()
+
+Returns a reference to an array which contain the names of the fields returnd
+by C<xover>.
+
+=item active_times ()
+
+Returns a reference to a hash where the keys are the group names and each
+value is a reference to an array containg the time the groups was created
+and an identifier, possibly an Email address, of the creator.
+
+=item active ( [ PATTERN ] )
+
+Similar to C<list> but only active groups that match the pattern are returned.
+C<PATTERN> can be a group pattern.
+
+=item xgtitle ( PATTERN )
+
+Returns a reference to a hash where the keys are all the group names which
+match C<PATTERN> and each value is the description text for the group.
+
+=item xhdr ( HEADER, MESSAGE-RANGE )
+
+Obtain the header field C<HEADER> for all the messages specified. 
+
+Returns a reference to a hash where the keys are the message numbers and
+each value contains the header for that message.
+
+=item xover ( MESSAGE-RANGE )
+
+Returns a reference to a hash where the keys are the message numbers and each
+value is a reference to an array which contains the overview fields for that
+message. The names of these fields can be obtained by calling C<overview_fmt>.
+
+=item xpath ( MESSAGE-ID )
+
+Returns the path name to the file on the server which contains the specified
+message.
+
+=item xpat ( HEADER, PATTERN, MESSAGE-RANGE)
+
+The result is the same as C<xhdr> except the is will be restricted to
+headers that match C<PATTERN>
+
+=item xrover
+
+=item listgroup
+
+=item reader
+
+=back
+
+=head1 UNSUPPORTED
+
+The following NNTP command are unsupported by the package, and there are
+no plans to do so.
+
+    AUTHINFO GENERIC
+    XTHREAD
+    XSEARCH
+    XINDEX
+
+=head1 DEFINITIONS
+
+=over 4
+
+=item MESSAGE-RANGE
+
+C<MESSAGE-RANGE> is either a single message-id, a single mesage number, or
+two message numbers.
+
+If C<MESSAGE-RANGE> is two message numbers and the second number in a
+range is less than or equal to the first then the range represents all
+messages in the group after the first message number.
+
+=item PATTERN
+
+The C<NNTP> protocol uses the C<WILDMAT> format for patterns.
+The WILDMAT format was first developed by Rich Salz based on
+the format used in the UNIX "find" command to articulate
+file names. It was developed to provide a uniform mechanism
+for matching patterns in the same manner that the UNIX shell
+matches filenames.
+
+Patterns are implicitly anchored at the
+beginning and end of each string when testing for a match.
+
+There are five pattern matching operations other than a strict
+one-to-one match between the pattern and the source to be
+checked for a match.
+
+The first is an asterisk C<*> to match any sequence of zero or more
+characters.
+
+The second is a question mark C<?> to match any single character. The
+third specifies a specific set of characters.
+
+The set is specified as a list of characters, or as a range of characters
+where the beginning and end of the range are separated by a minus (or dash)
+character, or as any combination of lists and ranges. The dash can
+also be included in the set as a character it if is the beginning
+or end of the set. This set is enclosed in square brackets. The
+close square bracket C<]> may be used in a set if it is the first
+character in the set.
+
+The fourth operation is the same as the
+logical not of the third operation and is specified the same
+way as the third with the addition of a caret character C<^> at
+the beginning of the test string just inside the open square
+bracket.
+
+The final operation uses the backslash character to
+invalidate the special meaning of the a open square bracket C<[>,
+the asterisk, backslash or the question mark. Two backslashes in
+sequence will result in the evaluation of the backslash as a
+character with no special meaning.
+
+=over 4
+
+=item Examples
+
+=item C<[^]-]>
+
+matches any single character other than a close square
+bracket or a minus sign/dash.
+
+=item C<*bdc>
+
+matches any string that ends with the string "bdc"
+including the string "bdc" (without quotes).
+
+=item C<[0-9a-zA-Z]>
+
+matches any single printable alphanumeric ASCII character.
+
+=item C<a??d>
+
+matches any four character string which begins
+with a and ends with d.
+
+=back
+
+=back
+
+=head1 SEE ALSO
+
+L<Net::Cmd>
+
+=head1 AUTHOR
+
+Graham Barr <Graham.Barr@tiuk.ti.com>
+
+=head1 REVISION
+
+$Revision: 2.5 $
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
+software; you can redistribute it and/or modify it under the same terms
+as Perl itself.
+
+=cut
+
+use strict;
+use vars qw(@ISA $VERSION $debug);
+use IO::Socket;
+use Net::Cmd;
+use Carp;
+
+$VERSION = sprintf("%d.%02d", q$Revision: 2.5 $ =~ /(\d+)\.(\d+)/);
+@ISA     = qw(Net::Cmd IO::Socket::INET);
+
+sub new
+{
+ my $self = shift;
+ my $type = ref($self) || $self;
+ my $host = shift if @_ % 2;
+ my %arg  = @_;
+
+ $host ||= $ENV{NNTPSERVER} || $ENV{NEWSHOST} || "news";
+
+ my $obj = $type->SUPER::new(PeerAddr => $host, 
+                            PeerPort => $arg{Port} || 'nntp(119)',
+                            Proto    => 'tcp',
+                            Timeout  => defined $arg{Timeout}
+                                               ? $arg{Timeout}
+                                               : 120
+                           ) or return undef;
+
+ ${*$obj}{'net_nntp_host'} = $host;
+
+ $obj->autoflush(1);
+ $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
+
+ unless ($obj->response() == CMD_OK)
+  {
+   $obj->close();
+   return undef;
+  }
+
+ my $c = $obj->code;
+ ${*$obj}{'net_nntp_post'} = $c >= 200 && $c <= 209 ? 1 : 0;
+
+ $obj;
+}
+
+sub debug_text
+{
+ my $nntp = shift;
+ my $inout = shift;
+ my $text = shift;
+
+ if(($nntp->code == 350 && $text =~ /^(\S+)/)
+    || ($text =~ /^(authinfo\s+pass)/io)) 
+  {
+   $text = "$1 ....\n"
+  }
+
+ $text;
+}
+
+sub postok
+{
+ @_ == 1 or croak 'usage: $nntp->postok()';
+ my $nntp = shift;
+ ${*$nntp}{'net_nntp_post'} || 0;
+}
+
+sub article
+{
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->article( MSGID )';
+ my $nntp = shift;
+
+ $nntp->_ARTICLE(@_)
+    ? $nntp->read_until_dot()
+    : undef;
+}
+
+sub authinfo
+{
+ @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )';
+ my($nntp,$user,$pass) = @_;
+
+ $nntp->_AUTHINFO("USER",$user) == CMD_MORE 
+    && $nntp->_AUTHINFO("PASS",$pass) == CMD_OK;
+}
+
+sub authinfo_simple
+{
+ @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )';
+ my($nntp,$user,$pass) = @_;
+
+ $nntp->_AUTHINFO('SIMPLE') == CMD_MORE 
+    && $nntp->command($user,$pass)->response == CMD_OK;
+}
+
+sub body
+{
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->body( [ MSGID ] )';
+ my $nntp = shift;
+
+ $nntp->_BODY(@_)
+    ? $nntp->read_until_dot()
+    : undef;
+}
+
+sub head
+{
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->head( [ MSGID ] )';
+ my $nntp = shift;
+
+ $nntp->_HEAD(@_)
+    ? $nntp->read_until_dot()
+    : undef;
+}
+
+sub nntpstat
+{
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->nntpstat( [ MSGID ] )';
+ my $nntp = shift;
+
+ $nntp->_STAT(@_) && $nntp->message =~ /(<[^>]+>)/o
+    ? $1
+    : undef;
+}
+
+
+sub group
+{
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->group( [ GROUP ] )';
+ my $nntp = shift;
+ my $grp = ${*$nntp}{'net_nntp_group'} || undef;
+
+ return $grp
+    unless(@_ || wantarray);
+
+ my $newgrp = shift;
+
+ return wantarray ? () : undef
+       unless $nntp->_GROUP($newgrp || $grp || "")
+               && $nntp->message =~ /(\d+)\s+(\d+)\s+(\d+)\s+(\S+)/;
+
+ my($count,$first,$last,$group) = ($1,$2,$3,$4);
+
+ # group may be replied as '(current group)'
+ $group = ${*$nntp}{'net_nntp_group'}
+    if $group =~ /\(/;
+
+ ${*$nntp}{'net_nntp_group'} = $group;
+
+ wantarray
+    ? ($count,$first,$last,$group)
+    : $group;
+}
+
+sub help
+{
+ @_ == 1 or croak 'usage: $nntp->help()';
+ my $nntp = shift;
+
+ $nntp->_HELP
+    ? $nntp->read_until_dot
+    : undef;
+}
+
+sub ihave
+{
+ @_ >= 2 or croak 'usage: $nntp->ihave( MESSAGE-ID [, MESSAGE ])';
+ my $nntp = shift;
+ my $mid = shift;
+
+ $nntp->_IHAVE($mid) && $nntp->datasend(@_)
+    ? @_ == 0 || $nntp->dataend
+    : undef;
+}
+
+sub last
+{
+ @_ == 1 or croak 'usage: $nntp->last()';
+ my $nntp = shift;
+
+ $nntp->_LAST && $nntp->message =~ /(<[^>]+>)/o
+    ? $1
+    : undef;
+}
+
+sub list
+{
+ @_ == 1 or croak 'usage: $nntp->list()';
+ my $nntp = shift;
+
+ $nntp->_LIST
+    ? $nntp->_grouplist
+    : undef;
+}
+
+sub newgroups
+{
+ @_ >= 2 or croak 'usage: $nntp->newgroups( SINCE [, DISTRIBUTIONS ])';
+ my $nntp = shift;
+ my $time = _timestr(shift);
+ my $dist = shift || "";
+
+ $dist = join(",", @{$dist})
+    if ref($dist);
+
+ $nntp->_NEWGROUPS($time,$dist)
+    ? $nntp->_grouplist
+    : undef;
+}
+
+sub newnews
+{
+ @_ >= 3 or croak 'usage: $nntp->newnews( SINCE [, GROUPS [, DISTRIBUTIONS ]])';
+ my $nntp = shift;
+ my $time = _timestr(shift);
+ my $grp  = @_ ? shift : $nntp->group;
+ my $dist = shift || "";
+
+ $grp ||= "*";
+ $grp = join(",", @{$grp})
+    if ref($grp);
+
+ $dist = join(",", @{$dist})
+    if ref($dist);
+
+ $nntp->_NEWNEWS($grp,$time,$dist)
+    ? $nntp->_articlelist
+    : undef;
+}
+
+sub next
+{
+ @_ == 1 or croak 'usage: $nntp->next()';
+ my $nntp = shift;
+
+ $nntp->_NEXT && $nntp->message =~ /(<[^>]+>)/o
+    ? $1
+    : undef;
+}
+
+sub post
+{
+ @_ >= 1 or croak 'usage: $nntp->post( [ MESSAGE ] )';
+ my $nntp = shift;
+
+ $nntp->_POST() && $nntp->datasend(@_)
+    ? @_ == 0 || $nntp->dataend
+    : undef;
+}
+
+sub quit
+{
+ @_ == 1 or croak 'usage: $nntp->quit()';
+ my $nntp = shift;
+
+ $nntp->_QUIT && $nntp->SUPER::close;
+}
+
+sub slave
+{
+ @_ == 1 or croak 'usage: $nntp->slave()';
+ my $nntp = shift;
+
+ $nntp->_SLAVE;
+}
+
+##
+## The following methods are not implemented by all servers
+##
+
+sub active
+{
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->active( [ PATTERN ] )';
+ my $nntp = shift;
+
+ $nntp->_LIST('ACTIVE',@_)
+    ? $nntp->_grouplist
+    : undef;
+}
+
+sub active_times
+{
+ @_ == 1 or croak 'usage: $nntp->active_times()';
+ my $nntp = shift;
+
+ $nntp->_LIST('ACTIVE.TIMES')
+    ? $nntp->_grouplist
+    : undef;
+}
+
+sub distributions
+{
+ @_ == 1 or croak 'usage: $nntp->distributions()';
+ my $nntp = shift;
+
+ $nntp->_LIST('DISTRIBUTIONS')
+    ? $nntp->_description
+    : undef;
+}
+
+sub distribution_patterns
+{
+ @_ == 1 or croak 'usage: $nntp->distributions()';
+ my $nntp = shift;
+
+ my $arr;
+ local $_;
+
+ $nntp->_LIST('DISTRIB.PATS') && ($arr = $nntp->read_until_dot)
+    ? [grep { /^\d/ && (chomp, $_ = [ split /:/ ]) } @$arr]
+    : undef;
+}
+
+sub newsgroups
+{
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->newsgroups( [ PATTERN ] )';
+ my $nntp = shift;
+
+ $nntp->_LIST('NEWSGROUPS',@_)
+    ? $nntp->_description
+    : undef;
+}
+
+sub overview_fmt
+{
+ @_ == 1 or croak 'usage: $nntp->overview_fmt()';
+ my $nntp = shift;
+
+ $nntp->_LIST('OVERVIEW.FMT')
+     ? $nntp->_articlelist
+     : undef;
+}
+
+sub subscriptions
+{
+ @_ == 1 or croak 'usage: $nntp->subscriptions()';
+ my $nntp = shift;
+
+ $nntp->_LIST('SUBSCRIPTIONS')
+    ? $nntp->_articlelist
+    : undef;
+}
+
+sub listgroup
+{
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->listgroup( [ GROUP ] )';
+ my $nntp = shift;
+
+ $nntp->_LISTGROUP(@_)
+    ? $nntp->_articlelist
+    : undef;
+}
+
+sub reader
+{
+ @_ == 1 or croak 'usage: $nntp->reader()';
+ my $nntp = shift;
+
+ $nntp->_MODE('READER');
+}
+
+sub xgtitle
+{
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->xgtitle( [ PATTERN ] )';
+ my $nntp = shift;
+
+ $nntp->_XGTITLE(@_)
+    ? $nntp->_description
+    : undef;
+}
+
+sub xhdr
+{
+ @_ >= 2 && @_ <= 4 or croak 'usage: $nntp->xhdr( HEADER, [ MESSAGE-ID | MESSAGE_NUM [, MESSAGE-NUM ]] )';
+ my($nntp,$hdr,$first) = splice(@_,0,3);
+
+ my $arg = "$first";
+
+ if(@_)
+  {
+   my $last = shift;
+
+   $arg .= "-";
+   $arg .= "$last"
+       if(defined $last && $last > $first);
+  }
+
+ $nntp->_XHDR($hdr, $arg)
+    ? $nntp->_description
+    : undef;
+}
+
+sub xover
+{
+ @_ == 2 || @_ == 3 or croak 'usage: $nntp->xover( RANGE )';
+ my($nntp,$first) = splice(@_,0,2);
+
+ my $arg = "$first";
+
+ if(@_)
+  {
+   my $last = shift;
+   $arg .= "-";
+   $arg .= "$last"
+       if(defined $last && $last > $first);
+  }
+
+ $nntp->_XOVER($arg)
+    ? $nntp->_fieldlist
+    : undef;
+}
+
+sub xpat
+{
+ @_ == 4 || @_ == 5 or croak '$nntp->xpat( HEADER, PATTERN, RANGE )';
+ my($nntp,$hdr,$pat,$first) = splice(@_,0,4);
+
+ my $arg = "$first";
+
+ if(@_)
+  {
+   my $last = shift;
+   $arg .= "-";
+   $arg .= "$last"
+       if(defined $last && $last > $first);
+  }
+
+ $pat = join(" ", @$pat)
+    if ref($pat);
+
+ $nntp->_XPAT($hdr,$arg,$pat)
+    ? $nntp->_description
+    : undef;
+}
+
+sub xpath
+{
+ @_ == 2 or croak 'usage: $nntp->xpath( MESSAGE-ID )';
+ my($nntp,$mid) = @_;
+
+ return undef
+       unless $nntp->_XPATH($mid);
+
+ my $m; ($m = $nntp->message) =~ s/^\d+\s+//o;
+ my @p = split /\s+/, $m;
+
+ wantarray ? @p : $p[0];
+}
+
+sub xrover
+{
+ @_ == 2 || @_ == 3 or croak 'usage: $nntp->xrover( RANGE )';
+ my($nntp,$first) = splice(@_,0,2);
+
+ my $arg = "$first";
+
+ if(@_)
+  {
+   my $last = shift;
+
+   $arg .= "-";
+   $arg .= "$last"
+       if(defined $last && $last > $first);
+  }
+
+ $nntp->_XROVER($arg)
+    ? $nntp->_fieldlist
+    : undef;
+}
+
+sub date
+{
+ @_ == 1 or croak 'usage: $nntp->date()';
+ my $nntp = shift;
+
+ $nntp->_DATE && $nntp->message =~ /(\d{4})(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/
+    ? timegm($6,$5,$4,$3,$2-1,$1)
+    : undef;
+}
+
+
+##
+## Private subroutines
+##
+
+sub _timestr
+{
+ my $time = shift;
+ my @g = reverse((gmtime($time))[0..5]);
+ $g[1] += 1;
+ $g[0] %= 100;
+ sprintf "%02d%02d%02d %02d%02d%02d GMT", @g;
+}
+
+sub _grouplist
+{
+ my $nntp = shift;
+ my $arr = $nntp->read_until_dot or
+    return undef;
+
+ my $hash = {};
+ my $ln;
+
+ foreach $ln (@$arr)
+  {
+   my @a = split(/[\s\n]+/,$ln);
+   $hash->{$a[0]} = [ @a[1,2,3] ];
+  }
+
+ $hash;
+}
+
+sub _fieldlist
+{
+ my $nntp = shift;
+ my $arr = $nntp->read_until_dot or
+    return undef;
+
+ my $hash = {};
+ my $ln;
+
+ foreach $ln (@$arr)
+  {
+   my @a = split(/[\t\n]/,$ln);
+   $hash->{$a[0]} = @a[1,2,3];
+  }
+
+ $hash;
+}
+
+sub _articlelist
+{
+ my $nntp = shift;
+ my $arr = $nntp->read_until_dot;
+
+ chomp(@$arr)
+    if $arr;
+
+ $arr;
+}
+
+sub _description
+{
+ my $nntp = shift;
+ my $arr = $nntp->read_until_dot or
+    return undef;
+
+ my $hash = {};
+ my $ln;
+
+ foreach $ln (@$arr)
+  {
+   chomp($ln);
+
+   $hash->{$1} = $ln
+    if $ln =~ s/^\s*(\S+)\s*//o;
+  }
+
+ $hash;
+
+}
+
+##
+## The commands
+##
+
+sub _ARTICLE   { shift->command('ARTICLE',@_)->response == CMD_OK }
+sub _AUTHINFO  { shift->command('AUTHINFO',@_)->response }
+sub _BODY      { shift->command('BODY',@_)->response == CMD_OK }
+sub _DATE      { shift->command('DATE')->response == CMD_INFO }
+sub _GROUP     { shift->command('GROUP',@_)->response == CMD_OK }
+sub _HEAD      { shift->command('HEAD',@_)->response == CMD_OK }
+sub _HELP      { shift->command('HELP',@_)->response == CMD_INFO }
+sub _IHAVE     { shift->command('IHAVE',@_)->response == CMD_MORE }
+sub _LAST      { shift->command('LAST')->response == CMD_OK }
+sub _LIST      { shift->command('LIST',@_)->response == CMD_OK }
+sub _LISTGROUP { shift->command('LISTGROUP',@_)->response == CMD_OK }
+sub _NEWGROUPS { shift->command('NEWGROUPS',@_)->response == CMD_OK }
+sub _NEWNEWS   { shift->command('NEWNEWS',@_)->response == CMD_OK }
+sub _NEXT      { shift->command('NEXT')->response == CMD_OK }
+sub _POST      { shift->command('POST',@_)->response == CMD_OK }
+sub _QUIT      { shift->command('QUIT',@_)->response == CMD_OK }
+sub _SLAVE     { shift->command('SLAVE',@_)->response == CMD_OK }
+sub _STAT      { shift->command('STAT',@_)->response == CMD_OK }
+sub _MODE      { shift->command('MODE',@_)->response == CMD_OK }
+sub _XGTITLE   { shift->command('XGTITLE',@_)->response == CMD_OK }
+sub _XHDR      { shift->command('XHDR',@_)->response == CMD_OK }
+sub _XPAT      { shift->command('XPAT',@_)->response == CMD_OK }
+sub _XPATH     { shift->command('XPATH',@_)->response == CMD_OK }
+sub _XOVER     { shift->command('XOVER',@_)->response == CMD_OK }
+sub _XROVER    { shift->command('XROVER',@_)->response == CMD_OK }
+sub _XTHREAD   { shift->unsupported }
+sub _XSEARCH   { shift->unsupported }
+sub _XINDEX    { shift->unsupported }
+
+##
+## IO/perl methods
+##
+
+sub close
+{
+ my $nntp = shift;
+
+ ref($nntp) 
+    && defined fileno($nntp)
+    && $nntp->quit;
+}
+
+sub DESTROY { shift->close }
+
+
+1;
index 58f0663..4299821 100644 (file)
+# Net::Netrc.pm
+#
+# Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
+# reserved. This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
 package Net::Netrc;
 
+=head1 NAME
+
+Net::Netrc - OO interface to users netrc file
+
+=head1 SYNOPSIS
+
+    use Net::Netrc;
+    
+    $mach = Net::Netrc->lookup('some.machine');
+    $login = $mach->login;
+    ($login, $password, $account) = $mach->lpa;
+
+=head1 DESCRIPTION
+
+C<Net::Netrc> is a class implementing a simple interface to the .netrc file
+used as by the ftp program.
+
+C<Net::Netrc> also implements security checks just like the ftp program,
+these checks are, first that the .netrc file must be owned by the user and 
+second the ownership permissions should be such that only the owner has
+read and write access. If these conditions are not met then a warning is
+output and the .netrc file is not read.
+
+=head1 THE .netrc FILE
+
+The .netrc file contains login and initialization information used by the
+auto-login process.  It resides in the user's home directory.  The following
+tokens are recognized; they may be separated by spaces, tabs, or new-lines:
+
+=over 4
+
+=item machine name
+
+Identify a remote machine name. The auto-login process searches
+the .netrc file for a machine token that matches the remote machine
+specified.  Once a match is made, the subsequent .netrc tokens
+are processed, stopping when the end of file is reached or an-
+other machine or a default token is encountered.
+
+=item default
+
+This is the same as machine name except that default matches
+any name.  There can be only one default token, and it must be
+after all machine tokens.  This is normally used as:
+
+    default login anonymous password user@site
+
+thereby giving the user automatic anonymous login to machines
+not specified in .netrc.
+
+=item login name
+
+Identify a user on the remote machine.  If this token is present,
+the auto-login process will initiate a login using the
+specified name.
+
+=item password string
+
+Supply a password.  If this token is present, the auto-login
+process will supply the specified string if the remote server
+requires a password as part of the login process.
+
+=item account string
+
+Supply an additional account password.  If this token is present,
+the auto-login process will supply the specified string
+if the remote server requires an additional account password.
+
+=item macdef name
+
+Define a macro. C<Net::Netrc> only parses this field to be compatible
+with I<ftp>.
+
+=back
+
+=head1 CONSTRUCTOR
+
+The constructor for a C<Net::Netrc> object is not called new as it does not
+really create a new object. But instead is called C<lookup> as this is
+essentially what it deos.
+
+=over 4
+
+=item lookup ( MACHINE [, LOGIN ])
+
+Lookup and return a reference to the entry for C<MACHINE>. If C<LOGIN> is given
+then the entry returned will have the given login. If C<LOGIN> is not given then
+the first entry in the .netrc file for C<MACHINE> will be returned.
+
+If a matching entry cannot be found, and a default entry exists, then a
+reference to the default entry is returned.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item login ()
+
+Return the login id for the netrc entry
+
+=item password ()
+
+Return the password for the netrc entry
+
+=item account ()
+
+Return the account information for the netrc entry
+
+=item lpa ()
+
+Return a list of login, password and account information fir the netrc entry
+
+=back
+
+=head1 AUTHOR
+
+Graham Barr <Graham.Barr@tiuk.ti.com>
+
+=head1 REVISION
+
+$Revision: 2.1 $
+
+=head1 SEE ALSO
+
+L<Net::Netrc>
+L<Net::Cmd>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
+software; you can redistribute it and/or modify it under the same terms
+as Perl itself.
+
+=cut
+
 use Carp;
 use strict;
+use FileHandle;
+use vars qw($VERSION);
+
+$VERSION = sprintf("%d.%02d", q$Revision: 2.1 $ =~ /(\d+)\.(\d+)/);
 
 my %netrc = ();
 
-sub _readrc {
+sub _readrc
+{
  my $host = shift;
- my $file = (getpwuid($>))[7] . "/.netrc";
+
+ # Some OS's don't have `getpwuid', so we default to $ENV{HOME}
+ my $home = eval { (getpwuid($>))[7] } || $ENV{HOME};
+ my $file = $home . "/.netrc";
+
  my($login,$pass,$acct) = (undef,undef,undef);
local *NETRC;
my $fh;
  local $_;
 
  $netrc{default} = undef;
 
- my @stat = stat($file);
+ # OS/2 does not handle stat in a way compatable with this check :-(
+ unless($^O eq 'os2')
+  { 
+   my @stat = stat($file);
 
- if(@stat)
-  {
-   if($stat[2] & 077)
+   if(@stat)
     {
-     carp "Bad permissions: $file";
-     return ();
-    }
-   if($stat[4] != $<)
-    {
-     carp "Not owner: $file";
-     return ();
+     if($stat[2] & 077)
+      {
+       carp "Bad permissions: $file";
+       return;
+      }
+     if($stat[4] != $<)
+      {
+       carp "Not owner: $file";
+       return;
+      }
     }
   }
 
- if(open(NETRC,$file))
+ if($fh = FileHandle->new($file,"r"))
   {
    my($mach,$macdef,$tok,@tok) = (0,0);
 
-   while(<NETRC>) 
+   while(<$fh>)
     {
      undef $macdef if /\A\n\Z/;
 
@@ -50,72 +206,109 @@ TOKEN:
      while(@tok)
       {
        if($tok[0] eq "default")
-       {
-        shift(@tok);
-         $mach = $netrc{default} = {};
+        {
+         shift(@tok);
+         $mach = bless {};
+        $netrc{default} = [$mach];
+
+         next TOKEN;
+        }
 
-        next TOKEN;
-       }
+       last TOKEN
+            unless @tok > 1;
 
-       last TOKEN unless @tok > 1;
        $tok = shift(@tok);
 
        if($tok eq "machine")
-       {
+        {
          my $host = shift @tok;
-         $mach = $netrc{$host} = {};
-       }
+         $mach = bless {machine => $mach};
+
+         $netrc{$host} = []
+            unless exists($netrc{$host});
+         push(@{$netrc{$host}}, $mach);
+        }
        elsif($tok =~ /^(login|password|account)$/)
-       {
+        {
          next TOKEN unless $mach;
          my $value = shift @tok;
          $mach->{$1} = $value;
-       }
+        }
        elsif($tok eq "macdef")
-       {
+        {
          next TOKEN unless $mach;
          my $value = shift @tok;
-         $mach->{macdef} = {} unless exists $mach->{macdef};
+         $mach->{macdef} = {}
+            unless exists $mach->{macdef};
          $macdef = $mach->{machdef}{$value} = [];
-       }
+        }
       }
     }
-   close(NETRC);
+   $fh->close();
   }
 }
 
-sub lookup {
- my $pkg = shift;
- my $mach = shift;
+sub lookup
+{
+ my($pkg,$mach,$login) = @_;
+
+ _readrc()
+    unless exists $netrc{default};
 
- _readrc() unless exists $netrc{default};
+ $mach ||= 'default';
+ undef $login
+    if $mach eq 'default';
 
- return bless \$mach if exists $netrc{$mach};
+ if(exists $netrc{$mach})
+  {
+   if(defined $login)
+    {
+     my $m;
+     foreach $m (@{$netrc{$mach}})
+      {
+       return $m
+            if(exists $m->{login} && $m->{login} eq $login);
+      }
+     return undef;
+    }
+   return $netrc{$mach}->[0]
+  }
 
- return bless \("default") if defined $netrc{default};
+ return $netrc{default}
+    if defined $netrc{default};
 
  return undef;
 }
 
-sub login {
+sub login
+{
  my $me = shift;
- $me = $netrc{$$me};
- exists $me->{login} ? $me->{login} : undef;
+
+ exists $me->{login}
+    ? $me->{login}
+    : undef;
 }
 
-sub account {
+sub account
+{
  my $me = shift;
- $me = $netrc{$$me};
- exists $me->{account} ? $me->{account} : undef;
+
+ exists $me->{account}
+    ? $me->{account}
+    : undef;
 }
 
-sub password {
+sub password
+{
  my $me = shift;
- $me = $netrc{$$me};
- exists $me->{password} ? $me->{password} : undef;
+
+ exists $me->{password}
+    ? $me->{password}
+    : undef;
 }
 
-sub lpa {
+sub lpa
+{
  my $me = shift;
  ($me->login, $me->password, $me->account);
 }
diff --git a/lib/Net/POP3.pm b/lib/Net/POP3.pm
new file mode 100644 (file)
index 0000000..538039e
--- /dev/null
@@ -0,0 +1,402 @@
+# Net::POP3.pm
+#
+# Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
+# reserved. This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Net::POP3;
+
+=head1 NAME
+
+Net::POP3 - Post Office Protocol 3 Client class (RFC1081)
+
+=head1 SYNOPSIS
+
+    use Net::POP3;
+    
+    # Constructors
+    $pop = Net::POP3->new('pop3host');
+    $pop = Net::POP3->new('pop3host', Timeout => 60);
+
+=head1 DESCRIPTION
+
+This module implements a client interface to the POP3 protocol, enabling
+a perl5 application to talk to POP3 servers. This documentation assumes
+that you are familiar with the POP3 protocol described in RFC1081.
+
+A new Net::POP3 object must be created with the I<new> method. Once
+this has been done, all POP3 commands are accessed via method calls
+on the object.
+
+=head1 EXAMPLES
+
+    Need some small examples in here :-)
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( HOST, [ OPTIONS ] )
+
+This is the constructor for a new Net::POP3 object. C<HOST> is the
+name of the remote host to which a POP3 connection is required.
+
+C<OPTIONS> are passed in a hash like fasion, using key and value pairs.
+Possible options are:
+
+B<Timeout> - Maximum time, in seconds, to wait for a response from the
+POP3 server (default: 120)
+
+B<Debug> - Enable debugging information
+
+=back
+
+=head1 METHODS
+
+Unless otherwise stated all methods return either a I<true> or I<false>
+value, with I<true> meaning that the operation was a success. When a method
+states that it returns a value, falure will be returned as I<undef> or an
+empty list.
+
+=over 4
+
+=item user ( USER )
+
+Send the USER command.
+
+=item pass ( PASS )
+
+Send the PASS command. Returns the number of messages in the mailbox.
+
+=item login ( [ USER [, PASS ]] )
+
+Send both the the USER and PASS commands. If C<PASS> is not given the
+C<Net::POP3> uses C<Net::Netrc> to lookup the password using the host
+and username. If the username is not specified then the current user name
+will be used.
+
+Returns the number of messages in the mailbox.
+
+=item top ( MSGNUM [, NUMLINES ] )
+
+Get the header and the first C<NUMLINES> of the body for the message
+C<MSGNUM>. Returns a reference to an array which contains the lines of text
+read from the server.
+
+=item list ( [ MSGNUM ] )
+
+If called with an argument the C<list> returns the size of the messsage
+in octets.
+
+If called without arguments the a refererence to a hash is returned. The
+keys will be the C<MSGNUM>'s of all undeleted messages and the values will
+be their size in octets.
+
+=item get ( MSGNUM )
+
+Get the message C<MSGNUM> from the remote mailbox. Returns a reference to an
+array which contains the lines of text read from the server.
+
+=item last ()
+
+Returns the highest C<MSGNUM> of all the messages accessed.
+
+=item popstat ()
+
+Returns an array of two elements. These are the number of undeleted
+elements and the size of the mbox in octets.
+
+=item delete ( MSGNUM )
+
+Mark message C<MSGNUM> to be deleted from the remote mailbox. All messages
+that are marked to be deleted will be removed from the remote mailbox
+when the server connection closed.
+
+=item reset ()
+
+Reset the status of the remote POP3 server. This includes reseting the
+status of all messages to not be deleted.
+
+=item quit ()
+
+Quit and close the connection to the remote POP3 server. Any messages marked
+as deleted will be deleted from the remote mailbox.
+
+=back
+
+=head1 NOTES
+
+If a C<Net::POP3> object goes out of scope before C<quit> method is called
+then the C<reset> method will called before the connection is closed. This
+means that any messages marked to be deleted will not be.
+
+=head1 SEE ALSO
+
+L<Net::Netrc>
+L<Net::Cmd>
+
+=head1 AUTHOR
+
+Graham Barr <Graham.Barr@tiuk.ti.com>
+
+=head1 REVISION
+
+$Revision: 2.1 $
+$Date: 1996/07/26 06:44:44 $
+
+The VERSION is derived from the revision by changing each number after the
+first dot into a 2 digit number so
+
+       Revision 1.8   => VERSION 1.08
+       Revision 1.2.3 => VERSION 1.0203
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
+software; you can redistribute it and/or modify it under the same terms
+as Perl itself.
+
+=cut
+
+use strict;
+use IO::Socket;
+use vars qw(@ISA $VERSION $debug);
+use Net::Cmd;
+use Carp;
+
+$VERSION = do{my @r=(q$Revision: 2.1 $=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r};
+
+@ISA = qw(Net::Cmd IO::Socket::INET);
+
+sub new
+{
+ my $self = shift;
+ my $type = ref($self) || $self;
+ my $host = shift;
+ my %arg  = @_; 
+ my $obj = $type->SUPER::new(PeerAddr => $host, 
+                            PeerPort => $arg{Port} || 'pop3(110)',
+                            Proto    => 'tcp',
+                            Timeout  => defined $arg{Timeout}
+                                               ? $arg{Timeout}
+                                               : 120
+                           ) or return undef;
+
+ ${*$obj}{'net_pop3_host'} = $host;
+
+ $obj->autoflush(1);
+ $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
+
+ unless ($obj->response() == CMD_OK)
+  {
+   $obj->close();
+   return undef;
+  }
+
+ $obj;
+}
+
+##
+## We don't want people sending me their passwords when they report problems
+## now do we :-)
+##
+
+sub debug_text { $_[2] =~ /^(pass|rpop)/i ? "$1 ....\n" : $_[2]; }
+
+sub login
+{
+ @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->login( USER, PASS )';
+ my($me,$user,$pass) = @_;
+
+ if(@_ < 2)
+  {
+   require Net::Netrc;
+
+   $user ||= (getpwuid($>))[0];
+
+   my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'},$user);
+
+   $m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'});
+
+   $pass = $m ? $m->password || ""
+              : "";
+  }
+
+ $me->user($user) and
+    $me->pass($pass);
+}
+
+sub user
+{
+ @_ == 2 or croak 'usage: $pop3->user( USER )';
+ $_[0]->_USER($_[1]);
+}
+
+sub pass
+{
+ @_ == 2 or croak 'usage: $pop3->pass( PASS )';
+
+ my($me,$pass) = @_;
+
+ return undef
+   unless($me->_PASS($pass));
+
+ $me->message =~ /(\d+)\s+message/io;
+
+ ${*$me}{'net_pop3_count'} = $1 || 0;
+}
+
+sub reset
+{
+ @_ == 1 or croak 'usage: $obj->reset()';
+
+ my $me = shift;
+
+ return 0 
+   unless($me->_RSET);
+  
+ if(defined ${*$me}{'net_pop3_mail'})
+  {
+   local $_;
+   foreach (@{${*$me}{'net_pop3_mail'}})
+    {
+     delete $_->{'net_pop3_deleted'};
+    }
+  }
+}
+
+sub last
+{
+ @_ == 1 or croak 'usage: $obj->last()';
+
+ return undef
+    unless $_[0]->_LAST && $_[0]->message =~ /(\d+)/;
+
+ return $1;
+}
+
+sub top
+{
+ @_ == 2 || @_ == 3 or croak 'usage: $pop3->top( MSGNUM [, NUMLINES ])';
+ my $me = shift;
+
+ return undef
+    unless $me->_TOP($_[0], $_[1] || 0);
+
+ $me->read_until_dot;
+}
+
+sub popstat
+{
+ @_ == 1 or croak 'usage: $pop3->popstat()';
+ my $me = shift;
+
+ return ()
+    unless $me->_STAT && $me->message =~ /(\d+)\D+(\d+)/;
+
+ ($1 || 0, $2 || 0);
+}
+
+sub list
+{
+ @_ == 1 || @_ == 2 or croak 'usage: $pop3->list( [ MSGNUM ] )';
+ my $me = shift;
+
+ return undef
+    unless $me->_LIST(@_);
+
+ if(@_)
+  {
+   $me->message =~ /\d+\D+(\d+)/;
+   return $1 || undef;
+  }
+ my $info = $me->read_until_dot;
+ my %hash = ();
+ map { /(\d+)\D+(\d+)/; $hash{$1} = $2; } @$info;
+
+ return \%hash;
+}
+
+sub get
+{
+ @_ == 2 or croak 'usage: $pop3->get( MSGNUM )';
+ my $me = shift;
+
+ return undef
+    unless $me->_RETR(@_);
+
+ $me->read_until_dot;
+}
+
+sub delete
+{
+ @_ == 2 or croak 'usage: $pop3->delete( MSGNUM )';
+ $_[0]->_DELE($_[1]);
+}
+
+sub _USER { shift->command('USER',$_[0])->response() == CMD_OK }
+sub _PASS { shift->command('PASS',$_[0])->response() == CMD_OK }
+sub _RPOP { shift->command('RPOP',$_[0])->response() == CMD_OK }
+sub _RETR { shift->command('RETR',$_[0])->response() == CMD_OK }
+sub _DELE { shift->command('DELE',$_[0])->response() == CMD_OK }
+sub _TOP  { shift->command('TOP', @_)->response() == CMD_OK }
+sub _LIST { shift->command('LIST',@_)->response() == CMD_OK }
+sub _NOOP { shift->command('NOOP')->response() == CMD_OK }
+sub _RSET { shift->command('RSET')->response() == CMD_OK }
+sub _LAST { shift->command('LAST')->response() == CMD_OK }
+sub _QUIT { shift->command('QUIT')->response() == CMD_OK }
+sub _STAT { shift->command('STAT')->response() == CMD_OK }
+
+sub close
+{
+ my $me = shift;
+
+ return 1
+   unless (ref($me) && defined fileno($me));
+
+ $me->_QUIT && $me->SUPER::close;
+}
+
+sub quit    { shift->close }
+
+sub DESTROY
+{
+ my $me = shift;
+
+ if(fileno($me))
+  {
+   $me->reset;
+   $me->quit;
+  }
+}
+
+##
+## POP3 has weird responses, so we emulate them to look the same :-)
+##
+
+sub response
+{
+ my $cmd = shift;
+ my $str = $cmd->getline() || return undef;
+ my $code = "500";
+
+ $cmd->debug_print(0,$str)
+   if ($cmd->debug);
+
+ if($str =~ s/^\+OK\s+//io)
+  {
+   $code = "200"
+  }
+ else
+  {
+   $str =~ s/^\+ERR\s+//io;
+  }
+
+ ${*$cmd}{'net_cmd_resp'} = [ $str ];
+ ${*$cmd}{'net_cmd_code'} = $code;
+
+ substr($code,0,1);
+}
+
+1;
diff --git a/lib/Net/SMTP.pm b/lib/Net/SMTP.pm
new file mode 100644 (file)
index 0000000..8d56523
--- /dev/null
@@ -0,0 +1,526 @@
+# Net::SMTP.pm
+#
+# Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
+# reserved. This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Net::SMTP;
+
+=head1 NAME
+
+Net::SMTP - Simple Mail transfer Protocol Client
+
+=head1 SYNOPSIS
+
+    use Net::SMTP;
+    
+    # Constructors
+    $smtp = Net::SMTP->new('mailhost');
+    $smtp = Net::SMTP->new('mailhost', Timeout => 60);
+
+=head1 DESCRIPTION
+
+This module implements a client interface to the SMTP protocol, enabling
+a perl5 application to talk to SMTP servers. This documentation assumes
+that you are familiar with the SMTP protocol described in RFC821.
+
+A new Net::SMTP object must be created with the I<new> method. Once
+this has been done, all SMTP commands are accessed through this object.
+
+=head1 EXAMPLES
+
+This example prints the mail domain name of the SMTP server known as mailhost:
+
+    #!/usr/local/bin/perl -w
+    
+    use Net::SMTP;
+    
+    $smtp = Net::SMTP->new('mailhost');
+    
+    print $smtp->domain,"\n";
+    
+    $smtp->quit;
+
+This example sends a small message to the postmaster at the SMTP server
+known as mailhost:
+
+    #!/usr/local/bin/perl -w
+    
+    use Net::SMTP;
+    
+    $smtp = Net::SMTP->new('mailhost');
+    
+    $smtp->mail($ENV{USER});
+    
+    $smtp->to('postmaster');
+    
+    $smtp->data();
+    
+    $smtp->datasend("To: postmaster\n");
+    $smtp->datasend("\n");
+    $smtp->datasend("A simple test message\n");
+    
+    $smtp->dataend();
+    
+    $smtp->quit;
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( HOST, [ OPTIONS ] )
+
+This is the constructor for a new Net::SMTP object. C<HOST> is the
+name of the remote host to which a SMTP connection is required.
+
+C<OPTIONS> are passed in a hash like fasion, using key and value pairs.
+Possible options are:
+
+B<Hello> - SMTP requires that you identify yourself. This option
+specifies a string to pass as your mail domain. If not
+given a guess will be taken.
+
+B<Timeout> - Maximum time, in seconds, to wait for a response from the
+SMTP server (default: 120)
+
+B<Debug> - Enable debugging information
+
+
+Example:
+
+
+    $smtp = Net::SMTP->new('mailhost',
+                          Hello => 'my.mail.domain'
+                         );
+
+=head1 METHODS
+
+Unless otherwise stated all methods return either a I<true> or I<false>
+value, with I<true> meaning that the operation was a success. When a method
+states that it returns a value, falure will be returned as I<undef> or an
+empty list.
+
+=over 4
+
+=item domain ()
+
+Returns the domain that the remote SMTP server identified itself as during
+connection.
+
+=item hello ( DOMAIN )
+
+Tell the remote server the mail domain which you are in using the HELO
+command.
+
+=item mail ( ADDRESS )
+
+=item send ( ADDRESS )
+
+=item send_or_mail ( ADDRESS )
+
+=item send_and_mail ( ADDRESS )
+
+Send the appropriate command to the server MAIL, SEND, SOML or SAML. C<ADDRESS>
+is the address of the sender. This initiates the sending of a message. The
+method C<recipient> should be called for each address that the message is to
+be sent to.
+
+=item reset ()
+
+Reset the status of the server. This may be called after a message has been 
+initiated, but before any data has been sent, to cancel the sending of the
+message.
+
+=item recipient ( ADDRESS [, ADDRESS [ ...]] )
+
+Notify the server that the current message should be sent to all of the
+addresses given. Each address is sent as a separate command to the server.
+Should the sending of any address result in a failure then the
+process is aborted and a I<false> value is returned. It is up to the
+user to call C<reset> if they so desire.
+
+=item to ()
+
+A synonym for recipient
+
+=item data ( [ DATA ] )
+
+Initiate the sending of the data fro the current message. 
+
+C<DATA> may be a reference to a list or a list. If specified the contents
+of C<DATA> and a termination string C<".\r\n"> is sent to the server. And the
+result will be true if the data was accepted.
+
+If C<DATA> is not specified then the result will indicate that the server
+wishes the data to be sent. The data must then be sent using the C<datasend>
+and C<dataend> methods defined in C<Net::Cmd>.
+
+=item expand ( ADDRESS )
+
+Request the server to expand the given address Returns a reference to an array
+which contains the text read from the server.
+
+=item verify ( ADDRESS )
+
+Verify that C<ADDRESS> is a legitimate mailing address.
+
+=item help ( [ $subject ] )
+
+Request help text from the server. Returns the text or undef upon failure
+
+=item quit ()
+
+Send the QUIT command to the remote SMTP server and close the socket connection.
+
+=back
+
+=head1 SEE ALSO
+
+L<Net::Cmd>
+
+=head1 AUTHOR
+
+Graham Barr <Graham.Barr@tiuk.ti.com>
+
+=head1 REVISION
+
+$Revision: 2.1 $
+$Date: 1996/08/20 20:23:56 $
+
+The VERSION is derived from the revision by changing each number after the
+first dot into a 2 digit number so
+
+       Revision 1.8   => VERSION 1.08
+       Revision 1.2.3 => VERSION 1.0203
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
+software; you can redistribute it and/or modify it under the same terms
+as Perl itself.
+
+=cut
+
+require 5.001;
+
+use strict;
+use vars qw($VERSION @ISA);
+use Socket 1.3;
+use Carp;
+use IO::Socket;
+use Net::Cmd;
+
+$VERSION = do{my @r=(q$Revision: 2.1 $=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r};
+
+@ISA = qw(Net::Cmd IO::Socket::INET);
+
+sub new
+{
+ my $self = shift;
+ my $type = ref($self) || $self;
+ my $host = shift;
+ my %arg  = @_; 
+ my $obj = $type->SUPER::new(PeerAddr => $host, 
+                            PeerPort => $arg{Port} || 'smtp(25)',
+                            Proto    => 'tcp',
+                            Timeout  => defined $arg{Timeout}
+                                               ? $arg{Timeout}
+                                               : 120
+                           ) or return undef;
+
+ $obj->autoflush(1);
+
+ $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
+
+ unless ($obj->response() == CMD_OK)
+  {
+   $obj->SUPER::close();
+   return undef;
+  }
+
+ ${*$obj}{'net_smtp_host'} = $host;
+
+ (${*$obj}{'net_smtp_domain'}) = $obj->message =~ /\A\s*(\S+)/;
+
+ $obj->hello($arg{Hello} || "");
+
+ $obj;
+}
+
+##
+## User interface methods
+##
+
+sub domain
+{
+ my $me = shift;
+
+ return ${*$me}{'net_smtp_domain'} || undef;
+}
+
+sub hello
+{
+ my $me = shift;
+ my $domain = shift ||
+             eval {
+                   require Net::Domain;
+                   Net::Domain::hostdomain();
+                  } ||
+               "";
+ my $ok = $me->_EHLO($domain);
+ my $msg;
+
+ if($ok)
+  {
+   $msg = $me->message;
+
+   my $h = ${*$me}{'net_smtp_esmtp'} = {};
+   my $ext;
+   foreach $ext (qw(8BITMIME CHECKPOINT DSN SIZE))
+    {
+     $h->{$ext} = 1
+       if $msg =~ /\b${ext}\b/;
+    }
+  }
+ else
+  {
+   $msg = $me->message
+       if $me->_HELO($domain);
+  }
+
+ $ok && $msg =~ /\A(\S+)/
+       ? $1
+       : undef;
+}
+
+sub _addr
+{
+ my $addr = shift || "";
+
+ return $1
+    if $addr =~ /(<[^>]+>)/so;
+
+ $addr =~ s/\n/ /sog;
+ $addr =~ s/(\A\s+|\s+\Z)//sog;
+
+ return "<" . $addr . ">";
+}
+
+
+sub mail
+{
+ my $me = shift;
+ my $addr = _addr(shift);
+ my $opts = "";
+
+ if(@_)
+  {
+   my %opt = @_;
+   my($k,$v);
+
+   if(exists ${*$me}{'net_smtp_esmtp'})
+    {
+     my $esmtp = ${*$me}{'net_smtp_esmtp'};
+
+     if(defined($v = delete $opt{Size}))
+      {
+       if(exists $esmtp->{SIZE})
+        {
+         $opts .= sprintf " SIZE=%d", $v + 0
+        }
+       else
+        {
+        carp 'Net::SMTP::mail: SIZE option not supported by host';
+        }
+      }
+
+     if(defined($v = delete $opt{Return}))
+      {
+       if(exists $esmtp->{DSN})
+        {
+        $opts .= " RET=" . uc $v
+        }
+       else
+        {
+        carp 'Net::SMTP::mail: DSN option not supported by host';
+        }
+      }
+
+     if(defined($v = delete $opt{Bits}))
+      {
+       if(exists $esmtp->{'8BITMIME'})
+        {
+        $opts .= $v == 8 ? " BODY=8BITMIME" : " BODY=7BIT"
+        }
+       else
+        {
+        carp 'Net::SMTP::mail: 8BITMIME option not supported by host';
+        }
+      }
+
+     if(defined($v = delete $opt{Transaction}))
+      {
+       if(exists $esmtp->{CHECKPOINT})
+        {
+        $opts .= " TRANSID=" . _addr($v);
+        }
+       else
+        {
+        carp 'Net::SMTP::mail: CHECKPOINT option not supported by host';
+        }
+      }
+
+     if(defined($v = delete $opt{Envelope}))
+      {
+       if(exists $esmtp->{DSN})
+        {
+        $v =~ s/([^\041-\176]|=|\+)/sprintf "+%02x", ord($1)/sge;
+        $opts .= " ENVID=$v"
+        }
+       else
+        {
+        carp 'Net::SMTP::mail: DSN option not supported by host';
+        }
+      }
+
+     carp 'Net::SMTP::recipient: unknown option(s) '
+               . join(" ", keys %opt)
+               . ' - ignored'
+       if scalar keys %opt;
+    }
+   else
+    {
+     carp 'Net::SMTP::mail: ESMTP not supported by host - options discarded :-(';
+    }
+  }
+
+ $me->_MAIL("FROM:".$addr.$opts);
+}
+
+sub send         { shift->_SEND("FROM:" . _addr($_[0])) }
+sub send_or_mail  { shift->_SOML("FROM:" . _addr($_[0])) }
+sub send_and_mail { shift->_SAML("FROM:" . _addr($_[0])) }
+
+sub reset
+{
+ my $me = shift;
+
+ $me->dataend()
+       if(exists ${*$me}{'net_smtp_lastch'});
+
+ $me->_RSET();
+}
+
+
+sub recipient
+{
+ my $smtp = shift;
+ my $ok = 1;
+ my $opts = "";
+
+ if(@_ && ref($_[-1]))
+  {
+   my %opt = %{pop(@_)};
+   my $v;
+
+   if(exists ${*$smtp}{'net_smtp_esmtp'})
+    {
+     my $esmtp = ${*$smtp}{'net_smtp_esmtp'};
+
+     if(defined($v = delete $opt{Notify}))
+      {
+       if(exists $esmtp->{DSN})
+        {
+        $opts .= " NOTIFY=" . join(",",map { uc $_ } @$v)
+        }
+       else
+        {
+        carp 'Net::SMTP::recipient: DSN option not supported by host';
+        }
+      }
+
+     carp 'Net::SMTP::recipient: unknown option(s) '
+               . join(" ", keys %opt)
+               . ' - ignored'
+       if scalar keys %opt;
+    }
+   else
+    {
+     carp 'Net::SMTP::recipient: ESMTP not supported by host - options discarded :-(';
+    }
+  }
+
+ while($ok && scalar(@_))
+  {
+   $ok = $smtp->_RCPT("TO:" . _addr(shift) . $opts);
+  }
+
+ return $ok;
+}
+
+*to = \&recipient;
+
+sub data
+{
+ my $me = shift;
+
+ my $ok = $me->_DATA() && $me->datasend(@_);
+
+ $ok && @_ ? $me->dataend
+          : $ok;
+}
+
+sub expand
+{
+ my $me = shift;
+
+ $me->_EXPN(@_) ? ($me->message)
+               : ();
+}
+
+
+sub verify { shift->_VRFY(@_) }
+
+sub help
+{
+ my $me = shift;
+
+ $me->_HELP(@_) ? scalar $me->message
+               : undef;
+}
+
+sub close
+{
+ my $me = shift;
+
+ return 1
+   unless (ref($me) && defined fileno($me));
+
+ $me->_QUIT && $me->SUPER::close;
+}
+
+sub DESTROY { shift->close }
+sub quit    { shift->close }
+
+##
+## RFC821 commands
+##
+
+sub _EHLO { shift->command("EHLO", @_)->response()  == CMD_OK }   
+sub _HELO { shift->command("HELO", @_)->response()  == CMD_OK }   
+sub _MAIL { shift->command("MAIL", @_)->response()  == CMD_OK }   
+sub _RCPT { shift->command("RCPT", @_)->response()  == CMD_OK }   
+sub _SEND { shift->command("SEND", @_)->response()  == CMD_OK }   
+sub _SAML { shift->command("SAML", @_)->response()  == CMD_OK }   
+sub _SOML { shift->command("SOML", @_)->response()  == CMD_OK }   
+sub _VRFY { shift->command("VRFY", @_)->response()  == CMD_OK }   
+sub _EXPN { shift->command("EXPN", @_)->response()  == CMD_OK }   
+sub _HELP { shift->command("HELP", @_)->response()  == CMD_OK }   
+sub _RSET { shift->command("RSET")->response()     == CMD_OK }   
+sub _NOOP { shift->command("NOOP")->response()     == CMD_OK }   
+sub _QUIT { shift->command("QUIT")->response()     == CMD_OK }   
+sub _DATA { shift->command("DATA")->response()     == CMD_MORE } 
+sub _TURN { shift->unsupported(@_); }                            
+
+1;
+
diff --git a/lib/Net/SNPP.pm b/lib/Net/SNPP.pm
new file mode 100644 (file)
index 0000000..d869188
--- /dev/null
@@ -0,0 +1,389 @@
+# Net::SNPP.pm
+#
+# Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
+# reserved. This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Net::SNPP;
+
+=head1 NAME
+
+Net::SNPP - Simple Network Pager Protocol Client
+
+=head1 SYNOPSIS
+
+    use Net::SNPP;
+    
+    # Constructors
+    $snpp = Net::SNPP->new('snpphost');
+    $snpp = Net::SNPP->new('snpphost', Timeout => 60);
+
+=head1 NOTE
+
+This module is not complete, yet !
+
+=head1 DESCRIPTION
+
+This module implements a client interface to the SNPP protocol, enabling
+a perl5 application to talk to SNPP servers. This documentation assumes
+that you are familiar with the SNPP protocol described in RFC1861.
+
+A new Net::SNPP object must be created with the I<new> method. Once
+this has been done, all SNPP commands are accessed through this object.
+
+=head1 EXAMPLES
+
+This example will send a pager message in one hour saying "Your lunch is ready"
+
+    #!/usr/local/bin/perl -w
+    
+    use Net::SNPP;
+    
+    $snpp = Net::SNPP->new('snpphost');
+    
+    $snpp->send( Pager   => $some_pager_number,
+                Message => "Your lunch is ready",
+                Alert   => 1,
+                Hold    => time + 3600, # lunch ready in 1 hour :-)
+              ) || die $snpp->message;
+    
+    $snpp->quit;
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( HOST, [ OPTIONS ] )
+
+This is the constructor for a new Net::SNPP object. C<HOST> is the
+name of the remote host to which a SNPP connection is required.
+
+C<OPTIONS> are passed in a hash like fasion, using key and value pairs.
+Possible options are:
+
+B<Timeout> - Maximum time, in seconds, to wait for a response from the
+SNPP server (default: 120)
+
+B<Debug> - Enable debugging information
+
+
+Example:
+
+
+    $snpp = Net::SNPP->new('snpphost',
+                          Debug => 1,
+                         );
+
+=head1 METHODS
+
+Unless otherwise stated all methods return either a I<true> or I<false>
+value, with I<true> meaning that the operation was a success. When a method
+states that it returns a value, falure will be returned as I<undef> or an
+empty list.
+
+=over 4
+
+=item reset ()
+
+=item help ()
+
+Request help text from the server. Returns the text or undef upon failure
+
+=item quit ()
+
+Send the QUIT command to the remote SNPP server and close the socket connection.
+
+=back
+
+=head1 EXPORTS
+
+C<Net::SNPP> exports all that C<Net::CMD> exports, plus three more subroutines
+that can bu used to compare against the result of C<status>. These are :-
+C<CMD_2WAYERROR>, C<CMD_2WAYOK>, and C<CMD_2WAYQUEUED>.
+
+=head1 SEE ALSO
+
+L<Net::Cmd>
+RFC1861
+
+=head1 AUTHOR
+
+Graham Barr <Graham.Barr@tiuk.ti.com>
+
+=head1 REVISION
+
+$Revision: 1.1 $
+$Date: 1996/07/26 06:49:13 $
+
+The VERSION is derived from the revision by changing each number after the
+first dot into a 2 digit number so
+
+       Revision 1.8   => VERSION 1.08
+       Revision 1.2.3 => VERSION 1.0203
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
+software; you can redistribute it and/or modify it under the same terms
+as Perl itself.
+
+=cut
+
+require 5.001;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT);
+use Socket 1.3;
+use Carp;
+use IO::Socket;
+use Net::Cmd;
+
+$VERSION = do{my @r=(q$Revision: 1.1 $=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r};
+@ISA     = qw(Net::Cmd IO::Socket::INET);
+@EXPORT  = qw(CMD_2WAYERROR CMD_2WAYOK CMD_2WAYQUEUED);
+
+sub CMD_2WAYERROR  { 7 }
+sub CMD_2WAYOK     { 8 }
+sub CMD_2WAYQUEUED { 9 }
+
+sub import
+{
+ my $pkg = shift;
+ my $callpkg = caller;
+ my @export = ();
+ my %export;
+ my $export;
+
+ @export{@_} = (1) x @_;
+
+ foreach $export (@EXPORT)
+  {
+   if(exists $export{$export})
+    {
+     push(@export,$export);
+     delete $export{$export};
+    }
+  }
+
+ Exporter::export 'Net::SNPP', $callpkg, @export
+       if(@_ == 0 || @export);
+
+ @export = keys %export;
+ Exporter::export 'Net::Cmd',  $callpkg, @export
+       if(@_ == 0 || @export);
+}
+
+sub new
+{
+ my $self = shift;
+ my $type = ref($self) || $self;
+ my $host = shift;
+ my %arg  = @_; 
+ my $obj = $type->SUPER::new(PeerAddr => $host, 
+                            PeerPort => $arg{Port} || 'snpp(444)',
+                            Proto    => 'tcp',
+                            Timeout  => defined $arg{Timeout}
+                                               ? $arg{Timeout}
+                                               : 120
+                           ) or return undef;
+
+ $obj->autoflush(1);
+
+ $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
+
+ unless ($obj->response() == CMD_OK)
+  {
+   $obj->SUPER::close();
+   return undef;
+  }
+
+ $obj;
+}
+
+##
+## User interface methods
+##
+
+sub pager_id
+{
+ @_ == 2 or croak 'usage: $snpp->pager_id( PAGER_ID )';
+ shift->_PAGE(@_);
+}
+
+sub content
+{
+ @_ == 2 or croak 'usage: $snpp->content( MESSAGE )';
+ shift->_MESS(@_);
+}
+
+sub send
+{
+ my $me = shift;
+
+ if(@_)
+  {
+   my %arg = @_;
+
+   $me->_PAGE($arg{Pager}) || return 0
+       if(exists $arg{Pager});
+
+   $me->_MESS($arg{Message}) || return 0
+       if(exists $arg{Message});
+
+   $me->hold($arg{Hold}) || return 0
+       if(exists $arg{Hold});
+
+   $me->hold($arg{HoldLocal},1) || return 0
+       if(exists $arg{HoldLocal});
+
+   $me->_COVE($arg{Coverage}) || return 0
+       if(exists $arg{Coverage});
+
+   $me->_ALER($arg{Alert} ? 1 : 0) || return 0
+       if(exists $arg{Alert});
+
+   $me->service_level($arg{ServiceLevel}) || return 0
+       if(exists $arg{ServiceLevel});
+  }
+
+ $me->_SEND();
+}
+
+sub data
+{
+ my $me = shift;
+
+ my $ok = $me->_DATA() && $me->datasend(@_);
+
+ return $ok
+       unless($ok && @_);
+
+ $me->dataend;
+}
+
+sub login
+{
+ @_ == 2 || @_ == 3 or croak 'usage: $snpp->login( USER [, PASSWORD ])';
+ shift->_LOGI(@_);
+}
+
+sub help
+{
+ @_ == 1 or croak 'usage: $snpp->help()';
+ my $me = shift;
+
+ return $me->_HELP() ? $me->message
+                    : undef;
+}
+
+sub service_level
+{
+ @_ == 2 or croak 'usage: $snpp->service_level( LEVEL )';
+ my $me = shift;
+ my $levl = int(shift);
+ my($me,$level) = @_;
+
+ if($level < 0 || $level > 11)
+  {
+   $me->set_status(550,"Invalid Service Level");
+   return 0;
+  }
+
+ $me->_LEVE($levl);
+}
+
+sub alert
+{
+ @_ == 1 || @_ == 2 or croak 'usage: $snpp->alert( VALUE )';
+ my $me = shift;
+ my $value  = (@_ == 1 || shift) ? 1 : 0;
+
+ $me->_ALER($value);
+}
+
+sub coverage
+{
+ @_ == 1 or croak 'usage: $snpp->coverage( AREA )';
+ shift->_COVE(@_);
+}
+
+sub hold
+{
+ @_ == 2 || @_ == 3 or croak 'usage: $snpp->hold( TIME [, LOCAL ] )';
+ my $me = shift;
+ my $until = shift;
+ my $local = shift ? "" : " +0000";
+
+ my @g = reverse((gmtime($time))[0..5]);
+ $g[1] += 1;
+ $g[0] %= 100;
+
+ $me->_HOLD( sprintf("%02d%02d%02d%02d%02d%02d%s",@g,$local));
+}
+
+sub caller_id
+{
+ @_ == 2 or croak 'usage: $snpp->caller_id( CALLER_ID )';
+ shift->_CALL(@_);
+}
+
+sub subject
+{
+ @_ == 2 or croak 'usage: $snpp->subject( SUBJECT )';
+ shift->_SUBJ(@_);
+}
+
+sub two_way
+{
+ @_ == 1 or croak 'usage: $snpp->two_way()';
+ shift->_2WAY();
+}
+
+sub close
+{
+ my $me = shift;
+
+ return 1
+   unless (ref($me) && defined fileno($me));
+
+ $me->_QUIT && $me->SUPER::close;
+}
+
+sub DESTROY { shift->close }
+sub quit    { shift->close }
+
+##
+## Over-ride methods (Net::Cmd)
+##
+
+sub debug_text
+{
+ $_[2] =~ s/^((logi|page)\s+\S+\s+)\S*/$1 xxxx/io;
+}
+
+##
+## RFC1861 commands
+##
+
+# Level 1
+
+sub _PAGE { shift->command("PAGE", @_)->response()  == CMD_OK }   
+sub _MESS { shift->command("MESS", @_)->response()  == CMD_OK }   
+sub _RESE { shift->command("RESE")->response()  == CMD_OK }   
+sub _SEND { shift->command("SEND")->response()  == CMD_OK }   
+sub _QUIT { shift->command("QUIT")->response()  == CMD_OK }   
+sub _HELP { shift->command("HELP")->response()  == CMD_OK }   
+sub _DATA { shift->command("DATA")->response()  == CMD_MORE }   
+
+# Level 2
+
+sub _LOGI { shift->command("LOGI", @_)->response()  == CMD_OK }   
+sub _LEVE { shift->command("LEVE", @_)->response()  == CMD_OK }   
+sub _ALER { shift->command("ALER", @_)->response()  == CMD_OK }   
+sub _COVE { shift->command("COVE", @_)->response()  == CMD_OK }   
+sub _HOLD { shift->command("HOLD", @_)->response()  == CMD_OK }   
+sub _CALL { shift->command("CALL", @_)->response()  == CMD_OK }   
+sub _SUBJ { shift->command("SUBJ", @_)->response()  == CMD_OK }   
+
+
+1;
diff --git a/lib/Net/Telnet.pm b/lib/Net/Telnet.pm
new file mode 100644 (file)
index 0000000..397502e
--- /dev/null
@@ -0,0 +1,250 @@
+
+package        Net::Telnet;
+
+=head1 NAME
+
+Net::Telnet - Defines constants for the telnet protocol
+
+=head1 SYNOPSIS
+
+    use Telnet qw(TELNET_IAC TELNET_DO TELNET_DONT);
+
+=head1 DESCRIPTION
+
+This module is B<VERY> preliminary as I am not 100% sure how it should
+be implemented.
+
+Currently it just exports constants used in the telnet protocol.
+
+Should it contain sub's for packing and unpacking commands ?
+
+Please feel free to send me any suggestions
+
+=head1 NOTE
+
+This is not an implementation of the 'telnet' command but of the telnet
+protocol as defined in RFC854
+
+=head1 AUTHOR
+
+Graham Barr <Graham.Barr@tiuk.ti.com>
+
+=head1 REVISION
+
+$Revision: 2.0 $
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
+software; you can redistribute it and/or modify it under the same terms
+as Perl itself.
+
+=cut
+
+use     vars qw(@ISA $VERSION);
+require        Exporter;
+@ISA = qw(Exporter);
+
+$VERSION = sprintf("%d.%02d", q$Revision: 2.0 $ =~ /(\d+)\.(\d+)/);
+
+my %telnet = (
+       TELNET_IAC      => 255,         # interpret as command:
+       TELNET_DONT     => 254,         # you are not to use option
+       TELNET_DO       => 253,         # please, you use option
+       TELNET_WONT     => 252,         # I won't use option
+       TELNET_WILL     => 251,         # I will use option
+       TELNET_SB       => 250,         # interpret as subnegotiation
+       TELNET_GA       => 249,         # you may reverse the line
+       TELNET_EL       => 248,         # erase the current line
+       TELNET_EC       => 247,         # erase the current character
+       TELNET_AYT      => 246,         # are you there
+       TELNET_AO       => 245,         # abort output--but let prog finish
+       TELNET_IP       => 244,         # interrupt process--permanently
+       TELNET_BREAK    => 243,         # break
+       TELNET_DM       => 242,         # data mark--for connect. cleaning
+       TELNET_NOP      => 241,         # nop
+       TELNET_SE       => 240,         # end sub negotiation
+       TELNET_EOR      => 239,         # end of record (transparent mode)
+       TELNET_ABORT    => 238,         # Abort process
+       TELNET_SUSP     => 237,         # Suspend process
+       TELNET_EOF      => 236,         # End of file: EOF is already used...
+
+       TELNET_SYNCH    => 242,         # for telfunc calls
+);
+
+while(($n,$v) =        each %telnet) { eval "sub $n {$v}"; }
+
+sub telnet_command {
+    my $cmd = shift;
+    my($n,$v);
+
+    while(($n,$v) = each %telnet) {
+       return $n
+           if($v == $cmd);
+    }
+
+    return undef;
+}
+
+# telnet options
+my %telopt = (
+       TELOPT_BINARY           => 0,   # 8-bit data path
+       TELOPT_ECHO             => 1,   # echo
+       TELOPT_RCP              => 2,   # prepare to reconnect
+       TELOPT_SGA              => 3,   # suppress go ahead
+       TELOPT_NAMS             => 4,   # approximate message size
+       TELOPT_STATUS           => 5,   # give status
+       TELOPT_TM               => 6,   # timing mark
+       TELOPT_RCTE             => 7,   # remote controlled transmission and echo
+       TELOPT_NAOL             => 8,   # negotiate about output line width
+       TELOPT_NAOP             => 9,   # negotiate about output page size
+       TELOPT_NAOCRD           => 10,  # negotiate about CR disposition
+       TELOPT_NAOHTS           => 11,  # negotiate about horizontal tabstops
+       TELOPT_NAOHTD           => 12,  # negotiate about horizontal tab disposition
+       TELOPT_NAOFFD           => 13,  # negotiate about formfeed disposition
+       TELOPT_NAOVTS           => 14,  # negotiate about vertical tab stops
+       TELOPT_NAOVTD           => 15,  # negotiate about vertical tab disposition
+       TELOPT_NAOLFD           => 16,  # negotiate about output LF disposition
+       TELOPT_XASCII           => 17,  # extended ascic character set
+       TELOPT_LOGOUT           => 18,  # force logout
+       TELOPT_BM               => 19,  # byte macro
+       TELOPT_DET              => 20,  # data entry terminal
+       TELOPT_SUPDUP           => 21,  # supdup protocol
+       TELOPT_SUPDUPOUTPUT     => 22,  # supdup output
+       TELOPT_SNDLOC           => 23,  # send location
+       TELOPT_TTYPE            => 24,  # terminal type
+       TELOPT_EOR              => 25,  # end or record
+       TELOPT_TUID             => 26,  # TACACS user identification
+       TELOPT_OUTMRK           => 27,  # output marking
+       TELOPT_TTYLOC           => 28,  # terminal location number
+       TELOPT_3270REGIME       => 29,  # 3270 regime
+       TELOPT_X3PAD            => 30,  # X.3 PAD
+       TELOPT_NAWS             => 31,  # window size
+       TELOPT_TSPEED           => 32,  # terminal speed
+       TELOPT_LFLOW            => 33,  # remote flow control
+       TELOPT_LINEMODE         => 34,  # Linemode option
+       TELOPT_XDISPLOC         => 35,  # X Display Location
+       TELOPT_OLD_ENVIRON      => 36,  # Old - Environment variables
+       TELOPT_AUTHENTICATION   => 37,  # Authenticate
+       TELOPT_ENCRYPT          => 38,  # Encryption option
+       TELOPT_NEW_ENVIRON      => 39,  # New - Environment variables
+       TELOPT_EXOPL            => 255, # extended-options-list
+);
+
+while(($n,$v) =        each %telopt) { eval "sub $n {$v}"; }
+
+sub telnet_option {
+    my $cmd = shift;
+    my($n,$v);
+
+    while(($n,$v) = each %telopt) {
+       return $n
+           if($v == $cmd);
+    }
+
+    return undef;
+}
+
+# sub-option qualifiers
+
+sub TELQUAL_IS         {0}     # option is...
+sub TELQUAL_SEND       {1}     # send option
+sub TELQUAL_INFO       {2}     # ENVIRON: informational version of IS
+sub TELQUAL_REPLY      {2}     # AUTHENTICATION: client version of IS
+sub TELQUAL_NAME       {3}     # AUTHENTICATION: client version of IS
+
+sub LFLOW_OFF          {0}     # Disable remote flow control
+sub LFLOW_ON           {1}     # Enable remote flow control
+sub LFLOW_RESTART_ANY  {2}     # Restart output on any char
+sub LFLOW_RESTART_XON  {3}     # Restart output only on XON
+
+# LINEMODE suboptions
+
+sub LM_MODE            {1}
+sub LM_FORWARDMASK     {2}
+sub LM_SLC             {3}
+
+sub MODE_EDIT          {0x01}
+sub MODE_TRAPSIG       {0x02}
+sub MODE_ACK           {0x04}
+sub MODE_SOFT_TAB      {0x08}
+sub MODE_LIT_ECHO      {0x10}
+
+sub MODE_MASK          {0x1f}
+
+# Not part of protocol,        but needed to simplify things...
+sub MODE_FLOW          {0x0100}
+sub MODE_ECHO          {0x0200}
+sub MODE_INBIN         {0x0400}
+sub MODE_OUTBIN                {0x0800}
+sub MODE_FORCE         {0x1000}
+
+my %slc        = (
+       SLC_SYNCH       =>  1,
+       SLC_BRK         =>  2,
+       SLC_IP          =>  3,
+       SLC_AO          =>  4,
+       SLC_AYT         =>  5,
+       SLC_EOR         =>  6,
+       SLC_ABORT       =>  7,
+       SLC_EOF         =>  8,
+       SLC_SUSP        =>  9,
+       SLC_EC          => 10,
+       SLC_EL          => 11,
+       SLC_EW          => 12,
+       SLC_RP          => 13,
+       SLC_LNEXT       => 14,
+       SLC_XON         => 15,
+       SLC_XOFF        => 16,
+       SLC_FORW1       => 17,
+       SLC_FORW2       => 18,
+);
+
+
+while(($n,$v) =        each %slc) { eval "sub $n {$v}"; }
+
+sub telnet_slc {
+    my $cmd = shift;
+    my($n,$v);
+
+    while(($n,$v) = each %slc) {
+       return $n
+           if($v == $cmd);
+    }
+
+    return undef;
+}
+
+sub NSLC               {18}
+
+sub SLC_NOSUPPORT      {0}
+sub SLC_CANTCHANGE     {1}
+sub SLC_VARIABLE       {2}
+sub SLC_DEFAULT                {3}
+sub SLC_LEVELBITS      {0x03}
+
+sub SLC_FUNC           {0}
+sub SLC_FLAGS          {1}
+sub SLC_VALUE          {2}
+
+sub SLC_ACK            {0x80}
+sub SLC_FLUSHIN                {0x40}
+sub SLC_FLUSHOUT       {0x20}
+
+sub OLD_ENV_VAR                {1}
+sub OLD_ENV_VALUE      {0}
+sub NEW_ENV_VAR                {0}
+sub NEW_ENV_VALUE      {1}
+sub ENV_ESC            {2}
+sub ENV_USERVAR                {3}
+
+@EXPORT_OK = (keys %telnet, keys %telopt, keys %slc);
+
+sub telnet_pack {
+    my $r = '';
+
+
+    $r;
+}
+
+1;
diff --git a/lib/Net/Time.pm b/lib/Net/Time.pm
new file mode 100644 (file)
index 0000000..a6b0b59
--- /dev/null
@@ -0,0 +1,112 @@
+# Net::Time.pm
+#
+# Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
+# reserved. This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Net::Time;
+
+=head1 NAME
+
+Net::Time - time and daytime network client interface
+
+=head1 SYNOPSIS
+
+    use Net::Time qw(inet_time inet_daytime);
+    
+    print inet_time('localhost');
+    print inet_time('localhost', 'tcp');
+    
+    print inet_daytime('localhost');
+    print inet_daytime('localhost', 'tcp');
+
+=head1 DESCRIPTION
+
+C<Net::Time> provides subroutines that obtain the time on a remote machine.
+
+=over 4
+
+=item inet_time ( HOST [, PROTOCOL])
+
+Obtain the time on C<HOST> using the protocol as defined in RFC868. The
+optional argument C<PROTOCOL> should define the protocol to use, either
+C<tcp> or C<udp>. The result will be a unix-like time value or I<undef>
+upon failure.
+
+=item inet_daytime ( HOST [, PROTOCOL])
+
+Obtain the time on C<HOST> using the protocol as defined in RFC867. The
+optional argument C<PROTOCOL> should define the protocol to use, either
+C<tcp> or C<udp>. The result will be an ASCII string or I<undef>
+upon failure.
+
+=back
+
+=head1 AUTHOR
+
+Graham Barr <Graham.Barr@tiuk.ti.com>
+
+=head1 REVISION
+
+$Revision: 2.0 $
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
+software; you can redistribute it and/or modify it under the same terms
+as Perl itself.
+
+=cut
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT_OK);
+use Carp;
+use IO::Socket;
+require Exporter;
+
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(inet_time inet_daytime);
+
+$VERSION = sprintf("%d.%02d", q$Revision: 2.0 $ =~ /(\d+)\.(\d+)/);
+
+sub _socket
+{
+ my($pname,$pnum,$host,$proto) = @_;
+
+ $proto ||= 'udp';
+
+ my $port = (getservbyname($pname, $proto))[2] || $pnum;
+
+ my $me = IO::Socket::INET->new(PeerAddr => $host,
+                               PeerPort => $port,
+                               Proto    => $proto
+                              );
+
+ $me->send("\n")
+    if(defined $me && $proto eq 'udp');
+
+ $me;
+}
+
+sub inet_time
+{
+ my $s = _socket('time',37,@_) || return undef;
+ my $buf = '';
+
+ # the time protocol return time in seconds since 1900, convert
+ # it to a unix time (seconds since 1970)
+
+ $s->recv($buf, length(pack("N",0))) ? (unpack("N",$buf))[0] - 2208988800
+                                    : undef;
+}
+
+sub inet_daytime
+{
+ my $s = _socket('daytime',13,@_) || return undef;
+ my $buf = '';
+
+ $s->recv($buf, 1024) ? $buf
+                     : undef;
+}
+
+1;
index c006547..c0e7ebd 100644 (file)
@@ -38,7 +38,7 @@ C<isa> can be called as either a static or object method call.
 =item can ( METHOD )
 
 C<can> checks if the object has a method called C<METHOD>. If it does
-then a reference to the sub is returned. If it does not the I<undef>
+then a reference to the sub is returned. If it does not then I<undef>
 is returned.
 
 C<can> can be called as either a static or object method call.
index 7d3b970..8cf08c2 100644 (file)
@@ -1,54 +1,12 @@
-# &open2: tom christiansen, <tchrist@convex.com>
+# This is a compatibility interface to IPC::Open2.  New programs should
+# do
 #
-# usage: $pid = &open2('rdr', 'wtr', 'some cmd and args');
-#    or  $pid = &open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args');
+#     use IPC::Open2;
 #
-# spawn the given $cmd and connect $rdr for
-# reading and $wtr for writing.  return pid
-# of child, or 0 on failure.  
-# 
-# WARNING: this is dangerous, as you may block forever
-# unless you are very careful.  
-# 
-# $wtr is left unbuffered.
-# 
-# abort program if
-#      rdr or wtr are null
-#      pipe or fork or exec fails
-
-package open2;
-$fh = 'FHOPEN000';  # package static in case called more than once
-
-sub main'open2 {
-    local($kidpid);
-    local($dad_rdr, $dad_wtr, @cmd) = @_;
-
-    $dad_rdr ne ''             || die "open2: rdr should not be null";
-    $dad_wtr ne ''             || die "open2: wtr should not be null";
-
-    # force unqualified filehandles into callers' package
-    local($package) = caller;
-    $dad_rdr =~ s/^([^']+$)/$package'$1/;
-    $dad_wtr =~ s/^([^']+$)/$package'$1/;
-
-    local($kid_rdr) = ++$fh;
-    local($kid_wtr) = ++$fh;
-
-    pipe($dad_rdr, $kid_wtr)   || die "open2: pipe 1 failed: $!";
-    pipe($kid_rdr, $dad_wtr)   || die "open2: pipe 2 failed: $!";
+# instead of
+#
+#     require 'open2.pl';
 
-    if (($kidpid = fork) < 0) {
-       die "open2: fork failed: $!";
-    } elsif ($kidpid == 0) {
-       close $dad_rdr; close $dad_wtr;
-       open(STDIN,  "<&$kid_rdr");
-       open(STDOUT, ">&$kid_wtr");
-       warn "execing @cmd\n" if $debug;
-       exec @cmd;
-       die "open2: exec of @cmd failed";   
-    } 
-    close $kid_rdr; close $kid_wtr;
-    select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
-    $kidpid;
-}
-1; # so require is happy
+package main;
+use IPC::Open2 'open2';
+1
index 8b3917a..7fcc931 100644 (file)
-# &open3: Marc Horowitz <marc@mit.edu>
-# derived mostly from &open2 by tom christiansen, <tchrist@convex.com>
+# This is a compatibility interface to IPC::Open3.  New programs should
+# do
 #
-# $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $
+#     use IPC::Open3;
 #
-# usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...);
+# instead of
 #
-# spawn the given $cmd and connect rdr for
-# reading, wtr for writing, and err for errors.
-# if err is '', or the same as rdr, then stdout and
-# stderr of the child are on the same fh.  returns pid
-# of child, or 0 on failure.
+#     require 'open3.pl';
 
-
-# if wtr begins with '>&', then wtr will be closed in the parent, and
-# the child will read from it directly.  if rdr or err begins with
-# '>&', then the child will send output directly to that fd.  In both
-# cases, there will be a dup() instead of a pipe() made.
-
-
-# WARNING: this is dangerous, as you may block forever
-# unless you are very careful.
-#
-# $wtr is left unbuffered.
-#
-# abort program if
-#   rdr or wtr are null
-#   pipe or fork or exec fails
-
-package open3;
-
-$fh = 'FHOPEN000';  # package static in case called more than once
-
-sub main'open3 {
-    local($kidpid);
-    local($dad_wtr, $dad_rdr, $dad_err, @cmd) = @_;
-    local($dup_wtr, $dup_rdr, $dup_err);
-
-    $dad_wtr                   || die "open3: wtr should not be null";
-    $dad_rdr                   || die "open3: rdr should not be null";
-    $dad_err = $dad_rdr if ($dad_err eq '');
-
-    $dup_wtr = ($dad_wtr =~ s/^\>\&//);
-    $dup_rdr = ($dad_rdr =~ s/^\>\&//);
-    $dup_err = ($dad_err =~ s/^\>\&//);
-
-    # force unqualified filehandles into callers' package
-    local($package) = caller;
-    $dad_wtr =~ s/^([^']+$)/$package'$1/;
-    $dad_rdr =~ s/^([^']+$)/$package'$1/;
-    $dad_err =~ s/^([^']+$)/$package'$1/;
-
-    local($kid_rdr) = ++$fh;
-    local($kid_wtr) = ++$fh;
-    local($kid_err) = ++$fh;
-
-    if (!$dup_wtr) {
-       pipe($kid_rdr, $dad_wtr)    || die "open3: pipe 1 (stdin) failed: $!";
-    }
-    if (!$dup_rdr) {
-       pipe($dad_rdr, $kid_wtr)    || die "open3: pipe 2 (stdout) failed: $!";
-    }
-    if ($dad_err ne $dad_rdr && !$dup_err) {
-       pipe($dad_err, $kid_err)    || die "open3: pipe 3 (stderr) failed: $!";
-    }
-
-    if (($kidpid = fork) < 0) {
-        die "open2: fork failed: $!";
-    } elsif ($kidpid == 0) {
-       if ($dup_wtr) {
-           open(STDIN,  "<&$dad_wtr") if (fileno(STDIN) != fileno($dad_wtr));
-       } else {
-           close($dad_wtr);
-           open(STDIN,  "<&$kid_rdr");
-       }
-       if ($dup_rdr) {
-           open(STDOUT, ">&$dad_rdr") if (fileno(STDOUT) != fileno($dad_rdr));
-       } else {
-           close($dad_rdr);
-           open(STDOUT, ">&$kid_wtr");
-       }
-       if ($dad_rdr ne $dad_err) {
-           if ($dup_err) {
-               open(STDERR, ">&$dad_err")
-                   if (fileno(STDERR) != fileno($dad_err));
-           } else {
-               close($dad_err);
-               open(STDERR, ">&$kid_err");
-           }
-       } else {
-           open(STDERR, ">&STDOUT") if (fileno(STDERR) != fileno(STDOUT));
-       }
-       local($")=(" ");
-       exec @cmd;
-        die "open2: exec of @cmd failed";
-    }
-
-    close $kid_rdr; close $kid_wtr; close $kid_err;
-    if ($dup_wtr) {
-       close($dad_wtr);
-    }
-
-    select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
-    $kidpid;
-}
-1; # so require is happy
+package main;
+use IPC::Open3 'open3';
+1
index 73210e2..066db70 100644 (file)
@@ -1,5 +1,5 @@
 #define PATCHLEVEL 3
-#define SUBVERSION 12
+#define SUBVERSION 13
 
 /*
        local_patches -- list of locally applied less-than-subversion patches.
index bbd699f..49d30fc 100644 (file)
@@ -635,7 +635,7 @@ Usually this is because you don't have read permission for the file.
 
 (W) You tried to say C<open(CMD, "|cmd|")>, which is not supported.  You can
 try any of several modules in the Perl library to do this, such as
-"open2.pl".  Alternately, direct the pipe's output to a file using "E<gt>",
+IPC::Open2.  Alternately, direct the pipe's output to a file using "E<gt>",
 and then read it in under a different file handle.
 
 =item Can't open error file %s as stderr
@@ -842,7 +842,7 @@ case it indicates something else.
 (W) You probably said %hash{$key} when you meant $hash{$key} or @hash{@keys}.
 On the other hand, maybe you just meant %hash and got carried away.
 
-=item Died.
+=item Died
 
 (F) You passed die() an empty string (the equivalent of C<die "">) or
 you called it with no args and both C<$@> and C<$_> were empty.
@@ -2363,7 +2363,7 @@ on the front of your variable.
 of Perl.  Check the E<lt>#!E<gt> line, or manually feed your script
 into Perl yourself.
 
-=item Warning: something's wrong.
+=item Warning: something's wrong
 
 (W) You passed warn() an empty string (the equivalent of C<warn "">) or
 you called it with no args and C<$_> was empty.
index 49b77f0..9e6a7f1 100644 (file)
@@ -1040,20 +1040,17 @@ would need to use the more system-specific fcntl() for that.
 
 Here's a mailbox appender for BSD systems.
 
-    $LOCK_SH = 1;
-    $LOCK_EX = 2;
-    $LOCK_NB = 4;
-    $LOCK_UN = 8;
+    use Fcntl ':flock'; # import LOCK_* constants
 
     sub lock {
-       flock(MBOX,$LOCK_EX);
+       flock(MBOX,LOCK_EX);
        # and, in case someone appended
        # while we were waiting...
        seek(MBOX, 0, 2);
     }
 
     sub unlock {
-       flock(MBOX,$LOCK_UN);
+       flock(MBOX,LOCK_UN);
     }
 
     open(MBOX, ">>/usr/spool/mail/$ENV{'USER'}")
@@ -1754,8 +1751,9 @@ If the filename begins with "|", the filename is interpreted as a command
 to which output is to be piped, and if the filename ends with a "|", the
 filename is interpreted See L<perlipc/"Using open() for IPC"> for more
 examples of this.  as command which pipes input to us.  (You may not have
-a raw open() to a command that pipes both in I<and> out, but see L<open2>,
-L<open3>, and L<perlipc/"Bidirectional Communication"> for alternatives.)
+a raw open() to a command that pipes both in I<and> out, but see
+L<IPC::Open2>, L<IPC::Open3>, and L<perlipc/"Bidirectional Communication">
+for alternatives.)
 
 Opening '-' opens STDIN and opening 'E<gt>-' opens STDOUT.  Open returns
 non-zero upon success, the undefined value otherwise.  If the open
@@ -2052,7 +2050,7 @@ unless you are very careful.  In addition, note that Perl's pipes use
 stdio buffering, so you may need to set C<$|> to flush your WRITEHANDLE
 after each command, depending on the application.
 
-See L<open2>, L<open3>, and L<perlipc/"Bidirectional Communication">
+See L<IPC::Open2>, L<IPC::Open3>, and L<perlipc/"Bidirectional Communication">
 for examples of such things.
 
 =item pop ARRAY
index 4fb5ec8..e6081aa 100644 (file)
@@ -648,21 +648,49 @@ complex numbers and associated mathematical functions
 
 tied access to ndbm files
 
+=item Net::Cmd
+
+Base class for command-oriented protocols
+
+=item Net::Domain
+
+Domain Name System client
+
 =item Net::FTP
 
 File Transfer Protocol client
 
-=item Net::Ping
+=item Net::NNTP
 
-check a host for upness
+Network News Transfer Protocol client
 
 =item Net::Netrc
 
-parser for ".netrc" files a la Berkeley UNIX
+.netrc lookup routines
+
+=item Net::Ping
+
+Hello, anybody home?
+
+=item Net::POP3
+
+Post Office Protocol client
+
+=item Net::SMTP
+
+Simple Mail Transfer Protocol client
+
+=item Net::SNPP
+
+Simple Network Pager Protocol client
+
+=item Net::Telnet
+
+Telnet client
 
-=item Net::Socket
+=item Net::Time
 
-support class for Net::FTP
+Time and NetTime protocols
 
 =item Net::hostent
 
index 7624881..6bfdf59 100644 (file)
@@ -630,7 +630,7 @@ This is the constructor for the class.  That means it is expected to
 return a blessed reference of some sort. The reference can be used to
 hold some internal information.
 
-    sub TIEHANDLE { print "<shout>\n"; my $r; bless \$r, shift }
+    sub TIEHANDLE { print "<shout>\n"; my $i; bless \$i, shift }
 
 =item PRINT this, LIST
 
index e69de29..8dd786b 100755 (executable)
@@ -0,0 +1,39 @@
+#!./perl -w
+use strict;
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    # make warnings fatal
+    $SIG{__WARN__} = sub { die @_ };
+}
+
+use IO::Handle;
+use IPC::Open2;
+#require 'open2.pl'; use subs 'open2';
+
+sub ok {
+    my ($n, $result, $info) = @_;
+    if ($result) {
+       print "ok $n\n";
+    }
+    else {
+       print "not ok $n\n";
+       print "# $info\n" if $info;
+    }
+}
+
+my ($pid, $reaped_pid);
+STDOUT->autoflush;
+STDERR->autoflush;
+
+print "1..7\n";
+
+ok 1, $pid = open2 'READ', 'WRITE', $^X, '-e', 'print scalar <STDIN>';
+ok 2, print WRITE "hi kid\n";
+ok 3, <READ> eq "hi kid\n";
+ok 4, close(WRITE), $!;
+ok 5, close(READ), $!;
+$reaped_pid = waitpid $pid, 0;
+ok 6, $reaped_pid == $pid, $reaped_pid;
+ok 7, $? == 0, $?;
index e69de29..a4a978e 100755 (executable)
@@ -0,0 +1,114 @@
+#!./perl -w
+use strict;
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    # make warnings fatal
+    $SIG{__WARN__} = sub { die @_ };
+}
+
+use IO::Handle;
+use IPC::Open3;
+#require 'open3.pl'; use subs 'open3';
+
+sub ok {
+    my ($n, $result, $info) = @_;
+    if ($result) {
+       print "ok $n\n";
+    }
+    else {
+       print "not ok $n\n";
+       print "# $info\n" if $info;
+    }
+}
+
+my ($pid, $reaped_pid);
+STDOUT->autoflush;
+STDERR->autoflush;
+
+print "1..21\n";
+
+# basic
+ok 1, $pid = open3 'WRITE', 'READ', 'ERROR', $^X, '-e', <<'EOF';
+    $| = 1;
+    print scalar <STDIN>;
+    print STDERR "hi error\n";
+EOF
+ok 2, print WRITE "hi kid\n";
+ok 3, <READ> eq "hi kid\n";
+ok 4, <ERROR> eq "hi error\n";
+ok 5, close(WRITE), $!;
+ok 6, close(READ), $!;
+ok 7, close(ERROR), $!;
+$reaped_pid = waitpid $pid, 0;
+ok 8, $reaped_pid == $pid, $reaped_pid;
+ok 9, $? == 0, $?;
+
+# read and error together, both named
+$pid = open3 'WRITE', 'READ', 'READ', $^X, '-e', <<'EOF';
+    $| = 1;
+    print scalar <STDIN>;
+    print STDERR scalar <STDIN>;
+EOF
+print WRITE "ok 10\n";
+print scalar <READ>;
+print WRITE "ok 11\n";
+print scalar <READ>;
+waitpid $pid, 0;
+
+# read and error together, error empty
+$pid = open3 'WRITE', 'READ', '', $^X, '-e', <<'EOF';
+    $| = 1;
+    print scalar <STDIN>;
+    print STDERR scalar <STDIN>;
+EOF
+print WRITE "ok 12\n";
+print scalar <READ>;
+print WRITE "ok 13\n";
+print scalar <READ>;
+waitpid $pid, 0;
+
+# dup writer
+ok 14, pipe PIPE_READ, PIPE_WRITE;
+$pid = open3 '<&PIPE_READ', 'READ', '',
+                   $^X, '-e', 'print scalar <STDIN>';
+close PIPE_READ;
+print PIPE_WRITE "ok 15\n";
+close PIPE_WRITE;
+print scalar <READ>;
+waitpid $pid, 0;
+
+# dup reader
+$pid = open3 'WRITE', '>&STDOUT', 'ERROR',
+                   $^X, '-e', 'print scalar <STDIN>';
+print WRITE "ok 16\n";
+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', '>&STDOUT',
+                   $^X, '-e', 'print STDERR scalar <STDIN>';
+print WRITE "ok 17\n";
+waitpid $pid, 0;
+
+# dup reader and error together, both named
+$pid = open3 'WRITE', '>&STDOUT', '>&STDOUT', $^X, '-e', <<'EOF';
+    $| = 1;
+    print STDOUT scalar <STDIN>;
+    print STDERR scalar <STDIN>;
+EOF
+print WRITE "ok 18\n";
+print WRITE "ok 19\n";
+waitpid $pid, 0;
+
+# dup reader and error together, error empty
+$pid = open3 'WRITE', '>&STDOUT', '', $^X, '-e', <<'EOF';
+    $| = 1;
+    print STDOUT scalar <STDIN>;
+    print STDERR scalar <STDIN>;
+EOF
+print WRITE "ok 20\n";
+print WRITE "ok 21\n";
+waitpid $pid, 0;