From: Perl 5 Porters Date: Thu, 19 Dec 1996 23:14:00 +0000 (+1200) Subject: [inseparable changes from patch from perl5.003_12 to perl5.003_13] X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7e1af8bca57f405a8444b575a870918a6d88fc5c;p=p5sagit%2Fp5-mst-13.2.git [inseparable changes from patch from perl5.003_12 to perl5.003_13] DOCUMENTATION Subject: small doc tweaks for _12 Date: Thu, 19 Dec 1996 11:05:57 -0500 From: Roderick Schertler 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 Files: Configure UTILITIES, LIBRARY, AND EXTENSIONS Subject: Include libnet-1.01 instead of old Net::FTP From: Graham Barr 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 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 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: (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 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 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) --- diff --git a/Changes b/Changes index dff8dff..26c4ad8 100644 --- 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 + Files: toke.c + + Title: "Make evals' lexicals visible to nested evals" + From: Chip Salzenberg + Files: pp_ctl.c + + OTHER CORE CHANGES + + Title: "Fix core dump bug with anoncode" + From: Chip Salzenberg + Files: op.c + + Title: "Allow DESTROY to make refs to dying objects" + From: Chip Salzenberg + Files: sv.c + + PORTABILITY + + Title: "Add missing backslash in Configure" + From: Chip Salzenberg + Files: Configure + + UTILITIES, LIBRARY, AND EXTENSIONS + + Title: "Include libnet-1.01 instead of old Net::FTP" + From: Graham Barr + 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 + Msg-ID: + 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 + 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 + 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 + Msg-ID: + 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 + 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 + Msg-ID: + Date: 19 Dec 1996 10:30:43 -0500 + Files: pod/perlpod.pod pod/pod2html.PL + + +---------------- Version 5.003_12 ---------------- diff --git a/Configure b/Configure index c8ee9f6..d22b009 100755 --- 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' diff --git a/MANIFEST b/MANIFEST index ce57721..79e9203 100644 --- 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 diff --git a/Porting/Glossary b/Porting/Glossary index da02084..58f2cac 100644 --- a/Porting/Glossary +++ b/Porting/Glossary @@ -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 diff --git a/config_H b/config_H index 11e9033..cec8188 100644 --- a/config_H +++ b/config_H @@ -335,6 +335,13 @@ #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. diff --git a/config_h.SH b/config_h.SH index dd73771..c6d662a 100755 --- a/config_h.SH +++ b/config_h.SH @@ -349,6 +349,13 @@ sed <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. diff --git a/ext/Fcntl/Fcntl.pm b/ext/Fcntl/Fcntl.pm index 9d000a1..4898534 100644 --- a/ext/Fcntl/Fcntl.pm +++ b/ext/Fcntl/Fcntl.pm @@ -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. + =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 { diff --git a/ext/Fcntl/Fcntl.xs b/ext/Fcntl/Fcntl.xs index 90f3af5..0f51b10 100644 --- a/ext/Fcntl/Fcntl.xs +++ b/ext/Fcntl/Fcntl.xs @@ -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")) diff --git a/ext/IO/lib/IO/Pipe.pm b/ext/IO/lib/IO/Pipe.pm index 27fe7f1..9ec8b64 100644 --- a/ext/IO/lib/IO/Pipe.pm +++ b/ext/IO/lib/IO/Pipe.pm @@ -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 diff --git a/ext/Socket/Socket.pm b/ext/Socket/Socket.pm index 9872d03..e04689d 100644 --- a/ext/Socket/Socket.pm +++ b/ext/Socket/Socket.pm @@ -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 diff --git a/ext/Socket/Socket.xs b/ext/Socket/Socket.xs index 6c39557..7e3e3b3 100644 --- a/ext/Socket/Socket.xs +++ b/ext/Socket/Socket.xs @@ -30,10 +30,117 @@ #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)); + } diff --git a/lib/IPC/Open2.pm b/lib/IPC/Open2.pm index 35bb0d1..cfd15a8 100644 --- a/lib/IPC/Open2.pm +++ b/lib/IPC/Open2.pm @@ -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. @@ -44,13 +58,11 @@ read and write a line from it. =head1 SEE ALSO -See L for an alternative that handles STDERR as well. +See L 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, # # usage: $pid = open2('rdr', 'wtr', 'some cmd and args'); @@ -67,41 +79,15 @@ See L 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 diff --git a/lib/IPC/Open3.pm b/lib/IPC/Open3.pm index d416ae7..5d85458 100644 --- a/lib/IPC/Open3.pm +++ b/lib/IPC/Open3.pm @@ -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 for details. +open3() returns the process ID of the child process. It doesn't return on +failure: it just raises an exception matching C. -=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, both writing to it +and reading from it. This is presumably safe because you "know" that +commands like B will read a line at a time and output a line at a +time. Programs like B 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 and continually read and write a line from it. + +=cut # &open3: Marc Horowitz # derived mostly from &open2 by tom christiansen, @@ -48,7 +75,7 @@ All caveats from open2() continue to apply. See L 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 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 index 0000000..6697ad1 --- /dev/null +++ b/lib/Net/Cmd.pm @@ -0,0 +1,529 @@ +# Net::Cmd.pm +# +# 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. + +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 is a collection of methods that can be inherited by a sub class +of C. 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 object. + +=over 4 + +=item debug ( VALUE ) + +Set the level of debug information for this object. If C is not given +then the current state is returned. Otherwise the state is changed to +C and the previous state returned. If C is C then +the debug level will be set to the default debug level for the class. + +This method can also be called as a I 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 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 calls C and +returns true if C 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 + +=over 4 + +=item debug_print ( DIR, TEXT ) + +Print debugging information. C denotes the direction I being +data being sent to the server. Calls C 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 is +returned. + +=item parse_response ( TEXT ) + +This method is called by C 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 +upon failure. + +B: If you do use this method for any reason, please remember to add +some C 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 upon failure. + +=back + +=head1 EXPORTS + +C exports six subroutines, five of these, C, C, +C, C and C ,correspond to possible results +of C and C. The sixth is C. + +=head1 AUTHOR + +Graham Barr + +=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 index 0000000..558b7f3 --- /dev/null +++ b/lib/Net/Domain.pm @@ -0,0 +1,245 @@ +# Net::Domain.pm +# +# 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. + +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 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 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 has been removed. + +=back + +=head1 AUTHOR + +Graham Barr . +Adapted from Sys::Hostname by David Sundstrom + +=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() { + $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 index 0000000..8dddc90 --- /dev/null +++ b/lib/Net/DummyInetd.pm @@ -0,0 +1,156 @@ +# Net::DummyInetd.pm +# +# 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. + +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 is just what it's name says, it is a dummy inetd server. +Creation of a C 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 to connect +to a C process, which is not the default, via SIDIN and STDOUT. +A C package will be avaliable in the next release of C + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( CMD ) + +Creates a new object and spawns a child process which listens to a socket. +C is a list, which will be passed to C when a new process needs +to be created. + +=back + +=head1 METHODS + +=over 4 + +=item port + +Returns the port number on which the I object is listening + +=back + +=head1 AUTHOR + +Graham Barr + +=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; diff --git a/lib/Net/FTP.pm b/lib/Net/FTP.pm index 64b21fe..d635f00 100644 --- a/lib/Net/FTP.pm +++ b/lib/Net/FTP.pm @@ -1,16 +1,8 @@ -;# Net::FTP.pm -;# -;# 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. - -;#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 . 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 is a class implementing a simple FTP client in Perl as described in RFC959 -=head2 TO BE CONTINUED ... +C 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 is the +name of the remote host to which a FTP connection is required. -use strict; +C are passed in a hash like fasion, using key and value pairs. +Possible options are: + +B - The name of a machine which acts as a FTP firewall. This can be +overridden by an environment variable C. 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 - The port number to connect to on the remote machine for the +FTP connection + +B - Set a timeout value (defaults to 120) + +B - Debug level + +B - If set to I then all data transfers will be done using +passive mode. This is required for some I servers. + +=back =head1 METHODS -All methods return 0 or undef upon failure +Unless otherwise stated all methods return either a I or I +value, with I meaning that the operation was a success. When a method +states that it returns a value, falure will be returned as I 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 uses the C +package to lookup the login information for the connected host. +If no information is found then a login of I is used. +If no password is given and the login is I then the users +Email address will be used for a password. + +If the connection is via a firewall then the C 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 uses C 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 with the first arguments set correctly + +B ebcdic and byte are not fully supported. + +=item rename ( OLDNAME, NEWNAME ) + +Rename a file on the remote FTP server from C to C. This +is done by sending the RNFR and RNTO commands. + +=item delete ( FILENAME ) + +Send a request to the server to delete C. + +=item cwd ( [ DIR ] ) + +Change the current working directory to C, 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. + +=item mkdir ( DIR [, RECURSE ]) + +Create a new directory with the name C. If C is I then +C 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, 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, 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 from the server and store locally. C 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, or the generated local file name if C +is not given. + +=item put ( LOCAL_FILE [, REMOTE_FILE ] ) + +Put a file on the remote server. C may be a name or a filehandle. +If C is a filehandle then C must be specified. If +C is not specified then the file will be stored in the current +directory with the same leafname as C. + +Returns C, or the generated remote filename if C +is not given. + +=item put_unique ( LOCAL_FILE [, REMOTE_FILE ] ) + +Same as put but uses the C 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, or the generated remote filename if C +is not given. + +=item unique_name () + +Returns the name of the last file stored on the server using the +C command. + +=item mdtm ( FILE ) + +Returns the I 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 or C methods then these methods will +return a I or I value. If the user does not +call either of these methods then the result will be a +reference to a C based object. + +=over 4 + +=item nlst ( [ DIR ] ) + +Send a C command to the server, with an optional parameter. + +=item list ( [ DIR ] ) + +Same as C but using the C command + +=item retr ( FILE ) + +Begin the retrieval of a file called C from the remote server. + +=item stor ( FILE ) + +Tell the server that you wish to store a file. C is the +name of the new file that should be created. + +=item stou ( FILE ) + +Same as C but using the C command. The name of the unique +file which was created on the server will be avalaliable via the C +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. 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 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, C, +C and those that do not require data connections. + +=over 4 + +=item port ( [ PORT ] ) + +Send a C command to the server. If C 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 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 is omitted then the leaf name of C 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 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 inherits from C so methods defined in C 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 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 return an object which will +be derived from this class.The dataconn class itself is derived from +the C 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 bytes of data from the server and place it into C, also +performing any translation necessary. C is optional, if not +given the the timeout value from the command connection will be used. + +Returns the number of bytes read before any translation. + +=item write ( BUFFER, SIZE [, TIMEOUT ] ) + +Write C bytes of data from C to the server, also +performing any translation necessary. C is optional, if not +given the the timeout value from the command connection will be used. + +Returns the number of bytes written before any translation. + +=item abort () + +Abort the current data transfer. + +=item close () + +Close the data connection and get a response from the FTP server. Returns +I if the connection was closed sucessfully and the first digit of +the response from the server was a '2'. + +=back + +=head1 AUTHOR + +Graham Barr + +=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 +L + +=head1 CREDITS + +Henry Gabryjelski - 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 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 \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 \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 - -=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 index 0000000..a23b9bb --- /dev/null +++ b/lib/Net/NNTP.pm @@ -0,0 +1,996 @@ +# Net::NNTP.pm +# +# 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. + +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 is a class implementing a simple NNTP client in Perl as described +in RFC977. C inherits its communication methods from C + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [ HOST ] [, OPTIONS ]) + +This is the constructor for a new Net::NNTP object. C is the +name of the remote host to which a NNTP connection is required. If not +given two environment variables are checked, first C then +C, if neither are set C is used. + +C are passed in a hash like fasion, using key and value pairs. +Possible options are: + +B - 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 - Enable the printing of debugging information to STDERR + +=back + +=head1 METHODS + +Unless otherwise stated all methods return either a I or I +value, with I meaning that the operation was a success. When a method +states that it returns a value, falure will be returned as I 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 is a numeric id of an article in the +current newsgroup, and will change the current article pointer. +C is the message id of an article as +shown in that article's header. It is anticipated that the client +will obtain the C from a list provided by the C +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
+ +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
+ +Returns a reference to an array containing the header of the article. + +=item nntpstat ( [ MSGID|MSGNUM ] ) + +The C command is similar to the C
command except that no +text is returned. When selecting by message number within a group, +the C command serves to set the "current article pointer" without +sending text. + +Using the C command to +select by message-id is valid but of questionable value, since a +selection by message-id does B 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 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 command informs the server that the client has an article +whose id is C. If the server desires a copy of that +article, and C has been given the it will be sent. + +Returns I if the server desires the article and C was +successfully sent,if specified. + +If C is not specified then the message must be sent using the +C and C methods from L + +C 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 will return I 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 is a time value and C is either a distribution +pattern or a reference to a list of distribution patterns. +The result is the same as C, but the +groups return will be limited to those created after C and, if +specified, in one of the distribution areas in C. + +=item newnews ( SINCE [, GROUPS [, DISTRIBUTIONS ]]) + +C is a time value. C is either a group pattern or a reference +to a list of group patterns. C 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, that are in a groups which matched C and a +distribution which matches C. + +=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 is specified and posting +is allowed then the message will be sent. + +If C is not specified then the message must be sent using the +C and C methods from L + +C 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, 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. + +=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 but only active groups that match the pattern are returned. +C 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 and each value is the description text for the group. + +=item xhdr ( HEADER, MESSAGE-RANGE ) + +Obtain the header field C
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. + +=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 except the is will be restricted to +headers that match C + +=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 is either a single message-id, a single mesage number, or +two message numbers. + +If C 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 protocol uses the C 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 + +matches any four character string which begins +with a and ends with d. + +=back + +=back + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Graham Barr + +=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; diff --git a/lib/Net/Netrc.pm b/lib/Net/Netrc.pm index 58f0663..4299821 100644 --- a/lib/Net/Netrc.pm +++ b/lib/Net/Netrc.pm @@ -1,40 +1,196 @@ +# Net::Netrc.pm +# +# 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. + 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 is a class implementing a simple interface to the .netrc file +used as by the ftp program. + +C 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 only parses this field to be compatible +with I. + +=back + +=head1 CONSTRUCTOR + +The constructor for a C object is not called new as it does not +really create a new object. But instead is called C as this is +essentially what it deos. + +=over 4 + +=item lookup ( MACHINE [, LOGIN ]) + +Lookup and return a reference to the entry for C. If C is given +then the entry returned will have the given login. If C is not given then +the first entry in the .netrc file for C 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 + +=head1 REVISION + +$Revision: 2.1 $ + +=head1 SEE ALSO + +L +L + +=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() + 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 index 0000000..538039e --- /dev/null +++ b/lib/Net/POP3.pm @@ -0,0 +1,402 @@ +# Net::POP3.pm +# +# 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. + +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 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 is the +name of the remote host to which a POP3 connection is required. + +C are passed in a hash like fasion, using key and value pairs. +Possible options are: + +B - Maximum time, in seconds, to wait for a response from the +POP3 server (default: 120) + +B - Enable debugging information + +=back + +=head1 METHODS + +Unless otherwise stated all methods return either a I or I +value, with I meaning that the operation was a success. When a method +states that it returns a value, falure will be returned as I 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 is not given the +C uses C 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 of the body for the message +C. 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 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's of all undeleted messages and the values will +be their size in octets. + +=item get ( MSGNUM ) + +Get the message C 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 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 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 object goes out of scope before C method is called +then the C method will called before the connection is closed. This +means that any messages marked to be deleted will not be. + +=head1 SEE ALSO + +L +L + +=head1 AUTHOR + +Graham Barr + +=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 index 0000000..8d56523 --- /dev/null +++ b/lib/Net/SMTP.pm @@ -0,0 +1,526 @@ +# Net::SMTP.pm +# +# 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. + +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 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 is the +name of the remote host to which a SMTP connection is required. + +C are passed in a hash like fasion, using key and value pairs. +Possible options are: + +B - 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 - Maximum time, in seconds, to wait for a response from the +SMTP server (default: 120) + +B - Enable debugging information + + +Example: + + + $smtp = Net::SMTP->new('mailhost', + Hello => 'my.mail.domain' + ); + +=head1 METHODS + +Unless otherwise stated all methods return either a I or I +value, with I meaning that the operation was a success. When a method +states that it returns a value, falure will be returned as I 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
+is the address of the sender. This initiates the sending of a message. The +method C 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 value is returned. It is up to the +user to call C if they so desire. + +=item to () + +A synonym for recipient + +=item data ( [ DATA ] ) + +Initiate the sending of the data fro the current message. + +C may be a reference to a list or a list. If specified the contents +of C 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 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 +and C methods defined in C. + +=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
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 + +=head1 AUTHOR + +Graham Barr + +=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 index 0000000..d869188 --- /dev/null +++ b/lib/Net/SNPP.pm @@ -0,0 +1,389 @@ +# Net::SNPP.pm +# +# 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. + +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 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 is the +name of the remote host to which a SNPP connection is required. + +C are passed in a hash like fasion, using key and value pairs. +Possible options are: + +B - Maximum time, in seconds, to wait for a response from the +SNPP server (default: 120) + +B - Enable debugging information + + +Example: + + + $snpp = Net::SNPP->new('snpphost', + Debug => 1, + ); + +=head1 METHODS + +Unless otherwise stated all methods return either a I or I +value, with I meaning that the operation was a success. When a method +states that it returns a value, falure will be returned as I 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 exports all that C exports, plus three more subroutines +that can bu used to compare against the result of C. These are :- +C, C, and C. + +=head1 SEE ALSO + +L +RFC1861 + +=head1 AUTHOR + +Graham Barr + +=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 index 0000000..397502e --- /dev/null +++ b/lib/Net/Telnet.pm @@ -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 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 + +=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 index 0000000..a6b0b59 --- /dev/null +++ b/lib/Net/Time.pm @@ -0,0 +1,112 @@ +# Net::Time.pm +# +# 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. + +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 provides subroutines that obtain the time on a remote machine. + +=over 4 + +=item inet_time ( HOST [, PROTOCOL]) + +Obtain the time on C using the protocol as defined in RFC868. The +optional argument C should define the protocol to use, either +C or C. The result will be a unix-like time value or I +upon failure. + +=item inet_daytime ( HOST [, PROTOCOL]) + +Obtain the time on C using the protocol as defined in RFC867. The +optional argument C should define the protocol to use, either +C or C. The result will be an ASCII string or I +upon failure. + +=back + +=head1 AUTHOR + +Graham Barr + +=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; diff --git a/lib/UNIVERSAL.pm b/lib/UNIVERSAL.pm index c006547..c0e7ebd 100644 --- a/lib/UNIVERSAL.pm +++ b/lib/UNIVERSAL.pm @@ -38,7 +38,7 @@ C can be called as either a static or object method call. =item can ( METHOD ) C checks if the object has a method called C. If it does -then a reference to the sub is returned. If it does not the I +then a reference to the sub is returned. If it does not then I is returned. C can be called as either a static or object method call. diff --git a/lib/open2.pl b/lib/open2.pl index 7d3b970..8cf08c2 100644 --- a/lib/open2.pl +++ b/lib/open2.pl @@ -1,54 +1,12 @@ -# &open2: tom christiansen, +# 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 diff --git a/lib/open3.pl b/lib/open3.pl index 8b3917a..7fcc931 100644 --- a/lib/open3.pl +++ b/lib/open3.pl @@ -1,106 +1,12 @@ -# &open3: Marc Horowitz -# derived mostly from &open2 by tom christiansen, +# 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 diff --git a/patchlevel.h b/patchlevel.h index 73210e2..066db70 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1,5 +1,5 @@ #define PATCHLEVEL 3 -#define SUBVERSION 12 +#define SUBVERSION 13 /* local_patches -- list of locally applied less-than-subversion patches. diff --git a/pod/perldiag.pod b/pod/perldiag.pod index bbd699f..49d30fc 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -635,7 +635,7 @@ Usually this is because you don't have read permission for the file. (W) You tried to say C, 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", +IPC::Open2. Alternately, direct the pipe's output to a file using "E", 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) 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#!E 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) or you called it with no args and C<$_> was empty. diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 49b77f0..9e6a7f1 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -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 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 out, but see L, -L, and L for alternatives.) +a raw open() to a command that pipes both in I out, but see +L, L, and L +for alternatives.) Opening '-' opens STDIN and opening 'E-' 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, L, and L +See L, L, and L for examples of such things. =item pop ARRAY diff --git a/pod/perlmod.pod b/pod/perlmod.pod index 4fb5ec8..e6081aa 100644 --- a/pod/perlmod.pod +++ b/pod/perlmod.pod @@ -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 diff --git a/pod/perltie.pod b/pod/perltie.pod index 7624881..6bfdf59 100644 --- a/pod/perltie.pod +++ b/pod/perltie.pod @@ -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 "\n"; my $r; bless \$r, shift } + sub TIEHANDLE { print "\n"; my $i; bless \$i, shift } =item PRINT this, LIST diff --git a/t/lib/open2.t b/t/lib/open2.t index e69de29..8dd786b 100755 --- a/t/lib/open2.t +++ b/t/lib/open2.t @@ -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 '; +ok 2, print WRITE "hi kid\n"; +ok 3, 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, $?; diff --git a/t/lib/open3.t b/t/lib/open3.t index e69de29..a4a978e 100755 --- a/t/lib/open3.t +++ b/t/lib/open3.t @@ -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 ; + print STDERR "hi error\n"; +EOF +ok 2, print WRITE "hi kid\n"; +ok 3, eq "hi kid\n"; +ok 4, 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 ; + print STDERR scalar ; +EOF +print WRITE "ok 10\n"; +print scalar ; +print WRITE "ok 11\n"; +print scalar ; +waitpid $pid, 0; + +# read and error together, error empty +$pid = open3 'WRITE', 'READ', '', $^X, '-e', <<'EOF'; + $| = 1; + print scalar ; + print STDERR scalar ; +EOF +print WRITE "ok 12\n"; +print scalar ; +print WRITE "ok 13\n"; +print scalar ; +waitpid $pid, 0; + +# dup writer +ok 14, pipe PIPE_READ, PIPE_WRITE; +$pid = open3 '<&PIPE_READ', 'READ', '', + $^X, '-e', 'print scalar '; +close PIPE_READ; +print PIPE_WRITE "ok 15\n"; +close PIPE_WRITE; +print scalar ; +waitpid $pid, 0; + +# dup reader +$pid = open3 'WRITE', '>&STDOUT', 'ERROR', + $^X, '-e', 'print scalar '; +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 '; +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 ; + print STDERR scalar ; +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 ; + print STDERR scalar ; +EOF +print WRITE "ok 20\n"; +print WRITE "ok 21\n"; +waitpid $pid, 0;