From: Jarkko Hietaniemi Date: Sun, 17 Jun 2001 16:53:29 +0000 (+0000) Subject: Initial integration of libnet-1.0703. X-Git-Tag: perl-5.7.2~614 X-Git-Url: https://perl5.git.perl.org/perl5.git/commitdiff_plain/406c51eefa6c9c4f403ef7f86adb46a627701935 Initial integration of libnet-1.0703. The Configure script renamed as libnetcfg, will be installed along other utilities. p4raw-id: //depot/perl@10663 --- diff --git a/MANIFEST b/MANIFEST index a4c63cf..5785ce3 100644 --- a/MANIFEST +++ b/MANIFEST @@ -878,11 +878,49 @@ lib/Memoize/t/tie_storable.t Memoize lib/Memoize/t/tiefeatures.t Memoize lib/Memoize/t/unmemoize.t Memoize lib/NEXT.pm Pseudo-class NEXT for method redispatch +lib/Net/ChangeLog.libnet libnet +lib/Net/Cmd.pm libnet +lib/Net/Config.eg libnet +lib/Net/Config.pm libnet +lib/Net/Domain.pm libnet +lib/Net/DummyInetd.pm libnet +lib/Net/FTP.pm libnet +lib/Net/FTP/A.pm libnet +lib/Net/FTP/E.pm libnet +lib/Net/FTP/I.pm libnet +lib/Net/FTP/L.pm libnet +lib/Net/FTP/dataconn.pm libnet +lib/Net/Hostname.eg libnet +lib/Net/NNTP.pm libnet +lib/Net/Netrc.pm libnet +lib/Net/PH.pm libnet +lib/Net/POP3.pm libnet lib/Net/Ping.pm Hello, anybody home? +lib/Net/README.config libnet +lib/Net/README.libnet libnet +lib/Net/SMTP.pm libnet +lib/Net/SNPP.pm libnet +lib/Net/Time.pm libnet +lib/Net/demos/ftp libnet +lib/Net/demos/inetd libnet +lib/Net/demos/nntp libnet +lib/Net/demos/nntp.mirror libnet +lib/Net/demos/pop3 libnet +lib/Net/demos/smtp.self libnet +lib/Net/demos/snpp libnet +lib/Net/demos/time libnet lib/Net/hostent.pm By-name interface to Perl's builtin gethost* +lib/Net/libnet.ppd libnet +lib/Net/libnetFAQ.pod libnet lib/Net/netent.pm By-name interface to Perl's builtin getnet* lib/Net/protoent.pm By-name interface to Perl's builtin getproto* lib/Net/servent.pm By-name interface to Perl's builtin getserv* +lib/Net/t/ftp.t libnet +lib/Net/t/hostname.t libnet +lib/Net/t/nntp.t libnet +lib/Net/t/ph.t libnet +lib/Net/t/require.t libnet +lib/Net/t/smtp.t libnet lib/PerlIO.pm PerlIO support module lib/Pod/Checker.pm Pod-Parser - check POD documents for syntax errors lib/Pod/Find.pm used by pod/splitpod @@ -1998,6 +2036,7 @@ utils/c2ph.PL program to translate dbx stabs to perl utils/dprofpp.PL Perl code profile post-processor utils/h2ph.PL A thing to turn C .h files into perl .ph files utils/h2xs.PL Program to make .xs files from C header files +utils/libnetcfg.PL libnet utils/perlbug.PL A simple tool to submit a bug report utils/perlcc.PL Front-end for compiler utils/perldoc.PL A simple tool to find & display perl's documentation diff --git a/lib/Net/ChangeLog.libnet b/lib/Net/ChangeLog.libnet new file mode 100644 index 0000000..ccfcac5 --- /dev/null +++ b/lib/Net/ChangeLog.libnet @@ -0,0 +1,717 @@ +Change 402 on 2000/03/23 by (Graham Barr) + + Net::Config + - Fix typos in requires_firewall(), Thanks to Johan Vromans + +Change 401 on 2000/03/23 by (Graham Barr) + + Net::FTP + - fix rmdir for when ls() returns full paths + +Change 379 on 2000/03/13 by (Graham Barr) + + Release 1.0702 + +Change 378 on 2000/03/10 by (Graham Barr) + + Net::FTP::A + - Fix to stop possible forever loop + +Change 377 on 2000/03/10 by (Graham Barr) + + Net::FTP::A + - use " not ' + +Change 376 on 2000/03/10 by (Graham Barr) + + Net::Config + - need to import inet_aton and inet_ntoa + +Change 375 on 2000/03/10 by (Graham Barr) + + Net::Config + - change arg to split to /\./ from "." + +Change 374 on 2000/03/07 by (Graham Barr) + + Net::FTP::A + - Fix return value of read() + +Change 373 on 2000/03/07 by (Graham Barr) + + Net::FTP::I + - Fix typo + +Change 372 on 2000/03/07 by (Graham Barr) + + Release 1.07 + +Change 371 on 2000/03/06 by (Graham Barr) + + - Moved FAQ to Net/libnetFAQ.pod + +Change 370 on 2000/03/06 by (Graham Barr) + + - Added mput and mget examples + +Change 369 on 2000/03/06 by (Graham Barr) + + - Added support for the xwho command in qpage, but no docs yet. + +Change 368 on 2000/03/06 by (Graham Barr) + + new Configure script + +Change 367 on 2000/03/06 by (Graham Barr) + + Local-ize $SIG{__DIE__} + +Change 361 on 2000/02/17 by (Graham Barr) + + Net::FTP + - Fix arg count check in cwd() + +Change 351 on 2000/01/31 by (Graham Barr) + + Net::Cmd + - Fixed bug in getline returning an empty line + - Added optional filehandle argument to read_until_dot. + + Net::POP3 + - get now takes an optional filehandle argument, if given the + message is sent to the handle. + +Change 348 on 2000/01/17 by (Graham Barr) + + Net::Cmd + - fix getline not to drop blank lines + +Change 347 on 2000/01/12 by (Graham Barr) + + Net::Time + - Fix use of uninitialized warning caused by _socket + +Change 346 on 2000/01/11 by (Graham Barr) + + Net::FTP + - Change firewall code to use Net::Config->requires_firewall + + Net::Config + - renamed is_external to be requires_firewall + +Change 345 on 2000/01/06 by (Graham Barr) + + Net::FTP + - Added workaround for a Y2K bug that exists with the MDTM + command on some servers. + +Change 341 on 1999/09/29 by (Graham Barr) + + Net::FTP, Net::FTP::A, Net::FTP::I, Net::FTP::datacon + - Added BlockSize option to control size of blocks read from server + (defaults to 10K) + +Change 340 on 1999/09/28 by (Graham Barr) + + Net::FTP, Configure + - First attempt to add multiple firewall type support + +Change 339 on 1999/09/28 by (Graham Barr) + + Added ppd info to Makefile.PL and libnet.ppd to MANIFEST + +Change 333 on 1999/09/18 by (Graham Barr) + + Release 1.0607 + +Change 332 on 1999/09/18 by (Graham Barr) + + Configure + - Fix typo + +Change 331 on 1999/09/18 by (Graham Barr) + + Net::FTP + - get and put now accept *FD as well as \*FD for the local filehandle + +Change 330 on 1999/09/18 by (Graham Barr) + + Net::Domain + - Added support for VMS as suggest by lane@DUPHY4.Physics.Drexel.Edu + +Change 329 on 1999/09/18 by (Graham Barr) + + Net::Netrc + - Added support for spaces in passwords + +Change 328 on 1999/09/18 by (Graham Barr) + + Net::Cmd + - Map \n's in commands to " " + +Change 327 on 1999/09/18 by (Graham Barr) + + Net::Netrc + - Applied patch from Randy Merrell to fix / escaping + +Change 318 on 1999/08/06 by (Graham Barr) + + Net::Cmd + - Remove use of defined(@ISA) + +Change 316 on 1999/07/11 by (Graham Barr) + + Net::POP3 + - Added ping method supplied by William Rolston + +Change 309 on 1999/05/05 by (Graham Barr) + + Net::FTP + - Check that writes to local file succeed + +Change 308 on 1999/05/05 by (Graham Barr) + + Net::FTP + - Fix bug ->size when SIZE and STAT are not implemented + +Change 307 on 1999/05/05 by (Graham Barr) + + Net::POP3 + - The return value for apop is now the same as login + +Change 306 on 1999/05/05 by (Graham Barr) + + Net::POP3 + - login now returns "0E0" when there are no messages on te server. + This is true in a boolean context, but zero in a numeric context + +Change 305 on 1999/05/05 by (Graham Barr) + + Net::FTP::A + - Fixed bug when sending a file in ascii mode that already contains + \r\n character sequences + - Made improvements to speed of \r\n <-> \n translation + +Change 304 on 1999/05/04 by (Graham Barr) + + Net::FTP + - Added hash mark printing + +Change 264 on 1999/03/17 by (Graham Barr) + + Net::TFTP + - Fix typo in CLOSE() + +Change 262 on 1999/03/16 by (Graham Barr) + + Net::FTP + - new should only call authorize if there is user/passwd data + + Net::SMTP + - Allow ->to to ignore bad addresses + +Change 254 on 1999/02/24 by (Graham Barr) + + Added some debug to t/ftp.t to help understand failure + +Change 253 on 1999/02/17 by (Graham Barr) + + Net::Cmd + - Added checks for a closed connection + +Change 252 on 1999/02/17 by (Graham Barr) + + Net::Domain + - set FQDN = IP if host does not have a name + +Change 248 on 1999/02/05 by (Graham Barr) + + Net::Domain + - check for defined(&main::SYS_gethostname) before calling syscall + as user may have a UNIVERSAL::AUTOLOADER defined + +Change 245 on 1999/01/18 by (Graham Barr) + + Net::FTP + - Modify mkdir to call ->cwd(), not ->cd() + +Change 206 on 1998/10/20 by (Graham Barr) + + Fix typo in Net::Cmd + +Change 204 on 1998/10/18 by (Graham Barr) + + Net::SMTP + - DESTROY now does nothing, so any half-sent message should be aborted + +Change 198 on 1998/10/15 by (Graham Barr) + + Net::Config added + + Configure, Makefile.PL + - Canges to handle new Net::Config module + +Change 197 on 1998/10/15 by (Graham Barr) + + Net::FTP + - Fixed return vlue of _ACCT + + Net::Cmd + - Fixed datasend to ensure all data is sent + - Fixed a || bug in getline + + Some FAQ updates + +Change 196 on 1998/10/15 by (Graham Barr) + + Net::TFTP + - Initial public release + +Change 195 on 1998/10/04 by (Graham Barr) + + Net::FTP + - Fixed bad use of ||= in cwd() + + Net::POP3 + - Fixed pattern for -ERR (had +ERR) + +Change 191 on 1998/09/26 by (Graham Barr) + + Net::POP3 + - Fix bug in UIDL + +Change 187 on 1998/09/01 by (Graham Barr) + + Net::TFTP + - Some cleanup of the code + - removed leading - from named args + +Change 185 on 1998/08/23 by (Graham Barr) + + Net::TFTP + - Initial version + +Change 184 on 1998/08/23 by (Graham Barr) + + Remove mention of Net::SNMP from README + +Change 183 on 1998/08/06 by (Graham Barr) + + Net::Domain + - Fix problem with returning last name instead of first name for a + win32 multi-homed machine + +Change 182 on 1998/08/06 by (Graham Barr) + + Net::FTP + - _list_cmd returned (undef) instead of () + - Fix typo in docs + + Net::NNTP + - Fix typo in docs + +Change 181 on 1998/08/04 by (Graham Barr) + + Net::FTP + - Allow spaces in filenames (ick!) + +Change 179 on 1998/08/04 by (Graham Barr) + + Net::FTP + - added new rmdir from Dunkin Software + - fix to the code generating the listen port + +Change 171 on 1998/07/08 by (Graham Barr) + + Net::FTP + - login will now send ACCT if $acct is defined and the PASS + command completed with 2xx or 3xx + - Added a check for the close of the dataconn in _store_cmd + - Debug trace will hide any parameter given to ACCT + +Change 167 on 1998/07/04 by (Graham Barr) + + - Added Config.eg, an example Config.pm + - Removed set method from Net::Config + - Removed check for Data::Dumper from Makefile.PL + +Change 157 on 1998/06/19 by (Graham Barr) + + Net::FTP + - Another small tweak to ->supported() + +Change 156 on 1998/06/18 by (Graham Barr) + + Net::FTP + - Tweak to ->supported() to better detect reports from some + servers (NcFTPd) + +Change 153 on 1998/06/16 by (Graham Barr) + + Net::FTP + - Fix "Use of uninitialized" warning, patch from + Lars Thegler + +Change 148 on 1998/06/07 by (Graham Barr) + + Net::SMTP + - Fix typo + +Change 147 on 1998/06/07 by (Graham Barr) + + Net::SMTP + - Added ->supports() + - Added ->etrn() + + Updated FAQ + +Change 141 on 1998/05/24 by (Graham Barr) + + Net::SMTP + - Added banner() method + +Change 132 on 1998/04/18 by (Graham Barr) + + Net::POP3 + - Added ResvPort option to new() + +Change 131 on 1998/04/18 by (Graham Barr) + + Makefile.PL + - Patch for running $^X Configure under VMS + +Change 130 on 1998/04/18 by (Graham Barr) + + Net::FTP, Net::POP3 + - wrapped getpwuid in eval {} as some OSs (eg NT) do not support it + +Change 129 on 1998/04/18 by (Graham Barr) + + Net::FTP + - Enhanced ->size() to try different approaces if SIZE is + not implemented + +Change 128 on 1998/04/15 by (Graham Barr) + + Net::Time + - Correct number of seconds in a year + +Change 126 on 1998/04/06 by (Graham Barr) + + Net::FTP, Net::FTP::A, Net::FTP::I, Net::Cmd + - changes for undef checking on sysread/syswrite + +Change 118 on 1998/02/23 by (Graham Barr) + + Net::FTP + - Added site method + +Change 117 on 1998/02/23 by (Graham Barr) + + Net::POP3 + - Remove use of map in a void context + +Change 116 on 1998/02/21 by (Graham Barr) + + Net::FTP + - Changes to mkdir for recursive creates. + +Change 114 on 1998/02/20 by (Graham Barr) + + Net::Domain + - Change $SIG{__DIE__} to $SIG{'__DIE__'} to stop warning in 5.003 + +Change 113 on 1998/02/17 by (Graham Barr) + + Net::FTP::A + - modified regexp in write for converting to CRLF, should now work with MacOS + + Net::FTP + - Added use of File::Basename + - Small tweak to abort() + + Net::Time + - Changed inet_time to handle MacOS + + Net::Netrc + - Fixes for MacOS + + Net::Domain + - Fixes for MacOS + + Net::SMTP + - Fix for new() to fail if HELO command fails + +Change 108 on 1998/02/14 by (Graham Barr) + + Net::FTP + - Added check for filenames with spaces, \r or \n + +Change 107 on 1998/02/06 by (Graham Barr) + + Net::FTP + - Ensure dataconn object is in reading mode for data transfers + +Change 101 on 1998/01/22 by (Graham Barr) + + Renamed FAQ.pod as FAQ + +Change 100 on 1998/01/22 by (Graham Barr) + + Net::NNTP + - Added Reader option to new() + +Change 99 on 1998/01/22 by (Graham Barr) + + Net::POP3 + - fix pass() to call popstat() if pattern does not match for + message count + +Change 98 on 1998/01/22 by (Graham Barr) + + Restore changes lost in disk-crash + + *** Patch 1.0605 + + Sun Dec 21 1997 (Graham Barr) + + Net::FTP + - Fix for pasv_xfer, previous version hung if an error occured + while setting up the link between the two servers. + + Sun Dec 14 1997 (Graham Barr) + + Net::Domain + - Fix for 'Use of uninitialized' when setting $SIG{__DIE__} + + Sat Dec 13 1997 (Graham Barr) + + Net::Domain, Net::Netrc + - patches from Nick Ing-Simmons for MSWin32 + + *** Patch 1.0604 + + Thu Dec 11 1997 (Graham Barr) + + Net::FTP + - Removed use of AutoLoader, it was causing problems on + some platforms + +Change 92 on 1997/12/08 by (Graham Barr) + + Net::FTP + - Fix to pasv_xfer, the command stream on the source side was left + out of sync. + +Change 91 on 1997/12/04 by (Graham Barr) + + MANIFEST, FAQ.pod + - Added initial FAQ document + +Change 90 on 1997/12/04 by (Graham Barr) + + Net::FTP + - Set $@ if ->new() fails + +Change 82 on 1997/11/30 by (Graham Barr) + + x + +Change 79 on 1997/11/30 by (Graham Barr) + + Net::Cmd + - Fix for read_until_dot entering an endless loop, now returns undef + + Net::POP3 + - Fix ->list() and ->uidl() to handle undef being returned from + ->read_until_dot() + +Change 78 on 1997/11/30 by (Graham Barr) + + Net::FTP + - Fix to login() and authorize() for OS/2 which does not + support getpw*() + +Change 65 on 1997/11/28 by (Graham Barr) + + Net::Domain + - If user has defined $SIG{__DIE__} then failures inside eval + still call it. local-ized $SIG{__DIE__} to stop this as Net::Domain + used eval to hide such errors. + +Change 64 on 1997/11/28 by (Graham Barr) + + t/nntp.t + - Now exits passing if commands fail due to not having + authorization. + +Change 61 on 1997/11/25 by (Graham Barr) + + none + +Change 60 on 1997/11/25 by (Graham Barr) + + Net::FTP::I + - Fix to prevent ABOR being sent when xfer is complete + - Change to write() to ensure whole packet is sent + + Net::FTP + - Moved $TELNET_ vars to top of file so that autosplit does not place them + in the wrong file and cause "Use of undefined ...." + - Clarification on the result from ->size() added to docs. + - pasv_xfer changed to use stor as stou is not a "MUST-have" command + - added pasv_xfer_unique + + Net::PH + - Documentation updates. + + t/nntp.t + - Modified to test for a list of groups + +Change 58 on 1997/11/17 by (Graham Barr) + + t/nntp.t + - Modified to check for more groups before failure + +Change 56 on 1997/11/17 by (Graham Barr) + + Net::SMTP + - Corrected documentation for ->expand() + +Change 54 on 1997/11/17 by (Graham Barr) + + Makefile.PL + - change to code for creating Net::Config + + Net::FTP::A + - Change to write() to ensure whole packet is sent + - Documentation correction to dir() and ls() + + Net::FTP::dataconn + - Stop abort be called when a write socket is being closed. + + Net::NNTP + - Changes to postok logic + + Net::PH + - fields() now also returns a reference to an ordered array of tag names + if called in an array context. + + Net::Cmd + - Catch added for SIGPIPE while in ->command() + +Change 43 on 1997/11/05 by (Graham Barr) + + rename files + +Change 39 on 1997/11/04 by (Graham Barr) + + Configure + - Fix croak problem + +Change 38 on 1997/11/04 by (Graham Barr) + + Net::FTP, Net::NNTP, Net::PH, Net::POP3, Net::SMTP, Net::SNPP + - Fix error cause by calling close method when "unexpected EOF: + has been encountered. + + t/require.t + - Remove Net::Telnet test + +Change 37 on 1997/10/31 by (Graham Barr) + + Release 1.06 + +Change 36 on 1997/10/31 by (Graham Barr) + + none + +Change 35 on 1997/10/31 by (Graham Barr) + + Net::FTP + - Fixed undef warning in login() when $ruser does not exist in .netrc + +Change 34 on 1997/10/31 by (Graham Barr) + + Net::FTP + - Added new supported() method + +Change 33 on 1997/10/31 by (Graham Barr) + + Net::FTP + - DESTORY now sends quit command + - corrected OOB commands sent prior to an abort command + - close will call abort unless eof seen + - documentation updates + + Net::FTP::datacon + - abort() will read a byte if non have been read + + Net::FTP::A + - read was using arg#3 as an offset ?? change to use as timeout, this + now matches Net::FTP::I::read and the docs + - speedup to read() + +Change 18 on 1997/10/03 by (Graham Barr) + + Release 1.17 + +Change 15 on 1997/09/26 by (Graham Barr) + + Email address and documentation changes + +Change 14 on 1997/09/26 by (Graham Barr) + + Net::FTP + - Added account method so ACCT command can be sent independantly + of ->login() + - Fixed a bug which caused an infinite loop if EOF happend on the + command channel while executing code to work around MS FTP + servers + + Net::Cmd + - Fixed undefined warning when an unexpected EOF is encountered + + Net::NNTP + - Added a call to ->reader() from within ->new(), just in case we are + talking to an INN server, but we have transfer rights. This will + ensure we are talking to nnrpd. + + Net::SNPP + - Fixed a bug in ->new() while locating default host + +Change 13 on 1997/09/26 by (Graham Barr) + + Net::FTP + - Modified code which determined whether to connect via a Firewall. + if the Firewall wall option is passed then it will be used, + reguardless of whether the real machine can be reached. + - The Firewall option to new is now used in preference over + the FTP_FIREWALL environment variable. + +Change 12 on 1997/09/26 by (Graham Barr) + + Net::Cmd + - modified ->response() to return CMD_ERROR if ->getline() returns + undef + +Change 6 on 1997/09/14 by (Graham Barr) + + Small tweak to Makefile,PL to remove requirement for Data::Dumper + +Change 3 on 1997/09/12 by (Graham Barr) + + Makefile.PL + - Local config file libnet.cfg installed as Net::Config + +Change 2 on 1997/09/12 by (Graham Barr) + + Net::FTP + - Modified to use AutoLoader + - Fixed Net::FTP::[AI]::write to trap SIGPIPE errors + and return an error, instead of aborting the script + +Change 1 on 1997/09/12 by (Graham Barr) + + A new beginning + diff --git a/lib/Net/Cmd.pm b/lib/Net/Cmd.pm new file mode 100644 index 0000000..22b8d48 --- /dev/null +++ b/lib/Net/Cmd.pm @@ -0,0 +1,591 @@ +# Net::Cmd.pm +# +# Copyright (c) 1995-1997 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; + +require 5.001; +require Exporter; + +use strict; +use vars qw(@ISA @EXPORT $VERSION); +use Carp; + +$VERSION = "2.18"; +@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(@{"${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'} = "000" + unless exists ${*$cmd}{'net_cmd_code'}; + + ${*$cmd}{'net_cmd_code'}; +} + +sub status +{ + @_ == 1 or croak 'usage: $obj->status()'; + + 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; + my($code,$resp) = @_; + + $resp = [ $resp ] + unless ref($resp); + + (${*$cmd}{'net_cmd_code'},${*$cmd}{'net_cmd_resp'}) = ($code, $resp); + + 1; +} + +sub command +{ + my $cmd = shift; + + return $cmd unless defined fileno($cmd); + + $cmd->dataend() + if(exists ${*$cmd}{'net_cmd_lastch'}); + + if (scalar(@_)) + { + local $SIG{PIPE} = 'IGNORE'; + + my $str = join(" ", map { /\n/ ? do { my $n = $_; $n =~ tr/\n/ /; $n } : $_; } @_) . "\015\012"; + my $len = length $str; + my $swlen; + + $cmd->close + unless (defined($swlen = syswrite($cmd,$str,$len)) && $swlen == $len); + + $cmd->debug_print(1,$str) + if($cmd->debug); + + ${*$cmd}{'net_cmd_resp'} = []; # the response + ${*$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 = defined(${*$cmd}{'net_cmd_partial'}) + ? ${*$cmd}{'net_cmd_partial'} : ""; + my $fd = fileno($cmd); + + return undef + unless defined $fd; + + my $rin = ""; + vec($rin,$fd,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") + if $cmd->debug; + $cmd->close; + return undef; + } + + substr($buf,0,0) = $partial; ## prepend from last sysread + + my @buf = split(/\015?\012/, $buf, -1); ## break into lines + + $partial = pop @buf; + + push(@{${*$cmd}{'net_cmd_lines'}}, map { "$_\n" } @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(); + + return CMD_ERROR + unless defined($str); + + $cmd->debug_print(0,$str) + if ($cmd->debug); + + ($code,$more) = $cmd->parse_response($str); + unless(defined $code) + { + $cmd->ungetline($str); + last; + } + + ${*$cmd}{'net_cmd_code'} = $code; + + push(@{${*$cmd}{'net_cmd_resp'}},$str); + + last unless($more); + } + + substr($code,0,1); +} + +sub read_until_dot +{ + my $cmd = shift; + my $fh = shift; + my $arr = []; + + while(1) + { + my $str = $cmd->getline() or return undef; + + $cmd->debug_print(0,$str) + if ($cmd->debug & 4); + + last if($str =~ /^\.\r?\n/o); + + $str =~ s/^\.\././o; + + if (defined $fh) + { + print $fh $str; + } + else + { + push(@$arr,$str); + } + } + + $arr; +} + +sub datasend +{ + my $cmd = shift; + my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_; + my $line = join("" ,@$arr); + + return 0 unless defined(fileno($cmd)); + + return 1 + unless length($line); + + if($cmd->debug) + { + my $b = "$cmd>>> "; + print STDERR $b,join("\n$b",split(/\n/,$line)),"\n"; + } + + $line =~ s/\n/\015\012/sgo; + + ${*$cmd}{'net_cmd_lastch'} ||= " "; + $line = ${*$cmd}{'net_cmd_lastch'} . $line; + + $line =~ s/(\012\.)/$1./sog; + + ${*$cmd}{'net_cmd_lastch'} = substr($line,-1,1); + + my $len = length($line) - 1; + my $offset = 1; + my $win = ""; + vec($win,fileno($cmd),1) = 1; + my $timeout = $cmd->timeout || undef; + + while($len) + { + my $wout; + if (select(undef,$wout=$win, undef, $timeout) > 0) + { + my $w = syswrite($cmd, $line, $len, $offset); + unless (defined($w)) + { + carp("$cmd: $!") if $cmd->debug; + return undef; + } + $len -= $w; + $offset += $w; + } + else + { + carp("$cmd: Timeout") if($cmd->debug); + return undef; + } + } + + 1; +} + +sub dataend +{ + my $cmd = shift; + + return 0 unless defined(fileno($cmd)); + + 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; + +__END__ + + +=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. + +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. Different packages +may implement different levels of debug but, a non-zero value result in +copies of all commands and responses also being sent to STDERR. + +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, converting LF to CRLF. Any line starting +with a '.' will be prefixed with another '.'. +C may be an array or a reference to an array. + +=item dataend () + +End the sending of data to the remote server. This is done by ensuring 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 response () + +Obtain a response 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 () + +Retrieve 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 COPYRIGHT + +Copyright (c) 1995-1997 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 diff --git a/lib/Net/Config.eg b/lib/Net/Config.eg new file mode 100644 index 0000000..450acac --- /dev/null +++ b/lib/Net/Config.eg @@ -0,0 +1,49 @@ +package Net::Config; + +require Exporter; +use vars qw(@ISA @EXPORT %NetConfig); +use strict; + +@EXPORT = qw(%NetConfig); +@ISA = qw(Exporter); + +# WARNING WARNING WARNING WARNING WARNING WARNING WARNING +# WARNING WARNING WARNING WARNING WARNING WARNING WARNING +# +# Below this line is auto-generated, *ANY* changes will be lost + +%NetConfig = ( + # the followinf parameters are all lists of hosts for the + # respective protocols. + nntp_hosts => [], + snpp_hosts => [], + pop3_hosts => [], + smtp_hosts => [], + ph_hosts => [], + daytime_hosts => [], + time_hosts => [], + + # your internet domain + inet_domain => undef, + + # If you have an ftp proxy firewall (not a http firewall) + # then set this to the name of the firewall + ftp_firewall => undef, + + # set if all connections done via the firewall should use + # passive data connections + ftp_ext_passive => 0, + + # set if all connections not done via the firewall should use + # passive data connections + ftp_int_passive => 0, + + # If set the make test will attempt to connect to the hosts above + test_hosts => 0, + + # Used during Configure (which you are not using) to do + # DNS lookups to ensure hosts exist + test_exist => 0, + +); +1; diff --git a/lib/Net/Config.pm b/lib/Net/Config.pm new file mode 100644 index 0000000..30a65fd --- /dev/null +++ b/lib/Net/Config.pm @@ -0,0 +1,212 @@ + +package Net::Config; +# $Id: //depot/libnet/Net/Config.pm#6 $ + +require Exporter; +use vars qw(@ISA @EXPORT %NetConfig $VERSION $CONFIGURE $LIBNET_CFG); +use Socket qw(inet_aton inet_ntoa); +use strict; + +@EXPORT = qw(%NetConfig); +@ISA = qw(Net::LocalCfg Exporter); +$VERSION = "1.04"; + +eval { local $SIG{__DIE__}; require Net::LocalCfg }; + +%NetConfig = ( + nntp_hosts => [], + snpp_hosts => [], + pop3_hosts => [], + smtp_hosts => [], + ph_hosts => [], + daytime_hosts => [], + time_hosts => [], + inet_domain => undef, + ftp_firewall => undef, + ftp_ext_passive => 0, + ftp_int_passive => 0, + test_hosts => 1, + test_exist => 1, +); + +my $file = __FILE__; +my $ref; +$file =~ s/Config.pm/libnet.cfg/; +if ( -f $file ) { + $ref = eval { do $file }; + if (ref($ref) eq 'HASH') { + %NetConfig = (%NetConfig, %{ $ref }); + $LIBNET_CFG = $file; + } +} +if ($< == $> and !$CONFIGURE) { + my $home = eval { (getpwuid($>))[7] } || $ENV{HOME}; + $file = $home . "/.libnetrc"; + $ref = eval { do $file } if -f $file; + %NetConfig = (%NetConfig, %{ $ref }) + if ref($ref) eq 'HASH'; +} +my ($k,$v); +while(($k,$v) = each %NetConfig) { + $v = [ $v ] + if($k =~ /_hosts$/ && !ref($v)); +} + +# Take a hostname and determine if it is inside te firewall + +sub requires_firewall { + shift; # ignore package + my $host = shift; + + return 0 unless defined $NetConfig{'ftp_firewall'}; + + $host = inet_aton($host) or return -1; + $host = inet_ntoa($host); + + if(exists $NetConfig{'local_netmask'}) { + my $quad = unpack("N",pack("C*",split(/\./,$host))); + my $list = $NetConfig{'local_netmask'}; + $list = [$list] unless ref($list); + foreach (@$list) { + my($net,$bits) = (m#^(\d+\.\d+\.\d+\.\d+)/(\d+)$#) or next; + my $mask = ~0 << (32 - $bits); + my $addr = unpack("N",pack("C*",split(/\./,$net))); + + return 0 if (($addr & $mask) == ($quad & $mask)); + } + return 1; + } + + return 0; +} + +use vars qw(*is_external); +*is_external = \&requires_firewall; + +1; + +__END__ + +=head1 NAME + +Net::Config - Local configuration data for libnet + +=head1 SYNOPSYS + + use Net::Config qw(%NetConfig); + +=head1 DESCRIPTION + +C holds configuration data for the modules in the libnet +distribuion. During installation you will be asked for these values. + +The configuration data is held globally in a file in the perl installation +tree, but a user may override any of these values by providing thier own. This +can be done by having a C<.libnetrc> file in thier home directory. This file +should return a reference to a HASH containing the keys described below. +For example + + # .libnetrc + { + nntp_hosts => [ "my_prefered_host" ], + ph_hosts => [ "my_ph_server" ], + } + __END__ + +=head1 METHODS + +C defines the following methods. They are methods as they are +invoked as class methods. This is because C inherits from +C so you can override these methods if you want. + +=over 4 + +=item requires_firewall HOST + +Attempts to determine if a given host is outside your firewall. Possible +return values are. + + -1 Cannot lookup hostname + 0 Host is inside firewall (or there is no ftp_firewall entry) + 1 Host is outside the firewall + +This is done by using hostname lookup and the C entry in +the configuration data. + +=back + +=head1 NetConfig VALUES + +=over 4 + +=item nntp_hosts + +=item snpp_hosts + +=item pop3_hosts + +=item smtp_hosts + +=item ph_hosts + +=item daytime_hosts + +=item time_hosts + +Each is a reference to an array of hostnames (in order of preference), +which should be used for the given protocol + +=item inet_domain + +Your internet domain name + +=item ftp_firewall + +If you have an FTP proxy firewall (B a HTTP or SOCKS firewall) +then this value should be set to the firewall hostname. If your firewall +does not listen to port 21, then this value should be set to +C<"hostname:port"> (eg C<"hostname:99">) + +=item ftp_ext_passive + +=item ftp_int_pasive + +FTP servers normally work on a non-passive mode. That is when you want to +transfer data you have to tell the server the address and port to +connect to. + +With some firewalls this does not work as te server cannot +connect to your machine (because you are beind a firewall) and the firewall +does not re-write te command. In this case you should set C +to a I value. + +Some servers are configured to only work in passive mode. If you have +one of these you can force C to always transfer in passive +mode, when not going via a firewall, by cetting C to +a I value. + +=item local_netmask + +A reference to a list of netmask strings in the form C<"134.99.4.0/24">. +These are used by the C function to determine if a given +host is inside or outside your firewall. + +=back + +The following entries are used during installation & testing on the +libnet package + +=over 4 + +=item test_hosts + +If true them C may attempt to connect to hosts given in the +configuration. + +=item test_exists + +If true the C will check each hostname given that it exists + +=back + +=cut diff --git a/lib/Net/Domain.pm b/lib/Net/Domain.pm new file mode 100644 index 0000000..c1b0140 --- /dev/null +++ b/lib/Net/Domain.pm @@ -0,0 +1,331 @@ +# Net::Domain.pm +# +# Copyright (c) 1995-1998 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; + +require Exporter; + +use Carp; +use strict; +use vars qw($VERSION @ISA @EXPORT_OK); +use Net::Config; + +@ISA = qw(Exporter); +@EXPORT_OK = qw(hostname hostdomain hostfqdn domainname); + +$VERSION = "2.13"; # $Id: //depot/libnet/Net/Domain.pm#10 $ + +my($host,$domain,$fqdn) = (undef,undef,undef); + +# Try every conceivable way to get hostname. + +sub _hostname { + + # we already know it + return $host + if(defined $host); + + if ($^O eq 'MSWin32') { + require Socket; + my ($name,$alias,$type,$len,@addr) = gethostbyname($ENV{'COMPUTERNAME'}||'localhost'); + while (@addr) + { + my $a = shift(@addr); + $host = gethostbyaddr($a,Socket::AF_INET()); + last if defined $host; + } + if (index($host,'.') > 0) { + $fqdn = $host; + ($host,$domain) = $fqdn =~ /^([^\.]+)\.(.*)$/; + } + return $host; + } + elsif ($^O eq 'MacOS') { + chomp ($host = `hostname`); + } + elsif ($^O eq 'VMS') { ## multiple varieties of net s/w makes this hard + $host = $ENV{'UCX$INET_HOST'} if defined($ENV{'UCX$INET_HOST'}); + $host = $ENV{'MULTINET_HOST_NAME'} if defined($ENV{'MULTINET_HOST_NAME'}); + if (index($host,'.') > 0) { + $fqdn = $host; + ($host,$domain) = $fqdn =~ /^([^\.]+)\.(.*)$/; + } + return $host; + } + else { + local $SIG{'__DIE__'}; + + # syscall is preferred since it avoids tainting problems + eval { + my $tmp = "\0" x 256; ## preload scalar + eval { + package main; + require "syscall.ph"; + defined(&main::SYS_gethostname); + } + || eval { + package main; + require "sys/syscall.ph"; + defined(&main::SYS_gethostname); + } + and $host = (syscall(&main::SYS_gethostname, $tmp, 256) == 0) + ? $tmp + : undef; + } + + # POSIX + || eval { + require POSIX; + $host = (POSIX::uname())[1]; + } + + # trusty old hostname command + || eval { + chop($host = `(hostname) 2>/dev/null`); # BSD'ish + } + + # sysV/POSIX uname command (may truncate) + || eval { + chop($host = `uname -n 2>/dev/null`); ## SYSV'ish && POSIX'ish + } + + # 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 { + + # we already know it + return $domain + if(defined $domain); + + local $SIG{'__DIE__'}; + + return $domain = $NetConfig{'inet_domain'} + if defined $NetConfig{'inet_domain'}; + + # try looking in /etc/resolv.conf + # putting this here and assuming that it is correct, eliminates + # calls to gethostbyname, and therefore DNS lookups. This helps + # those on dialup systems. + + 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); + } + + # just try hostname and system calls + + my $host = _hostname(); + my(@hosts); + local($_); + + @hosts = ($host,"localhost"); + + unless($host =~ /\./) { + my $dom = undef; + eval { + my $tmp = "\0" x 256; ## preload scalar + eval { + package main; + require "syscall.ph"; + } + || eval { + package main; + require "sys/syscall.ph"; + } + and $dom = (syscall(&main::SYS_getdomainname, $tmp, 256) == 0) + ? $tmp + : undef; + }; + + chop($dom = `domainname 2>/dev/null`) + unless(defined $dom); + + if(defined $dom) { + my @h = (); + while(length($dom)) { + push(@h, "$host.$dom"); + $dom =~ s/^[^.]+.//; + } + unshift(@hosts,@h); + } + } + + # Attempt to locate FQDN + + foreach (@hosts) { + my @info = gethostbyname($_); + + next unless @info; + + # look at real name & aliases + my $site; + foreach $site ($info[0], split(/ /,$info[1])) { + if(rindex($site,".") > 0) { + + # Extract domain from FQDN + + ($domain = $site) =~ s/\A[^\.]+\.//; + return $domain; + } + } + } + + # Look for environment variable + + $domain ||= $ENV{LOCALDOMAIN} ||= $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(); + + # Assumption: If the host name does not contain a period + # and the domain name does, then assume that they are correct + # this helps to eliminate calls to gethostbyname, and therefore + # eleminate DNS lookups + + return $fqdn = $host . "." . $domain + if($host !~ /\./ && $domain =~ /\./); + + # For hosts that have no name, just an IP address + return $fqdn = $host if $host =~ /^\d+(\.\d+){3}$/; + + 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 + +__END__ + +=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 COPYRIGHT + +Copyright (c) 1995-1998 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 diff --git a/lib/Net/DummyInetd.pm b/lib/Net/DummyInetd.pm new file mode 100644 index 0000000..8247337 --- /dev/null +++ b/lib/Net/DummyInetd.pm @@ -0,0 +1,148 @@ +# Net::DummyInetd.pm +# +# Copyright (c) 1995-1997 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; + +require 5.002; + +use IO::Handle; +use IO::Socket; +use strict; +use vars qw($VERSION); +use Carp; + +$VERSION = do { my @r=(q$Revision: 1.6 $=~/\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; + +__END__ + +=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 available 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 COPYRIGHT + +Copyright (c) 1995-1997 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 diff --git a/lib/Net/FTP.pm b/lib/Net/FTP.pm new file mode 100644 index 0000000..6748256 --- /dev/null +++ b/lib/Net/FTP.pm @@ -0,0 +1,1642 @@ +# Net::FTP.pm +# +# Copyright (c) 1995-8 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. +# +# Documentation (at end) improved 1996 by Nathan Torkington . + +package Net::FTP; + +require 5.001; + +use strict; +use vars qw(@ISA $VERSION); +use Carp; + +use Socket 1.3; +use IO::Socket; +use Time::Local; +use Net::Cmd; +use Net::Config; +# use AutoLoader qw(AUTOLOAD); + +$VERSION = "2.56"; # $Id:$ +@ISA = qw(Exporter Net::Cmd IO::Socket::INET); + +# Someday I will "use constant", when I am not bothered to much about +# compatability with older releases of perl + +use vars qw($TELNET_IAC $TELNET_IP $TELNET_DM); +($TELNET_IAC,$TELNET_IP,$TELNET_DM) = (255,244,242); + +# Name is too long for AutoLoad, it clashes with pasv_xfer +sub pasv_xfer_unique { + my($sftp,$sfile,$dftp,$dfile) = @_; + $sftp->pasv_xfer($sfile,$dftp,$dfile,1); +} + +1; +# Having problems with AutoLoader +#__END__ + +sub new +{ + my $pkg = shift; + my $peer = shift; + my %arg = @_; + + my $host = $peer; + my $fire = undef; + + if(exists($arg{Firewall}) || Net::Config->requires_firewall($peer)) + { + $fire = $arg{Firewall} + || $ENV{FTP_FIREWALL} + || $NetConfig{ftp_firewall} + || undef; + + if(defined $fire) + { + $peer = $fire; + delete $arg{Port}; + } + } + + my $ftp = $pkg->SUPER::new(PeerAddr => $peer, + PeerPort => $arg{Port} || 'ftp(21)', + Proto => 'tcp', + Timeout => defined $arg{Timeout} + ? $arg{Timeout} + : 120 + ) or return undef; + + ${*$ftp}{'net_ftp_host'} = $host; # Remote hostname + ${*$ftp}{'net_ftp_type'} = 'A'; # ASCII/binary/etc mode + ${*$ftp}{'net_ftp_blksize'} = abs($arg{'BlockSize'} || 10240); + + ${*$ftp}{'net_ftp_firewall'} = $fire + if(defined $fire); + + ${*$ftp}{'net_ftp_passive'} = int + exists $arg{Passive} + ? $arg{Passive} + : exists $ENV{FTP_PASSIVE} + ? $ENV{FTP_PASSIVE} + : defined $fire + ? $NetConfig{ftp_ext_passive} + : $NetConfig{ftp_int_passive}; # Whew! :-) + + $ftp->hash(exists $arg{Hash} ? $arg{Hash} : 0, 1024); + + $ftp->autoflush(1); + + $ftp->debug(exists $arg{Debug} ? $arg{Debug} : undef); + + unless ($ftp->response() == CMD_OK) + { + $ftp->close(); + $@ = $ftp->message; + undef $ftp; + } + + $ftp; +} + +## +## User interface methods +## + +sub hash { + my $ftp = shift; # self + my $prev = ${*$ftp}{'net_ftp_hash'} || [\*STDERR, 0]; + + unless(@_) { + return $prev; + } + my($h,$b) = @_; + if(@_ == 1) { + unless($h) { + delete ${*$ftp}{'net_ftp_hash'}; + return $prev; + } + elsif(ref($h)) { + $b = 1024; + } + else { + ($h,$b) = (\*STDERR,$h); + } + } + select((select($h), $|=1)[0]); + $b = 512 if $b < 512; + ${*$ftp}{'net_ftp_hash'} = [$h, $b]; + $prev; +} + +sub quit +{ + my $ftp = shift; + + $ftp->_QUIT; + $ftp->close; +} + +sub DESTROY +{ + my $ftp = shift; + defined(fileno($ftp)) && $ftp->quit +} + +sub ascii { shift->type('A',@_); } +sub binary { shift->type('I',@_); } + +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 $ftp = shift; + my $cmd = shift; + + $ftp->command( uc $cmd, @_); + $ftp->response(); +} + +sub site +{ + my $ftp = shift; + + $ftp->command("SITE", @_); + $ftp->response(); +} + +sub mdtm +{ + my $ftp = shift; + my $file = shift; + + # Server Y2K bug workaround + # + # sigh; some idiotic FTP servers use ("19%d",tm.tm_year) instead of + # ("%d",tm.tm_year+1900). This results in an extra digit in the + # string returned. To account for this we allow an optional extra + # digit in the year. Then if the first two digits are 19 we use the + # remainder, otherwise we subtract 1900 from the whole year. + + $ftp->_MDTM($file) && $ftp->message =~ /((\d\d)(\d\d\d?))(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/ + ? timegm($8,$7,$6,$5,$4-1,$2 eq '19' ? $3 : ($1-1900)) + : undef; +} + +sub size { + my $ftp = shift; + my $file = shift; + my $io; + if($ftp->supported("SIZE")) { + return $ftp->_SIZE($file) + ? ($ftp->message =~ /(\d+)/)[0] + : undef; + } + elsif($ftp->supported("STAT")) { + my @msg; + return undef + unless $ftp->_STAT($file) && (@msg = $ftp->message) == 3; + my $line; + foreach $line (@msg) { + return (split(/\s+/,$line))[4] + if $line =~ /^[-rw]{10}/ + } + } + else { + my @files = $ftp->dir($file); + if(@files) { + return (split(/\s+/,$1))[4] + if $files[0] =~ /^([-rw]{10}.*)$/; + } + } + undef; +} + +sub login { + my($ftp,$user,$pass,$acct) = @_; + my($ok,$ruser,$fwtype); + + unless (defined $user) { + require Net::Netrc; + + my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'}); + + ($user,$pass,$acct) = $rc->lpa() + if ($rc); + } + + $user ||= "anonymous"; + $ruser = $user; + + $fwtype = $NetConfig{'ftp_firewall_type'} || 0; + + if ($fwtype && defined ${*$ftp}{'net_ftp_firewall'}) { + if ($fwtype == 1 || $fwtype == 7) { + $user .= '@' . ${*$ftp}{'net_ftp_host'}; + } + else { + require Net::Netrc; + + my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}); + + my($fwuser,$fwpass,$fwacct) = $rc ? $rc->lpa() : (); + + if ($fwtype == 5) { + $user = join('@',$user,$fwuser,${*$ftp}{'net_ftp_host'}); + $pass = $pass . '@' . $fwpass; + } + else { + if ($fwtype == 2) { + $user .= '@' . ${*$ftp}{'net_ftp_host'}; + } + elsif ($fwtype == 6) { + $fwuser .= '@' . ${*$ftp}{'net_ftp_host'}; + } + + $ok = $ftp->_USER($fwuser); + + return 0 unless $ok == CMD_OK || $ok == CMD_MORE; + + $ok = $ftp->_PASS($fwpass || ""); + + return 0 unless $ok == CMD_OK || $ok == CMD_MORE; + + $ok = $ftp->_ACCT($fwacct) + if defined($fwacct); + + if ($fwtype == 3) { + $ok = $ftp->command("SITE",${*$ftp}{'net_ftp_host'})->response; + } + elsif ($fwtype == 4) { + $ok = $ftp->command("OPEN",${*$ftp}{'net_ftp_host'})->response; + } + + return 0 unless $ok == CMD_OK || $ok == CMD_MORE; + } + } + } + + $ok = $ftp->_USER($user); + + # Some dumb firewalls don't prefix the connection messages + $ok = $ftp->response() + if ($ok == CMD_OK && $ftp->code == 220 && $user =~ /\@/); + + if ($ok == CMD_MORE) { + unless(defined $pass) { + require Net::Netrc; + + my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'}, $ruser); + + ($ruser,$pass,$acct) = $rc->lpa() + if ($rc); + + $pass = "-" . (eval { (getpwuid($>))[0] } || $ENV{NAME} ) . '@' + if (!defined $pass && (!defined($ruser) || $ruser =~ /^anonymous/o)); + } + + $ok = $ftp->_PASS($pass || ""); + } + + $ok = $ftp->_ACCT($acct) + if (defined($acct) && ($ok == CMD_MORE || $ok == CMD_OK)); + + if ($fwtype == 7 && $ok == CMD_OK && defined ${*$ftp}{'net_ftp_firewall'}) { + my($f,$auth,$resp) = _auth_id($ftp); + $ftp->authorize($auth,$resp) if defined($resp); + } + + $ok == CMD_OK; +} + +sub account +{ + @_ == 2 or croak 'usage: $ftp->account( ACCT )'; + my $ftp = shift; + my $acct = shift; + $ftp->_ACCT($acct) == CMD_OK; +} + +sub _auth_id { + my($ftp,$auth,$resp) = @_; + + unless(defined $resp) + { + require Net::Netrc; + + $auth ||= eval { (getpwuid($>))[0] } || $ENV{NAME}; + + my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}, $auth) + || Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}); + + ($auth,$resp) = $rc->lpa() + if ($rc); + } + ($ftp,$auth,$resp); +} + +sub authorize +{ + @_ >= 1 || @_ <= 3 or croak 'usage: $ftp->authorize( [AUTH [, RESP]])'; + + my($ftp,$auth,$resp) = &_auth_id; + + 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)'; + + my($ftp,$from,$to) = @_; + + $ftp->_RNFR($from) + && $ftp->_RNTO($to); +} + +sub type +{ + my $ftp = shift; + my $type = shift; + my $oldval = ${*$ftp}{'net_ftp_type'}; + + return $oldval + unless (defined $type); + + return undef + unless ($ftp->_TYPE($type,@_)); + + ${*$ftp}{'net_ftp_type'} = join(" ",$type,@_); + + $oldval; +} + +sub abort +{ + my $ftp = shift; + + send($ftp,pack("CCC", $TELNET_IAC, $TELNET_IP, $TELNET_IAC),MSG_OOB); + + $ftp->command(pack("C",$TELNET_DM) . "ABOR"); + + ${*$ftp}{'net_ftp_dataconn'}->close() + if defined ${*$ftp}{'net_ftp_dataconn'}; + + $ftp->response(); + + $ftp->status == CMD_OK; +} + +sub get +{ + my($ftp,$remote,$local,$where) = @_; + + my($loc,$len,$buf,$resp,$localfd,$data); + local *FD; + + $localfd = ref($local) || ref(\$local) eq "GLOB" + ? fileno($local) + : undef; + + ($local = $remote) =~ s#^.*/## + unless(defined $local); + + croak("Bad remote filename '$remote'\n") + if $remote =~ /[\r\n]/s; + + ${*$ftp}{'net_ftp_rest'} = $where + if ($where); + + delete ${*$ftp}{'net_ftp_port'}; + delete ${*$ftp}{'net_ftp_pasv'}; + + $data = $ftp->retr($remote) or + return undef; + + if(defined $localfd) + { + $loc = $local; + } + else + { + $loc = \*FD; + + unless(($where) ? open($loc,">>$local") : open($loc,">$local")) + { + carp "Cannot open Local file $local: $!\n"; + $data->abort; + return undef; + } + } + + if($ftp->type eq 'I' && !binmode($loc)) + { + carp "Cannot binmode Local file $local: $!\n"; + $data->abort; + close($loc) unless $localfd; + return undef; + } + + $buf = ''; + my($count,$hashh,$hashb,$ref) = (0); + + ($hashh,$hashb) = @$ref + if($ref = ${*$ftp}{'net_ftp_hash'}); + + my $blksize = ${*$ftp}{'net_ftp_blksize'}; + + while(1) + { + last unless $len = $data->read($buf,$blksize); + if($hashh) { + $count += $len; + print $hashh "#" x (int($count / $hashb)); + $count %= $hashb; + } + my $written = syswrite($loc,$buf,$len); + unless(defined($written) && $written == $len) + { + carp "Cannot write to Local file $local: $!\n"; + $data->abort; + close($loc) + unless defined $localfd; + return undef; + } + } + + print $hashh "\n" if $hashh; + + close($loc) + unless defined $localfd; + + $data->close(); # implied $ftp->response + + return $local; +} + +sub cwd +{ + @_ == 1 || @_ == 2 or croak 'usage: $ftp->cwd( [ DIR ] )'; + + my($ftp,$dir) = @_; + + $dir = "/" unless defined($dir) && $dir =~ /\S/; + + $dir eq ".." + ? $ftp->_CDUP() + : $ftp->_CWD($dir); +} + +sub cdup +{ + @_ == 1 or croak 'usage: $ftp->cdup()'; + $_[0]->_CDUP; +} + +sub pwd +{ + @_ == 1 || croak 'usage: $ftp->pwd()'; + my $ftp = shift; + + $ftp->_PWD(); + $ftp->_extract_path; +} + +# rmdir( $ftp, $dir, [ $recurse ] ) +# +# Removes $dir on remote host via FTP. +# $ftp is handle for remote host +# +# If $recurse is TRUE, the directory and deleted recursively. +# This means all of its contents and subdirectories. +# +# Initial version contributed by Dinkum Software +# +sub rmdir +{ + @_ == 2 || @_ == 3 or croak('usage: $ftp->rmdir( DIR [, RECURSE ] )'); + + # Pick off the args + my ($ftp, $dir, $recurse) = @_ ; + my $ok; + + return $ok + if $ftp->_RMD( $dir ) || !$recurse; + + # Try to delete the contents + # Get a list of all the files in the directory + my $filelist = $ftp->ls($dir); + + return undef + unless $filelist && @$filelist; # failed, it is probably not a directory + + # Go thru and delete each file or the directory + my $file; + foreach $file (map { m,/, ? $_ : "$dir/$_" } @$filelist) + { + next # successfully deleted the file + if $ftp->delete($file); + + # Failed to delete it, assume its a directory + # Recurse and ignore errors, the final rmdir() will + # fail on any errors here + return $ok + unless $ok = $ftp->rmdir($file, 1) ; + } + + # Directory should be empty + # Try to remove the directory again + # Pass results directly to caller + # If any of the prior deletes failed, this + # rmdir() will fail because directory is not empty + return $ftp->_RMD($dir) ; +} + +sub mkdir +{ + @_ == 2 || @_ == 3 or croak 'usage: $ftp->mkdir( DIR [, RECURSE ] )'; + + my($ftp,$dir,$recurse) = @_; + + $ftp->_MKD($dir) || $recurse or + return undef; + + my $path = $dir; + + unless($ftp->ok) + { + my @path = split(m#(?=/+)#, $dir); + + $path = ""; + + while(@path) + { + $path .= shift @path; + + $ftp->_MKD($path); + + $path = $ftp->_extract_path($path); + } + + # If the creation of the last element was not sucessful, see if we + # can cd to it, if so then return path + + unless($ftp->ok) + { + my($status,$message) = ($ftp->status,$ftp->message); + my $pwd = $ftp->pwd; + + if($pwd && $ftp->cwd($dir)) + { + $path = $dir; + $ftp->cwd($pwd); + } + else + { + undef $path; + } + $ftp->set_status($status,$message); + } + } + + $path; +} + +sub delete +{ + @_ == 2 || croak 'usage: $ftp->delete( FILENAME )'; + + $_[0]->_DELE($_[1]); +} + +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 _store_cmd +{ + my($ftp,$cmd,$local,$remote) = @_; + my($loc,$sock,$len,$buf,$localfd); + local *FD; + + $localfd = ref($local) || ref(\$local) eq "GLOB" + ? fileno($local) + : undef; + + unless(defined $remote) + { + croak 'Must specify remote filename with stream input' + if defined $localfd; + + require File::Basename; + $remote = File::Basename::basename($local); + } + + croak("Bad remote filename '$remote'\n") + if $remote =~ /[\r\n]/s; + + if(defined $localfd) + { + $loc = $local; + } + else + { + $loc = \*FD; + + unless(open($loc,"<$local")) + { + carp "Cannot open Local file $local: $!\n"; + return undef; + } + } + + if($ftp->type eq 'I' && !binmode($loc)) + { + carp "Cannot binmode Local file $local: $!\n"; + return undef; + } + + delete ${*$ftp}{'net_ftp_port'}; + delete ${*$ftp}{'net_ftp_pasv'}; + + $sock = $ftp->_data_cmd($cmd, $remote) or + return undef; + + my $blksize = ${*$ftp}{'net_ftp_blksize'}; + + my($count,$hashh,$hashb,$ref) = (0); + + ($hashh,$hashb) = @$ref + if($ref = ${*$ftp}{'net_ftp_hash'}); + + while(1) + { + last unless $len = sysread($loc,$buf="",$blksize); + + if($hashh) { + $count += $len; + print $hashh "#" x (int($count / $hashb)); + $count %= $hashb; + } + + my $wlen; + unless(defined($wlen = $sock->write($buf,$len)) && $wlen == $len) + { + $sock->abort; + close($loc) + unless defined $localfd; + print $hashh "\n" if $hashh; + return undef; + } + } + + print $hashh "\n" if $hashh; + + close($loc) + unless defined $localfd; + + $sock->close() or + return undef; + + ($remote) = $ftp->message =~ /unique file name:\s*(\S*)\s*\)/ + if ('STOU' eq uc $cmd); + + return $remote; +} + +sub port +{ + @_ == 1 || @_ == 2 or croak 'usage: $ftp->port([PORT])'; + + my($ftp,$port) = @_; + my $ok; + + delete ${*$ftp}{'net_ftp_intern_port'}; + + unless(defined $port) + { + # create a Listen socket at same address as the command socket + + ${*$ftp}{'net_ftp_listen'} ||= IO::Socket::INET->new(Listen => 5, + Proto => 'tcp', + ); + + my $listen = ${*$ftp}{'net_ftp_listen'}; + + my($myport, @myaddr) = ($listen->sockport, split(/\./,$ftp->sockhost)); + + $port = join(',', @myaddr, $myport >> 8, $myport & 0xff); + + ${*$ftp}{'net_ftp_intern_port'} = 1; + } + + $ok = $ftp->_PORT($port); + + ${*$ftp}{'net_ftp_port'} = $port; + + $ok; +} + +sub ls { shift->_list_cmd("NLST",@_); } +sub dir { shift->_list_cmd("LIST",@_); } + +sub pasv +{ + @_ == 1 or croak 'usage: $ftp->pasv()'; + + my $ftp = shift; + + delete ${*$ftp}{'net_ftp_intern_port'}; + + $ftp->_PASV && $ftp->message =~ /(\d+(,\d+)+)/ + ? ${*$ftp}{'net_ftp_pasv'} = $1 + : undef; +} + +sub unique_name +{ + my $ftp = shift; + ${*$ftp}{'net_ftp_unique'} || undef; +} + +sub supported { + @_ == 2 or croak 'usage: $ftp->supported( CMD )'; + my $ftp = shift; + my $cmd = uc shift; + my $hash = ${*$ftp}{'net_ftp_supported'} ||= {}; + + return $hash->{$cmd} + if exists $hash->{$cmd}; + + return $hash->{$cmd} = 0 + unless $ftp->_HELP($cmd); + + my $text = $ftp->message; + if($text =~ /following\s+commands/i) { + $text =~ s/^.*\n//; + $text =~ s/\n/ /sog; + while($text =~ /(\w+)([* ])/g) { + $hash->{"\U$1"} = $2 eq " " ? 1 : 0; + } + } + else { + $hash->{$cmd} = $text !~ /unimplemented/i; + } + + $hash->{$cmd} ||= 0; +} + +## +## Deprecated methods +## + +sub lsl +{ + carp "Use of Net::FTP::lsl deprecated, use 'dir'" + if $^W; + goto &dir; +} + +sub authorise +{ + carp "Use of Net::FTP::authorise deprecated, use 'authorize'" + if $^W; + goto &authorize; +} + + +## +## Private methods +## + +sub _extract_path +{ + my($ftp, $path) = @_; + + # This tries to work both with and without the quote doubling + # convention (RFC 959 requires it, but the first 3 servers I checked + # didn't implement it). It will fail on a server which uses a quote in + # the message which isn't a part of or surrounding the path. + $ftp->ok && + $ftp->message =~ /(?:^|\s)\"(.*)\"(?:$|\s)/ && + ($path = $1) =~ s/\"\"/\"/g; + + $path; +} + +## +## Communication methods +## + +sub _dataconn +{ + my $ftp = shift; + my $data = undef; + my $pkg = "Net::FTP::" . $ftp->type; + + eval "require " . $pkg; + + $pkg =~ s/ /_/g; + + delete ${*$ftp}{'net_ftp_dataconn'}; + + if(defined ${*$ftp}{'net_ftp_pasv'}) + { + my @port = split(/,/,${*$ftp}{'net_ftp_pasv'}); + + $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}{'net_ftp_blksize'} = ${*$ftp}{'net_ftp_blksize'}; + } + + $data; +} + +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 + unless(defined $data); + + require Net::FTP::A; + bless $data, "Net::FTP::A"; # Force ASCII mode + + my $databuf = ''; + my $buf = ''; + my $blksize = ${*$ftp}{'net_ftp_blksize'}; + + while($data->read($databuf,$blksize)) { + $buf .= $databuf; + } + + my $list = [ split(/\n/,$buf) ]; + + $data->close(); + + wantarray ? @{$list} + : $list; +} + +sub _data_cmd +{ + my $ftp = shift; + my $cmd = uc shift; + my $ok = 1; + my $where = delete ${*$ftp}{'net_ftp_rest'} || 0; + my $arg; + + for $arg (@_) { + croak("Bad argument '$arg'\n") + if $arg =~ /[\r\n]/s; + } + + if(${*$ftp}{'net_ftp_passive'} && + !defined ${*$ftp}{'net_ftp_pasv'} && + !defined ${*$ftp}{'net_ftp_port'}) + { + my $data = undef; + + $ok = defined $ftp->pasv; + $ok = $ftp->_REST($where) + if $ok && $where; + + if($ok) + { + $ftp->command($cmd,@_); + $data = $ftp->_dataconn(); + $ok = CMD_INFO == $ftp->response(); + if($ok) + { + $data->reading + if $data && $cmd =~ /RETR|LIST|NLST/; + return $data + } + $data->_close + if $data; + } + return undef; + } + + $ok = $ftp->port + unless (defined ${*$ftp}{'net_ftp_port'} || + defined ${*$ftp}{'net_ftp_pasv'}); + + $ok = $ftp->_REST($where) + if $ok && $where; + + return undef + unless $ok; + + $ftp->command($cmd,@_); + + return 1 + if(defined ${*$ftp}{'net_ftp_pasv'}); + + $ok = CMD_INFO == $ftp->response(); + + return $ok + unless exists ${*$ftp}{'net_ftp_intern_port'}; + + if($ok) { + my $data = $ftp->_dataconn(); + + $data->reading + if $data && $cmd =~ /RETR|LIST|NLST/; + + return $data; + } + + + close(delete ${*$ftp}{'net_ftp_listen'}); + + return undef; +} + +## +## Over-ride methods (Net::Cmd) +## + +sub debug_text { $_[2] =~ /^(pass|resp|acct)/i ? "$1 ....\n" : $_[2]; } + +sub command +{ + my $ftp = shift; + + delete ${*$ftp}{'net_ftp_port'}; + $ftp->SUPER::command(@_); +} + +sub response +{ + my $ftp = shift; + my $code = $ftp->SUPER::response(); + + delete ${*$ftp}{'net_ftp_pasv'} + if ($code != CMD_MORE && $code != CMD_INFO); + + $code; +} + +sub parse_response +{ + return ($1, $2 eq "-") + if $_[1] =~ s/^(\d\d\d)(.?)//o; + + my $ftp = shift; + + # Darn MS FTP server is a load of CRAP !!!! + return () + unless ${*$ftp}{'net_cmd_code'} + 0; + + (${*$ftp}{'net_cmd_code'},1); +} + +## +## Allow 2 servers to talk directly +## + +sub pasv_xfer { + my($sftp,$sfile,$dftp,$dfile,$unique) = @_; + + ($dfile = $sfile) =~ s#.*/## + unless(defined $dfile); + + my $port = $sftp->pasv or + return undef; + + $dftp->port($port) or + return undef; + + return undef + unless($unique ? $dftp->stou($dfile) : $dftp->stor($dfile)); + + unless($sftp->retr($sfile) && $sftp->response == CMD_INFO) { + $sftp->retr($sfile); + $dftp->abort; + $dftp->response(); + return undef; + } + + $dftp->pasv_wait($sftp); +} + +sub pasv_wait +{ + @_ == 2 or croak 'usage: $ftp->pasv_wait(NON_PASV_FTP)'; + + my($ftp, $non_pasv) = @_; + my($file,$rin,$rout); + + vec($rin='',fileno($ftp),1) = 1; + select($rout=$rin, undef, undef, undef); + + $ftp->response(); + $non_pasv->response(); + + return undef + unless $ftp->ok() && $non_pasv->ok(); + + return $1 + if $ftp->message =~ /unique file name:\s*(\S*)\s*\)/; + + return $1 + if $non_pasv->message =~ /unique file name:\s*(\S*)\s*\)/; + + return 1; +} + +sub cmd { shift->command(@_)->response() } + +######################################## +# +# 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 _RESP { shift->command("RESP",@_)->response() == CMD_OK } +sub _MDTM { shift->command("MDTM",@_)->response() == CMD_OK } +sub _SIZE { shift->command("SIZE",@_)->response() == CMD_OK } +sub _HELP { shift->command("HELP",@_)->response() == CMD_OK } +sub _STAT { shift->command("STAT",@_)->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 _ACCT { shift->command("ACCT",@_)->response() } +sub _AUTH { shift->command("AUTH",@_)->response() } + +sub _ALLO { shift->unsupported(@_) } +sub _SMNT { shift->unsupported(@_) } +sub _MODE { shift->unsupported(@_) } +sub _SYST { shift->unsupported(@_) } +sub _STRU { shift->unsupported(@_) } +sub _REIN { shift->unsupported(@_) } + +1; + +__END__ + +=head1 NAME + +Net::FTP - FTP Client class + +=head1 SYNOPSIS + + use Net::FTP; + + $ftp = Net::FTP->new("some.host.name", Debug => 0); + $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. It provides wrappers for a subset of the RFC959 +commands. + +=head1 OVERVIEW + +FTP stands for File Transfer Protocol. It is a way of transferring +files between networked machines. The protocol defines a client +(whose commands are provided by this module) and a server (not +implemented in this module). Communication is always initiated by the +client, and the server responds with a message and a status code (and +sometimes with data). + +The FTP protocol allows files to be sent to or fetched from the +server. Each transfer involves a B (on the client) and a +B (on the server). In this module, the same file name +will be used for both local and remote if only one is specified. This +means that transferring remote file C will try to put +that file in C locally, unless you specify a local file +name. + +The protocol also defines several standard B which the +file can undergo during transfer. These are ASCII, EBCDIC, binary, +and byte. ASCII is the default type, and indicates that the sender of +files will translate the ends of lines to a standard representation +which the receiver will then translate back into their local +representation. EBCDIC indicates the file being transferred is in +EBCDIC format. Binary (also known as image) format sends the data as +a contiguous bit stream. Byte format transfers the data as bytes, the +values of which remain the same regardless of differences in byte size +between the two machines (in theory - in practice you should only use +this if you really know what you're doing). + +=head1 CONSTRUCTOR + +=over 4 + +=item new (HOST [,OPTIONS]) + +This is the constructor for a new Net::FTP object. C is the +name of the remote host to which a FTP connection is required. + +C are passed in a hash like fashion, 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 firewall machine and the string C<@hostname> is +appended to the login identifier. This kind of setup is also refered to +as a ftp proxy. + +B - This is the block size that Net::FTP will use when doing +transfers. (defaults to 10240) + +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 (see the debug method in L) + +B - If set to a non-zero value then all data transfers will be done +using passive mode. This is not usually required except for some I +servers, and some firewall configurations. This can also be set by the +environment variable C. + +B - If TRUE, print hash marks (#) on STDERR every 1024 bytes. This +simply invokes the C method for you, so that hash marks are displayed +for all transfers. You can, of course, call C explicitly whenever +you'd like. + +If the constructor fails undef will be returned and an error message will +be in $@ + +=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, failure 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 site (ARGS) + +Send a SITE command to the remote server and wait for a response. + +Returns most significant digit of the response code. + +=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 ] ) + +Attempt to change directory to the directory given in C<$dir>. If +C<$dir> is C<"..">, the FTP C command is used to attempt to +move up one directory. If no directory is given then an attempt is made +to change the directory to the root directory. + +=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. + +In an array context, returns a list of lines returned from the server. In +a scalar context, returns a reference to a list. + +=item dir ( [ DIR ] ) + +Get a directory listing of C, or the current directory in long format. + +In an array context, returns a list of lines returned from the server. In +a scalar context, returns a reference to a list. + +=item get ( REMOTE_FILE [, LOCAL_FILE [, WHERE]] ) + +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. + +If C is given then the first C bytes of the file will +not be transfered, and the remaining bytes will be appended to +the local file if it already exists. + +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. + +B: If for some reason the transfer does not complete and an error is +returned then the contents that had been transfered will not be remove +automatically. + +=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 as stored on the remote server. + +B: The size reported is the size of the stored file on the remote server. +If the file is subsequently transfered from the server in ASCII mode +and the remote server and local machine have different ideas about +"End Of Line" then the size of file on the local machine after transfer +may be different. + +=item supported ( CMD ) + +Returns TRUE if the remote server supports the given command. + +=item hash ( [FILEHANDLE_GLOB_REF],[ BYTES_PER_HASH_MARK] ) + +Called without parameters, or with the first argument false, hash marks +are suppressed. If the first argument is true but not a reference to a +file handle glob, then \*STDERR is used. The second argument is the number +of bytes per hash mark printed, and defaults to 1024. In all cases the +return value is a reference to an array of two: the filehandle glob reference +and the bytes per hash mark. + +=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 available 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 + +The following methods can be used to transfer files between two remote +servers, providing that these two servers can connect directly to each other. + +=over 4 + +=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_xfer_unique ( SRC_FILE, DEST_SERVER [, DEST_FILE ] ) + +Like C but the file is stored on the remote server using +the STOU command. + +=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 successfully and the first digit of +the response from the server was a '2'. + +=back + +=head1 UNIMPLEMENTED + +The following RFC959 commands have not been implemented: + +=over 4 + +=item B + +Allocates storage for the file to be transferred. + +=item B + +Mount a different file system structure without changing login or +accounting information. + +=item B + +Ask the server for "helpful information" (that's what the RFC says) on +the commands it accepts. + +=item B + +Specifies transfer mode (stream, block or compressed) for file to be +transferred. + +=item B + +Request remote server system identification. + +=item B + +Request remote server status. + +=item B + +Specifies file structure for file to be transferred. + +=item B + +Reinitialize the connection, flushing all I/O and account information. + +=back + +=head1 REPORTING BUGS + +When reporting bugs/problems please include as much information as possible. +It may be difficult for me to reproduce the problem as almost every setup +is different. + +A small script which yields the problem will probably be of help. It would +also be useful if this script was run with the extra options C 1> +passed to the constructor, and the output sent with the bug report. If you +cannot include a small script then please include a Debug trace from a +run of your program which does yield the problem. + +=head1 AUTHOR + +Graham Barr + +=head1 SEE ALSO + +L +L + +ftp(1), ftpd(8), RFC 959 +http://www.cis.ohio-state.edu/htbin/rfc/rfc959.html + +=head1 CREDITS + +Henry Gabryjelski - for the suggestion of creating directories +recursively. + +Nathan Torkington - for some input on the documentation. + +Roderick Schertler - for various inputs + +=head1 COPYRIGHT + +Copyright (c) 1995-1998 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 diff --git a/lib/Net/FTP/A.pm b/lib/Net/FTP/A.pm new file mode 100644 index 0000000..46791e8 --- /dev/null +++ b/lib/Net/FTP/A.pm @@ -0,0 +1,99 @@ +## +## Package to read/write on ASCII data connections +## + +package Net::FTP::A; +use strict; +use vars qw(@ISA $buf $VERSION); +use Carp; + +require Net::FTP::dataconn; + +@ISA = qw(Net::FTP::dataconn); +$VERSION = "1.13"; # $Id: //depot/libnet/Net/FTP/A.pm#9 $ + +sub read { + my $data = shift; + local *buf = \$_[0]; shift; + my $size = shift || croak 'read($buf,$size,[$offset])'; + my $timeout = @_ ? shift : $data->timeout; + + if (length(${*$data}) < $size && !${*$data}{'net_ftp_eof'}) { + my $blksize = ${*$data}{'net_ftp_blksize'}; + $blksize = $size if $size > $blksize; + + my $l = 0; + my $n; + + READ: + { + my $readbuf = defined(${*$data}{'net_ftp_cr'}) ? "\015" : ''; + + $data->can_read($timeout) or + croak "Timeout"; + + if ($n = sysread($data, $readbuf, $blksize, length $readbuf)) { + ${*$data}{'net_ftp_bytesread'} += $n; + ${*$data}{'net_ftp_cr'} = substr($readbuf,-1) eq "\015" + ? chop($readbuf) + : undef; + } + else { + return undef + unless defined $n; + + ${*$data}{'net_ftp_eof'} = 1; + } + + $readbuf =~ s/\015\012/\n/sgo; + ${*$data} .= $readbuf; + + unless (length(${*$data})) { + + redo READ + if($n > 0); + + $size = length(${*$data}) + if($n == 0); + } + } + } + + $buf = substr(${*$data},0,$size); + substr(${*$data},0,$size) = ''; + + length $buf; +} + +sub write { + my $data = shift; + local *buf = \$_[0]; shift; + my $size = shift || croak 'write($buf,$size,[$timeout])'; + my $timeout = @_ ? shift : $data->timeout; + + $data->can_write($timeout) or + croak "Timeout"; + + (my $tmp = substr($buf,0,$size)) =~ s/\n/\015\012/sg; + + # If the remote server has closed the connection we will be signal'd + # when we write. This can happen if the disk on the remote server fills up + + local $SIG{PIPE} = 'IGNORE'; + + my $len = length($tmp); + my $off = 0; + my $wrote = 0; + + while($len) { + $off += $wrote; + $wrote = syswrite($data, substr($tmp,$off), $len); + return undef + unless defined($wrote); + $len -= $wrote; + } + + $size; +} + +1; diff --git a/lib/Net/FTP/E.pm b/lib/Net/FTP/E.pm new file mode 100644 index 0000000..6e458bd --- /dev/null +++ b/lib/Net/FTP/E.pm @@ -0,0 +1,7 @@ +package Net::FTP::E; + +require Net::FTP::I; + +@ISA = qw(Net::FTP::I); + +1; diff --git a/lib/Net/FTP/I.pm b/lib/Net/FTP/I.pm new file mode 100644 index 0000000..4548c12 --- /dev/null +++ b/lib/Net/FTP/I.pm @@ -0,0 +1,70 @@ +## +## Package to read/write on BINARY data connections +## + +package Net::FTP::I; + +use vars qw(@ISA $buf $VERSION); +use Carp; + +require Net::FTP::dataconn; + +@ISA = qw(Net::FTP::dataconn); +$VERSION = "1.08"; # $Id: //depot/libnet/Net/FTP/I.pm#6$ + +sub read { + my $data = shift; + local *buf = \$_[0]; shift; + my $size = shift || croak 'read($buf,$size,[$timeout])'; + my $timeout = @_ ? shift : $data->timeout; + + $data->can_read($timeout) or + croak "Timeout"; + + my($b,$n,$l); + my $blksize = ${*$data}{'net_ftp_blksize'}; + $blksize = $size if $size > $blksize; + + while(($l = length(${*$data})) < $size) { + $n += ($b = sysread($data, ${*$data}, $blksize, $l)); + last unless $b; + } + + $n = $size < ($l = length(${*$data})) ? $size : $l; + + $buf = substr(${*$data},0,$n); + substr(${*$data},0,$n) = ''; + + ${*$data}{'net_ftp_bytesread'} += $n if $n; + ${*$data}{'net_ftp_eof'} = 1 unless $n; + + $n; +} + +sub write { + my $data = shift; + local *buf = \$_[0]; shift; + my $size = shift || croak 'write($buf,$size,[$timeout])'; + my $timeout = @_ ? shift : $data->timeout; + + $data->can_write($timeout) or + croak "Timeout"; + + # If the remote server has closed the connection we will be signal'd + # when we write. This can happen if the disk on the remote server fills up + + local $SIG{PIPE} = 'IGNORE'; + my $sent = $size; + my $off = 0; + + while($sent > 0) { + my $n = syswrite($data, $buf, $sent,$off); + return undef unless defined($n); + $sent -= $n; + $off += $n; + } + + $size; +} + +1; diff --git a/lib/Net/FTP/L.pm b/lib/Net/FTP/L.pm new file mode 100644 index 0000000..fbb5a5a --- /dev/null +++ b/lib/Net/FTP/L.pm @@ -0,0 +1,7 @@ +package Net::FTP::L; + +require Net::FTP::I; + +@ISA = qw(Net::FTP::I); + +1; diff --git a/lib/Net/FTP/dataconn.pm b/lib/Net/FTP/dataconn.pm new file mode 100644 index 0000000..e43c6e6 --- /dev/null +++ b/lib/Net/FTP/dataconn.pm @@ -0,0 +1,123 @@ +## +## Generic data connection package +## + +package Net::FTP::dataconn; + +use Carp; +use vars qw(@ISA $timeout); +use Net::Cmd; + +@ISA = qw(IO::Socket::INET); + +sub reading +{ + my $data = shift; + ${*$data}{'net_ftp_bytesread'} = 0; +} + +sub abort +{ + my $data = shift; + my $ftp = ${*$data}{'net_ftp_cmd'}; + + # no need to abort if we have finished the xfer + return $data->close + if ${*$data}{'net_ftp_eof'}; + + # for some reason if we continously open RETR connections and not + # read a single byte, then abort them after a while the server will + # close our connection, this prevents the unexpected EOF on the + # command channel -- GMB + if(exists ${*$data}{'net_ftp_bytesread'} + && (${*$data}{'net_ftp_bytesread'} == 0)) { + my $buf=""; + my $timeout = $data->timeout; + $data->can_read($timeout) && sysread($data,$buf,1); + } + + ${*$data}{'net_ftp_eof'} = 1; # fake + + $ftp->abort; # this will close me +} + +sub _close +{ + my $data = shift; + my $ftp = ${*$data}{'net_ftp_cmd'}; + + $data->SUPER::close(); + + delete ${*$ftp}{'net_ftp_dataconn'} + if exists ${*$ftp}{'net_ftp_dataconn'} && + $data == ${*$ftp}{'net_ftp_dataconn'}; +} + +sub close +{ + my $data = shift; + my $ftp = ${*$data}{'net_ftp_cmd'}; + + if(exists ${*$data}{'net_ftp_bytesread'} && !${*$data}{'net_ftp_eof'}) { + my $junk; + $data->read($junk,1,0); + return $data->abort unless ${*$data}{'net_ftp_eof'}; + } + + $data->_close; + + $ftp->response() == CMD_OK && + $ftp->message =~ /unique file name:\s*(\S*)\s*\)/ && + (${*$ftp}{'net_ftp_unique'} = $1); + + $ftp->status == CMD_OK; +} + +sub _select +{ + my $data = shift; + local *timeout = \$_[0]; shift; + my $rw = shift; + + my($rin,$win); + + return 1 unless $timeout; + + $rin = ''; + vec($rin,fileno($data),1) = 1; + + $win = $rw ? undef : $rin; + $rin = undef unless $rw; + + my $nfound = select($rin, $win, undef, $timeout); + + croak "select: $!" + if $nfound < 0; + + return $nfound; +} + +sub can_read +{ + my $data = shift; + local *timeout = \$_[0]; + + $data->_select($timeout,1); +} + +sub can_write +{ + my $data = shift; + local *timeout = \$_[0]; + + $data->_select($timeout,0); +} + +sub cmd +{ + my $ftp = shift; + + ${*$ftp}{'net_ftp_cmd'}; +} + +1; diff --git a/lib/Net/Hostname.eg b/lib/Net/Hostname.eg new file mode 100644 index 0000000..3bf2b7c --- /dev/null +++ b/lib/Net/Hostname.eg @@ -0,0 +1,14 @@ +# This is an example Hostname.pm. + +package Sys::Hostname; + +use Net::Domain qw(hostname); +use Carp; + +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(hostname); + +carp "deprecated package 'Sys::Hostname', use Net::Domain" if $^W; + +1; diff --git a/lib/Net/NNTP.pm b/lib/Net/NNTP.pm new file mode 100644 index 0000000..2644397 --- /dev/null +++ b/lib/Net/NNTP.pm @@ -0,0 +1,1060 @@ +# Net::NNTP.pm +# +# Copyright (c) 1995-1997 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; + +use strict; +use vars qw(@ISA $VERSION $debug); +use IO::Socket; +use Net::Cmd; +use Carp; +use Time::Local; +use Net::Config; + +$VERSION = "2.19"; # $Id: //depot/libnet/Net/NNTP.pm#8$ +@ISA = qw(Net::Cmd IO::Socket::INET); + +sub new +{ + my $self = shift; + my $type = ref($self) || $self; + my $host = shift if @_ % 2; + my %arg = @_; + my $obj; + + $host ||= $ENV{NNTPSERVER} || $ENV{NEWSHOST}; + + my $hosts = defined $host ? [ $host ] : $NetConfig{nntp_hosts}; + + @{$hosts} = qw(news) + unless @{$hosts}; + + my $h; + foreach $h (@{$hosts}) + { + $obj = $type->SUPER::new(PeerAddr => ($host = $h), + PeerPort => $arg{Port} || 'nntp(119)', + Proto => 'tcp', + Timeout => defined $arg{Timeout} + ? $arg{Timeout} + : 120 + ) and last; + } + + return undef + unless defined $obj; + + ${*$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; + my @m = $obj->message; + + unless(exists $arg{Reader} && $arg{Reader} == 0) { + # if server is INN and we have transfer rights the we are currently + # talking to innd not nnrpd + if($obj->reader) + { + # If reader suceeds the we need to consider this code to determine postok + $c = $obj->code; + } + else + { + # I want to ignore this failure, so restore the previous status. + $obj->set_status($c,\@m); + } + } + + ${*$obj}{'net_nntp_post'} = $c == 200 ? 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 && @_ <= 3 or croak 'usage: $nntp->article( [ MSGID ], [ FH ] )'; + my $nntp = shift; + my @fh; + + @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB'); + + $nntp->_ARTICLE(@_) + ? $nntp->read_until_dot(@fh) + : 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 && @_ <= 3 or croak 'usage: $nntp->body( [ MSGID ], [ FH ] )'; + my $nntp = shift; + my @fh; + + @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB'); + + $nntp->_BODY(@_) + ? $nntp->read_until_dot(@fh) + : undef; +} + +sub head +{ + @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->head( [ MSGID ], [ FH ] )'; + my $nntp = shift; + my @fh; + + @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB'); + + $nntp->_HEAD(@_) + ? $nntp->read_until_dot(@fh) + : 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 +{ + @_ >= 2 && @_ <= 4 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->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-SPEC ] )'; + my $nntp = shift; + my $hdr = shift; + my $arg = _msg_arg(@_); + + $nntp->_XHDR($hdr, $arg) + ? $nntp->_description + : undef; +} + +sub xover +{ + @_ == 2 || @_ == 3 or croak 'usage: $nntp->xover( MESSAGE-SPEC )'; + my $nntp = shift; + my $arg = _msg_arg(@_); + + $nntp->_XOVER($arg) + ? $nntp->_fieldlist + : undef; +} + +sub xpat +{ + @_ == 4 || @_ == 5 or croak '$nntp->xpat( HEADER, PATTERN, MESSAGE-SPEC )'; + my $nntp = shift; + my $hdr = shift; + my $pat = shift; + my $arg = _msg_arg(@_); + + $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( MESSAGE-SPEC )'; + my $nntp = shift; + my $arg = _msg_arg(@_); + + $nntp->_XROVER($arg) + ? $nntp->_description + : 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 - 1900) + : undef; +} + + +## +## Private subroutines +## + +sub _msg_arg +{ + my $spec = shift; + my $arg = ""; + + if(@_) + { + carp "Depriciated passing of two message numbers, " + . "pass a reference" + if $^W; + $spec = [ $spec, $_[0] ]; + } + + if(defined $spec) + { + if(ref($spec)) + { + $arg = $spec->[0] . "-"; + $arg .= $spec->[1] + if defined $spec->[1] && $spec->[1] > $spec->[0]; + } + else + { + $arg = $spec; + } + } + + $arg; +} + +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); + my $m = shift @a; + $hash->{$m} = [ @a ]; + } + + $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_MORE } +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 DESTROY +{ + my $nntp = shift; + defined(fileno($nntp)) && $nntp->quit +} + + +1; + +__END__ + +=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, then C is checked, and if a host is not found +then C is used. + +C are passed in a hash like fashion, 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 + +B - If the remote server is INN then initially the connection +will be to nnrpd, by default C will issue a C command +so that the remote server becomes innd. If the C option is given +with a value of zero, then this command will not be sent and the +connection will be left talking to nnrpd. + +=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, failure will be returned as I or an +empty list. + +=over 4 + +=item article ( [ MSGID|MSGNUM ], [FH] ) + +Retrieve the header, a blank line, then the body (text) of the +specified article. + +If C is specified then it is expected to be a valid filehandle +and the result will be printed to it, on sucess a true value will be +returned. If C is not specified then the return value, on sucess, +will be a reference to an array containg the article requested, each +entry in the array will contain one line of the article. + +If no arguments are passed then the current article in the currently +selected newsgroup is fetched. + +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. + +If there is an error then C will be returned. + +=item body ( [ MSGID|MSGNUM ], [FH] ) + +Like C
but only fetches the body of the article. + +=item head ( [ MSGID|MSGNUM ], [FH] ) + +Like C
but only fetches the headers for 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 recommended for a new user to subscribe to. + +=item overview_fmt () + +Returns a reference to an array which contain the names of the fields returned +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 containing 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-SPEC ) + +Obtain the header field C
for all the messages specified. + +The return value will be a reference +to a hash where the keys are the message numbers and each value contains +the text of the requested header for that message. + +=item xover ( MESSAGE-SPEC ) + +The return value will be a reference +to a hash where the keys are the message numbers and each value contains +a reference to an array which contains the overview fields for that +message. + +The names of the 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-SPEC) + +The result is the same as C except the is will be restricted to +headers where the text of the header matches C + +=item xrover + +The XROVER command returns reference information for the article(s) +specified. + +Returns a reference to a HASH where the keys are the message numbers and the +values are the References: lines from the articles + +=item listgroup ( [ GROUP ] ) + +Returns a reference to a list of all the active messages in C, or +the current group if C is not specified. + +=item reader + +Tell the server that you are a reader and not another server. + +This is required by some servers. For example if you are connecting to +an INN server and you have transfer permission your connection will +be connected to the transfer daemon, not the NNTP daemon. Issuing +this command will cause the transfer daemon to hand over control +to the NNTP daemon. + +Some servers do not understand this command, but issuing it and ignoring +the response is harmless. + +=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-SPEC + +C is either a single message-id, a single message number, or +a reference to a list of two message numbers. + +If C is a reference to a list of 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. + +B For compatibility reasons only with earlier versions of Net::NNTP +a message spec can be passed as a list of two numbers, this is deprecated +and a reference to the list should now be passed + +=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 COPYRIGHT + +Copyright (c) 1995-1997 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 diff --git a/lib/Net/Netrc.pm b/lib/Net/Netrc.pm new file mode 100644 index 0000000..0c63310 --- /dev/null +++ b/lib/Net/Netrc.pm @@ -0,0 +1,326 @@ +# Net::Netrc.pm +# +# Copyright (c) 1995-1998 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; + +use Carp; +use strict; +use FileHandle; +use vars qw($VERSION); + +$VERSION = "2.10"; # $Id: //depot/libnet/Net/Netrc.pm#4$ + +my %netrc = (); + +sub _readrc +{ + my $host = shift; + my($home,$file); + + if($^O eq "MacOS") { + $home = $ENV{HOME} || `pwd`; + chomp($home); + $file = ($home =~ /:$/ ? $home . "netrc" : $home . ":netrc"); + } else { + # Some OS's don't have `getpwuid', so we default to $ENV{HOME} + $home = eval { (getpwuid($>))[7] } || $ENV{HOME}; + $file = $home . "/.netrc"; + } + + my($login,$pass,$acct) = (undef,undef,undef); + my $fh; + local $_; + + $netrc{default} = undef; + + # OS/2 and Win32 do not handle stat in a way compatable with this check :-( + unless($^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'MacOS') + { + my @stat = stat($file); + + if(@stat) + { + if($stat[2] & 077) + { + carp "Bad permissions: $file"; + return; + } + if($stat[4] != $<) + { + carp "Not owner: $file"; + return; + } + } + } + + if($fh = FileHandle->new($file,"r")) + { + my($mach,$macdef,$tok,@tok) = (0,0); + + while(<$fh>) + { + undef $macdef if /\A\n\Z/; + + if($macdef) + { + push(@$macdef,$_); + next; + } + + s/^\s*//; + chomp; + push(@tok, $+) + while(length && s/^("([^"]*)"|(\S+))\s*//); + +TOKEN: + while(@tok) + { + if($tok[0] eq "default") + { + shift(@tok); + $mach = bless {}; + $netrc{default} = [$mach]; + + next TOKEN; + } + + last TOKEN + unless @tok > 1; + + $tok = shift(@tok); + + if($tok eq "machine") + { + my $host = shift @tok; + $mach = bless {machine => $host}; + + $netrc{$host} = [] + unless exists($netrc{$host}); + push(@{$netrc{$host}}, $mach); + } + elsif($tok =~ /^(login|password|account)$/) + { + next TOKEN unless $mach; + my $value = shift @tok; + # Following line added by rmerrell to remove '/' escape char in .netrc + $value =~ s/\/\\/\\/g; + $mach->{$1} = $value; + } + elsif($tok eq "macdef") + { + next TOKEN unless $mach; + my $value = shift @tok; + $mach->{macdef} = {} + unless exists $mach->{macdef}; + $macdef = $mach->{machdef}{$value} = []; + } + } + } + $fh->close(); + } +} + +sub lookup +{ + my($pkg,$mach,$login) = @_; + + _readrc() + unless exists $netrc{default}; + + $mach ||= 'default'; + undef $login + if $mach eq 'default'; + + 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 $netrc{default}->[0] + if defined $netrc{default}; + + return undef; +} + +sub login +{ + my $me = shift; + + exists $me->{login} + ? $me->{login} + : undef; +} + +sub account +{ + my $me = shift; + + exists $me->{account} + ? $me->{account} + : undef; +} + +sub password +{ + my $me = shift; + + exists $me->{password} + ? $me->{password} + : undef; +} + +sub lpa +{ + my $me = shift; + ($me->login, $me->password, $me->account); +} + +1; + +__END__ + +=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 does. + +=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 SEE ALSO + +L +L + +=head1 COPYRIGHT + +Copyright (c) 1995-1998 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 diff --git a/lib/Net/PH.pm b/lib/Net/PH.pm new file mode 100644 index 0000000..d245b5c --- /dev/null +++ b/lib/Net/PH.pm @@ -0,0 +1,784 @@ +# +# Copyright (c) 1995-1997 Graham Barr and +# Alex Hristov . 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::PH; + +require 5.001; + +use strict; +use vars qw(@ISA $VERSION); +use Carp; + +use Socket 1.3; +use IO::Socket; +use Net::Cmd; +use Net::Config; + +$VERSION = "2.20"; # $Id: //depot/libnet/Net/PH.pm#7$ +@ISA = qw(Exporter Net::Cmd IO::Socket::INET); + +sub new +{ + my $pkg = shift; + my $host = shift if @_ % 2; + my %arg = @_; + my $hosts = defined $host ? [ $host ] : $NetConfig{ph_hosts}; + my $ph; + + my $h; + foreach $h (@{$hosts}) + { + $ph = $pkg->SUPER::new(PeerAddr => ($host = $h), + PeerPort => $arg{Port} || 'csnet-ns(105)', + Proto => 'tcp', + Timeout => defined $arg{Timeout} + ? $arg{Timeout} + : 120 + ) and last; + } + + return undef + unless defined $ph; + + ${*$ph}{'net_ph_host'} = $host; + + $ph->autoflush(1); + + $ph->debug(exists $arg{Debug} ? $arg{Debug} : undef); + + $ph; +} + +sub status +{ + my $ph = shift; + + $ph->command('status')->response; + $ph->code; +} + +sub login +{ + my $ph = shift; + my($user,$pass,$encrypted) = @_; + my $resp; + + $resp = $ph->command("login",$user)->response; + + if(defined($pass) && $resp == CMD_MORE) + { + if($encrypted) + { + my $challenge_str = $ph->message; + chomp($challenge_str); + Net::PH::crypt::crypt_start($pass); + my $cryptstr = Net::PH::crypt::encryptit($challenge_str); + + $ph->command("answer", $cryptstr); + } + else + { + $ph->command("clear", $pass); + } + $resp = $ph->response; + } + + $resp == CMD_OK; +} + +sub logout +{ + my $ph = shift; + + $ph->command("logout")->response == CMD_OK; +} + +sub id +{ + my $ph = shift; + my $id = @_ ? shift : $<; + + $ph->command("id",$id)->response == CMD_OK; +} + +sub siteinfo +{ + my $ph = shift; + + $ph->command("siteinfo"); + + my $ln; + my %resp; + my $cur_num = 0; + + while(defined($ln = $ph->getline)) + { + $ph->debug_print(0,$ln) + if ($ph->debug & 2); + chomp($ln); + my($code,$num,$tag,$data); + + if($ln =~ /^-(\d+):(\d+):(?:\s*([^:]+):)?\s*(.*)/o) + { + ($code,$num,$tag,$data) = ($1, $2, $3 || "",$4); + $resp{$tag} = bless [$code, $num, $tag, $data], "Net::PH::Result"; + } + else + { + $ph->set_status($ph->parse_response($ln)); + return \%resp; + } + } + + return undef; +} + +sub query +{ + my $ph = shift; + my $search = shift; + + my($k,$v); + + my @args = ('query', _arg_hash($search)); + + push(@args,'return',_arg_list( shift )) + if @_; + + unless($ph->command(@args)->response == CMD_INFO) + { + return $ph->code == 501 + ? [] + : undef; + } + + my $ln; + my @resp; + my $cur_num = 0; + + my($last_tag); + + while(defined($ln = $ph->getline)) + { + $ph->debug_print(0,$ln) + if ($ph->debug & 2); + chomp($ln); + my($code,$idx,$num,$tag,$data); + + if($ln =~ /^-(\d+):(\d+):\s*([^:]*):\s*(.*)/o) + { + ($code,$idx,$tag,$data) = ($1,$2,$3,$4); + my $num = $idx - 1; + + $resp[$num] ||= {}; + + $tag = $last_tag + unless(length($tag)); + + $last_tag = $tag; + + if(exists($resp[$num]->{$tag})) + { + $resp[$num]->{$tag}->[3] .= "\n" . $data; + } + else + { + $resp[$num]->{$tag} = bless [$code, $idx, $tag, $data], "Net::PH::Result"; + } + } + else + { + $ph->set_status($ph->parse_response($ln)); + return \@resp; + } + } + + return undef; +} + +sub change +{ + my $ph = shift; + my $search = shift; + my $make = shift; + + $ph->command( + "change", _arg_hash($search), + "make", _arg_hash($make) + )->response == CMD_OK; +} + +sub _arg_hash +{ + my $hash = shift; + + return $hash + unless(ref($hash)); + + my($k,$v); + my @r; + + while(($k,$v) = each %$hash) + { + my $a = $v; + $a =~ s/\n/\\n/sog; + $a =~ s/\t/\\t/sog; + $a = '"' . $a . '"' + if $a =~ /\W/; + $a = '""' + unless length $a; + + push(@r, "$k=$a"); + } + join(" ", @r); +} + +sub _arg_list +{ + my $arr = shift; + + return $arr + unless(ref($arr)); + + my $v; + my @r; + + foreach $v (@$arr) + { + my $a = $v; + $a =~ s/\n/\\n/sog; + $a =~ s/\t/\\t/sog; + $a = '"' . $a . '"' + if $a =~ /\W/; + push(@r, $a); + } + + join(" ",@r); +} + +sub add +{ + my $ph = shift; + my $arg = @_ > 1 ? { @_ } : shift; + + $ph->command('add', _arg_hash($arg))->response == CMD_OK; +} + +sub delete +{ + my $ph = shift; + my $arg = @_ > 1 ? { @_ } : shift; + + $ph->command('delete', _arg_hash($arg))->response == CMD_OK; +} + +sub force +{ + my $ph = shift; + my $search = shift; + my $force = shift; + + $ph->command( + "change", _arg_hash($search), + "force", _arg_hash($force) + )->response == CMD_OK; +} + + +sub fields +{ + my $ph = shift; + + $ph->command("fields", _arg_list(\@_)); + + my $ln; + my %resp; + my $cur_num = 0; + my @tags = (); + + while(defined($ln = $ph->getline)) + { + $ph->debug_print(0,$ln) + if ($ph->debug & 2); + chomp($ln); + + my($code,$num,$tag,$data,$last_tag); + + if($ln =~ /^-(\d+):(\d+):\s*([^:]*):\s*(.*)/o) + { + ($code,$num,$tag,$data) = ($1,$2,$3,$4); + + $tag = $last_tag + unless(length($tag)); + + $last_tag = $tag; + + if(exists $resp{$tag}) + { + $resp{$tag}->[3] .= "\n" . $data; + } + else + { + $resp{$tag} = bless [$code, $num, $tag, $data], "Net::PH::Result"; + push @tags, $tag; + } + } + else + { + $ph->set_status($ph->parse_response($ln)); + return wantarray ? (\%resp, \@tags) : \%resp; + } + } + + return; +} + +sub quit +{ + my $ph = shift; + + $ph->close + if $ph->command("quit")->response == CMD_OK; +} + +## +## Net::Cmd overrides +## + +sub parse_response +{ + return () + unless $_[1] =~ s/^(-?)(\d\d\d):?//o; + ($2, $1 eq "-"); +} + +sub debug_text { $_[2] =~ /^(clear)/i ? "$1 ....\n" : $_[2]; } + +package Net::PH::Result; + +sub code { shift->[0] } +sub value { shift->[1] } +sub field { shift->[2] } +sub text { shift->[3] } + +package Net::PH::crypt; + +# The code in this package is based upon 'cryptit.c', Copyright (C) 1988 by +# Steven Dorner, and Paul Pomes, and the University of Illinois Board +# of Trustees, and by CSNET. + +use integer; +use strict; + +sub ROTORSZ () { 256 } +sub MASK () { 255 } + +my(@t1,@t2,@t3,$n1,$n2); + +sub crypt_start { + my $pass = shift; + $n1 = 0; + $n2 = 0; + crypt_init($pass); +} + +sub crypt_init { + my $pw = shift; + my $i; + + @t2 = @t3 = (0) x ROTORSZ; + + my $buf = crypt($pw,$pw); + return -1 unless length($buf) > 0; + $buf = substr($buf . "\0" x 13,0,13); + my @buf = map { ord $_ } split(//, $buf); + + + my $seed = 123; + for($i = 0 ; $i < 13 ; $i++) { + $seed = $seed * $buf[$i] + $i; + } + @t1 = (0 .. ROTORSZ-1); + + for($i = 0 ; $i < ROTORSZ ; $i++) { + $seed = 5 * $seed + $buf[$i % 13]; + my $random = $seed % 65521; + my $k = ROTORSZ - 1 - $i; + my $ic = ($random & MASK) % ($k + 1); + $random >>= 8; + @t1[$k,$ic] = @t1[$ic,$k]; + next if $t3[$k] != 0; + $ic = ($random & MASK) % $k; + while($t3[$ic] != 0) { + $ic = ($ic + 1) % $k; + } + $t3[$k] = $ic; + $t3[$ic] = $k; + } + for($i = 0 ; $i < ROTORSZ ; $i++) { + $t2[$t1[$i] & MASK] = $i + } +} + +sub encode { + my $sp = shift; + my $ch; + my $n = scalar(@$sp); + my @out = ($n); + my $i; + + for($i = 0 ; $i < $n ; ) { + my($f0,$f1,$f2) = splice(@$sp,0,3); + push(@out, + $f0 >> 2, + ($f0 << 4) & 060 | ($f1 >> 4) & 017, + ($f1 << 2) & 074 | ($f2 >> 6) & 03, + $f2 & 077); + $i += 3; + } + join("", map { chr((($_ & 077) + 35) & 0xff) } @out); # ord('#') == 35 +} + +sub encryptit { + my $from = shift; + my @from = map { ord $_ } split(//, $from); + my @sp = (); + my $ch; + while(defined($ch = shift @from)) { + push(@sp, + $t2[($t3[($t1[($ch + $n1) & MASK] + $n2) & MASK] - $n2) & MASK] - $n1); + + $n1++; + if($n1 == ROTORSZ) { + $n1 = 0; + $n2++; + $n2 = 0 if $n2 == ROTORSZ; + } + } + encode(\@sp); +} + +1; + +__END__ + +=head1 NAME + +Net::PH - CCSO Nameserver Client class + +=head1 SYNOPSIS + + use Net::PH; + + $ph = Net::PH->new("some.host.name", + Port => 105, + Timeout => 120, + Debug => 0); + + if($ph) { + $q = $ph->query({ field1 => "value1" }, + [qw(name address pobox)]); + + if($q) { + } + } + + # Alternative syntax + + if($ph) { + $q = $ph->query('field1=value1', + 'name address pobox'); + + if($q) { + } + } + +=head1 DESCRIPTION + +C is a class implementing a simple Nameserver/PH client in Perl +as described in the CCSO Nameserver -- Server-Client Protocol. Like other +modules in the Net:: family the C object inherits methods from +C. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [ HOST ] [, OPTIONS ]) + + $ph = Net::PH->new("some.host.name", + Port => 105, + Timeout => 120, + Debug => 0 + ); + +This is the constructor for a new Net::PH object. C is the +name of the remote host to which a PH connection is required. + +If C is not given, then the C specified in C +will be used. + +C is an optional list of named options which are passed in +a hash like fashion, using key and value pairs. Possible options are:- + +B - Port number to connect to on remote host. + +B - Maximum time, in seconds, to wait for a response from the +Nameserver, 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, failure will be returned as I or an +empty list. + +=over 4 + +=item query( SEARCH [, RETURN ] ) + + $q = $ph->query({ name => $myname }, + [qw(name email schedule)]); + + foreach $handle (@{$q}) { + foreach $field (keys %{$handle}) { + $c = ${$handle}{$field}->code; + $v = ${$handle}{$field}->value; + $f = ${$handle}{$field}->field; + $t = ${$handle}{$field}->text; + print "field:[$field] [$c][$v][$f][$t]\n" ; + } + } + + + +Search the database and return fields from all matching entries. + +The C argument is a reference to a HASH which contains field/value +pairs which will be passed to the Nameserver as the search criteria. + +C is optional, but if given it should be a reference to a list which +contains field names to be returned. + +The alternative syntax is to pass strings instead of references, for example + + $q = $ph->query('name=myname', + 'name email schedule'); + +The C argument is a string that is passed to the Nameserver as the +search criteria. The strings being passed should B contain any carriage +returns, or else the query command might fail or return invalid data. + +C is optional, but if given it should be a string which will +contain field names to be returned. + +Each match from the server will be returned as a HASH where the keys are the +field names and the values are C objects (I, I, +I, I). + +Returns a reference to an ARRAY which contains references to HASHs, one +per match from the server. + +=item change( SEARCH , MAKE ) + + $r = $ph->change({ email => "*.domain.name" }, + { schedule => "busy"); + +Change field values for matching entries. + +The C argument is a reference to a HASH which contains field/value +pairs which will be passed to the Nameserver as the search criteria. + +The C argument is a reference to a HASH which contains field/value +pairs which will be passed to the Nameserver that +will set new values to designated fields. + +The alternative syntax is to pass strings instead of references, for example + + $r = $ph->change('email="*.domain.name"', + 'schedule="busy"'); + +The C argument is a string to be passed to the Nameserver as the +search criteria. The strings being passed should B contain any carriage +returns, or else the query command might fail or return invalid data. + + +The C argument is a string to be passed to the Nameserver that +will set new values to designated fields. + +Upon success all entries that match the search criteria will have +the field values, given in the Make argument, changed. + +=item login( USER, PASS [, ENCRYPT ]) + + $r = $ph->login('username','password',1); + +Enter login mode using C and C. If C is given and +is I then the password will be used to encrypt a challenge text +string provided by the server, and the encrypted string will be sent back +to the server. If C is not given, or I then the password +will be sent in clear text (I) + +=item logout() + + $r = $ph->logout(); + +Exit login mode and return to anonymous mode. + +=item fields( [ FIELD_LIST ] ) + + $fields = $ph->fields(); + foreach $field (keys %{$fields}) { + $c = ${$fields}{$field}->code; + $v = ${$fields}{$field}->value; + $f = ${$fields}{$field}->field; + $t = ${$fields}{$field}->text; + print "field:[$field] [$c][$v][$f][$t]\n"; + } + +In a scalar context, returns a reference to a HASH. The keys of the HASH are +the field names and the values are C objects (I, +I, I, I). + +In an array context, returns a two element array. The first element is a +reference to a HASH as above, the second element is a reference to an array +which contains the tag names in the order that they were returned from the +server. + +C is a string that lists the fields for which info will be +returned. + +=item add( FIELD_VALUES ) + + $r = $ph->add( { name => $name, phone => $phone }); + +This method is used to add new entries to the Nameserver database. You +must successfully call L before this method can be used. + +B that this method adds new entries to the database. To modify +an existing entry use L. + +C is a reference to a HASH which contains field/value +pairs which will be passed to the Nameserver and will be used to +initialize the new entry. + +The alternative syntax is to pass a string instead of a reference, for example + + $r = $ph->add('name=myname phone=myphone'); + +C is a string that consists of field/value pairs which the +new entry will contain. The strings being passed should B contain any +carriage returns, or else the query command might fail or return invalid data. + + +=item delete( FIELD_VALUES ) + + $r = $ph->delete('name=myname phone=myphone'); + +This method is used to delete existing entries from the Nameserver database. +You must successfully call L before this method can be used. + +B that this method deletes entries to the database. To modify +an existing entry use L. + +C is a string that serves as the search criteria for the +records to be deleted. Any entry in the database which matches this search +criteria will be deleted. + +=item id( [ ID ] ) + + $r = $ph->id('709'); + +Sends C to the Nameserver, which will enter this into its +logs. If C is not given then the UID of the user running the +process will be sent. + +=item status() + +Returns the current status of the Nameserver. + +=item siteinfo() + + $siteinfo = $ph->siteinfo(); + foreach $field (keys %{$siteinfo}) { + $c = ${$siteinfo}{$field}->code; + $v = ${$siteinfo}{$field}->value; + $f = ${$siteinfo}{$field}->field; + $t = ${$siteinfo}{$field}->text; + print "field:[$field] [$c][$v][$f][$t]\n"; + } + +Returns a reference to a HASH containing information about the server's +site. The keys of the HASH are the field names and values are +C objects (I, I, I, I). + +=item quit() + + $r = $ph->quit(); + +Quit the connection + +=back + +=head1 Q&A + +How do I get the values of a Net::PH::Result object? + + foreach $handle (@{$q}) { + foreach $field (keys %{$handle}) { + $my_code = ${$q}{$field}->code; + $my_value = ${$q}{$field}->value; + $my_field = ${$q}{$field}->field; + $my_text = ${$q}{$field}->text; + } + } + +How do I get a count of the returned matches to my query? + + $my_count = scalar(@{$query_result}); + +How do I get the status code and message of the last C<$ph> command? + + $status_code = $ph->code; + $status_message = $ph->message; + +=head1 SEE ALSO + +L + +=head1 AUTHORS + +Graham Barr +Alex Hristov + +=head1 ACKNOWLEDGMENTS + +Password encryption code ported to perl by Broc Seib , +Purdue University Computing Center. + +Otis Gospodnetic suggested +passing parameters as string constants. Some queries cannot be +executed when passing parameters as string references. + + Example: query first_name last_name email="*.domain" + +=head1 COPYRIGHT + +The encryption code is based upon cryptit.c, Copyright (C) 1988 by +Steven Dorner, and Paul Pomes, and the University of Illinois Board +of Trustees, and by CSNET. + +All other code is Copyright (c) 1996-1997 Graham Barr +and Alex Hristov . All rights reserved. This program is +free software; you can redistribute it and/or modify it under the same +terms as Perl itself. + +=cut diff --git a/lib/Net/POP3.pm b/lib/Net/POP3.pm new file mode 100644 index 0000000..6a05147 --- /dev/null +++ b/lib/Net/POP3.pm @@ -0,0 +1,521 @@ +# Net::POP3.pm +# +# Copyright (c) 1995-1997 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; + +use strict; +use IO::Socket; +use vars qw(@ISA $VERSION $debug); +use Net::Cmd; +use Carp; +use Net::Config; + +$VERSION = "2.21"; # $Id$ + +@ISA = qw(Net::Cmd IO::Socket::INET); + +sub new +{ + my $self = shift; + my $type = ref($self) || $self; + my $host = shift if @_ % 2; + my %arg = @_; + my $hosts = defined $host ? [ $host ] : $NetConfig{pop3_hosts}; + my $obj; + my @localport = exists $arg{ResvPort} ? ( LocalPort => $arg{ResvPort} ): (); + + my $h; + foreach $h (@{$hosts}) + { + $obj = $type->SUPER::new(PeerAddr => ($host = $h), + PeerPort => $arg{Port} || 'pop3(110)', + Proto => 'tcp', + @localport, + Timeout => defined $arg{Timeout} + ? $arg{Timeout} + : 120 + ) and last; + } + + return undef + unless defined $obj; + + ${*$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}{'net_pop3_banner'} = $obj->message; + + $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 ||= eval { (getpwuid($>))[0] } || $ENV{NAME}; + + 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 apop +{ + @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->apop( USER, PASS )'; + my($me,$user,$pass) = @_; + my $banner; + + unless(eval { require MD5 }) + { + carp "You need to install MD5 to use the APOP command"; + return undef; + } + + return undef + unless ( $banner = (${*$me}{'net_pop3_banner'} =~ /(<.*>)/)[0] ); + + if(@_ <= 2) + { + require Net::Netrc; + + $user ||= eval { (getpwuid($>))[0] } || $ENV{NAME}; + + my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'},$user); + + $m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'}); + + $pass = $m ? $m->password || "" + : ""; + } + + my $md = new MD5; + $md->add($banner,$pass); + + return undef + unless($me->_APOP($user,$md->hexdigest)); + + my $ret = ${*$me}{'net_pop3_count'} = ($me->message =~ /(\d+)\s+message/io) + ? $1 : ($me->popstat)[0]; + + $ret ? $ret : "0E0"; +} + +sub user +{ + @_ == 2 or croak 'usage: $pop3->user( USER )'; + $_[0]->_USER($_[1]) ? 1 : undef; +} + +sub pass +{ + @_ == 2 or croak 'usage: $pop3->pass( PASS )'; + + my($me,$pass) = @_; + + return undef + unless($me->_PASS($pass)); + + my $ret = ${*$me}{'net_pop3_count'} = ($me->message =~ /(\d+)\s+message/io) + ? $1 : ($me->popstat)[0]; + + $ret ? $ret : "0E0"; +} + +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 + or return undef; + + my %hash = map { (/(\d+)\D+(\d+)/) } @$info; + + return \%hash; +} + +sub get +{ + @_ == 2 or @_ == 3 or croak 'usage: $pop3->get( MSGNUM [, FH ])'; + my $me = shift; + + return undef + unless $me->_RETR(shift); + + $me->read_until_dot(@_); +} + +sub delete +{ + @_ == 2 or croak 'usage: $pop3->delete( MSGNUM )'; + $_[0]->_DELE($_[1]); +} + +sub uidl +{ + @_ == 1 || @_ == 2 or croak 'usage: $pop3->uidl( [ MSGNUM ] )'; + my $me = shift; + my $uidl; + + $me->_UIDL(@_) or + return undef; + if(@_) + { + $uidl = ($me->message =~ /\d+\s+([\041-\176]+)/)[0]; + } + else + { + my $ref = $me->read_until_dot + or return undef; + my $ln; + $uidl = {}; + foreach $ln (@$ref) { + my($msg,$uid) = $ln =~ /^\s*(\d+)\s+([\041-\176]+)/; + $uidl->{$msg} = $uid; + } + } + return $uidl; +} + +sub ping +{ + @_ == 2 or croak 'usage: $pop3->ping( USER )'; + my $me = shift; + + return () unless $me->_PING(@_) && $me->message =~ /(\d+)\D+(\d+)/; + + ($1 || 0, $2 || 0); +} + + +sub _STAT { shift->command('STAT')->response() == CMD_OK } +sub _LIST { shift->command('LIST',@_)->response() == CMD_OK } +sub _RETR { shift->command('RETR',$_[0])->response() == CMD_OK } +sub _DELE { shift->command('DELE',$_[0])->response() == CMD_OK } +sub _NOOP { shift->command('NOOP')->response() == CMD_OK } +sub _RSET { shift->command('RSET')->response() == CMD_OK } +sub _QUIT { shift->command('QUIT')->response() == CMD_OK } +sub _TOP { shift->command('TOP', @_)->response() == CMD_OK } +sub _UIDL { shift->command('UIDL',@_)->response() == CMD_OK } +sub _USER { shift->command('USER',$_[0])->response() == CMD_OK } +sub _PASS { shift->command('PASS',$_[0])->response() == CMD_OK } +sub _APOP { shift->command('APOP',@_)->response() == CMD_OK } +sub _PING { shift->command('PING',$_[0])->response() == CMD_OK } + +sub _RPOP { shift->command('RPOP',$_[0])->response() == CMD_OK } +sub _LAST { shift->command('LAST')->response() == CMD_OK } + +sub quit +{ + my $me = shift; + + $me->_QUIT; + $me->close; +} + +sub DESTROY +{ + my $me = shift; + + if(defined 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; + +__END__ + +=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. + +If C is not given, then the C specified in C +will be used. + +C are passed in a hash like fashion, using key and value pairs. +Possible options are: + +B - If given then the socket for the C object +will be bound to the local port given using C when the socket is +created. + +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, failure 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. However if there are no +messages on the server the string C<"0E0"> will be returned. This is +will give a true value in a boolean context, but zero in a numeric context. + +If there was an error authenticating the user then I will be returned. + +=item apop ( USER, PASS ) + +Authenticate with the server identifying as C with password C. +Similar ti L, but the password is not sent in clear text. + +To use this method you must have the MD5 package installed, if you do not +this method will return I + + +=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 message +in octets. + +If called without arguments a reference 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 [, FH ] ) + +Get the message C from the remote mailbox. If C is not given +then get returns a reference to an array which contains the lines of +text read from the server. If C is given then the lines returned +from the server are printed to the filehandle C. + +=item last () + +Returns the highest C of all the messages accessed. + +=item popstat () + +Returns a list of two elements. These are the number of undeleted +elements and the size of the mbox in octets. + +=item ping ( USER ) + +Returns a list of two elements. These are the number of new messages +and the total number of messages for C. + +=item uidl ( [ MSGNUM ] ) + +Returns a unique identifier for C if given. If C is not +given C returns a reference to a hash where the keys are the +message numbers and the values are the unique identifiers. + +=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 COPYRIGHT + +Copyright (c) 1995-1997 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 diff --git a/lib/Net/README.config b/lib/Net/README.config new file mode 100644 index 0000000..4dc7380 --- /dev/null +++ b/lib/Net/README.config @@ -0,0 +1,28 @@ +Hopefully the next release of libnet will be release 2.00. For this +release I want to completely re-write the configuration system. + +My current thoughts are that a hash of values is not sufficient and that +Net::Config should be code. This is what I have planned, if you see any +problems or have any ideas please let me know by sending an Email +to gbarr@pobox.com + +Net::Config will become an object based interface. Methods will be called +as static methods on the package. Net::Config will inherit from +Net::LocalCfg and Net::Config::default. Net::LocalCfg is a package +that local sys-admins can write to override the defaulr behaviour of +Net::Config. + +Most of the variables that are currently stored in Net::Config will +be turned into method calls, eg $NetConfig{'nntp_hosts'} will +become Net::Config->nntp_hosts + +This approach will allow for a better implementation of the firewall code, +which currently makes a lot of assumptions. To aid this Net::Config::default +will provide a method 'reachable' which will take a single argument as +a hostname and should return true it the host is reachable directly. + +This will also allow people who have dialup accounts, and appear in different +domains at different times, to do what they need. + +Graham +gbarr@pobox.com diff --git a/lib/Net/README.libnet b/lib/Net/README.libnet new file mode 100644 index 0000000..0b6b0cd --- /dev/null +++ b/lib/Net/README.libnet @@ -0,0 +1,100 @@ +libnet is a collection of Perl modules which provides a simple +and consistent programming interface (API) to the client side +of various protocols used in the internet community. + +For details of each protocol please refer to the RFC. RFC's +can be found a various places on the WEB, for a staring +point look at: + + http://www.yahoo.com/Computers_and_Internet/Standards/RFCs/ + +The RFC implemented in this distribution are + +Net::FTP RFC959 File Transfer Protocol +Net::SMTP RFC821 Simple Mail Transfer Protocol +Net::Time RFC867 Daytime Protocol +Net::Time RFC868 Time Protocol +Net::NNTP RFC977 Network News Transfer Protocol +Net::POP3 RFC1939 Post Office Protocol 3 +Net::SNPP RFC1861 Simple Network Pager Protocol + +The distribution also contains a module (Net::PH) which facilitates +comunicate with with servers using the CCSO Nameserver Server-Client +Protocol + +FUTURE WORK + +AVAILABILITY + +The latest version of libnet is available from the Comprehensive Perl +Archive Network (CPAN). To find a CPAN site near you see: + + http://www.perl.com/CPAN + ^ no slash here !! + +INSTALLATION + +In order to use this package you will need Perl version 5.002 or +better. You install libnet, as you would install any perl module +library, by running these commands: + + perl Makefile.PL + make + make test + make install + +If you want to install a private copy of libnet in your home +directory, then you should try to produce the initial Makefile with +something like this command: + + perl Makefile.PL PREFIX=~/perl + + +The Makefile.PL program will start out by checking your perl +installation for a few packages that are recommended to be installed +together with libnet. These packages should be available on CPAN +(described above). + +CONFIGURE + +Normally when perl Makefile.PL is run it will run Configure which will ask some +questions about your system. The results of these questions will be stored in +the Net::Config package. If you are on a system when this script cannot be run +for some reason then the file Config.eg can be edited manually and installed +as Net::Config (Net/Comfig.pm) + +DOCUMENTATION + +See ChangeLog for recent changes. POD style documentation is included +in all modules and scripts. These are normally converted to manual +pages and installed as part of the "make install" process. You should +also be able to use the 'perldoc' utility to extract documentation from +the module files directly. + +DEMOS + +The demos directory does contain a few demo scripts. These should be +run from the top directory like + + demos/smtp.self -user my-email-address -debug + +However I do not guarantee these scripts to work. + +SUPPORT + +Questions about how to use this library should be directed to the +comp.lang.perl.modules USENET Newsgroup. Bug reports and suggestions +for improvements can be sendt to me at . + +Most of the modules in this library have an option to output a debug +transcript to STDERR. When reporting bugs/problems please, if possible, +include a transcript of a run. + +COPYRIGHT + + © 1996-98 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. + +Share and Enjoy! diff --git a/lib/Net/SMTP.pm b/lib/Net/SMTP.pm new file mode 100644 index 0000000..8202d48 --- /dev/null +++ b/lib/Net/SMTP.pm @@ -0,0 +1,596 @@ +# Net::SMTP.pm +# +# Copyright (c) 1995-1997 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; + +require 5.001; + +use strict; +use vars qw($VERSION @ISA); +use Socket 1.3; +use Carp; +use IO::Socket; +use Net::Cmd; +use Net::Config; + +$VERSION = "2.15"; # $Id$ + +@ISA = qw(Net::Cmd IO::Socket::INET); + +sub new +{ + my $self = shift; + my $type = ref($self) || $self; + my $host = shift if @_ % 2; + my %arg = @_; + my $hosts = defined $host ? [ $host ] : $NetConfig{smtp_hosts}; + my $obj; + + my $h; + foreach $h (@{$hosts}) + { + $obj = $type->SUPER::new(PeerAddr => ($host = $h), + PeerPort => $arg{Port} || 'smtp(25)', + Proto => 'tcp', + Timeout => defined $arg{Timeout} + ? $arg{Timeout} + : 120 + ) and last; + } + + return undef + unless defined $obj; + + $obj->autoflush(1); + + $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef); + + unless ($obj->response() == CMD_OK) + { + $obj->close(); + return undef; + } + + ${*$obj}{'net_smtp_host'} = $host; + + (${*$obj}{'net_smtp_banner'}) = $obj->message; + (${*$obj}{'net_smtp_domain'}) = $obj->message =~ /\A\s*(\S+)/; + + unless($obj->hello($arg{Hello} || "")) + { + $obj->close(); + return undef; + } + + $obj; +} + +## +## User interface methods +## + +sub banner +{ + my $me = shift; + + return ${*$me}{'net_smtp_banner'} || undef; +} + +sub domain +{ + my $me = shift; + + return ${*$me}{'net_smtp_domain'} || undef; +} + +sub etrn { + my $self = shift; + defined($self->supports('ETRN',500,["Command unknown: 'ETRN'"])) && + $self->_ETRN(@_); +} + +sub hello +{ + my $me = shift; + my $domain = shift || + eval { + require Net::Domain; + Net::Domain::hostfqdn(); + } || + ""; + my $ok = $me->_EHLO($domain); + my @msg = $me->message; + + if($ok) + { + my $h = ${*$me}{'net_smtp_esmtp'} = {}; + my $ln; + foreach $ln (@msg) { + $h->{$1} = $2 + if $ln =~ /(\S+)\b[ \t]*([^\n]*)/; + } + } + elsif($me->status == CMD_ERROR) + { + @msg = $me->message + if $ok = $me->_HELO($domain); + } + + $ok && $msg[0] =~ /\A(\S+)/ + ? $1 + : undef; +} + +sub supports { + my $self = shift; + my $cmd = uc shift; + return ${*$self}{'net_smtp_esmtp'}->{$cmd} + if exists ${*$self}{'net_smtp_esmtp'}->{$cmd}; + $self->set_status(@_) + if @_; + return; +} + +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 $opts = ""; + my $skip_bad = 0; + + if(@_ && ref($_[-1])) + { + my %opt = %{pop(@_)}; + my $v; + + $skip_bad = delete $opt{'SkipBad'}; + + 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; + } + elsif(%opt) + { + carp 'Net::SMTP::recipient: ESMTP not supported by host - options discarded :-('; + } + } + + my @ok; + my $addr; + foreach $addr (@_) + { + if($smtp->_RCPT("TO:" . _addr($addr) . $opts)) { + push(@ok,$addr) if $skip_bad; + } + elsif(!$skip_bad) { + return 0; + } + } + + return $skip_bad ? @ok : 1; +} + +sub to { shift->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 quit +{ + my $me = shift; + + $me->_QUIT; + $me->close; +} + +sub DESTROY +{ +# ignore +} + +## +## 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(@_); } +sub _ETRN { shift->command("ETRN", @_)->response() == CMD_OK } + +1; + +__END__ + +=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 and ESMTP +protocol, enabling a perl5 application to talk to SMTP servers. This +documentation assumes that you are familiar with the concepts of 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. + +The Net::SMTP class is a subclass of Net::Cmd and IO::Socket::INET. + +=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 Net::SMTP [ 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. + +If C is not given, then the C specified in C +will be used. + +C are passed in a hash like fashion, 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' + Timeout => 30, + 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, failure will be returned as I or an +empty list. + +=over 4 + +=item banner () + +Returns the banner message which the server replied with when the +initial connection was made. + +=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 EHLO +command (or HELO if EHLO fails). Since this method is invoked +automatically when the Net::SMTP object is constructed the user should +normally not have to call it manually. + +=item etrn ( DOMAIN ) + +Request a queue run for the DOMAIN given. + +=item mail ( ADDRESS [, OPTIONS] ) + +=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. + +The C method can some additional ESMTP OPTIONS which is passed +in hash like fashion, using key and value pairs. Possible options are: + + Size => + Return => + Bits => "7" | "8" + Transaction =>
+ Envelope => + + +=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 [ ...]] [, OPTIONS ] ) + +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. + +The C method can some additional OPTIONS which is passed +in hash like fashion, using key and value pairs. Possible options are: + + Notify => + SkipBad => ignore bad addresses + +If C is true the C will not return an error when a +bad address is encountered and it will return an array of addresses +that did succeed. + +=item to ( ADDRESS [, ADDRESS [...]] ) + +A synonym for C. + +=item data ( [ DATA ] ) + +Initiate the sending of the data from 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 described in L. + +=item expand ( ADDRESS ) + +Request the server to expand the given address Returns 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 COPYRIGHT + +Copyright (c) 1995-1997 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 diff --git a/lib/Net/SNPP.pm b/lib/Net/SNPP.pm new file mode 100644 index 0000000..60781b3 --- /dev/null +++ b/lib/Net/SNPP.pm @@ -0,0 +1,414 @@ +# Net::SNPP.pm +# +# Copyright (c) 1995-1997 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; + +require 5.001; + +use strict; +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); +use Socket 1.3; +use Carp; +use IO::Socket; +use Net::Cmd; +use Net::Config; + +$VERSION = "1.11"; # $Id:$ +@ISA = qw(Net::Cmd IO::Socket::INET); +@EXPORT = (qw(CMD_2WAYERROR CMD_2WAYOK CMD_2WAYQUEUED), @Net::Cmd::EXPORT); + +sub CMD_2WAYERROR () { 7 } +sub CMD_2WAYOK () { 8 } +sub CMD_2WAYQUEUED () { 9 } + +sub new +{ + my $self = shift; + my $type = ref($self) || $self; + my $host = shift if @_ % 2; + my %arg = @_; + my $hosts = defined $host ? [ $host ] : $NetConfig{snpp_hosts}; + my $obj; + + my $h; + foreach $h (@{$hosts}) + { + $obj = $type->SUPER::new(PeerAddr => ($host = $h), + PeerPort => $arg{Port} || 'snpp(444)', + Proto => 'tcp', + Timeout => defined $arg{Timeout} + ? $arg{Timeout} + : 120 + ) and last; + } + + return undef + unless defined $obj; + + ${*$obj}{'net_snpp_host'} = $host; + + $obj->autoflush(1); + + $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef); + + unless ($obj->response() == CMD_OK) + { + $obj->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 = @_; + + if(exists $arg{Pager}) + { + my $pagers = ref($arg{Pager}) ? $arg{Pager} : [ $arg{Pager} ]; + my $pager; + foreach $pager (@$pagers) + { + $me->_PAGE($pager) || return 0 + } + } + + $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 xwho +{ + @_ == 1 or croak 'usage: $snpp->xwho()'; + my $me = shift; + + $me->_XWHO or return undef; + + my(%hash,$line); + my @msg = $me->message; + pop @msg; # Remove command complete line + + foreach $line (@msg) { + $line =~ /^\s*(\S+)\s*(.*)/ and $hash{$1} = $2; + } + + \%hash; +} + +sub service_level +{ + @_ == 2 or croak 'usage: $snpp->service_level( LEVEL )'; + my $me = shift; + my $level = int(shift); + + if($level < 0 || $level > 11) + { + $me->set_status(550,"Invalid Service Level"); + return 0; + } + + $me->_LEVE($level); +} + +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 $time = 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 quit +{ + @_ == 1 or croak 'usage: $snpp->quit()'; + my $snpp = shift; + + $snpp->_QUIT; + $snpp->close; +} + +## +## IO/perl methods +## + +sub DESTROY +{ + my $snpp = shift; + defined(fileno($snpp)) && $snpp->quit +} + +## +## Over-ride methods (Net::Cmd) +## + +sub debug_text +{ + $_[2] =~ s/^((logi|page)\s+\S+\s+)\S+/$1 xxxx/io; + $_[2]; +} + +sub parse_response +{ + return () + unless $_[1] =~ s/^(\d\d\d)(.?)//o; + my($code,$more) = ($1, $2 eq "-"); + + $more ||= $code == 214; + + ($code,$more); +} + +## +## 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 } +sub _SITE { shift->command("SITE",@_) } + +# 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 } + +# NonStandard + +sub _XWHO { shift->command("XWHO")->response() == CMD_OK } + +1; +__END__ + +=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. + +If C is not given, then the C specified in C +will be used. + +C are passed in a hash like fashion, 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, failure 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 COPYRIGHT + +Copyright (c) 1995-1997 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 diff --git a/lib/Net/Time.pm b/lib/Net/Time.pm new file mode 100644 index 0000000..828babf --- /dev/null +++ b/lib/Net/Time.pm @@ -0,0 +1,147 @@ +# Net::Time.pm +# +# Copyright (c) 1995-1998 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; + +use strict; +use vars qw($VERSION @ISA @EXPORT_OK $TIMEOUT); +use Carp; +use IO::Socket; +require Exporter; +use Net::Config; +use IO::Select; + +@ISA = qw(Exporter); +@EXPORT_OK = qw(inet_time inet_daytime); + +$VERSION = "2.08"; + +$TIMEOUT = 120; + +sub _socket +{ + my($pname,$pnum,$host,$proto,$timeout) = @_; + + $proto ||= 'udp'; + + my $port = (getservbyname($pname, $proto))[2] || $pnum; + + my $hosts = defined $host ? [ $host ] : $NetConfig{$pname . '_hosts'}; + + my $me; + + foreach $host (@$hosts) + { + $me = IO::Socket::INET->new(PeerAddr => $host, + PeerPort => $port, + Proto => $proto + ) and last; + } + + return unless $me; + + $me->send("\n") + if $proto eq 'udp'; + + $timeout = $TIMEOUT + unless defined $timeout; + + IO::Select->new($me)->can_read($timeout) + ? $me + : undef; +} + +sub inet_time +{ + my $s = _socket('time',37,@_) || return undef; + my $buf = ''; + my $offset = 0 | 0; + + return undef + unless $s->recv($buf, length(pack("N",0))); + + # unpack, we | 0 to ensure we have an unsigned + my $time = (unpack("N",$buf))[0] | 0; + + # the time protocol return time in seconds since 1900, convert + # it to a the required format + + if($^O eq "MacOS") { + # MacOS return seconds since 1904, 1900 was not a leap year. + $offset = (4 * 31536000) | 0; + } + else { + # otherwise return seconds since 1972, there were 17 leap years between + # 1900 and 1972 + $offset = (70 * 31536000 + 17 * 86400) | 0; + } + + $time - $offset; +} + +sub inet_daytime +{ + my $s = _socket('daytime',13,@_) || return undef; + my $buf = ''; + + $s->recv($buf, 1024) ? $buf + : undef; +} + +1; + +__END__ + +=head1 NAME + +Net::Time - time and daytime network client interface + +=head1 SYNOPSIS + + use Net::Time qw(inet_time inet_daytime); + + print inet_time(); # use default host from Net::Config + print inet_time('localhost'); + print inet_time('localhost', 'tcp'); + + print inet_daytime(); # use default host from Net::Config + 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 [, TIMEOUT]]]) + +Obtain the time on C, or some default host if C is not given +or not defined, 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 time value in the same units as returned +by time() or I upon failure. + +=item inet_daytime ( [HOST [, PROTOCOL [, TIMEOUT]]]) + +Obtain the time on C, or some default host if C is not given +or not defined, 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 COPYRIGHT + +Copyright (c) 1995-1998 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 diff --git a/lib/Net/demos/ftp b/lib/Net/demos/ftp new file mode 100755 index 0000000..610e102 --- /dev/null +++ b/lib/Net/demos/ftp @@ -0,0 +1,21 @@ +#!/usr/local/bin/perl + +use blib; +use Net::FTP; +use Getopt::Long; + +$opt_debug = undef; +$opt_firewall = undef; + +GetOptions(qw(debug firewall=s)); + +@firewall = defined $opt_firewall ? (Firewall => $opt_firewall) : (); + +foreach $host (@ARGV) + { + $ftp = Net::FTP->new($host, @firewall, Debug => $opt_debug ? 1 : 0); + $ftp->login(); + print $ftp->pwd,"\n"; + $ftp->quit; + } + diff --git a/lib/Net/demos/inetd b/lib/Net/demos/inetd new file mode 100644 index 0000000..36a00e7 --- /dev/null +++ b/lib/Net/demos/inetd @@ -0,0 +1,9 @@ +#!/usr/local/bin/perl + +use Net::DummyInetd; +use Net::SMTP; + +$p = new Net::DummyInetd qw(/usr/lib/sendmail -ba -bs); + +$smtp = Net::SMTP->new('localhost', Port => $p->port, Debug => 7); +$smtp->quit; diff --git a/lib/Net/demos/nntp b/lib/Net/demos/nntp new file mode 100755 index 0000000..7753fbc --- /dev/null +++ b/lib/Net/demos/nntp @@ -0,0 +1,40 @@ +#!/usr/local/bin/perl + +use blib; +use Getopt::Long; +use Net::NNTP; + +$opt_debug = undef; + +GetOptions(qw(debug)); + +@groups = @ARGV; + +$nntp = Net::NNTP->new('news', Debug => $opt_debug ? 1 : 0); + +if($subs = $nntp->newsgroups) + { + print join("\n",(keys %$subs)[0 .. 10]),"\n"; + } + else + { + warn $nntp->message; + } + +foreach $group (@groups) + { + $new = $nntp->newnews(time - 3600, lc $group); + + if(ref($new) && scalar(@$new)) + { + print@{$news}[0..3],"\n" + if $news = $nntp->article($new->[-1]); + + warn $nntp->message + unless $news; + } + } + +$nntp->quit; + + diff --git a/lib/Net/demos/nntp.mirror b/lib/Net/demos/nntp.mirror new file mode 100644 index 0000000..8a43c32 --- /dev/null +++ b/lib/Net/demos/nntp.mirror @@ -0,0 +1,86 @@ +#!/usr/bin/perl5 + +### Subject: Re: Fuller example of Net::NNTP? +### Date: Tue, 4 Feb 1997 10:37:58 -0800 +### From: "Paul E. Hoffman" +### To: Graham Barr +### +### Thanks for your reply. After looking at the examples, I realized that +### you're not doing what I want, which is to store the messages on the local +### hard disk with the same message number as what was on the remote. So, I +### rolled my own program, although I haven't finished it yet (I have a hook +### for expiring, but haven't done it yet). +### +### You are welcome to use this in the Net:: distribution if you think it is +### useful. +### +### NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE +### +### This script is included as-is, I give no guarantee that it will +### work on every system +### + +use Net::NNTP; + +$BaseDir = '/usr/usenet'; +chdir($BaseDir) or die "Could not cd to $BaseDir\n"; + +# Format of grouplist is: +# groupnameexpirationdays +# expirationdays is the number of days to leave the articles around; +# set it to 0 if you want the articles to stay forever +# If the groupname starts with a #, it is skipped +open(GROUPLIST, 'grouplist.txt') or die "Could not open grouplist.txt\n"; +while() { + $Line = $_; chomp($Line); + if($Line eq '') { next }; # Skip blank lines + if(substr($Line, 0, 1) eq '#') { next }; # Skip comments + push(@Groups, $Line) +} + +$NntpPtr = Net::NNTP->new('news.server.com'); + +foreach $GroupLine (@Groups) { + ($GroupName, $GroupExp) = split(/\s/, $GroupLine, 2); + # Process the expiration first (still to be done...) + + # See if this is a new group + unless(-e "$BaseDir/$GroupName") { + unless(mkdir("$BaseDir/$GroupName", 0755)) + { die "Could not make $BaseDir/$GroupName\n" } + } + chdir("$BaseDir/$GroupName") or die "Couldn't chdir to $GroupName\n"; + # Find the last article in the directory + @AllInDir = <*>; @RevSortedAllInDir = reverse(sort(@AllInDir)); + $LenArr = @RevSortedAllInDir; + if($LenArr > 0) { $NumLastInDir = $RevSortedAllInDir[0] } + else { $NumLastInDir = 0 } + ($NumArt, $NumFirst, $NumLast, $XGroupName) = +$NntpPtr->group($GroupName); + + if($NumLast == $NumLastInDir) { next } # No new articles + if($NumLast < $NumLastInDir) + { die "In $GroupName, the last number was $NumLast, but the " . + " last number in the directory was $NumLastInDir\n" } + # Figure out which article to start from + if($NumLastInDir == 0) { $GetArtNum = $NumFirst } + else { $GetArtNum = $NumLastInDir + 1 } + + # Now read each of the new articles + while(1) { # Loop until "last" is called + $ArtRef = $NntpPtr->article($GetArtNum); + @ArtArr = @$ArtRef; $ArtArrLen = @ArtArr; + if($ArtArrLen > 0 ) { # Skip article numbers that had 0 len + open(OUT, ">$GetArtNum") or + die "Could not create $GroupName/$GetArtNum\n"; + print OUT @$ArtRef; close(OUT); + } + + # Check if we're at the end + if($GetArtNum == $NumLast) { last } + $GetArtNum += 1; # Increment the article number to get + } +} + +$NntpPtr->quit; +exit; diff --git a/lib/Net/demos/pop3 b/lib/Net/demos/pop3 new file mode 100644 index 0000000..0ae07ae --- /dev/null +++ b/lib/Net/demos/pop3 @@ -0,0 +1,24 @@ +#!/usr/local/bin/perl -w + +use blib; +use Net::POP3; +use Getopt::Long; + +$opt_debug = 0; +$opt_user = undef; + +GetOptions(qw(debug user=s)); + +$pop = Net::POP3->new('backup3', Debug => $opt_debug ? 6 : 0); + +$user = $opt_user || $ENV{USER} || $ENV{LOGNAME}; + +$count = $pop->login($user); + +if($count) + { + $m = $pop->get(1); + print @$m if $m; + } + +$pop->quit; diff --git a/lib/Net/demos/smtp.self b/lib/Net/demos/smtp.self new file mode 100755 index 0000000..5cfbc2b --- /dev/null +++ b/lib/Net/demos/smtp.self @@ -0,0 +1,80 @@ +#!/usr/local/bin/perl -w + +use blib; +use Net::SMTP; +use Getopt::Long; + +=head1 NAME + + smtp.self - mail a message via smtp + +=head1 DESCRIPTION + +C will attempt to send a message to a given user + +=head1 OPTIONS + +=over 4 + +=item -debug + +Enabe the output of dubug information + +=item -help + +Display this help text and quit + +=item -user USERNAME + +Send the message to C + +=head1 EXAMPLE + + demos/smtp.self -user foo.bar + + demos/smtp.self -debug -user Graham.Barr + +=back + +=cut + +$opt_debug = undef; +$opt_user = undef; +$opt_help = undef; +GetOptions(qw(debug user=s help)); + +exec("pod2text $0") + if defined $opt_help; + +Net::SMTP->debug(1) if $opt_debug; + +$smtp = Net::SMTP->new("mailhost"); + +$user = $opt_user || $ENV{USER} || $ENV{LOGNAME}; + +$smtp->mail($user) && $smtp->to($user); +$smtp->reset; + +if($smtp->mail($user) && $smtp->to($user)) + { + $smtp->data(); + + map { s/-USER-/$user/g } @data=; + + $smtp->datasend(@data); + $smtp->dataend; + } +else + { + warn $smtp->message; + } + +$smtp->quit; + +__DATA__ +To: <-USER-> +Subject: A test message + +The message was sent directly via SMTP using Net::SMTP +. +The message was sent directly via SMTP using Net::SMTP diff --git a/lib/Net/demos/snpp b/lib/Net/demos/snpp new file mode 100755 index 0000000..f046b58 --- /dev/null +++ b/lib/Net/demos/snpp @@ -0,0 +1,39 @@ +#!/usr/local/bin/perl + +use blib; +use Getopt::Long; +use Net::SNPP; + +$opt_debug = undef; +$opt_h = undef; +$opt_p = undef; + +GetOptions(qw(debug h p)); + +die "usage: $0 -h -p " + unless defined $opt_h && defined $opt_p && @ARGV; + +Net::SNPP->debug(1) + if $opt_debug; + +$snpp = Net::SNPP->new($opt_host); + +$snpp->pager_id($opt_p) || die $snpp->message; +$snpp->content(join(" ",@ARGV)) || die $snpp->message; +$snpp->send() || die $snpp->message; + +$snpp->quit; + +__END__ + +or you could dp + +$snpp = Net::SNPP->new($opt_host); + +$snpp->send( Pager => $opt_p, + Message => join(" ",@ARGV), + Alert => 1, + Hold => time + 3600 + ) || die $snpp->message; + +$snpp->quit; diff --git a/lib/Net/demos/time b/lib/Net/demos/time new file mode 100644 index 0000000..61095d3 --- /dev/null +++ b/lib/Net/demos/time @@ -0,0 +1,13 @@ +#!/usr/local/bin/perl -w + +use blib; +use Net::Time qw(inet_time inet_daytime); + +print inet_daytime('localhost'); +print inet_daytime('localhost','tcp'); +print inet_daytime('localhost','udp'); + +print inet_time('localhost'),"\n"; +print inet_time('localhost','tcp'),"\n"; +print inet_time('localhost','udp'),"\n"; + diff --git a/lib/Net/libnet.ppd b/lib/Net/libnet.ppd new file mode 100644 index 0000000..ed864bc --- /dev/null +++ b/lib/Net/libnet.ppd @@ -0,0 +1,12 @@ + + libnet + Collection of Network protocol modules + Graham Barr <gbarr@pobox.com> + + + + + + + + diff --git a/lib/Net/libnetFAQ.pod b/lib/Net/libnetFAQ.pod new file mode 100644 index 0000000..1e5af56 --- /dev/null +++ b/lib/Net/libnetFAQ.pod @@ -0,0 +1,321 @@ +=head1 NAME + +libnetFAQ - libnet Frequently Asked Questions + +=head1 DESCRIPTION + +=head2 Where to get this document + +This document is distributed with the libnet disribution, and is also +avaliable on the libnet web page at + + http://www.pobox.com/~gbarr/libnet/ + + + +=head2 How to contribute to this document + +You may mail corrections, additions, and suggestions to me +gbarr@pobox.com. + + +=head1 Author and Copyright Information + +Copyright (c) 1997-1998 Graham Barr. All rights reserved. +This document is free; you can redistribute it and/or modify it +under the terms of the Artistic Licence. + +=head2 Disclaimer + +This information is offered in good faith and in the hope that it may +be of use, but is not guaranteed to be correct, up to date, or suitable +for any particular purpose whatsoever. The authors accept no liability +in respect of this information or its use. + + +=head1 Obtaining and installing libnet + +=over 4 + +=head2 What is libnet ? + +libnet is a collection of perl5 modules which all related to network +programming. The majority of the modules avaliable provided the +client side of popular server-client protocols that are used in +the internet community. + +=head2 Which version of perl do I need ? + +libnet has been know to work with versions of perl from 5.002 onwards. However +if your release of perl is prior to perl5.004 then you will need to +obtain and install the IO distribution from CPAN. If you have perl5.004 +or later then you will have the IO modules in your installation already, +but CPAN may contain updates. + +=head2 What other modules do I need ? + +The only modules you will need installed are the modules from the IO +distribution. If you have perl5.004 or later you will already have +these modules. + +=head2 What machines support libnet ? + +libnet itself is an entirly perl-code distribution so it should work +on any machine that perl runs on. However IO may not work +with some machines and earlier releases of perl. But this +should not be the case with perl version 5.004 or later. + +=head2 Where can I get the latest libnet release + +The latest libnet release is always on CPAN, you will find it +in + + http://www.perl.com/CPAN/modules/by-module/Net/ + +The latest release and information is also avaliable on the libnet web page +at + + http://www.pobox.com/~gbarr/libnet/ + +=back + +=head1 Using Net::FTP + +=over + +=head2 How do I download files from a FTP server ? + +An example taken from an article posted to comp.lang.perl.misc + + #!/your/path/to/perl + + # a module making life easier + + use Net::FTP; + + # for debuging: $ftp = Net::FTP->new('site','Debug',10); + # open a connection and log in! + + $ftp = Net::FTP->new('target_site.somewhere.xxx'); + $ftp->login('username','password'); + + # set transfer mode to binary + + $ftp->binary(); + + # change the directory on the ftp site + + $ftp->cwd('/some/path/to/somewhere/'); + + foreach $name ('file1', 'file2', 'file3') { + + # get's arguments are in the following order: + # ftp server's filename + # filename to save the transfer to on the local machine + # can be simply used as get($name) if you want the same name + + $ftp->get($name,$name); + } + + # ftp done! + + $ftp->quit; + +=head2 How do I transfer files in binary mode ? + +To transfer files without translation Net::FTP provides +the C method + + $ftp->binary; + +=head2 How can I get the size of a file on a remote FTP server ? + +=head2 How can I get the modification time of a file on a remote FTP server ? + +=head2 How can I change the permissions of a file on a remote server ? + +The FTP protocol does not have a command for changing the permissions +of a file on the remote server. But some ftp servers may allow a chmod +command to be issued via a SITE command, eg + + $ftp->quot('site chmod 0777',$filename); + +But this is not guaranteed to work. + +=head2 Can I do a reget operation like the ftp command ? + +=head2 How do I get a directory listing from a FTP server ? + +=head2 Changeing directory to "" does not fail ? + +Passing an argument of "" to ->cwd() has the same affect of calling ->cwd() +without any arguments. Turn on Debug (I) and you will see what is +happening + + $ftp = Net::FTP->new($host, Debug => 1); + $ftp->login; + $ftp->cwd(""); + +gives + + Net::FTP=GLOB(0x82196d8)>>> CWD / + Net::FTP=GLOB(0x82196d8)<<< 250 CWD command successful. + +=head2 I am behind a SOCKS firewall, but the Firewall option does not work ? + +The Firewall option is only for support of one type of firewall. The type +supported is a ftp proxy. + +To use Net::FTP, or any other module in the libnet distribution, +through a SOCKS firewall you must create a socks-ified perl executable +by compiling perl with the socks library. + +=head2 I am behind a FTP proxy firewall, but cannot access machines outside ? + +Net::FTP implements the most popular ftp proxy firewall approach. The sceme +implemented is that where you loginin to the firewall with C + +I have heard of one other type of firewall which requires a login to the +firewall with an accont, then a second login with C. You can +still use Net::FTP to traverse these firewalls, but a more manual approach +must be taken, eg + + $ftp = Net::FTP->new($firewall) or die $@; + $ftp->login($firewall_user, $firewall_passwd) or die $ftp->message; + $ftp->login($ext_user . '@' . $ext_host, $ext_passwd) or die $ftp->message. + +=head2 My ftp proxy firewall does not listen on port 21 + +FTP servers usually listen on the same port number, port 21, as any other +FTP server. But there is no reason why thi has to be the case. + +If you pass a port number to Net::FTP then it assumes this is the port +number of the final destination. By default Net::FTP will always try +to connect to the firewall on port 21. + +Net::FTP uses IO::Socket to open the connection and IO::Socket allows +the port number to be specified as part of the hostname. So this problem +can be resolved by either passing a Firewall option like C<"hostname:1234"> +or by setting the C option in Net::Config to be a string +in in the same form. + +=head2 Is it possible to change the file permissions of a file on an FTP server ? + +The answer to this is "maybe". The FTP protocol does not specify a command to change +file permissions on a remote host. However many servers do allow you to run the +chmod command via the C command. This can be done with + + $ftp->site('chmod','0775',$file); + +=head2 I have seen scripts call a method message, but cannot find it documented ? + +Net::FTP, like several other packages in libnet, inherits from Net::Cmd, so +all the methods described in Net::Cmd are also avaliable on Net::FTP +objects. + +=head2 Why does Net::FTP not implement mput and mget methods + +The quick answer is because they are easy to implement yourself. The long +answer is that to write these in such a way that multiple platforms are +supported correctly would just require too much code. Below are +some examples how you can implement these yourself. + +sub mput { + my($ftp,$pattern) = @_; + foreach my $file (<$pattern>) { + $ftp->put($file) or warn $ftp->message; + } +} + +sub mget { + my($ftp,$pattern) = @_; + foreach my $file ($ftp->ls($pattern)) { + $ftp->get($file) or warn $ftp->message; + } +} + + +=back + +=head1 Using Net::SMTP + +=over + +=head2 Why can't the part of an Email address after the @ be used as the hostname ? + +The part of an Email address which follows the @ is not necessarily a hostname, +it is a mail domain. To find the name of a host to connect for a mail domain +you need to do a DNS MX lookup + +=head2 Why does Net::SMTP not do DNS MX lookups ? + +Net::SMTP implements the SMTP protocol. The DNS MX lookup is not part +of this protocol. + +=head2 The verify method always returns true ? + +Well it may seem thay way, but it does not. The verify method returns true +if the command suceeded. If you pass verify an address which the +server would normally have to forward to another machine the the command +will suceed with something like + + 252 Couldn't verify but will attempt delivery anyway + +This command will only fail if you pass it an address in a domain the +the server directly delivers for, and that address does not exist. + +=back + +=head1 Debugging scripts + +=over + +=head2 How can I debug my scripts that use Net::* modules ? + +Most of the libnet client classes allow options to be passed to the +constructor, in most cases one option is called C. Passing +this option with a non-zero value will turn on a protocol trace, which +will be sent to STDERR. This trace can be useful to see what commands +are being sent to the remote server and what responces are being +received back. + + #!/your/path/to/perl + + use Net::FTP; + + my $ftp = new Net::FTP($host, Debug => 1); + $ftp->login('gbarr','password'); + $ftp->quit; + +this script would output something like + + Net::FTP: Net::FTP(2.22) + Net::FTP: Exporter + Net::FTP: Net::Cmd(2.0801) + Net::FTP: IO::Socket::INET + Net::FTP: IO::Socket(1.1603) + Net::FTP: IO::Handle(1.1504) + + Net::FTP=GLOB(0x8152974)<<< 220 imagine FTP server (Version wu-2.4(5) Tue Jul 29 11:17:18 CDT 1997) ready. + Net::FTP=GLOB(0x8152974)>>> user gbarr + Net::FTP=GLOB(0x8152974)<<< 331 Password required for gbarr. + Net::FTP=GLOB(0x8152974)>>> PASS .... + Net::FTP=GLOB(0x8152974)<<< 230 User gbarr logged in. Access restrictions apply. + Net::FTP=GLOB(0x8152974)>>> QUIT + Net::FTP=GLOB(0x8152974)<<< 221 Goodbye. + +The first few lines tell you the modules that Net::FTP uses and thier versions, +this is usefule data to me when a user reports a bug. The last seven lines +show the communication with the server. Each line has three parts. The first +part is the object itself, this is useful for separating the output +if you are using mutiple objects. The second part is either C<<<<<> to +show data coming from the server or C<>>>>> to show data +going to the server. The remainder of the line is the command +being sent or responce being received. + +=back + +=head1 AUTHOR AND COPYRIGHT + +Copyright (c) 1997 Graham Barr. +All rights reserved. diff --git a/lib/Net/t/ftp.t b/lib/Net/t/ftp.t new file mode 100644 index 0000000..f91d76a --- /dev/null +++ b/lib/Net/t/ftp.t @@ -0,0 +1,60 @@ +#!./perl -w + +use Net::Config; +use Net::FTP; + +unless(defined($NetConfig{ftp_testhost}) && $NetConfig{test_hosts}) { + print "1..0\n"; + exit 0; +} + +my $t = 1; +print "1..7\n"; + +$ftp = Net::FTP->new($NetConfig{ftp_testhost}, Debug => 0) + or (print("not ok 1\n"), exit); + +printf "ok %d\n",$t++; + +$ftp->login('anonymous') or die($ftp->message . "\n"); +printf "ok %d\n",$t++; + +$ftp->pwd or do { + print STDERR $ftp->message,"\n"; + print "not "; +}; + +printf "ok %d\n",$t++; + +$ftp->cwd('/pub') or do { + print STDERR $ftp->message,"\n"; + print "not "; +}; + +if ($data = $ftp->stor('libnet.tst')) { + my $text = "abc\ndef\nqwe\n"; + printf "ok %d\n",$t++; + $data->write($text,length $text); + $data->close; + $data = $ftp->retr('libnet.tst'); + $data->read($buf,length $text); + $data->close; + print "not " unless $text eq $buf; + printf "ok %d\n",$t++; + $ftp->delete('libnet.tst') or print "not "; + printf "ok %d\n",$t++; + +} +else { + print STDERR $ftp->message,"\n"; + printf "not ok %d\n",$t++; + printf "not ok %d\n",$t++; + printf "not ok %d\n",$t++; +} + +$ftp->quit or do { + print STDERR $ftp->message,"\n"; + print "not "; +}; + +printf "ok %d\n",$t++; diff --git a/lib/Net/t/hostname.t b/lib/Net/t/hostname.t new file mode 100644 index 0000000..3e55ace --- /dev/null +++ b/lib/Net/t/hostname.t @@ -0,0 +1,19 @@ + +use Net::Domain qw(hostname domainname hostdomain); +use Net::Config; + +unless($NetConfig{test_hosts}) { + print "1..0\n"; + exit 0; +} + +print "1..1\n"; + +$domain = domainname(); + +if(defined $domain && $domain ne "") { + print "ok 1\n"; +} +else { + print "not ok 1\n"; +} diff --git a/lib/Net/t/nntp.t b/lib/Net/t/nntp.t new file mode 100644 index 0000000..1afb588 --- /dev/null +++ b/lib/Net/t/nntp.t @@ -0,0 +1,46 @@ +#!./perl -w + +use Net::Config; +use Net::NNTP; +use Net::Cmd qw(CMD_REJECT); + +unless(@{$NetConfig{nntp_hosts}} && $NetConfig{test_hosts}) { + print "1..0\n"; + exit; +} + +print "1..4\n"; + +my $i = 1; + +$nntp = Net::NNTP->new(Debug => 0) + or (print("not ok 1\n"), exit); + +print "ok 1\n"; + +my $grp; +foreach $grp (qw(test alt.test control news.announce.newusers)) { + @grp = $nntp->group($grp); + last if @grp; +} + +if($nntp->status == CMD_REJECT) { + # Command was rejected, probably because we need authinfo + map { print "ok ",$_,"\n" } 2,3,4; + exit; +} + +print "not " unless @grp; +print "ok 2\n"; + + +if(@grp && $grp[2] > $grp[1]) { + $nntp->head($grp[1]) or print "not "; +} +print "ok 3\n"; + +if(@grp) { + $nntp->quit or print "not "; +} +print "ok 4\n"; + diff --git a/lib/Net/t/ph.t b/lib/Net/t/ph.t new file mode 100644 index 0000000..41ddab6 --- /dev/null +++ b/lib/Net/t/ph.t @@ -0,0 +1,31 @@ +#!./perl -w + +use Net::Config; +use Net::PH; + +unless(@{$NetConfig{ph_hosts}} && $NetConfig{test_hosts}) { + print "1..0\n"; + exit 0; +} + +print "1..5\n"; + +my $i = 1; + +$ph = Net::PH->new(Debug => 0) + or (print("not ok 1\n"), exit); + +print "ok 1\n"; + +$ph->fields or print "not "; +print "ok 2\n"; + +$ph->siteinfo or print "not "; +print "ok 3\n"; + +$ph->id or print "not "; +print "ok 4\n"; + +$ph->quit or print "not "; +print "ok 5\n"; + diff --git a/lib/Net/t/require.t b/lib/Net/t/require.t new file mode 100644 index 0000000..f9eba4d --- /dev/null +++ b/lib/Net/t/require.t @@ -0,0 +1,16 @@ + +print "1..11\n"; +my $i = 1; +eval { require Net::Config; } || print "not "; print "ok ",$i++,"\n"; +eval { require Net::Domain; } || print "not "; print "ok ",$i++,"\n"; +eval { require Net::Cmd; } || print "not "; print "ok ",$i++,"\n"; +eval { require Net::Netrc; } || print "not "; print "ok ",$i++,"\n"; +eval { require Net::FTP; } || print "not "; print "ok ",$i++,"\n"; +eval { require Net::SMTP; } || print "not "; print "ok ",$i++,"\n"; +eval { require Net::NNTP; } || print "not "; print "ok ",$i++,"\n"; +eval { require Net::SNPP; } || print "not "; print "ok ",$i++,"\n"; +eval { require Net::PH; } || print "not "; print "ok ",$i++,"\n"; +eval { require Net::POP3; } || print "not "; print "ok ",$i++,"\n"; +eval { require Net::Time; } || print "not "; print "ok ",$i++,"\n"; + + diff --git a/lib/Net/t/smtp.t b/lib/Net/t/smtp.t new file mode 100644 index 0000000..55607fe --- /dev/null +++ b/lib/Net/t/smtp.t @@ -0,0 +1,25 @@ +#!./perl -w + +use Net::Config; +use Net::SMTP; + +unless(@{$NetConfig{smtp_hosts}} && $NetConfig{test_hosts}) { + print "1..0\n"; + exit 0; +} + +print "1..3\n"; + +my $i = 1; + +$smtp = Net::SMTP->new(Debug => 0) + or (print("not ok 1\n"), exit); + +print "ok 1\n"; + +$smtp->domain or print "not "; +print "ok 2\n"; + +$smtp->quit or print "not "; +print "ok 3\n"; + diff --git a/utils.lst b/utils.lst index b4a839d..a5bb8bc 100644 --- a/utils.lst +++ b/utils.lst @@ -10,6 +10,7 @@ utils/c2ph # link = utils/pstruct utils/dprofpp utils/h2ph utils/h2xs +utils/libnetcfg utils/perlbug utils/perlcc utils/perldoc diff --git a/utils/Makefile b/utils/Makefile index ec26cd8..801b4a4 100644 --- a/utils/Makefile +++ b/utils/Makefile @@ -5,9 +5,9 @@ REALPERL = ../perl # Files to be built with variable substitution after miniperl is # available. Dependencies handled manually below (for now). -pl = c2ph.PL h2ph.PL h2xs.PL perlbug.PL perldoc.PL pl2pm.PL splain.PL perlcc.PL dprofpp.PL -plextract = c2ph h2ph h2xs perlbug perldoc pl2pm splain perlcc dprofpp -plextractexe = ./c2ph ./h2ph ./h2xs ./perlbug ./perldoc ./pl2pm ./splain ./perlcc ./dprofpp +pl = c2ph.PL h2ph.PL h2xs.PL perlbug.PL perldoc.PL pl2pm.PL splain.PL perlcc.PL dprofpp.PL libnetcfg.PL +plextract = c2ph h2ph h2xs perlbug perldoc pl2pm splain perlcc dprofpp libnetcfg +plextractexe = ./c2ph ./h2ph ./h2xs ./perlbug ./perldoc ./pl2pm ./splain ./perlcc ./dprofpp ./libnetcfg all: $(plextract) @@ -21,6 +21,7 @@ compile: all $(plextract) $(REALPERL) -I../lib perlcc splain -o splain.exe -v 10 -log ../compilelog; $(REALPERL) -I../lib perlcc perlcc -o perlcc.exe -v 10 -log ../compilelog; $(REALPERL) -I../lib perlcc dprofpp -o dprofpp.exe -v 10 -log ../compilelog; + $(REALPERL) -I../lib perlcc libnetcfg -o libnetcfg.exe -v 10 -log ../compilelog; $(plextract): $(PERL) -I../lib $@.PL @@ -43,6 +44,8 @@ perlcc: perlcc.PL ../config.sh dprofpp: dprofpp.PL ../config.sh +libnetcfg: libnetcfg.PL ../config.sh + clean: realclean: diff --git a/utils/libnetcfg.PL b/utils/libnetcfg.PL new file mode 100644 index 0000000..3418dd1 --- /dev/null +++ b/utils/libnetcfg.PL @@ -0,0 +1,642 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); +use Cwd; + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries. Thus you write +# $startperl +# to ensure Configure will look for $Config{startperl}. + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +my $origdir = cwd; +chdir dirname($0); +my $file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; + +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{startperl} + eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; +!GROK!THIS! + +# In the following, perl variables are not expanded during extraction. + +print OUT <<'!NO!SUBS!'; + +# $Id: Configure,v 1.8 1997/03/04 09:22:32 gbarr Exp $ + +use strict; +use IO::File; +use Getopt::Std; +use ExtUtils::MakeMaker qw(prompt); + +use vars qw($opt_d $opt_o); + +## +## +## + +my %cfg = (); +my @cfg = (); + +my($libnet_cfg,$msg,$ans,$def,$have_old); + +## +## +## + +sub valid_host +{ + my $h = shift; + + defined($h) && (($cfg{'test_exist'} == 0) || gethostbyname($h)); +} + +## +## +## + +sub test_hostnames (\@) +{ + my $hlist = shift; + my @h = (); + my $host; + my $err = 0; + + foreach $host (@$hlist) + { + if(valid_host($host)) + { + push(@h, $host); + next; + } + warn "Bad hostname: '$host'\n"; + $err++; + } + @$hlist = @h; + $err ? join(" ",@h) : undef; +} + +## +## +## + +sub Prompt +{ + my($prompt,$def) = @_; + + $def = "" unless defined $def; + + chomp($prompt); + + if($opt_d) + { + print $prompt,," [",$def,"]\n"; + return $def; + } + prompt($prompt,$def); +} + +## +## +## + +sub get_host_list +{ + my($prompt,$def) = @_; + + $def = join(" ",@$def) if ref($def); + + my @hosts; + + do + { + my $ans = Prompt($prompt,$def); + + $ans =~ s/(\A\s+|\s+\Z)//g; + + @hosts = split(/\s+/, $ans); + } + while(@hosts && defined($def = test_hostnames(@hosts))); + + \@hosts; +} + +## +## +## + +sub get_hostname +{ + my($prompt,$def) = @_; + + my $host; + + while(1) + { + my $ans = Prompt($prompt,$def); + $host = ($ans =~ /(\S*)/)[0]; + last + if(!length($host) || valid_host($host)); + + $def ="" + if $def eq $host; + + print <<"EDQ"; + +*** ERROR: + Hostname `$host' does not seem to exist, please enter again + or a single space to clear any default + +EDQ + } + + length $host + ? $host + : undef; +} + +## +## +## + +sub get_bool ($$) +{ + my($prompt,$def) = @_; + + chomp($prompt); + + my $val = Prompt($prompt,$def ? "yes" : "no"); + + $val =~ /^y/i ? 1 : 0; +} + +## +## +## + +sub get_netmask ($$) +{ + my($prompt,$def) = @_; + + chomp($prompt); + + my %list; + @list{@$def} = (); + +MASK: + while(1) { + my $bad = 0; + my $ans = Prompt($prompt) or last; + + if($ans eq '*') { + %list = (); + next; + } + + if($ans eq '=') { + print "\n",( %list ? join("\n", sort keys %list) : 'none'),"\n\n"; + next; + } + + unless ($ans =~ m{^\s*(?:(-?\s*)(\d+(?:\.\d+){0,3})/(\d+))}) { + warn "Bad netmask '$ans'\n"; + next; + } + + my($remove,$bits,@ip) = ($1,$3,split(/\./, $2),0,0,0); + if ( $ip[0] < 1 || $bits < 1 || $bits > 32) { + warn "Bad netmask '$ans'\n"; + next MASK; + } + foreach my $byte (@ip) { + if ( $byte > 255 ) { + warn "Bad netmask '$ans'\n"; + next MASK; + } + } + + my $mask = sprintf("%d.%d.%d.%d/%d",@ip[0..3],$bits); + + if ($remove) { + delete $list{$mask}; + } + else { + $list{$mask} = 1; + } + + } + + [ keys %list ]; +} + +## +## +## + +sub default_hostname +{ + my $host; + my @host; + + foreach $host (@_) + { + if(defined($host) && valid_host($host)) + { + return $host + unless wantarray; + push(@host,$host); + } + } + + return wantarray ? @host : undef; +} + +## +## +## + +getopts('do:'); + +$libnet_cfg = "libnet.cfg" + unless(defined($libnet_cfg = $opt_o)); + +my %oldcfg = (); + +$Net::Config::CONFIGURE = 1; # Suppress load of user overrides +if( -f $libnet_cfg ) + { + %oldcfg = ( %{ do $libnet_cfg } ); + } +elsif (eval { require Net::Config }) + { + $have_old = 1; + %oldcfg = %Net::Config::NetConfig; + } + +map { $cfg{lc $_} = $cfg{$_}; delete $cfg{$_} if /[A-Z]/ } keys %cfg; + +$oldcfg{'test_exist'} = 1 unless exists $oldcfg{'test_exist'}; +$oldcfg{'test_hosts'} = 1 unless exists $oldcfg{'test_hosts'}; + +#--------------------------------------------------------------------------- + +if($have_old && !$opt_d) + { + $msg = <. To accept the +default, hit + +EDQ + +$msg = 'Enter a list of available NNTP hosts :'; + +$def = $oldcfg{'nntp_hosts'} || + [ default_hostname($ENV{NNTPSERVER},$ENV{NEWSHOST},'news') ]; + +$cfg{'nntp_hosts'} = get_host_list($msg,$def); + +#--------------------------------------------------------------------------- + +$msg = 'Enter a list of available SMTP hosts :'; + +$def = $oldcfg{'smtp_hosts'} || + [ default_hostname(split(/:/,$ENV{SMTPHOSTS} || ""), 'mailhost') ]; + +$cfg{'smtp_hosts'} = get_host_list($msg,$def); + +#--------------------------------------------------------------------------- + +$msg = 'Enter a list of available POP3 hosts :'; + +$def = $oldcfg{'pop3_hosts'} || []; + +$cfg{'pop3_hosts'} = get_host_list($msg,$def); + +#--------------------------------------------------------------------------- + +$msg = 'Enter a list of available SNPP hosts :'; + +$def = $oldcfg{'snpp_hosts'} || []; + +$cfg{'snpp_hosts'} = get_host_list($msg,$def); + +#--------------------------------------------------------------------------- + +$msg = 'Enter a list of available PH Hosts :' ; + +$def = $oldcfg{'ph_hosts'} || + [ default_hostname('dirserv') ]; + +$cfg{'ph_hosts'} = get_host_list($msg,$def); + +#--------------------------------------------------------------------------- + +$msg = 'Enter a list of available TIME Hosts :' ; + +$def = $oldcfg{'time_hosts'} || []; + +$cfg{'time_hosts'} = get_host_list($msg,$def); + +#--------------------------------------------------------------------------- + +$msg = 'Enter a list of available DAYTIME Hosts :' ; + +$def = $oldcfg{'daytime_hosts'} || $oldcfg{'time_hosts'}; + +$cfg{'daytime_hosts'} = get_host_list($msg,$def); + +#--------------------------------------------------------------------------- + +$msg = < external user & password +fwuser/fwpass => firewall user & password + +0) None +1) ----------------------- + USER user@remote.host + PASS pass +2) ----------------------- + USER fwuser + PASS fwpass + USER user@remote.host + PASS pass +3) ----------------------- + USER fwuser + PASS fwpass + SITE remote.site + USER user + PASS pass +4) ----------------------- + USER fwuser + PASS fwpass + OPEN remote.site + USER user + PASS pass +5) ----------------------- + USER user@fwuser@remote.site + PASS pass@fwpass +6) ----------------------- + USER fwuser@remote.site + PASS fwpass + USER user + PASS pass +7) ----------------------- + USER user@remote.host + PASS pass + AUTH fwuser + RESP fwpass + +Choice: +EDQ + $def = exists $oldcfg{'ftp_firewall_type'} ? $oldcfg{'ftp_firewall_type'} : 1; + $ans = Prompt($msg,$def); + $cfg{'ftp_firewall_type'} = 0+$ans; + $def = $oldcfg{'ftp_firewall'} || $ENV{FTP_FIREWALL}; + + $cfg{'ftp_firewall'} = get_hostname("FTP proxy hostname :", $def); +} +else { + delete $cfg{'ftp_firewall'}; +} + + +#--------------------------------------------------------------------------- + +if (defined $cfg{'ftp_firewall'}) + { + print <new($libnet_cfg, "w") or + die "Cannot create `$libnet_cfg': $!"; + +print "Writing $libnet_cfg\n"; + +print $fh "{\n"; + +my $key; +foreach $key (keys %cfg) { + my $val = $cfg{$key}; + if(!defined($val)) { + $val = "undef"; + } + elsif(ref($val)) { + $val = '[' . join(",", + map { + my $v = "undef"; + if(defined $_) { + ($v = $_) =~ s/'/\'/sog; + $v = "'" . $v . "'"; + } + $v; + } @$val ) . ']'; + } + else { + $val =~ s/'/\'/sog; + $val = "'" . $val . "'" if $val =~ /\D/; + } + print $fh "\t'",$key,"' => ",$val,",\n"; +} + +print $fh "}\n"; + +$fh->close; + +############################################################################ +############################################################################ + +exit 0; +!NO!SUBS! + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; +chdir $origdir;