diff options
Diffstat (limited to 'lib/Net')
| -rw-r--r-- | lib/Net/Cmd.pm | 529 | ||||
| -rw-r--r-- | lib/Net/Domain.pm | 245 | ||||
| -rw-r--r-- | lib/Net/DummyInetd.pm | 156 | ||||
| -rw-r--r-- | lib/Net/FTP.pm | 1391 | ||||
| -rw-r--r-- | lib/Net/NNTP.pm | 996 | ||||
| -rw-r--r-- | lib/Net/Netrc.pm | 316 | ||||
| -rw-r--r-- | lib/Net/POP3.pm | 402 | ||||
| -rw-r--r-- | lib/Net/SMTP.pm | 526 | ||||
| -rw-r--r-- | lib/Net/SNPP.pm | 389 | ||||
| -rw-r--r-- | lib/Net/Telnet.pm | 250 | ||||
| -rw-r--r-- | lib/Net/Time.pm | 112 |
11 files changed, 0 insertions, 5312 deletions
diff --git a/lib/Net/Cmd.pm b/lib/Net/Cmd.pm deleted file mode 100644 index 6697ad1b80..0000000000 --- a/lib/Net/Cmd.pm +++ /dev/null @@ -1,529 +0,0 @@ -# Net::Cmd.pm -# -# Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights -# reserved. This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package Net::Cmd; - -=head1 NAME - -Net::Cmd - Network Command class (as used by FTP, SMTP etc) - -=head1 SYNOPSIS - - use Net::Cmd; - - @ISA = qw(Net::Cmd); - -=head1 DESCRIPTION - -C<Net::Cmd> is a collection of methods that can be inherited by a sub class -of C<IO::Handle>. These methods implement the functionality required for a -command based protocol, for example FTP and SMTP. - -=head1 USER METHODS - -These methods provide a user interface to the C<Net::Cmd> object. - -=over 4 - -=item debug ( VALUE ) - -Set the level of debug information for this object. If C<VALUE> is not given -then the current state is returned. Otherwise the state is changed to -C<VALUE> and the previous state returned. If C<VALUE> is C<undef> then -the debug level will be set to the default debug level for the class. - -This method can also be called as a I<static> method to set/get the default -debug level for a given class. - -=item message () - -Returns the text message returned from the last command - -=item code () - -Returns the 3-digit code from the last command. If a command is pending -then the value 0 is returned - -=item ok () - -Returns non-zero if the last code value was greater than zero and -less than 400. This holds true for most command servers. Servers -where this does not hold may override this method. - -=item status () - -Returns the most significant digit of the current status code. If a command -is pending then C<CMD_PENDING> is returned. - -=item datasend ( DATA ) - -Send data to the remote server, delimiting lines with CRLF. Any lin starting -with a '.' will be prefixed with another '.'. - -=item dataend () - -End the sending of data to the remote server. This is done by ensureing that -the data already sent ends with CRLF then sending '.CRLF' to end the -transmission. Once this data has been sent C<dataend> calls C<response> and -returns true if C<response> returns CMD_OK. - -=back - -=head1 CLASS METHODS - -These methods are not intended to be called by the user, but used or -over-ridden by a sub-class of C<Net::Cmd> - -=over 4 - -=item debug_print ( DIR, TEXT ) - -Print debugging information. C<DIR> denotes the direction I<true> being -data being sent to the server. Calls C<debug_text> before printing to -STDERR. - -=item debug_text ( TEXT ) - -This method is called to print debugging information. TEXT is -the text being sent. The method should return the text to be printed - -This is primarily meant for the use of modules such as FTP where passwords -are sent, but we do not want to display them in the debugging information. - -=item command ( CMD [, ARGS, ... ]) - -Send a command to the command server. All arguments a first joined with -a space character and CRLF is appended, this string is then sent to the -command server. - -Returns undef upon failure - -=item unsupported () - -Sets the status code to 580 and the response text to 'Unsupported command'. -Returns zero. - -=item responce () - -Obtain a responce from the server. Upon success the most significant digit -of the status code is returned. Upon failure, timeout etc., I<undef> is -returned. - -=item parse_response ( TEXT ) - -This method is called by C<response> as a method with one argument. It should -return an array of 2 values, the 3-digit status code and a flag which is true -when this is part of a multi-line response and this line is not the list. - -=item getline () - -Retreive one line, delimited by CRLF, from the remote server. Returns I<undef> -upon failure. - -B<NOTE>: If you do use this method for any reason, please remember to add -some C<debug_print> calls into your method. - -=item ungetline ( TEXT ) - -Unget a line of text from the server. - -=item read_until_dot () - -Read data from the remote server until a line consisting of a single '.'. -Any lines starting with '..' will have one of the '.'s removed. - -Returns a reference to a list containing the lines, or I<undef> upon failure. - -=back - -=head1 EXPORTS - -C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>, -C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR> ,correspond to possible results -of C<response> and C<status>. The sixth is C<CMD_PENDING>. - -=head1 AUTHOR - -Graham Barr <Graham.Barr@tiuk.ti.com> - -=head1 REVISION - -$Revision: 2.2 $ - -=head1 COPYRIGHT - -Copyright (c) 1995 Graham Barr. All rights reserved. This program is free -software; you can redistribute it and/or modify it under the same terms -as Perl itself. - -=cut - -require 5.001; -require Exporter; - -use strict; -use vars qw(@ISA @EXPORT $VERSION); -use Carp; - -$VERSION = sprintf("%d.%02d", q$Revision: 2.2 $ =~ /(\d+)\.(\d+)/); -@ISA = qw(Exporter); -@EXPORT = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING); - -sub CMD_INFO { 1 } -sub CMD_OK { 2 } -sub CMD_MORE { 3 } -sub CMD_REJECT { 4 } -sub CMD_ERROR { 5 } -sub CMD_PENDING { 0 } - -my %debug = (); - -sub _print_isa -{ - no strict qw(refs); - - my $pkg = shift; - my $cmd = $pkg; - - $debug{$pkg} ||= 0; - - my %done = (); - my @do = ($pkg); - my %spc = ( $pkg , ""); - - print STDERR "\n"; - while ($pkg = shift @do) - { - next if defined $done{$pkg}; - - $done{$pkg} = 1; - - my $v = defined ${"${pkg}::VERSION"} - ? "(" . ${"${pkg}::VERSION"} . ")" - : ""; - - my $spc = $spc{$pkg}; - print STDERR "$cmd: ${spc}${pkg}${v}\n"; - - if(defined @{"${pkg}::ISA"}) - { - @spc{@{"${pkg}::ISA"}} = (" " . $spc{$pkg}) x @{"${pkg}::ISA"}; - unshift(@do, @{"${pkg}::ISA"}); - } - } - - print STDERR "\n"; -} - -sub debug -{ - @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])'; - - my($cmd,$level) = @_; - my $pkg = ref($cmd) || $cmd; - my $oldval = 0; - - if(ref($cmd)) - { - $oldval = ${*$cmd}{'net_cmd_debug'} || 0; - } - else - { - $oldval = $debug{$pkg} || 0; - } - - return $oldval - unless @_ == 2; - - $level = $debug{$pkg} || 0 - unless defined $level; - - _print_isa($pkg) - if($level && !exists $debug{$pkg}); - - if(ref($cmd)) - { - ${*$cmd}{'net_cmd_debug'} = $level; - } - else - { - $debug{$pkg} = $level; - } - - $oldval; -} - -sub message -{ - @_ == 1 or croak 'usage: $obj->message()'; - - my $cmd = shift; - - wantarray ? @{${*$cmd}{'net_cmd_resp'}} - : join("", @{${*$cmd}{'net_cmd_resp'}}); -} - -sub debug_text { $_[2] } - -sub debug_print -{ - my($cmd,$out,$text) = @_; - print STDERR $cmd,($out ? '>>> ' : '<<< '), $cmd->debug_text($out,$text); -} - -sub code -{ - @_ == 1 or croak 'usage: $obj->code()'; - - my $cmd = shift; - - ${*$cmd}{'net_cmd_code'}; -} - -sub status -{ - @_ == 1 or croak 'usage: $obj->code()'; - - my $cmd = shift; - - substr(${*$cmd}{'net_cmd_code'},0,1); -} - -sub set_status -{ - @_ == 3 or croak 'usage: $obj->set_status( CODE, MESSAGE)'; - - my $cmd = shift; - - (${*$cmd}{'net_cmd_code'},${*$cmd}{'net_cmd_resp'}) = @_; - - 1; -} - -sub command -{ - my $cmd = shift; - - $cmd->dataend() - if(exists ${*$cmd}{'net_cmd_lastch'}); - - if (scalar(@_)) - { - my $str = join(" ", @_) . "\015\012"; - - syswrite($cmd,$str,length $str); - - $cmd->debug_print(1,$str) - if($cmd->debug); - - ${*$cmd}{'net_cmd_resp'} = []; # the responce - ${*$cmd}{'net_cmd_code'} = "000"; # Made this one up :-) - } - - $cmd; -} - -sub ok -{ - @_ == 1 or croak 'usage: $obj->ok()'; - - my $code = $_[0]->code; - 0 < $code && $code < 400; -} - -sub unsupported -{ - my $cmd = shift; - - ${*$cmd}{'net_cmd_resp'} = [ 'Unsupported command' ]; - ${*$cmd}{'net_cmd_code'} = 580; - 0; -} - -sub getline -{ - my $cmd = shift; - - ${*$cmd}{'net_cmd_lines'} ||= []; - - return shift @{${*$cmd}{'net_cmd_lines'}} - if scalar(@{${*$cmd}{'net_cmd_lines'}}); - - my $partial = ${*$cmd}{'net_cmd_partial'} || ""; - - my $rin = ""; - vec($rin,fileno($cmd),1) = 1; - - my $buf; - - until(scalar(@{${*$cmd}{'net_cmd_lines'}})) - { - my $timeout = $cmd->timeout || undef; - my $rout; - if (select($rout=$rin, undef, undef, $timeout)) - { - unless (sysread($cmd, $buf="", 1024)) - { - carp ref($cmd) . ": Unexpected EOF on command channel"; - return undef; - } - - substr($buf,0,0) = $partial; ## prepend from last sysread - - my @buf = split(/\015?\012/, $buf); ## break into lines - - $partial = length($buf) == 0 || substr($buf, -1, 1) eq "\012" - ? '' - : pop(@buf); - - map { $_ .= "\n" } @buf; - - push(@{${*$cmd}{'net_cmd_lines'}},@buf); - - } - else - { - carp "$cmd: Timeout" if($cmd->debug); - return undef; - } - } - - ${*$cmd}{'net_cmd_partial'} = $partial; - - shift @{${*$cmd}{'net_cmd_lines'}}; -} - -sub ungetline -{ - my($cmd,$str) = @_; - - ${*$cmd}{'net_cmd_lines'} ||= []; - unshift(@{${*$cmd}{'net_cmd_lines'}}, $str); -} - -sub parse_response -{ - return () - unless $_[1] =~ s/^(\d\d\d)(.)//o; - ($1, $2 eq "-"); -} - -sub response -{ - my $cmd = shift; - my($code,$more) = (undef) x 2; - - ${*$cmd}{'net_cmd_resp'} ||= []; - - while(1) - { - my $str = $cmd->getline(); - - $cmd->debug_print(0,$str) - if ($cmd->debug); - - if($str =~ s/^(\d\d\d)(.?)//o) - { - ($code,$more) = ($1,$2 && $2 eq "-"); - } - elsif(!$more) - { - $cmd->ungetline($str); - last; - } - - push(@{${*$cmd}{'net_cmd_resp'}},$str); - - last unless($more); - } - - ${*$cmd}{'net_cmd_code'} = $code; - - substr($code,0,1); -} - -sub read_until_dot -{ - my $cmd = shift; - my $arr = []; - - while(1) - { - my $str = $cmd->getline(); - - $cmd->debug_print(0,$str) - if ($cmd->debug & 4); - - last if($str =~ /^\.\n/o); - - $str =~ s/^\.\././o; - - push(@$arr,$str); - } - - $arr; -} - -sub datasend -{ - my $cmd = shift; - my $lch = exists ${*$cmd}{'net_cmd_lastch'} ? ${*$cmd}{'net_cmd_lastch'} - : " "; - my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_; - my $line = $lch . join("" ,@$arr); - - ${*$cmd}{'net_cmd_lastch'} = substr($line,-1,1); - - return 1 - unless length($line) > 1; - - if($cmd->debug) - { - my $ln = substr($line,1); - my $b = "$cmd>>> "; - print STDERR $b,join("\n$b",split(/\n/,$ln)),"\n"; - } - - $line =~ s/\n/\015\012/sgo; - $line =~ s/(?=\012\.)/./sgo; - - my $len = length($line) - 1; - - return $len < 1 || - syswrite($cmd, $line, $len, 1) == $len; -} - -sub dataend -{ - my $cmd = shift; - - return 1 - unless(exists ${*$cmd}{'net_cmd_lastch'}); - - if(${*$cmd}{'net_cmd_lastch'} eq "\015") - { - syswrite($cmd,"\012",1); - print STDERR "\n" - if($cmd->debug); - } - elsif(${*$cmd}{'net_cmd_lastch'} ne "\012") - { - syswrite($cmd,"\015\012",2); - print STDERR "\n" - if($cmd->debug); - } - - print STDERR "$cmd>>> .\n" - if($cmd->debug); - - syswrite($cmd,".\015\012",3); - - delete ${*$cmd}{'net_cmd_lastch'}; - - $cmd->response() == CMD_OK; -} - -1; diff --git a/lib/Net/Domain.pm b/lib/Net/Domain.pm deleted file mode 100644 index 558b7f3111..0000000000 --- a/lib/Net/Domain.pm +++ /dev/null @@ -1,245 +0,0 @@ -# Net::Domain.pm -# -# Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights -# reserved. This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package Net::Domain; - -=head1 NAME - -Net::Domain - Attempt to evaluate the current host's internet name and domain - -=head1 SYNOPSIS - - use Net::Domain qw(hostname hostfqdn hostdomain); - -=head1 DESCRIPTION - -Using various methods B<attempt> to find the Fully Qualified Domain Name (FQDN) -of the current host. From this determine the host-name and the host-domain. - -Each of the functions will return I<undef> if the FQDN cannot be determined. - -=over 4 - -=item hostfqdn () - -Identify and return the FQDN of the current host. - -=item hostname () - -Returns the smallest part of the FQDN which can be used to identify the host. - -=item hostdomain () - -Returns the remainder of the FQDN after the I<hostname> has been removed. - -=back - -=head1 AUTHOR - -Graham Barr <bodg@tiuk.ti.com>. -Adapted from Sys::Hostname by David Sundstrom <sunds@asictest.sc.ti.com> - -=head1 REVISION - -$Revision: 2.0 $ - -=head1 COPYRIGHT - -Copyright (c) 1995 Graham Barr. All rights reserved. -This library is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut - -require Exporter; - -use Carp; -use strict; -use vars qw($VERSION @ISA @EXPORT_OK); - -@ISA = qw(Exporter); -@EXPORT_OK = qw(hostname hostdomain hostfqdn domainname); - -$VERSION = sprintf("%d.%02d", q$Revision: 2.0 $ =~ /(\d+)\.(\d+)/); - -my($host,$domain,$fqdn) = (undef,undef,undef); - -# Try every conceivable way to get hostname. - -sub _hostname { - - # method 1 - we already know it - return $host - if(defined $host); - - # method 2 - syscall is preferred since it avoids tainting problems - eval { - { - package main; - require "syscall.ph"; - } - my $tmp = "\0" x 65; ## preload scalar - $host = (syscall(&main::SYS_gethostname, $tmp, 65) == 0) ? $tmp : undef; - } - - - # method 3 - trusty old hostname command - || eval { - chop($host = `(hostname) 2>/dev/null`); # BSD'ish - } - - # method 4 - sysV/POSIX uname command (may truncate) - || eval { - chop($host = `uname -n 2>/dev/null`); ## SYSV'ish && POSIX'ish - } - - - # method 5 - Apollo pre-SR10 - || eval { - $host = (split(/[:\. ]/,`/com/host`,6))[0]; - } - - || eval { - $host = ""; - }; - - # remove garbage - $host =~ s/[\0\r\n]+//go; - $host =~ s/(\A\.+|\.+\Z)//go; - $host =~ s/\.\.+/\./go; - - $host; -} - -sub _hostdomain { - - # method 1 - we already know it - return $domain - if(defined $domain); - - # method 2 - just try hostname and system calls - - my $host = _hostname(); - my($dom,$site,@hosts); - local($_); - - @hosts = ($host,"localhost"); - - unless($host =~ /\./) { - chop($dom = `domainname 2>/dev/null`); - unshift(@hosts, "$host.$dom") - if (defined $dom && $dom ne ""); - } - - # Attempt to locate FQDN - - foreach (@hosts) { - my @info = gethostbyname($_); - - next unless @info; - - # look at real name & aliases - foreach $site ($info[0], split(/ /,$info[1])) { - if(rindex($site,".") > 0) { - - # Extract domain from FQDN - - ($domain = $site) =~ s/\A[^\.]+\.//; - return $domain; - } - } - } - - # try looking in /etc/resolv.conf - - local *RES; - - if(open(RES,"/etc/resolv.conf")) { - while(<RES>) { - $domain = $1 - if(/\A\s*(?:domain|search)\s+(\S+)/); - } - close(RES); - - return $domain - if(defined $domain); - } - - # Look for environment variable - - $domain ||= $ENV{DOMAIN} || undef; - - if(defined $domain) { - $domain =~ s/[\r\n\0]+//g; - $domain =~ s/(\A\.+|\.+\Z)//g; - $domain =~ s/\.\.+/\./g; - } - - $domain; -} - -sub domainname { - - return $fqdn - if(defined $fqdn); - - _hostname(); - _hostdomain(); - - my @host = split(/\./, $host); - my @domain = split(/\./, $domain); - my @fqdn = (); - - # Determine from @host & @domain the FQDN - - my @d = @domain; - -LOOP: - while(1) { - my @h = @host; - while(@h) { - my $tmp = join(".",@h,@d); - if((gethostbyname($tmp))[0]) { - @fqdn = (@h,@d); - $fqdn = $tmp; - last LOOP; - } - pop @h; - } - last unless shift @d; - } - - if(@fqdn) { - $host = shift @fqdn; - until((gethostbyname($host))[0]) { - $host .= "." . shift @fqdn; - } - $domain = join(".", @fqdn); - } - else { - undef $host; - undef $domain; - undef $fqdn; - } - - $fqdn; -} - -sub hostfqdn { domainname() } - -sub hostname { - domainname() - unless(defined $host); - return $host; -} - -sub hostdomain { - domainname() - unless(defined $domain); - return $domain; -} - -1; # Keep require happy diff --git a/lib/Net/DummyInetd.pm b/lib/Net/DummyInetd.pm deleted file mode 100644 index 8dddc901e6..0000000000 --- a/lib/Net/DummyInetd.pm +++ /dev/null @@ -1,156 +0,0 @@ -# Net::DummyInetd.pm -# -# Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights -# reserved. This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package Net::DummyInetd; - -=head1 NAME - -Net::DummyInetd - A dummy Inetd server - -=head1 SYNOPSIS - - use Net::DummyInetd; - use Net::SMTP; - - $inetd = new Net::DummyInetd qw(/usr/lib/sendmail -ba -bs); - - $smtp = Net::SMTP->new('localhost', Port => $inetd->port); - -=head1 DESCRIPTION - -C<Net::DummyInetd> is just what it's name says, it is a dummy inetd server. -Creation of a C<Net::DummyInetd> will cause a child process to be spawned off -which will listen to a socket. When a connection arrives on this socket -the specified command is fork'd and exec'd with STDIN and STDOUT file -descriptors duplicated to the new socket. - -This package was added as an example of how to use C<Net::SMTP> to connect -to a C<sendmail> process, which is not the default, via SIDIN and STDOUT. -A C<Net::Inetd> package will be avaliable in the next release of C<libnet> - -=head1 CONSTRUCTOR - -=over 4 - -=item new ( CMD ) - -Creates a new object and spawns a child process which listens to a socket. -C<CMD> is a list, which will be passed to C<exec> when a new process needs -to be created. - -=back - -=head1 METHODS - -=over 4 - -=item port - -Returns the port number on which the I<DummyInet> object is listening - -=back - -=head1 AUTHOR - -Graham Barr <Graham.Barr@tiuk.ti.com> - -=head1 REVISION - -$Revision: 1.2 $ - -The VERSION is derived from the revision by changing each number after the -first dot into a 2 digit number so - - Revision 1.8 => VERSION 1.08 - Revision 1.2.3 => VERSION 1.0203 - -=head1 COPYRIGHT - -Copyright (c) 1995 Graham Barr. All rights reserved. This program is free -software; you can redistribute it and/or modify it under the same terms -as Perl itself. - -=cut - -require 5.002; - -use IO::Handle; -use IO::Socket; -use strict; -use vars qw($VERSION); -use Carp; - -$VERSION = do{my @r=(q$Revision: 1.2 $=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r}; - - -sub _process -{ - my $listen = shift; - my @cmd = @_; - my $vec = ''; - my $r; - - vec($vec,fileno($listen),1) = 1; - - while(select($r=$vec,undef,undef,undef)) - { - my $sock = $listen->accept; - my $pid; - - if($pid = fork()) - { - sleep 1; - close($sock); - } - elsif(defined $pid) - { - my $x = IO::Handle->new_from_fd($sock,"r"); - open(STDIN,"<&=".fileno($x)) || die "$! $@"; - close($x); - - my $y = IO::Handle->new_from_fd($sock,"w"); - open(STDOUT,">&=".fileno($y)) || die "$! $@"; - close($y); - - close($sock); - exec(@cmd) || carp "$! $@"; - } - else - { - close($sock); - carp $!; - } - } - exit -1; -} - -sub new -{ - my $self = shift; - my $type = ref($self) || $self; - - my $listen = IO::Socket::INET->new(Listen => 5, Proto => 'tcp'); - my $pid; - - return bless [ $listen->sockport, $pid ] - if($pid = fork()); - - _process($listen,@_); -} - -sub port -{ - my $self = shift; - $self->[0]; -} - -sub DESTROY -{ - my $self = shift; - kill 9, $self->[1]; -} - -1; diff --git a/lib/Net/FTP.pm b/lib/Net/FTP.pm deleted file mode 100644 index d635f000bc..0000000000 --- a/lib/Net/FTP.pm +++ /dev/null @@ -1,1391 +0,0 @@ -# Net::FTP.pm -# -# Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights -# reserved. This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package Net::FTP; - -=head1 NAME - -Net::FTP - FTP Client class - -=head1 SYNOPSIS - - use Net::FTP; - - $ftp = Net::FTP->new("some.host.name"); - $ftp->login("anonymous","me@here.there"); - $ftp->cwd("/pub"); - $ftp->get("that.file"); - $ftp->quit; - -=head1 DESCRIPTION - -C<Net::FTP> is a class implementing a simple FTP client in Perl as described -in RFC959 - -C<Net::FTP> provides methods that will perform various operations. These methods -could be split into groups depending the level of interface the user requires. - -=head1 CONSTRUCTOR - -=over 4 - -=item new (HOST [,OPTIONS]) - -This is the constructor for a new Net::SMTP object. C<HOST> is the -name of the remote host to which a FTP connection is required. - -C<OPTIONS> are passed in a hash like fasion, using key and value pairs. -Possible options are: - -B<Firewall> - The name of a machine which acts as a FTP firewall. This can be -overridden by an environment variable C<FTP_FIREWALL>. If specified, and the -given host cannot be directly connected to, then the -connection is made to the firwall machine and the string C<@hostname> is -appended to the login identifier. - -B<Port> - The port number to connect to on the remote machine for the -FTP connection - -B<Timeout> - Set a timeout value (defaults to 120) - -B<Debug> - Debug level - -B<Passive> - If set to I<true> then all data transfers will be done using -passive mode. This is required for some I<dumb> servers. - -=back - -=head1 METHODS - -Unless otherwise stated all methods return either a I<true> or I<false> -value, with I<true> meaning that the operation was a success. When a method -states that it returns a value, falure will be returned as I<undef> or an -empty list. - -=over 4 - -=item login ([LOGIN [,PASSWORD [, ACCOUNT] ] ]) - -Log into the remote FTP server with the given login information. If -no arguments are given then the C<Net::FTP> uses the C<Net::Netrc> -package to lookup the login information for the connected host. -If no information is found then a login of I<anonymous> is used. -If no password is given and the login is I<anonymous> then the users -Email address will be used for a password. - -If the connection is via a firewall then the C<authorize> method will -be called with no arguments. - -=item authorize ( [AUTH [, RESP]]) - -This is a protocol used by some firewall ftp proxies. It is used -to authorise the user to send data out. If both arguments are not specified -then C<authorize> uses C<Net::Netrc> to do a lookup. - -=item type (TYPE [, ARGS]) - -This method will send the TYPE command to the remote FTP server -to change the type of data transfer. The return value is the previous -value. - -=item ascii ([ARGS]) binary([ARGS]) ebcdic([ARGS]) byte([ARGS]) - -Synonyms for C<type> with the first arguments set correctly - -B<NOTE> ebcdic and byte are not fully supported. - -=item rename ( OLDNAME, NEWNAME ) - -Rename a file on the remote FTP server from C<OLDNAME> to C<NEWNAME>. This -is done by sending the RNFR and RNTO commands. - -=item delete ( FILENAME ) - -Send a request to the server to delete C<FILENAME>. - -=item cwd ( [ DIR ] ) - -Change the current working directory to C<DIR>, or / if not given. - -=item cdup () - -Change directory to the parent of the current directory. - -=item pwd () - -Returns the full pathname of the current directory. - -=item rmdir ( DIR ) - -Remove the directory with the name C<DIR>. - -=item mkdir ( DIR [, RECURSE ]) - -Create a new directory with the name C<DIR>. If C<RECURSE> is I<true> then -C<mkdir> will attempt to create all the directories in the given path. - -Returns the full pathname to the new directory. - -=item ls ( [ DIR ] ) - -Get a directory listing of C<DIR>, or the current directory. - -Returns a reference to a list of lines returned from the server. - -=item dir ( [ DIR ] ) - -Get a directory listing of C<DIR>, or the current directory in long format. - -Returns a reference to a list of lines returned from the server. - -=item get ( REMOTE_FILE [, LOCAL_FILE ] ) - -Get C<REMOTE_FILE> from the server and store locally. C<LOCAL_FILE> may be -a filename or a filehandle. If not specified the the file will be stored in -the current directory with the same leafname as the remote file. - -Returns C<LOCAL_FILE>, or the generated local file name if C<LOCAL_FILE> -is not given. - -=item put ( LOCAL_FILE [, REMOTE_FILE ] ) - -Put a file on the remote server. C<LOCAL_FILE> may be a name or a filehandle. -If C<LOCAL_FILE> is a filehandle then C<REMOTE_FILE> must be specified. If -C<REMOTE_FILE> is not specified then the file will be stored in the current -directory with the same leafname as C<LOCAL_FILE>. - -Returns C<REMOTE_FILE>, or the generated remote filename if C<REMOTE_FILE> -is not given. - -=item put_unique ( LOCAL_FILE [, REMOTE_FILE ] ) - -Same as put but uses the C<STOU> command. - -Returns the name of the file on the server. - -=item append ( LOCAL_FILE [, REMOTE_FILE ] ) - -Same as put but appends to the file on the remote server. - -Returns C<REMOTE_FILE>, or the generated remote filename if C<REMOTE_FILE> -is not given. - -=item unique_name () - -Returns the name of the last file stored on the server using the -C<STOU> command. - -=item mdtm ( FILE ) - -Returns the I<modification time> of the given file - -=item size ( FILE ) - -Returns the size in bytes for the given file. - -=back - -The following methods can return different results depending on -how they are called. If the user explicitly calls either -of the C<pasv> or C<port> methods then these methods will -return a I<true> or I<false> value. If the user does not -call either of these methods then the result will be a -reference to a C<Net::FTP::dataconn> based object. - -=over 4 - -=item nlst ( [ DIR ] ) - -Send a C<NLST> command to the server, with an optional parameter. - -=item list ( [ DIR ] ) - -Same as C<nlst> but using the C<LIST> command - -=item retr ( FILE ) - -Begin the retrieval of a file called C<FILE> from the remote server. - -=item stor ( FILE ) - -Tell the server that you wish to store a file. C<FILE> is the -name of the new file that should be created. - -=item stou ( FILE ) - -Same as C<stor> but using the C<STOU> command. The name of the unique -file which was created on the server will be avalaliable via the C<unique_name> -method after the data connection has been closed. - -=item appe ( FILE ) - -Tell the server that we want to append some data to the end of a file -called C<FILE>. If this file does not exist then create it. - -=back - -If for some reason you want to have complete control over the data connection, -this includes generating it and calling the C<response> method when required, -then the user can use these methods to do so. - -However calling these methods only affects the use of the methods above that -can return a data connection. They have no effect on methods C<get>, C<put>, -C<put_unique> and those that do not require data connections. - -=over 4 - -=item port ( [ PORT ] ) - -Send a C<PORT> command to the server. If C<PORT> is specified then it is sent -to the server. If not the a listen socket is created and the correct information -sent to the server. - -=item pasv () - -Tell the server to go into passive mode. Returns the text that represents the -port on which the server is listening, this text is in a suitable form to -sent to another ftp server using the C<port> method. - -=back - -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<DEST_FILE> is omitted then the leaf name of C<SRC_FILE> will be used. - -=item pasv_wait ( NON_PASV_SERVER ) - -This method can be used to wait for a transfer to complete between a passive -server and a non-passive server. The method should be called on the passive -server with the C<Net::FTP> object for the non-passive server passed as an -argument. - -=item abort () - -Abort the current data transfer. - -=item quit () - -Send the QUIT command to the remote FTP server and close the socket connection. - -=back - -=head2 Methods for the adventurous - -C<Net::FTP> inherits from C<Net::Cmd> so methods defined in C<Net::Cmd> may -be used to send commands to the remote FTP server. - -=over 4 - -=item quot (CMD [,ARGS]) - -Send a command, that Net::FTP does not directly support, to the remote -server and wait for a response. - -Returns most significant digit of the response code. - -B<WARNING> This call should only be used on commands that do not require -data connections. Misuse of this method can hang the connection. - -=back - -=head1 THE dataconn CLASS - -Some of the methods defined in C<Net::FTP> return an object which will -be derived from this class.The dataconn class itself is derived from -the C<IO::Socket::INET> class, so any normal IO operations can be performed. -However the following methods are defined in the dataconn class and IO should -be performed using these. - -=over 4 - -=item read ( BUFFER, SIZE [, TIMEOUT ] ) - -Read C<SIZE> bytes of data from the server and place it into C<BUFFER>, also -performing any <CRLF> translation necessary. C<TIMEOUT> is optional, if not -given the the timeout value from the command connection will be used. - -Returns the number of bytes read before any <CRLF> translation. - -=item write ( BUFFER, SIZE [, TIMEOUT ] ) - -Write C<SIZE> bytes of data from C<BUFFER> to the server, also -performing any <CRLF> translation necessary. C<TIMEOUT> is optional, if not -given the the timeout value from the command connection will be used. - -Returns the number of bytes written before any <CRLF> translation. - -=item abort () - -Abort the current data transfer. - -=item close () - -Close the data connection and get a response from the FTP server. Returns -I<true> if the connection was closed sucessfully and the first digit of -the response from the server was a '2'. - -=back - -=head1 AUTHOR - -Graham Barr <Graham.Barr@tiuk.ti.com> - -=head1 REVISION - -$Revision: 2.8 $ -$Date: 1996/09/05 06:53:58 $ - -The VERSION is derived from the revision by changing each number after the -first dot into a 2 digit number so - - Revision 1.8 => VERSION 1.08 - Revision 1.2.3 => VERSION 1.0203 - -=head1 SEE ALSO - -L<Net::Netrc> -L<Net::Cmd> - -=head1 CREDITS - -Henry Gabryjelski <henryg@WPI.EDU> - for the suggestion of creating directories -recursively. - -=head1 COPYRIGHT - -Copyright (c) 1995 Graham Barr. All rights reserved. This program is free -software; you can redistribute it and/or modify it under the same terms -as Perl itself. - -=cut - -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::Telnet qw(TELNET_IAC TELNET_IP TELNET_DM); - -$VERSION = do{my @r=(q$Revision: 2.8 $=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r}; -@ISA = qw(Exporter Net::Cmd IO::Socket::INET); - -sub new -{ - my $pkg = shift; - my $peer = shift; - my %arg = @_; - - my $host = $peer; - my $fire = undef; - - unless(defined inet_aton($peer)) - { - $fire = $ENV{FTP_FIREWALL} || $arg{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_passive'} = $arg{Passive} || 0; # Always use pasv mode - ${*$ftp}{'net_ftp_host'} = $host; # Remote hostname - ${*$ftp}{'net_ftp_type'} = 'A'; # ASCII/binary/etc mode - - ${*$ftp}{'net_ftp_firewall'} = $fire - if defined $fire; - - $ftp->autoflush(1); - - $ftp->debug(exists $arg{Debug} ? $arg{Debug} : undef); - - unless ($ftp->response() == CMD_OK) - { - $ftp->SUPER::close(); - undef $ftp; - } - - $ftp; -} - -## -## User interface methods -## - -sub quit -{ - my $ftp = shift; - - $ftp->_QUIT - && $ftp->SUPER::close; -} - -sub close -{ - my $ftp = shift; - - ref($ftp) - && defined fileno($ftp) - && $ftp->quit; -} - -sub DESTROY { shift->close } - -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 mdtm -{ - my $ftp = shift; - my $file = shift; - - return undef - unless $ftp->_MDTM($file); - - my @gt = reverse ($ftp->message =~ /(\d{4})(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/); - $gt[5] -= 1; - timegm(@gt); -} - -sub size -{ - my $ftp = shift; - my $file = shift; - - $ftp->_SIZE($file) - ? ($ftp->message =~ /(\d+)/)[0] - : undef; -} - -sub login -{ - my($ftp,$user,$pass,$acct) = @_; - my($ok,$ruser); - - unless (defined $user) - { - require Net::Netrc; - - my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'}); - - ($user,$pass,$acct) = $rc->lpa() - if ($rc); - } - - $user ||= "anonymous"; - $ruser = $user; - - if(defined ${*$ftp}{'net_ftp_firewall'}) - { - $user .= "@" . ${*$ftp}{'net_ftp_host'}; - } - - $ok = $ftp->_USER($user); - - # Some dumb firewall's 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 = "-" . (getpwuid($>))[0] . "@" - if (!defined $pass && $ruser =~ /^anonymous/o); - } - - $ok = $ftp->_PASS($pass || ""); - } - - $ok = $ftp->_ACCT($acct || "") - if ($ok == CMD_MORE); - - $ftp->authorize() - if($ok == CMD_OK && defined ${*$ftp}{'net_ftp_firewall'}); - - $ok == CMD_OK; -} - -sub authorize -{ - @_ >= 1 || @_ <= 3 or croak 'usage: $ftp->authorize( [AUTH [, RESP]])'; - - my($ftp,$auth,$resp) = @_; - - unless(defined $resp) - { - require Net::Netrc; - - $auth ||= (getpwuid($>))[0]; - - my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}, $auth) - || Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}); - - ($auth,$resp) = $rc->lpa() - if($rc); - } - - my $ok = $ftp->_AUTH($auth || ""); - - $ok = $ftp->_RESP($resp || "") - if ($ok == CMD_MORE); - - $ok == CMD_OK; -} - -sub rename -{ - @_ == 3 or croak 'usage: $ftp->rename(FROM, TO)'; - - 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("CC",TELNET_IAC,TELNET_IP),0); - send($ftp,pack("C", TELNET_IAC),MSG_OOB); - send($ftp,pack("C", TELNET_DM),0); - - $ftp->command("ABOR"); - - defined ${*$ftp}{'net_ftp_dataconn'} - ? ${*$ftp}{'net_ftp_dataconn'}->close() - : $ftp->response(); - - $ftp->response() - if $ftp->status == CMD_REJECT; - - $ftp->status == CMD_OK; -} - -sub get -{ - my($ftp,$remote,$local,$where) = @_; - - my($loc,$len,$buf,$resp,$localfd,$data); - local *FD; - - $localfd = ref($local) ? fileno($local) - : undef; - - ($local = $remote) =~ s#^.*/## - unless(defined $local); - - ${*$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->binary && !binmode($loc)) - { - carp "Cannot binmode Local file $local: $!\n"; - return undef; - } - - $buf = ''; - - do - { - $len = $data->read($buf,1024); - } - while($len > 0 && syswrite($loc,$buf,$len) == $len); - - close($loc) - unless defined $localfd; - - $data->close(); # implied $ftp->response - - return $local; -} - -sub cwd -{ - @_ == 2 || @_ == 3 or croak 'usage: $ftp->cwd( [ DIR ] )'; - - my($ftp,$dir) = @_; - - $dir ||= "/"; - - $dir eq ".." - ? $ftp->_CDUP() - : $ftp->_CWD($dir); -} - -sub cdup -{ - @_ == 1 or croak 'usage: $ftp->cdup()'; - $_[0]->_CDUP; -} - -sub pwd -{ - @_ == 1 || croak 'usage: $ftp->pwd()'; - my $ftp = shift; - - $ftp->_PWD(); - $ftp->_extract_path; -} - -sub rmdir -{ - @_ == 2 || croak 'usage: $ftp->rmdir( DIR )'; - - $_[0]->_RMD($_[1]); -} - -sub mkdir -{ - @_ == 2 || @_ == 3 or croak 'usage: $ftp->mkdir( DIR [, RECURSE ] )'; - - my($ftp,$dir,$recurse) = @_; - - $ftp->_MKD($dir) || $recurse or - return undef; - - my $path = undef; - unless($ftp->ok) - { - my @path = split(m#(?=/+)#, $dir); - - $path = ""; - - while(@path) - { - $path .= shift @path; - - $ftp->_MKD($path); - $path = $ftp->_extract_path($path); - - # 521 means directory already exists - last - unless $ftp->ok || $ftp->code == 521; - } - } - - $ftp->_extract_path($path); -} - -sub 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) ? fileno($local) - : undef; - - unless(defined $remote) - { - croak 'Must specify remote filename with stream input' - if defined $localfd; - - ($remote = $local) =~ s%.*/%%; - } - - if(defined $localfd) - { - $loc = $local; - } - else - { - $loc = \*FD; - - unless(open($loc,"<$local")) - { - carp "Cannot open Local file $local: $!\n"; - return undef; - } - if ($ftp->binary && !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; - - do - { - $len = sysread($loc,$buf="",1024); - } - while($len && $sock->write($buf,$len) == $len); - - close($loc) - unless defined $localfd; - - $sock->close(); - - ($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', - LocalAddr => $ftp->sockhost, - ); - - my $listen = ${*$ftp}{'net_ftp_listen'}; - - my($myport, @myaddr) = ($listen->sockport, split(/\./,$listen->sockhost)); - - $port = join(',', @myaddr, $myport >> 8, $myport & 0xff); - - ${*$ftp}{'net_ftp_intern_port'} = 1; - } - - $ok = $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; -} - -## -## Depreciated methods -## - -sub lsl -{ - carp "Use of Net::FTP::lsl depreciated, use 'dir'" - if $^W; - goto &dir; -} - -sub authorise -{ - carp "Use of Net::FTP::authorise depreciated, use 'authorize'" - if $^W; - goto &authorize; -} - - -## -## Private methods -## - -sub _extract_path -{ - my($ftp, $path) = @_; - - $ftp->ok && - $ftp->message =~ /\s\"(.*)\"\s/o && - ($path = $1) =~ s/\"\"/\"/g; - - $path; -} - -## -## Communication methods -## - -sub _dataconn -{ - my $ftp = shift; - my $data = undef; - my $pkg = "Net::FTP::" . $ftp->type; - - $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; -} - -sub _list_cmd -{ - my $ftp = shift; - my $cmd = uc shift; - - delete ${*$ftp}{'net_ftp_port'}; - delete ${*$ftp}{'net_ftp_pasv'}; - - my $data = $ftp->_data_cmd($cmd,@_); - - return undef - unless(defined $data); - - bless $data, "Net::FTP::A"; # Force ASCII mode - - my $databuf = ''; - my $buf = ''; - - while($data->read($databuf,1024)) - { - $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; - - 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(); - } - return $ok ? $data - : 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'}; - - $ok ? $ftp->_dataconn() - : undef; -} - -## -## Over-ride methods (Net::Cmd) -## - -sub debug_text { $_[2] =~ /^(pass|resp)/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; -} - -## -## Allow 2 servers to talk directly -## - -sub pasv_xfer -{ - my($sftp,$sfile,$dftp,$dfile) = @_; - - ($dfile = $sfile) =~ s#.*/## - unless(defined $dfile); - - my $port = $sftp->pasv or - return undef; - - unless($dftp->port($port) && $sftp->retr($sfile) && $dftp->stou($dfile)) - { - $sftp->abort; - $dftp->abort; - 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(@_)->responce() } - -######################################## -# -# RFC959 commands -# - -sub _ABOR { shift->command("ABOR")->response() == CMD_OK } -sub _CDUP { shift->command("CDUP")->response() == CMD_OK } -sub _NOOP { shift->command("NOOP")->response() == CMD_OK } -sub _PASV { shift->command("PASV")->response() == CMD_OK } -sub _QUIT { shift->command("QUIT")->response() == CMD_OK } -sub _DELE { shift->command("DELE",@_)->response() == CMD_OK } -sub _CWD { shift->command("CWD", @_)->response() == CMD_OK } -sub _PORT { shift->command("PORT",@_)->response() == CMD_OK } -sub _RMD { shift->command("RMD", @_)->response() == CMD_OK } -sub _MKD { shift->command("MKD", @_)->response() == CMD_OK } -sub _PWD { shift->command("PWD", @_)->response() == CMD_OK } -sub _TYPE { shift->command("TYPE",@_)->response() == CMD_OK } -sub _RNTO { shift->command("RNTO",@_)->response() == CMD_OK } -sub _ACCT { shift->command("ACCT",@_)->response() == CMD_OK } -sub _RESP { shift->command("RESP",@_)->response() == CMD_OK } -sub _MDTM { shift->command("MDTM",@_)->response() == CMD_OK } -sub _SIZE { shift->command("SIZE",@_)->response() == CMD_OK } -sub _APPE { shift->command("APPE",@_)->response() == CMD_INFO } -sub _LIST { shift->command("LIST",@_)->response() == CMD_INFO } -sub _NLST { shift->command("NLST",@_)->response() == CMD_INFO } -sub _RETR { shift->command("RETR",@_)->response() == CMD_INFO } -sub _STOR { shift->command("STOR",@_)->response() == CMD_INFO } -sub _STOU { shift->command("STOU",@_)->response() == CMD_INFO } -sub _RNFR { shift->command("RNFR",@_)->response() == CMD_MORE } -sub _REST { shift->command("REST",@_)->response() == CMD_MORE } -sub _USER { shift->command("user",@_)->response() } # A certain brain dead firewall :-) -sub _PASS { shift->command("PASS",@_)->response() } -sub _AUTH { shift->command("AUTH",@_)->response() } - -sub _ALLO { shift->unsupported(@_) } -sub _SMNT { shift->unsupported(@_) } -sub _HELP { shift->unsupported(@_) } -sub _MODE { shift->unsupported(@_) } -sub _SITE { shift->unsupported(@_) } -sub _SYST { shift->unsupported(@_) } -sub _STAT { shift->unsupported(@_) } -sub _STRU { shift->unsupported(@_) } -sub _REIN { shift->unsupported(@_) } - -## -## Generic data connection package -## - -package Net::FTP::dataconn; - -use Carp; -use vars qw(@ISA $timeout); -use Net::Cmd; - -@ISA = qw(IO::Socket::INET); - -sub abort -{ - my $data = shift; - my $ftp = ${*$data}{'net_ftp_cmd'}; - - $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'}; - - $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'}; -} - - -@Net::FTP::L::ISA = qw(Net::FTP::I); -@Net::FTP::E::ISA = qw(Net::FTP::I); - -## -## Package to read/write on ASCII data connections -## - -package Net::FTP::A; - -use vars qw(@ISA $buf); -use Carp; - -@ISA = qw(Net::FTP::dataconn); - -sub read -{ - my $data = shift; - local *buf = \$_[0]; shift; - my $size = shift || croak 'read($buf,$size,[$offset])'; - my $offset = shift || 0; - my $timeout = $data->timeout; - - croak "Bad offset" - if($offset < 0); - - $offset = length $buf - if($offset > length $buf); - - ${*$data} ||= ""; - my $l = 0; - - READ: - { - $data->can_read($timeout) or - croak "Timeout"; - - my $n = sysread($data, ${*$data}, $size, length ${*$data}); - - return $n - unless($n >= 0); - - ${*$data} =~ s/(\015)?(?!\012)\Z//so; - my $lf = $1 || ""; - - ${*$data} =~ s/\015\012/\n/sgo; - - substr($buf,$offset) = ${*$data}; - - $l += length(${*$data}); - $offset += length(${*$data}); - - ${*$data} = $lf; - - redo READ - if($l == 0 && $n > 0); - - if($n == 0 && $l == 0) - { - substr($buf,$offset) = ${*$data}; - ${*$data} = ""; - } - } - - return $l; -} - -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"; - - # What is previous pkt ended in \015 or not ?? - - my $tmp; - ($tmp = $buf) =~ s/(?!\015)\012/\015\012/sg; - - my $len = $size + length($tmp) - length($buf); - my $wrote = syswrite($data, $tmp, $len); - - if($wrote >= 0) - { - $wrote = $wrote == $len ? $size - : $len - $wrote - } - - return $wrote; -} - -## -## Package to read/write on BINARY data connections -## - -package Net::FTP::I; - -use vars qw(@ISA $buf); -use Carp; - -@ISA = qw(Net::FTP::dataconn); - -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 $n = sysread($data, $buf, $size); - - $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"; - - syswrite($data, $buf, $size); -} - - -1; - diff --git a/lib/Net/NNTP.pm b/lib/Net/NNTP.pm deleted file mode 100644 index a23b9bb589..0000000000 --- a/lib/Net/NNTP.pm +++ /dev/null @@ -1,996 +0,0 @@ -# Net::NNTP.pm -# -# Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights -# reserved. This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package Net::NNTP; - -=head1 NAME - -Net::NNTP - NNTP Client class - -=head1 SYNOPSIS - - use Net::NNTP; - - $nntp = Net::NNTP->new("some.host.name"); - $nntp->quit; - -=head1 DESCRIPTION - -C<Net::NNTP> is a class implementing a simple NNTP client in Perl as described -in RFC977. C<Net::NNTP> inherits its communication methods from C<Net::Cmd> - -=head1 CONSTRUCTOR - -=over 4 - -=item new ( [ HOST ] [, OPTIONS ]) - -This is the constructor for a new Net::NNTP object. C<HOST> is the -name of the remote host to which a NNTP connection is required. If not -given two environment variables are checked, first C<NNTPSERVER> then -C<NEWSHOST>, if neither are set C<news> is used. - -C<OPTIONS> are passed in a hash like fasion, using key and value pairs. -Possible options are: - -B<Timeout> - Maximum time, in seconds, to wait for a response from the -NNTP server, a value of zero will cause all IO operations to block. -(default: 120) - -B<Debug> - Enable the printing of debugging information to STDERR - -=back - -=head1 METHODS - -Unless otherwise stated all methods return either a I<true> or I<false> -value, with I<true> meaning that the operation was a success. When a method -states that it returns a value, falure will be returned as I<undef> or an -empty list. - -=over 4 - -=item article ( [ MSGID|MSGNUM ] ) - -Retreive the header, a blank line, then the body (text) of the -specified article. - -If no arguments are passed then the current aricle in the current -newsgroup is returned. - -C<MSGNUM> is a numeric id of an article in the -current newsgroup, and will change the current article pointer. -C<MSGID> is the message id of an article as -shown in that article's header. It is anticipated that the client -will obtain the C<MSGID> from a list provided by the C<newnews> -command, from references contained within another article, or from -the message-id provided in the response to some other commands. - -Returns a reference to an array containing the article. - -=item body ( [ MSGID|MSGNUM ] ) - -Retreive the body (text) of the specified article. - -Takes the same arguments as C<article> - -Returns a reference to an array containing the body of the article. - -=item head ( [ MSGID|MSGNUM ] ) - -Retreive the header of the specified article. - -Takes the same arguments as C<article> - -Returns a reference to an array containing the header of the article. - -=item nntpstat ( [ MSGID|MSGNUM ] ) - -The C<nntpstat> command is similar to the C<article> command except that no -text is returned. When selecting by message number within a group, -the C<nntpstat> command serves to set the "current article pointer" without -sending text. - -Using the C<nntpstat> command to -select by message-id is valid but of questionable value, since a -selection by message-id does B<not> alter the "current article pointer". - -Returns the message-id of the "current article". - -=item group ( [ GROUP ] ) - -Set and/or get the current group. If C<GROUP> is not given then information -is returned on the current group. - -In a scalar context it returns the group name. - -In an array context the return value is a list containing, the number -of articles in the group, the number of the first article, the number -of the last article and the group name. - -=item ihave ( MSGID [, MESSAGE ]) - -The C<ihave> command informs the server that the client has an article -whose id is C<MSGID>. If the server desires a copy of that -article, and C<MESSAGE> has been given the it will be sent. - -Returns I<true> if the server desires the article and C<MESSAGE> was -successfully sent,if specified. - -If C<MESSAGE> is not specified then the message must be sent using the -C<datasend> and C<dataend> methods from L<Net::Cmd> - -C<MESSAGE> can be either an array of lines or a reference to an array. - -=item last () - -Set the "current article pointer" to the previous article in the current -newsgroup. - -Returns the message-id of the article. - -=item date () - -Returns the date on the remote server. This date will be in a UNIX time -format (seconds since 1970) - -=item postok () - -C<postok> will return I<true> if the servers initial response indicated -that it will allow posting. - -=item authinfo ( USER, PASS ) - -=item list () - -Obtain information about all the active newsgroups. The results is a reference -to a hash where the key is a group name and each value is a reference to an -array. The elements in this array are:- the first article number in the group, -the last article number in the group and any information flags about the group. - -=item newgroups ( SINCE [, DISTRIBUTIONS ]) - -C<SINCE> is a time value and C<DISTRIBUTIONS> is either a distribution -pattern or a reference to a list of distribution patterns. -The result is the same as C<list>, but the -groups return will be limited to those created after C<SINCE> and, if -specified, in one of the distribution areas in C<DISTRIBUTIONS>. - -=item newnews ( SINCE [, GROUPS [, DISTRIBUTIONS ]]) - -C<SINCE> is a time value. C<GROUPS> is either a group pattern or a reference -to a list of group patterns. C<DISTRIBUTIONS> is either a distribution -pattern or a reference to a list of distribution patterns. - -Returns a reference to a list which contains the message-ids of all news posted -after C<SINCE>, that are in a groups which matched C<GROUPS> and a -distribution which matches C<DISTRIBUTIONS>. - -=item next () - -Set the "current article pointer" to the next article in the current -newsgroup. - -Returns the message-id of the article. - -=item post ( [ MESSAGE ] ) - -Post a new article to the news server. If C<MESSAGE> is specified and posting -is allowed then the message will be sent. - -If C<MESSAGE> is not specified then the message must be sent using the -C<datasend> and C<dataend> methods from L<Net::Cmd> - -C<MESSAGE> can be either an array of lines or a reference to an array. - -=item slave () - -Tell the remote server that I am not a user client, but probably another -news server. - -=item quit () - -Quit the remote server and close the socket connection. - -=back - -=head2 Extension methods - -These methods use commands that are not part of the RFC977 documentation. Some -servers may not support all of them. - -=over 4 - -=item newsgroups ( [ PATTERN ] ) - -Returns a reference to a hash where the keys are all the group names which -match C<PATTERN>, or all of the groups if no pattern is specified, and -each value contains the description text for the group. - -=item distributions () - -Returns a reference to a hash where the keys are all the possible -distribution names and the values are the distribution descriptions. - -=item subscriptions () - -Returns a reference to a list which contains a list of groups which -are reccomended for a new user to subscribe to. - -=item overview_fmt () - -Returns a reference to an array which contain the names of the fields returnd -by C<xover>. - -=item active_times () - -Returns a reference to a hash where the keys are the group names and each -value is a reference to an array containg the time the groups was created -and an identifier, possibly an Email address, of the creator. - -=item active ( [ PATTERN ] ) - -Similar to C<list> but only active groups that match the pattern are returned. -C<PATTERN> can be a group pattern. - -=item xgtitle ( PATTERN ) - -Returns a reference to a hash where the keys are all the group names which -match C<PATTERN> and each value is the description text for the group. - -=item xhdr ( HEADER, MESSAGE-RANGE ) - -Obtain the header field C<HEADER> for all the messages specified. - -Returns a reference to a hash where the keys are the message numbers and -each value contains the header for that message. - -=item xover ( MESSAGE-RANGE ) - -Returns a reference to a hash where the keys are the message numbers and each -value is a reference to an array which contains the overview fields for that -message. The names of these fields can be obtained by calling C<overview_fmt>. - -=item xpath ( MESSAGE-ID ) - -Returns the path name to the file on the server which contains the specified -message. - -=item xpat ( HEADER, PATTERN, MESSAGE-RANGE) - -The result is the same as C<xhdr> except the is will be restricted to -headers that match C<PATTERN> - -=item xrover - -=item listgroup - -=item reader - -=back - -=head1 UNSUPPORTED - -The following NNTP command are unsupported by the package, and there are -no plans to do so. - - AUTHINFO GENERIC - XTHREAD - XSEARCH - XINDEX - -=head1 DEFINITIONS - -=over 4 - -=item MESSAGE-RANGE - -C<MESSAGE-RANGE> is either a single message-id, a single mesage number, or -two message numbers. - -If C<MESSAGE-RANGE> is two message numbers and the second number in a -range is less than or equal to the first then the range represents all -messages in the group after the first message number. - -=item PATTERN - -The C<NNTP> protocol uses the C<WILDMAT> format for patterns. -The WILDMAT format was first developed by Rich Salz based on -the format used in the UNIX "find" command to articulate -file names. It was developed to provide a uniform mechanism -for matching patterns in the same manner that the UNIX shell -matches filenames. - -Patterns are implicitly anchored at the -beginning and end of each string when testing for a match. - -There are five pattern matching operations other than a strict -one-to-one match between the pattern and the source to be -checked for a match. - -The first is an asterisk C<*> to match any sequence of zero or more -characters. - -The second is a question mark C<?> to match any single character. The -third specifies a specific set of characters. - -The set is specified as a list of characters, or as a range of characters -where the beginning and end of the range are separated by a minus (or dash) -character, or as any combination of lists and ranges. The dash can -also be included in the set as a character it if is the beginning -or end of the set. This set is enclosed in square brackets. The -close square bracket C<]> may be used in a set if it is the first -character in the set. - -The fourth operation is the same as the -logical not of the third operation and is specified the same -way as the third with the addition of a caret character C<^> at -the beginning of the test string just inside the open square -bracket. - -The final operation uses the backslash character to -invalidate the special meaning of the a open square bracket C<[>, -the asterisk, backslash or the question mark. Two backslashes in -sequence will result in the evaluation of the backslash as a -character with no special meaning. - -=over 4 - -=item Examples - -=item C<[^]-]> - -matches any single character other than a close square -bracket or a minus sign/dash. - -=item C<*bdc> - -matches any string that ends with the string "bdc" -including the string "bdc" (without quotes). - -=item C<[0-9a-zA-Z]> - -matches any single printable alphanumeric ASCII character. - -=item C<a??d> - -matches any four character string which begins -with a and ends with d. - -=back - -=back - -=head1 SEE ALSO - -L<Net::Cmd> - -=head1 AUTHOR - -Graham Barr <Graham.Barr@tiuk.ti.com> - -=head1 REVISION - -$Revision: 2.5 $ - -=head1 COPYRIGHT - -Copyright (c) 1995 Graham Barr. All rights reserved. This program is free -software; you can redistribute it and/or modify it under the same terms -as Perl itself. - -=cut - -use strict; -use vars qw(@ISA $VERSION $debug); -use IO::Socket; -use Net::Cmd; -use Carp; - -$VERSION = sprintf("%d.%02d", q$Revision: 2.5 $ =~ /(\d+)\.(\d+)/); -@ISA = qw(Net::Cmd IO::Socket::INET); - -sub new -{ - my $self = shift; - my $type = ref($self) || $self; - my $host = shift if @_ % 2; - my %arg = @_; - - $host ||= $ENV{NNTPSERVER} || $ENV{NEWSHOST} || "news"; - - my $obj = $type->SUPER::new(PeerAddr => $host, - PeerPort => $arg{Port} || 'nntp(119)', - Proto => 'tcp', - Timeout => defined $arg{Timeout} - ? $arg{Timeout} - : 120 - ) or return undef; - - ${*$obj}{'net_nntp_host'} = $host; - - $obj->autoflush(1); - $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef); - - unless ($obj->response() == CMD_OK) - { - $obj->close(); - return undef; - } - - my $c = $obj->code; - ${*$obj}{'net_nntp_post'} = $c >= 200 && $c <= 209 ? 1 : 0; - - $obj; -} - -sub debug_text -{ - my $nntp = shift; - my $inout = shift; - my $text = shift; - - if(($nntp->code == 350 && $text =~ /^(\S+)/) - || ($text =~ /^(authinfo\s+pass)/io)) - { - $text = "$1 ....\n" - } - - $text; -} - -sub postok -{ - @_ == 1 or croak 'usage: $nntp->postok()'; - my $nntp = shift; - ${*$nntp}{'net_nntp_post'} || 0; -} - -sub article -{ - @_ == 1 || @_ == 2 or croak 'usage: $nntp->article( MSGID )'; - my $nntp = shift; - - $nntp->_ARTICLE(@_) - ? $nntp->read_until_dot() - : undef; -} - -sub authinfo -{ - @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )'; - my($nntp,$user,$pass) = @_; - - $nntp->_AUTHINFO("USER",$user) == CMD_MORE - && $nntp->_AUTHINFO("PASS",$pass) == CMD_OK; -} - -sub authinfo_simple -{ - @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )'; - my($nntp,$user,$pass) = @_; - - $nntp->_AUTHINFO('SIMPLE') == CMD_MORE - && $nntp->command($user,$pass)->response == CMD_OK; -} - -sub body -{ - @_ == 1 || @_ == 2 or croak 'usage: $nntp->body( [ MSGID ] )'; - my $nntp = shift; - - $nntp->_BODY(@_) - ? $nntp->read_until_dot() - : undef; -} - -sub head -{ - @_ == 1 || @_ == 2 or croak 'usage: $nntp->head( [ MSGID ] )'; - my $nntp = shift; - - $nntp->_HEAD(@_) - ? $nntp->read_until_dot() - : undef; -} - -sub nntpstat -{ - @_ == 1 || @_ == 2 or croak 'usage: $nntp->nntpstat( [ MSGID ] )'; - my $nntp = shift; - - $nntp->_STAT(@_) && $nntp->message =~ /(<[^>]+>)/o - ? $1 - : undef; -} - - -sub group -{ - @_ == 1 || @_ == 2 or croak 'usage: $nntp->group( [ GROUP ] )'; - my $nntp = shift; - my $grp = ${*$nntp}{'net_nntp_group'} || undef; - - return $grp - unless(@_ || wantarray); - - my $newgrp = shift; - - return wantarray ? () : undef - unless $nntp->_GROUP($newgrp || $grp || "") - && $nntp->message =~ /(\d+)\s+(\d+)\s+(\d+)\s+(\S+)/; - - my($count,$first,$last,$group) = ($1,$2,$3,$4); - - # group may be replied as '(current group)' - $group = ${*$nntp}{'net_nntp_group'} - if $group =~ /\(/; - - ${*$nntp}{'net_nntp_group'} = $group; - - wantarray - ? ($count,$first,$last,$group) - : $group; -} - -sub help -{ - @_ == 1 or croak 'usage: $nntp->help()'; - my $nntp = shift; - - $nntp->_HELP - ? $nntp->read_until_dot - : undef; -} - -sub ihave -{ - @_ >= 2 or croak 'usage: $nntp->ihave( MESSAGE-ID [, MESSAGE ])'; - my $nntp = shift; - my $mid = shift; - - $nntp->_IHAVE($mid) && $nntp->datasend(@_) - ? @_ == 0 || $nntp->dataend - : undef; -} - -sub last -{ - @_ == 1 or croak 'usage: $nntp->last()'; - my $nntp = shift; - - $nntp->_LAST && $nntp->message =~ /(<[^>]+>)/o - ? $1 - : undef; -} - -sub list -{ - @_ == 1 or croak 'usage: $nntp->list()'; - my $nntp = shift; - - $nntp->_LIST - ? $nntp->_grouplist - : undef; -} - -sub newgroups -{ - @_ >= 2 or croak 'usage: $nntp->newgroups( SINCE [, DISTRIBUTIONS ])'; - my $nntp = shift; - my $time = _timestr(shift); - my $dist = shift || ""; - - $dist = join(",", @{$dist}) - if ref($dist); - - $nntp->_NEWGROUPS($time,$dist) - ? $nntp->_grouplist - : undef; -} - -sub newnews -{ - @_ >= 3 or croak 'usage: $nntp->newnews( SINCE [, GROUPS [, DISTRIBUTIONS ]])'; - my $nntp = shift; - my $time = _timestr(shift); - my $grp = @_ ? shift : $nntp->group; - my $dist = shift || ""; - - $grp ||= "*"; - $grp = join(",", @{$grp}) - if ref($grp); - - $dist = join(",", @{$dist}) - if ref($dist); - - $nntp->_NEWNEWS($grp,$time,$dist) - ? $nntp->_articlelist - : undef; -} - -sub next -{ - @_ == 1 or croak 'usage: $nntp->next()'; - my $nntp = shift; - - $nntp->_NEXT && $nntp->message =~ /(<[^>]+>)/o - ? $1 - : undef; -} - -sub post -{ - @_ >= 1 or croak 'usage: $nntp->post( [ MESSAGE ] )'; - my $nntp = shift; - - $nntp->_POST() && $nntp->datasend(@_) - ? @_ == 0 || $nntp->dataend - : undef; -} - -sub quit -{ - @_ == 1 or croak 'usage: $nntp->quit()'; - my $nntp = shift; - - $nntp->_QUIT && $nntp->SUPER::close; -} - -sub slave -{ - @_ == 1 or croak 'usage: $nntp->slave()'; - my $nntp = shift; - - $nntp->_SLAVE; -} - -## -## The following methods are not implemented by all servers -## - -sub active -{ - @_ == 1 || @_ == 2 or croak 'usage: $nntp->active( [ PATTERN ] )'; - my $nntp = shift; - - $nntp->_LIST('ACTIVE',@_) - ? $nntp->_grouplist - : undef; -} - -sub active_times -{ - @_ == 1 or croak 'usage: $nntp->active_times()'; - my $nntp = shift; - - $nntp->_LIST('ACTIVE.TIMES') - ? $nntp->_grouplist - : undef; -} - -sub distributions -{ - @_ == 1 or croak 'usage: $nntp->distributions()'; - my $nntp = shift; - - $nntp->_LIST('DISTRIBUTIONS') - ? $nntp->_description - : undef; -} - -sub distribution_patterns -{ - @_ == 1 or croak 'usage: $nntp->distributions()'; - my $nntp = shift; - - my $arr; - local $_; - - $nntp->_LIST('DISTRIB.PATS') && ($arr = $nntp->read_until_dot) - ? [grep { /^\d/ && (chomp, $_ = [ split /:/ ]) } @$arr] - : undef; -} - -sub newsgroups -{ - @_ == 1 || @_ == 2 or croak 'usage: $nntp->newsgroups( [ PATTERN ] )'; - my $nntp = shift; - - $nntp->_LIST('NEWSGROUPS',@_) - ? $nntp->_description - : undef; -} - -sub overview_fmt -{ - @_ == 1 or croak 'usage: $nntp->overview_fmt()'; - my $nntp = shift; - - $nntp->_LIST('OVERVIEW.FMT') - ? $nntp->_articlelist - : undef; -} - -sub subscriptions -{ - @_ == 1 or croak 'usage: $nntp->subscriptions()'; - my $nntp = shift; - - $nntp->_LIST('SUBSCRIPTIONS') - ? $nntp->_articlelist - : undef; -} - -sub listgroup -{ - @_ == 1 || @_ == 2 or croak 'usage: $nntp->listgroup( [ GROUP ] )'; - my $nntp = shift; - - $nntp->_LISTGROUP(@_) - ? $nntp->_articlelist - : undef; -} - -sub reader -{ - @_ == 1 or croak 'usage: $nntp->reader()'; - my $nntp = shift; - - $nntp->_MODE('READER'); -} - -sub xgtitle -{ - @_ == 1 || @_ == 2 or croak 'usage: $nntp->xgtitle( [ PATTERN ] )'; - my $nntp = shift; - - $nntp->_XGTITLE(@_) - ? $nntp->_description - : undef; -} - -sub xhdr -{ - @_ >= 2 && @_ <= 4 or croak 'usage: $nntp->xhdr( HEADER, [ MESSAGE-ID | MESSAGE_NUM [, MESSAGE-NUM ]] )'; - my($nntp,$hdr,$first) = splice(@_,0,3); - - my $arg = "$first"; - - if(@_) - { - my $last = shift; - - $arg .= "-"; - $arg .= "$last" - if(defined $last && $last > $first); - } - - $nntp->_XHDR($hdr, $arg) - ? $nntp->_description - : undef; -} - -sub xover -{ - @_ == 2 || @_ == 3 or croak 'usage: $nntp->xover( RANGE )'; - my($nntp,$first) = splice(@_,0,2); - - my $arg = "$first"; - - if(@_) - { - my $last = shift; - $arg .= "-"; - $arg .= "$last" - if(defined $last && $last > $first); - } - - $nntp->_XOVER($arg) - ? $nntp->_fieldlist - : undef; -} - -sub xpat -{ - @_ == 4 || @_ == 5 or croak '$nntp->xpat( HEADER, PATTERN, RANGE )'; - my($nntp,$hdr,$pat,$first) = splice(@_,0,4); - - my $arg = "$first"; - - if(@_) - { - my $last = shift; - $arg .= "-"; - $arg .= "$last" - if(defined $last && $last > $first); - } - - $pat = join(" ", @$pat) - if ref($pat); - - $nntp->_XPAT($hdr,$arg,$pat) - ? $nntp->_description - : undef; -} - -sub xpath -{ - @_ == 2 or croak 'usage: $nntp->xpath( MESSAGE-ID )'; - my($nntp,$mid) = @_; - - return undef - unless $nntp->_XPATH($mid); - - my $m; ($m = $nntp->message) =~ s/^\d+\s+//o; - my @p = split /\s+/, $m; - - wantarray ? @p : $p[0]; -} - -sub xrover -{ - @_ == 2 || @_ == 3 or croak 'usage: $nntp->xrover( RANGE )'; - my($nntp,$first) = splice(@_,0,2); - - my $arg = "$first"; - - if(@_) - { - my $last = shift; - - $arg .= "-"; - $arg .= "$last" - if(defined $last && $last > $first); - } - - $nntp->_XROVER($arg) - ? $nntp->_fieldlist - : undef; -} - -sub date -{ - @_ == 1 or croak 'usage: $nntp->date()'; - my $nntp = shift; - - $nntp->_DATE && $nntp->message =~ /(\d{4})(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/ - ? timegm($6,$5,$4,$3,$2-1,$1) - : undef; -} - - -## -## Private subroutines -## - -sub _timestr -{ - my $time = shift; - my @g = reverse((gmtime($time))[0..5]); - $g[1] += 1; - $g[0] %= 100; - sprintf "%02d%02d%02d %02d%02d%02d GMT", @g; -} - -sub _grouplist -{ - my $nntp = shift; - my $arr = $nntp->read_until_dot or - return undef; - - my $hash = {}; - my $ln; - - foreach $ln (@$arr) - { - my @a = split(/[\s\n]+/,$ln); - $hash->{$a[0]} = [ @a[1,2,3] ]; - } - - $hash; -} - -sub _fieldlist -{ - my $nntp = shift; - my $arr = $nntp->read_until_dot or - return undef; - - my $hash = {}; - my $ln; - - foreach $ln (@$arr) - { - my @a = split(/[\t\n]/,$ln); - $hash->{$a[0]} = @a[1,2,3]; - } - - $hash; -} - -sub _articlelist -{ - my $nntp = shift; - my $arr = $nntp->read_until_dot; - - chomp(@$arr) - if $arr; - - $arr; -} - -sub _description -{ - my $nntp = shift; - my $arr = $nntp->read_until_dot or - return undef; - - my $hash = {}; - my $ln; - - foreach $ln (@$arr) - { - chomp($ln); - - $hash->{$1} = $ln - if $ln =~ s/^\s*(\S+)\s*//o; - } - - $hash; - -} - -## -## The commands -## - -sub _ARTICLE { shift->command('ARTICLE',@_)->response == CMD_OK } -sub _AUTHINFO { shift->command('AUTHINFO',@_)->response } -sub _BODY { shift->command('BODY',@_)->response == CMD_OK } -sub _DATE { shift->command('DATE')->response == CMD_INFO } -sub _GROUP { shift->command('GROUP',@_)->response == CMD_OK } -sub _HEAD { shift->command('HEAD',@_)->response == CMD_OK } -sub _HELP { shift->command('HELP',@_)->response == CMD_INFO } -sub _IHAVE { shift->command('IHAVE',@_)->response == CMD_MORE } -sub _LAST { shift->command('LAST')->response == CMD_OK } -sub _LIST { shift->command('LIST',@_)->response == CMD_OK } -sub _LISTGROUP { shift->command('LISTGROUP',@_)->response == CMD_OK } -sub _NEWGROUPS { shift->command('NEWGROUPS',@_)->response == CMD_OK } -sub _NEWNEWS { shift->command('NEWNEWS',@_)->response == CMD_OK } -sub _NEXT { shift->command('NEXT')->response == CMD_OK } -sub _POST { shift->command('POST',@_)->response == CMD_OK } -sub _QUIT { shift->command('QUIT',@_)->response == CMD_OK } -sub _SLAVE { shift->command('SLAVE',@_)->response == CMD_OK } -sub _STAT { shift->command('STAT',@_)->response == CMD_OK } -sub _MODE { shift->command('MODE',@_)->response == CMD_OK } -sub _XGTITLE { shift->command('XGTITLE',@_)->response == CMD_OK } -sub _XHDR { shift->command('XHDR',@_)->response == CMD_OK } -sub _XPAT { shift->command('XPAT',@_)->response == CMD_OK } -sub _XPATH { shift->command('XPATH',@_)->response == CMD_OK } -sub _XOVER { shift->command('XOVER',@_)->response == CMD_OK } -sub _XROVER { shift->command('XROVER',@_)->response == CMD_OK } -sub _XTHREAD { shift->unsupported } -sub _XSEARCH { shift->unsupported } -sub _XINDEX { shift->unsupported } - -## -## IO/perl methods -## - -sub close -{ - my $nntp = shift; - - ref($nntp) - && defined fileno($nntp) - && $nntp->quit; -} - -sub DESTROY { shift->close } - - -1; diff --git a/lib/Net/Netrc.pm b/lib/Net/Netrc.pm deleted file mode 100644 index 4299821865..0000000000 --- a/lib/Net/Netrc.pm +++ /dev/null @@ -1,316 +0,0 @@ -# Net::Netrc.pm -# -# Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights -# reserved. This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package Net::Netrc; - -=head1 NAME - -Net::Netrc - OO interface to users netrc file - -=head1 SYNOPSIS - - use Net::Netrc; - - $mach = Net::Netrc->lookup('some.machine'); - $login = $mach->login; - ($login, $password, $account) = $mach->lpa; - -=head1 DESCRIPTION - -C<Net::Netrc> is a class implementing a simple interface to the .netrc file -used as by the ftp program. - -C<Net::Netrc> also implements security checks just like the ftp program, -these checks are, first that the .netrc file must be owned by the user and -second the ownership permissions should be such that only the owner has -read and write access. If these conditions are not met then a warning is -output and the .netrc file is not read. - -=head1 THE .netrc FILE - -The .netrc file contains login and initialization information used by the -auto-login process. It resides in the user's home directory. The following -tokens are recognized; they may be separated by spaces, tabs, or new-lines: - -=over 4 - -=item machine name - -Identify a remote machine name. The auto-login process searches -the .netrc file for a machine token that matches the remote machine -specified. Once a match is made, the subsequent .netrc tokens -are processed, stopping when the end of file is reached or an- -other machine or a default token is encountered. - -=item default - -This is the same as machine name except that default matches -any name. There can be only one default token, and it must be -after all machine tokens. This is normally used as: - - default login anonymous password user@site - -thereby giving the user automatic anonymous login to machines -not specified in .netrc. - -=item login name - -Identify a user on the remote machine. If this token is present, -the auto-login process will initiate a login using the -specified name. - -=item password string - -Supply a password. If this token is present, the auto-login -process will supply the specified string if the remote server -requires a password as part of the login process. - -=item account string - -Supply an additional account password. If this token is present, -the auto-login process will supply the specified string -if the remote server requires an additional account password. - -=item macdef name - -Define a macro. C<Net::Netrc> only parses this field to be compatible -with I<ftp>. - -=back - -=head1 CONSTRUCTOR - -The constructor for a C<Net::Netrc> object is not called new as it does not -really create a new object. But instead is called C<lookup> as this is -essentially what it deos. - -=over 4 - -=item lookup ( MACHINE [, LOGIN ]) - -Lookup and return a reference to the entry for C<MACHINE>. If C<LOGIN> is given -then the entry returned will have the given login. If C<LOGIN> is not given then -the first entry in the .netrc file for C<MACHINE> will be returned. - -If a matching entry cannot be found, and a default entry exists, then a -reference to the default entry is returned. - -=back - -=head1 METHODS - -=over 4 - -=item login () - -Return the login id for the netrc entry - -=item password () - -Return the password for the netrc entry - -=item account () - -Return the account information for the netrc entry - -=item lpa () - -Return a list of login, password and account information fir the netrc entry - -=back - -=head1 AUTHOR - -Graham Barr <Graham.Barr@tiuk.ti.com> - -=head1 REVISION - -$Revision: 2.1 $ - -=head1 SEE ALSO - -L<Net::Netrc> -L<Net::Cmd> - -=head1 COPYRIGHT - -Copyright (c) 1995 Graham Barr. All rights reserved. This program is free -software; you can redistribute it and/or modify it under the same terms -as Perl itself. - -=cut - -use Carp; -use strict; -use FileHandle; -use vars qw($VERSION); - -$VERSION = sprintf("%d.%02d", q$Revision: 2.1 $ =~ /(\d+)\.(\d+)/); - -my %netrc = (); - -sub _readrc -{ - my $host = shift; - - # Some OS's don't have `getpwuid', so we default to $ENV{HOME} - my $home = eval { (getpwuid($>))[7] } || $ENV{HOME}; - my $file = $home . "/.netrc"; - - my($login,$pass,$acct) = (undef,undef,undef); - my $fh; - local $_; - - $netrc{default} = undef; - - # OS/2 does not handle stat in a way compatable with this check :-( - unless($^O eq 'os2') - { - my @stat = stat($file); - - if(@stat) - { - if($stat[2] & 077) - { - 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; - } - - push(@tok, split(/[\s\n]+/, $_)); - -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 => $mach}; - - $netrc{$host} = [] - unless exists($netrc{$host}); - push(@{$netrc{$host}}, $mach); - } - elsif($tok =~ /^(login|password|account)$/) - { - next TOKEN unless $mach; - my $value = shift @tok; - $mach->{$1} = $value; - } - elsif($tok eq "macdef") - { - next TOKEN unless $mach; - my $value = shift @tok; - $mach->{macdef} = {} - unless exists $mach->{macdef}; - $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} - 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; diff --git a/lib/Net/POP3.pm b/lib/Net/POP3.pm deleted file mode 100644 index 538039e5cd..0000000000 --- a/lib/Net/POP3.pm +++ /dev/null @@ -1,402 +0,0 @@ -# Net::POP3.pm -# -# Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights -# reserved. This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package Net::POP3; - -=head1 NAME - -Net::POP3 - Post Office Protocol 3 Client class (RFC1081) - -=head1 SYNOPSIS - - use Net::POP3; - - # Constructors - $pop = Net::POP3->new('pop3host'); - $pop = Net::POP3->new('pop3host', Timeout => 60); - -=head1 DESCRIPTION - -This module implements a client interface to the POP3 protocol, enabling -a perl5 application to talk to POP3 servers. This documentation assumes -that you are familiar with the POP3 protocol described in RFC1081. - -A new Net::POP3 object must be created with the I<new> method. Once -this has been done, all POP3 commands are accessed via method calls -on the object. - -=head1 EXAMPLES - - Need some small examples in here :-) - -=head1 CONSTRUCTOR - -=over 4 - -=item new ( HOST, [ OPTIONS ] ) - -This is the constructor for a new Net::POP3 object. C<HOST> is the -name of the remote host to which a POP3 connection is required. - -C<OPTIONS> are passed in a hash like fasion, using key and value pairs. -Possible options are: - -B<Timeout> - Maximum time, in seconds, to wait for a response from the -POP3 server (default: 120) - -B<Debug> - Enable debugging information - -=back - -=head1 METHODS - -Unless otherwise stated all methods return either a I<true> or I<false> -value, with I<true> meaning that the operation was a success. When a method -states that it returns a value, falure will be returned as I<undef> or an -empty list. - -=over 4 - -=item user ( USER ) - -Send the USER command. - -=item pass ( PASS ) - -Send the PASS command. Returns the number of messages in the mailbox. - -=item login ( [ USER [, PASS ]] ) - -Send both the the USER and PASS commands. If C<PASS> is not given the -C<Net::POP3> uses C<Net::Netrc> to lookup the password using the host -and username. If the username is not specified then the current user name -will be used. - -Returns the number of messages in the mailbox. - -=item top ( MSGNUM [, NUMLINES ] ) - -Get the header and the first C<NUMLINES> of the body for the message -C<MSGNUM>. Returns a reference to an array which contains the lines of text -read from the server. - -=item list ( [ MSGNUM ] ) - -If called with an argument the C<list> returns the size of the messsage -in octets. - -If called without arguments the a refererence to a hash is returned. The -keys will be the C<MSGNUM>'s of all undeleted messages and the values will -be their size in octets. - -=item get ( MSGNUM ) - -Get the message C<MSGNUM> from the remote mailbox. Returns a reference to an -array which contains the lines of text read from the server. - -=item last () - -Returns the highest C<MSGNUM> of all the messages accessed. - -=item popstat () - -Returns an array of two elements. These are the number of undeleted -elements and the size of the mbox in octets. - -=item delete ( MSGNUM ) - -Mark message C<MSGNUM> to be deleted from the remote mailbox. All messages -that are marked to be deleted will be removed from the remote mailbox -when the server connection closed. - -=item reset () - -Reset the status of the remote POP3 server. This includes reseting the -status of all messages to not be deleted. - -=item quit () - -Quit and close the connection to the remote POP3 server. Any messages marked -as deleted will be deleted from the remote mailbox. - -=back - -=head1 NOTES - -If a C<Net::POP3> object goes out of scope before C<quit> method is called -then the C<reset> method will called before the connection is closed. This -means that any messages marked to be deleted will not be. - -=head1 SEE ALSO - -L<Net::Netrc> -L<Net::Cmd> - -=head1 AUTHOR - -Graham Barr <Graham.Barr@tiuk.ti.com> - -=head1 REVISION - -$Revision: 2.1 $ -$Date: 1996/07/26 06:44:44 $ - -The VERSION is derived from the revision by changing each number after the -first dot into a 2 digit number so - - Revision 1.8 => VERSION 1.08 - Revision 1.2.3 => VERSION 1.0203 - -=head1 COPYRIGHT - -Copyright (c) 1995 Graham Barr. All rights reserved. This program is free -software; you can redistribute it and/or modify it under the same terms -as Perl itself. - -=cut - -use strict; -use IO::Socket; -use vars qw(@ISA $VERSION $debug); -use Net::Cmd; -use Carp; - -$VERSION = do{my @r=(q$Revision: 2.1 $=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r}; - -@ISA = qw(Net::Cmd IO::Socket::INET); - -sub new -{ - my $self = shift; - my $type = ref($self) || $self; - my $host = shift; - my %arg = @_; - my $obj = $type->SUPER::new(PeerAddr => $host, - PeerPort => $arg{Port} || 'pop3(110)', - Proto => 'tcp', - Timeout => defined $arg{Timeout} - ? $arg{Timeout} - : 120 - ) or return undef; - - ${*$obj}{'net_pop3_host'} = $host; - - $obj->autoflush(1); - $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef); - - unless ($obj->response() == CMD_OK) - { - $obj->close(); - return undef; - } - - $obj; -} - -## -## We don't want people sending me their passwords when they report problems -## now do we :-) -## - -sub debug_text { $_[2] =~ /^(pass|rpop)/i ? "$1 ....\n" : $_[2]; } - -sub login -{ - @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->login( USER, PASS )'; - my($me,$user,$pass) = @_; - - if(@_ < 2) - { - require Net::Netrc; - - $user ||= (getpwuid($>))[0]; - - my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'},$user); - - $m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'}); - - $pass = $m ? $m->password || "" - : ""; - } - - $me->user($user) and - $me->pass($pass); -} - -sub user -{ - @_ == 2 or croak 'usage: $pop3->user( USER )'; - $_[0]->_USER($_[1]); -} - -sub pass -{ - @_ == 2 or croak 'usage: $pop3->pass( PASS )'; - - my($me,$pass) = @_; - - return undef - unless($me->_PASS($pass)); - - $me->message =~ /(\d+)\s+message/io; - - ${*$me}{'net_pop3_count'} = $1 || 0; -} - -sub reset -{ - @_ == 1 or croak 'usage: $obj->reset()'; - - my $me = shift; - - return 0 - unless($me->_RSET); - - if(defined ${*$me}{'net_pop3_mail'}) - { - local $_; - foreach (@{${*$me}{'net_pop3_mail'}}) - { - delete $_->{'net_pop3_deleted'}; - } - } -} - -sub last -{ - @_ == 1 or croak 'usage: $obj->last()'; - - return undef - unless $_[0]->_LAST && $_[0]->message =~ /(\d+)/; - - return $1; -} - -sub top -{ - @_ == 2 || @_ == 3 or croak 'usage: $pop3->top( MSGNUM [, NUMLINES ])'; - my $me = shift; - - return undef - unless $me->_TOP($_[0], $_[1] || 0); - - $me->read_until_dot; -} - -sub popstat -{ - @_ == 1 or croak 'usage: $pop3->popstat()'; - my $me = shift; - - return () - unless $me->_STAT && $me->message =~ /(\d+)\D+(\d+)/; - - ($1 || 0, $2 || 0); -} - -sub list -{ - @_ == 1 || @_ == 2 or croak 'usage: $pop3->list( [ MSGNUM ] )'; - my $me = shift; - - return undef - unless $me->_LIST(@_); - - if(@_) - { - $me->message =~ /\d+\D+(\d+)/; - return $1 || undef; - } - - my $info = $me->read_until_dot; - my %hash = (); - map { /(\d+)\D+(\d+)/; $hash{$1} = $2; } @$info; - - return \%hash; -} - -sub get -{ - @_ == 2 or croak 'usage: $pop3->get( MSGNUM )'; - my $me = shift; - - return undef - unless $me->_RETR(@_); - - $me->read_until_dot; -} - -sub delete -{ - @_ == 2 or croak 'usage: $pop3->delete( MSGNUM )'; - $_[0]->_DELE($_[1]); -} - -sub _USER { shift->command('USER',$_[0])->response() == CMD_OK } -sub _PASS { shift->command('PASS',$_[0])->response() == CMD_OK } -sub _RPOP { shift->command('RPOP',$_[0])->response() == CMD_OK } -sub _RETR { shift->command('RETR',$_[0])->response() == CMD_OK } -sub _DELE { shift->command('DELE',$_[0])->response() == CMD_OK } -sub _TOP { shift->command('TOP', @_)->response() == CMD_OK } -sub _LIST { shift->command('LIST',@_)->response() == CMD_OK } -sub _NOOP { shift->command('NOOP')->response() == CMD_OK } -sub _RSET { shift->command('RSET')->response() == CMD_OK } -sub _LAST { shift->command('LAST')->response() == CMD_OK } -sub _QUIT { shift->command('QUIT')->response() == CMD_OK } -sub _STAT { shift->command('STAT')->response() == CMD_OK } - -sub close -{ - my $me = shift; - - return 1 - unless (ref($me) && defined fileno($me)); - - $me->_QUIT && $me->SUPER::close; -} - -sub quit { shift->close } - -sub DESTROY -{ - my $me = shift; - - if(fileno($me)) - { - $me->reset; - $me->quit; - } -} - -## -## POP3 has weird responses, so we emulate them to look the same :-) -## - -sub response -{ - my $cmd = shift; - my $str = $cmd->getline() || return undef; - my $code = "500"; - - $cmd->debug_print(0,$str) - if ($cmd->debug); - - if($str =~ s/^\+OK\s+//io) - { - $code = "200" - } - else - { - $str =~ s/^\+ERR\s+//io; - } - - ${*$cmd}{'net_cmd_resp'} = [ $str ]; - ${*$cmd}{'net_cmd_code'} = $code; - - substr($code,0,1); -} - -1; diff --git a/lib/Net/SMTP.pm b/lib/Net/SMTP.pm deleted file mode 100644 index 8d565230d1..0000000000 --- a/lib/Net/SMTP.pm +++ /dev/null @@ -1,526 +0,0 @@ -# Net::SMTP.pm -# -# Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights -# reserved. This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package Net::SMTP; - -=head1 NAME - -Net::SMTP - Simple Mail transfer Protocol Client - -=head1 SYNOPSIS - - use Net::SMTP; - - # Constructors - $smtp = Net::SMTP->new('mailhost'); - $smtp = Net::SMTP->new('mailhost', Timeout => 60); - -=head1 DESCRIPTION - -This module implements a client interface to the SMTP protocol, enabling -a perl5 application to talk to SMTP servers. This documentation assumes -that you are familiar with the SMTP protocol described in RFC821. - -A new Net::SMTP object must be created with the I<new> method. Once -this has been done, all SMTP commands are accessed through this object. - -=head1 EXAMPLES - -This example prints the mail domain name of the SMTP server known as mailhost: - - #!/usr/local/bin/perl -w - - use Net::SMTP; - - $smtp = Net::SMTP->new('mailhost'); - - print $smtp->domain,"\n"; - - $smtp->quit; - -This example sends a small message to the postmaster at the SMTP server -known as mailhost: - - #!/usr/local/bin/perl -w - - use Net::SMTP; - - $smtp = Net::SMTP->new('mailhost'); - - $smtp->mail($ENV{USER}); - - $smtp->to('postmaster'); - - $smtp->data(); - - $smtp->datasend("To: postmaster\n"); - $smtp->datasend("\n"); - $smtp->datasend("A simple test message\n"); - - $smtp->dataend(); - - $smtp->quit; - -=head1 CONSTRUCTOR - -=over 4 - -=item new ( HOST, [ OPTIONS ] ) - -This is the constructor for a new Net::SMTP object. C<HOST> is the -name of the remote host to which a SMTP connection is required. - -C<OPTIONS> are passed in a hash like fasion, using key and value pairs. -Possible options are: - -B<Hello> - SMTP requires that you identify yourself. This option -specifies a string to pass as your mail domain. If not -given a guess will be taken. - -B<Timeout> - Maximum time, in seconds, to wait for a response from the -SMTP server (default: 120) - -B<Debug> - Enable debugging information - - -Example: - - - $smtp = Net::SMTP->new('mailhost', - Hello => 'my.mail.domain' - ); - -=head1 METHODS - -Unless otherwise stated all methods return either a I<true> or I<false> -value, with I<true> meaning that the operation was a success. When a method -states that it returns a value, falure will be returned as I<undef> or an -empty list. - -=over 4 - -=item domain () - -Returns the domain that the remote SMTP server identified itself as during -connection. - -=item hello ( DOMAIN ) - -Tell the remote server the mail domain which you are in using the HELO -command. - -=item mail ( ADDRESS ) - -=item send ( ADDRESS ) - -=item send_or_mail ( ADDRESS ) - -=item send_and_mail ( ADDRESS ) - -Send the appropriate command to the server MAIL, SEND, SOML or SAML. C<ADDRESS> -is the address of the sender. This initiates the sending of a message. The -method C<recipient> should be called for each address that the message is to -be sent to. - -=item reset () - -Reset the status of the server. This may be called after a message has been -initiated, but before any data has been sent, to cancel the sending of the -message. - -=item recipient ( ADDRESS [, ADDRESS [ ...]] ) - -Notify the server that the current message should be sent to all of the -addresses given. Each address is sent as a separate command to the server. -Should the sending of any address result in a failure then the -process is aborted and a I<false> value is returned. It is up to the -user to call C<reset> if they so desire. - -=item to () - -A synonym for recipient - -=item data ( [ DATA ] ) - -Initiate the sending of the data fro the current message. - -C<DATA> may be a reference to a list or a list. If specified the contents -of C<DATA> and a termination string C<".\r\n"> is sent to the server. And the -result will be true if the data was accepted. - -If C<DATA> is not specified then the result will indicate that the server -wishes the data to be sent. The data must then be sent using the C<datasend> -and C<dataend> methods defined in C<Net::Cmd>. - -=item expand ( ADDRESS ) - -Request the server to expand the given address Returns a reference to an array -which contains the text read from the server. - -=item verify ( ADDRESS ) - -Verify that C<ADDRESS> is a legitimate mailing address. - -=item help ( [ $subject ] ) - -Request help text from the server. Returns the text or undef upon failure - -=item quit () - -Send the QUIT command to the remote SMTP server and close the socket connection. - -=back - -=head1 SEE ALSO - -L<Net::Cmd> - -=head1 AUTHOR - -Graham Barr <Graham.Barr@tiuk.ti.com> - -=head1 REVISION - -$Revision: 2.1 $ -$Date: 1996/08/20 20:23:56 $ - -The VERSION is derived from the revision by changing each number after the -first dot into a 2 digit number so - - Revision 1.8 => VERSION 1.08 - Revision 1.2.3 => VERSION 1.0203 - -=head1 COPYRIGHT - -Copyright (c) 1995 Graham Barr. All rights reserved. This program is free -software; you can redistribute it and/or modify it under the same terms -as Perl itself. - -=cut - -require 5.001; - -use strict; -use vars qw($VERSION @ISA); -use Socket 1.3; -use Carp; -use IO::Socket; -use Net::Cmd; - -$VERSION = do{my @r=(q$Revision: 2.1 $=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r}; - -@ISA = qw(Net::Cmd IO::Socket::INET); - -sub new -{ - my $self = shift; - my $type = ref($self) || $self; - my $host = shift; - my %arg = @_; - my $obj = $type->SUPER::new(PeerAddr => $host, - PeerPort => $arg{Port} || 'smtp(25)', - Proto => 'tcp', - Timeout => defined $arg{Timeout} - ? $arg{Timeout} - : 120 - ) or return undef; - - $obj->autoflush(1); - - $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef); - - unless ($obj->response() == CMD_OK) - { - $obj->SUPER::close(); - return undef; - } - - ${*$obj}{'net_smtp_host'} = $host; - - (${*$obj}{'net_smtp_domain'}) = $obj->message =~ /\A\s*(\S+)/; - - $obj->hello($arg{Hello} || ""); - - $obj; -} - -## -## User interface methods -## - -sub domain -{ - my $me = shift; - - return ${*$me}{'net_smtp_domain'} || undef; -} - -sub hello -{ - my $me = shift; - my $domain = shift || - eval { - require Net::Domain; - Net::Domain::hostdomain(); - } || - ""; - my $ok = $me->_EHLO($domain); - my $msg; - - if($ok) - { - $msg = $me->message; - - my $h = ${*$me}{'net_smtp_esmtp'} = {}; - my $ext; - foreach $ext (qw(8BITMIME CHECKPOINT DSN SIZE)) - { - $h->{$ext} = 1 - if $msg =~ /\b${ext}\b/; - } - } - else - { - $msg = $me->message - if $me->_HELO($domain); - } - - $ok && $msg =~ /\A(\S+)/ - ? $1 - : undef; -} - -sub _addr -{ - my $addr = shift || ""; - - return $1 - if $addr =~ /(<[^>]+>)/so; - - $addr =~ s/\n/ /sog; - $addr =~ s/(\A\s+|\s+\Z)//sog; - - return "<" . $addr . ">"; -} - - -sub mail -{ - my $me = shift; - my $addr = _addr(shift); - my $opts = ""; - - if(@_) - { - my %opt = @_; - my($k,$v); - - if(exists ${*$me}{'net_smtp_esmtp'}) - { - my $esmtp = ${*$me}{'net_smtp_esmtp'}; - - if(defined($v = delete $opt{Size})) - { - if(exists $esmtp->{SIZE}) - { - $opts .= sprintf " SIZE=%d", $v + 0 - } - else - { - carp 'Net::SMTP::mail: SIZE option not supported by host'; - } - } - - if(defined($v = delete $opt{Return})) - { - if(exists $esmtp->{DSN}) - { - $opts .= " RET=" . uc $v - } - else - { - carp 'Net::SMTP::mail: DSN option not supported by host'; - } - } - - if(defined($v = delete $opt{Bits})) - { - if(exists $esmtp->{'8BITMIME'}) - { - $opts .= $v == 8 ? " BODY=8BITMIME" : " BODY=7BIT" - } - else - { - carp 'Net::SMTP::mail: 8BITMIME option not supported by host'; - } - } - - if(defined($v = delete $opt{Transaction})) - { - if(exists $esmtp->{CHECKPOINT}) - { - $opts .= " TRANSID=" . _addr($v); - } - else - { - carp 'Net::SMTP::mail: CHECKPOINT option not supported by host'; - } - } - - if(defined($v = delete $opt{Envelope})) - { - if(exists $esmtp->{DSN}) - { - $v =~ s/([^\041-\176]|=|\+)/sprintf "+%02x", ord($1)/sge; - $opts .= " ENVID=$v" - } - else - { - carp 'Net::SMTP::mail: DSN option not supported by host'; - } - } - - carp 'Net::SMTP::recipient: unknown option(s) ' - . join(" ", keys %opt) - . ' - ignored' - if scalar keys %opt; - } - else - { - carp 'Net::SMTP::mail: ESMTP not supported by host - options discarded :-('; - } - } - - $me->_MAIL("FROM:".$addr.$opts); -} - -sub send { shift->_SEND("FROM:" . _addr($_[0])) } -sub send_or_mail { shift->_SOML("FROM:" . _addr($_[0])) } -sub send_and_mail { shift->_SAML("FROM:" . _addr($_[0])) } - -sub reset -{ - my $me = shift; - - $me->dataend() - if(exists ${*$me}{'net_smtp_lastch'}); - - $me->_RSET(); -} - - -sub recipient -{ - my $smtp = shift; - my $ok = 1; - my $opts = ""; - - if(@_ && ref($_[-1])) - { - my %opt = %{pop(@_)}; - my $v; - - if(exists ${*$smtp}{'net_smtp_esmtp'}) - { - my $esmtp = ${*$smtp}{'net_smtp_esmtp'}; - - if(defined($v = delete $opt{Notify})) - { - if(exists $esmtp->{DSN}) - { - $opts .= " NOTIFY=" . join(",",map { uc $_ } @$v) - } - else - { - carp 'Net::SMTP::recipient: DSN option not supported by host'; - } - } - - carp 'Net::SMTP::recipient: unknown option(s) ' - . join(" ", keys %opt) - . ' - ignored' - if scalar keys %opt; - } - else - { - carp 'Net::SMTP::recipient: ESMTP not supported by host - options discarded :-('; - } - } - - while($ok && scalar(@_)) - { - $ok = $smtp->_RCPT("TO:" . _addr(shift) . $opts); - } - - return $ok; -} - -*to = \&recipient; - -sub data -{ - my $me = shift; - - my $ok = $me->_DATA() && $me->datasend(@_); - - $ok && @_ ? $me->dataend - : $ok; -} - -sub expand -{ - my $me = shift; - - $me->_EXPN(@_) ? ($me->message) - : (); -} - - -sub verify { shift->_VRFY(@_) } - -sub help -{ - my $me = shift; - - $me->_HELP(@_) ? scalar $me->message - : undef; -} - -sub close -{ - my $me = shift; - - return 1 - unless (ref($me) && defined fileno($me)); - - $me->_QUIT && $me->SUPER::close; -} - -sub DESTROY { shift->close } -sub quit { shift->close } - -## -## RFC821 commands -## - -sub _EHLO { shift->command("EHLO", @_)->response() == CMD_OK } -sub _HELO { shift->command("HELO", @_)->response() == CMD_OK } -sub _MAIL { shift->command("MAIL", @_)->response() == CMD_OK } -sub _RCPT { shift->command("RCPT", @_)->response() == CMD_OK } -sub _SEND { shift->command("SEND", @_)->response() == CMD_OK } -sub _SAML { shift->command("SAML", @_)->response() == CMD_OK } -sub _SOML { shift->command("SOML", @_)->response() == CMD_OK } -sub _VRFY { shift->command("VRFY", @_)->response() == CMD_OK } -sub _EXPN { shift->command("EXPN", @_)->response() == CMD_OK } -sub _HELP { shift->command("HELP", @_)->response() == CMD_OK } -sub _RSET { shift->command("RSET")->response() == CMD_OK } -sub _NOOP { shift->command("NOOP")->response() == CMD_OK } -sub _QUIT { shift->command("QUIT")->response() == CMD_OK } -sub _DATA { shift->command("DATA")->response() == CMD_MORE } -sub _TURN { shift->unsupported(@_); } - -1; - diff --git a/lib/Net/SNPP.pm b/lib/Net/SNPP.pm deleted file mode 100644 index d869188cd6..0000000000 --- a/lib/Net/SNPP.pm +++ /dev/null @@ -1,389 +0,0 @@ -# Net::SNPP.pm -# -# Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights -# reserved. This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package Net::SNPP; - -=head1 NAME - -Net::SNPP - Simple Network Pager Protocol Client - -=head1 SYNOPSIS - - use Net::SNPP; - - # Constructors - $snpp = Net::SNPP->new('snpphost'); - $snpp = Net::SNPP->new('snpphost', Timeout => 60); - -=head1 NOTE - -This module is not complete, yet ! - -=head1 DESCRIPTION - -This module implements a client interface to the SNPP protocol, enabling -a perl5 application to talk to SNPP servers. This documentation assumes -that you are familiar with the SNPP protocol described in RFC1861. - -A new Net::SNPP object must be created with the I<new> method. Once -this has been done, all SNPP commands are accessed through this object. - -=head1 EXAMPLES - -This example will send a pager message in one hour saying "Your lunch is ready" - - #!/usr/local/bin/perl -w - - use Net::SNPP; - - $snpp = Net::SNPP->new('snpphost'); - - $snpp->send( Pager => $some_pager_number, - Message => "Your lunch is ready", - Alert => 1, - Hold => time + 3600, # lunch ready in 1 hour :-) - ) || die $snpp->message; - - $snpp->quit; - -=head1 CONSTRUCTOR - -=over 4 - -=item new ( HOST, [ OPTIONS ] ) - -This is the constructor for a new Net::SNPP object. C<HOST> is the -name of the remote host to which a SNPP connection is required. - -C<OPTIONS> are passed in a hash like fasion, using key and value pairs. -Possible options are: - -B<Timeout> - Maximum time, in seconds, to wait for a response from the -SNPP server (default: 120) - -B<Debug> - Enable debugging information - - -Example: - - - $snpp = Net::SNPP->new('snpphost', - Debug => 1, - ); - -=head1 METHODS - -Unless otherwise stated all methods return either a I<true> or I<false> -value, with I<true> meaning that the operation was a success. When a method -states that it returns a value, falure will be returned as I<undef> or an -empty list. - -=over 4 - -=item reset () - -=item help () - -Request help text from the server. Returns the text or undef upon failure - -=item quit () - -Send the QUIT command to the remote SNPP server and close the socket connection. - -=back - -=head1 EXPORTS - -C<Net::SNPP> exports all that C<Net::CMD> exports, plus three more subroutines -that can bu used to compare against the result of C<status>. These are :- -C<CMD_2WAYERROR>, C<CMD_2WAYOK>, and C<CMD_2WAYQUEUED>. - -=head1 SEE ALSO - -L<Net::Cmd> -RFC1861 - -=head1 AUTHOR - -Graham Barr <Graham.Barr@tiuk.ti.com> - -=head1 REVISION - -$Revision: 1.1 $ -$Date: 1996/07/26 06:49:13 $ - -The VERSION is derived from the revision by changing each number after the -first dot into a 2 digit number so - - Revision 1.8 => VERSION 1.08 - Revision 1.2.3 => VERSION 1.0203 - -=head1 COPYRIGHT - -Copyright (c) 1995 Graham Barr. All rights reserved. This program is free -software; you can redistribute it and/or modify it under the same terms -as Perl itself. - -=cut - -require 5.001; - -use strict; -use vars qw($VERSION @ISA @EXPORT); -use Socket 1.3; -use Carp; -use IO::Socket; -use Net::Cmd; - -$VERSION = do{my @r=(q$Revision: 1.1 $=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r}; -@ISA = qw(Net::Cmd IO::Socket::INET); -@EXPORT = qw(CMD_2WAYERROR CMD_2WAYOK CMD_2WAYQUEUED); - -sub CMD_2WAYERROR { 7 } -sub CMD_2WAYOK { 8 } -sub CMD_2WAYQUEUED { 9 } - -sub import -{ - my $pkg = shift; - my $callpkg = caller; - my @export = (); - my %export; - my $export; - - @export{@_} = (1) x @_; - - foreach $export (@EXPORT) - { - if(exists $export{$export}) - { - push(@export,$export); - delete $export{$export}; - } - } - - Exporter::export 'Net::SNPP', $callpkg, @export - if(@_ == 0 || @export); - - @export = keys %export; - Exporter::export 'Net::Cmd', $callpkg, @export - if(@_ == 0 || @export); -} - -sub new -{ - my $self = shift; - my $type = ref($self) || $self; - my $host = shift; - my %arg = @_; - my $obj = $type->SUPER::new(PeerAddr => $host, - PeerPort => $arg{Port} || 'snpp(444)', - Proto => 'tcp', - Timeout => defined $arg{Timeout} - ? $arg{Timeout} - : 120 - ) or return undef; - - $obj->autoflush(1); - - $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef); - - unless ($obj->response() == CMD_OK) - { - $obj->SUPER::close(); - return undef; - } - - $obj; -} - -## -## User interface methods -## - -sub pager_id -{ - @_ == 2 or croak 'usage: $snpp->pager_id( PAGER_ID )'; - shift->_PAGE(@_); -} - -sub content -{ - @_ == 2 or croak 'usage: $snpp->content( MESSAGE )'; - shift->_MESS(@_); -} - -sub send -{ - my $me = shift; - - if(@_) - { - my %arg = @_; - - $me->_PAGE($arg{Pager}) || return 0 - if(exists $arg{Pager}); - - $me->_MESS($arg{Message}) || return 0 - if(exists $arg{Message}); - - $me->hold($arg{Hold}) || return 0 - if(exists $arg{Hold}); - - $me->hold($arg{HoldLocal},1) || return 0 - if(exists $arg{HoldLocal}); - - $me->_COVE($arg{Coverage}) || return 0 - if(exists $arg{Coverage}); - - $me->_ALER($arg{Alert} ? 1 : 0) || return 0 - if(exists $arg{Alert}); - - $me->service_level($arg{ServiceLevel}) || return 0 - if(exists $arg{ServiceLevel}); - } - - $me->_SEND(); -} - -sub data -{ - my $me = shift; - - my $ok = $me->_DATA() && $me->datasend(@_); - - return $ok - unless($ok && @_); - - $me->dataend; -} - -sub login -{ - @_ == 2 || @_ == 3 or croak 'usage: $snpp->login( USER [, PASSWORD ])'; - shift->_LOGI(@_); -} - -sub help -{ - @_ == 1 or croak 'usage: $snpp->help()'; - my $me = shift; - - return $me->_HELP() ? $me->message - : undef; -} - -sub service_level -{ - @_ == 2 or croak 'usage: $snpp->service_level( LEVEL )'; - my $me = shift; - my $levl = int(shift); - my($me,$level) = @_; - - if($level < 0 || $level > 11) - { - $me->set_status(550,"Invalid Service Level"); - return 0; - } - - $me->_LEVE($levl); -} - -sub alert -{ - @_ == 1 || @_ == 2 or croak 'usage: $snpp->alert( VALUE )'; - my $me = shift; - my $value = (@_ == 1 || shift) ? 1 : 0; - - $me->_ALER($value); -} - -sub coverage -{ - @_ == 1 or croak 'usage: $snpp->coverage( AREA )'; - shift->_COVE(@_); -} - -sub hold -{ - @_ == 2 || @_ == 3 or croak 'usage: $snpp->hold( TIME [, LOCAL ] )'; - my $me = shift; - my $until = shift; - my $local = shift ? "" : " +0000"; - - my @g = reverse((gmtime($time))[0..5]); - $g[1] += 1; - $g[0] %= 100; - - $me->_HOLD( sprintf("%02d%02d%02d%02d%02d%02d%s",@g,$local)); -} - -sub caller_id -{ - @_ == 2 or croak 'usage: $snpp->caller_id( CALLER_ID )'; - shift->_CALL(@_); -} - -sub subject -{ - @_ == 2 or croak 'usage: $snpp->subject( SUBJECT )'; - shift->_SUBJ(@_); -} - -sub two_way -{ - @_ == 1 or croak 'usage: $snpp->two_way()'; - shift->_2WAY(); -} - -sub close -{ - my $me = shift; - - return 1 - unless (ref($me) && defined fileno($me)); - - $me->_QUIT && $me->SUPER::close; -} - -sub DESTROY { shift->close } -sub quit { shift->close } - -## -## Over-ride methods (Net::Cmd) -## - -sub debug_text -{ - $_[2] =~ s/^((logi|page)\s+\S+\s+)\S*/$1 xxxx/io; -} - -## -## RFC1861 commands -## - -# Level 1 - -sub _PAGE { shift->command("PAGE", @_)->response() == CMD_OK } -sub _MESS { shift->command("MESS", @_)->response() == CMD_OK } -sub _RESE { shift->command("RESE")->response() == CMD_OK } -sub _SEND { shift->command("SEND")->response() == CMD_OK } -sub _QUIT { shift->command("QUIT")->response() == CMD_OK } -sub _HELP { shift->command("HELP")->response() == CMD_OK } -sub _DATA { shift->command("DATA")->response() == CMD_MORE } - -# Level 2 - -sub _LOGI { shift->command("LOGI", @_)->response() == CMD_OK } -sub _LEVE { shift->command("LEVE", @_)->response() == CMD_OK } -sub _ALER { shift->command("ALER", @_)->response() == CMD_OK } -sub _COVE { shift->command("COVE", @_)->response() == CMD_OK } -sub _HOLD { shift->command("HOLD", @_)->response() == CMD_OK } -sub _CALL { shift->command("CALL", @_)->response() == CMD_OK } -sub _SUBJ { shift->command("SUBJ", @_)->response() == CMD_OK } - - -1; diff --git a/lib/Net/Telnet.pm b/lib/Net/Telnet.pm deleted file mode 100644 index 397502ea1d..0000000000 --- a/lib/Net/Telnet.pm +++ /dev/null @@ -1,250 +0,0 @@ - -package Net::Telnet; - -=head1 NAME - -Net::Telnet - Defines constants for the telnet protocol - -=head1 SYNOPSIS - - use Telnet qw(TELNET_IAC TELNET_DO TELNET_DONT); - -=head1 DESCRIPTION - -This module is B<VERY> preliminary as I am not 100% sure how it should -be implemented. - -Currently it just exports constants used in the telnet protocol. - -Should it contain sub's for packing and unpacking commands ? - -Please feel free to send me any suggestions - -=head1 NOTE - -This is not an implementation of the 'telnet' command but of the telnet -protocol as defined in RFC854 - -=head1 AUTHOR - -Graham Barr <Graham.Barr@tiuk.ti.com> - -=head1 REVISION - -$Revision: 2.0 $ - -=head1 COPYRIGHT - -Copyright (c) 1995 Graham Barr. All rights reserved. This program is free -software; you can redistribute it and/or modify it under the same terms -as Perl itself. - -=cut - -use vars qw(@ISA $VERSION); -require Exporter; -@ISA = qw(Exporter); - -$VERSION = sprintf("%d.%02d", q$Revision: 2.0 $ =~ /(\d+)\.(\d+)/); - -my %telnet = ( - TELNET_IAC => 255, # interpret as command: - TELNET_DONT => 254, # you are not to use option - TELNET_DO => 253, # please, you use option - TELNET_WONT => 252, # I won't use option - TELNET_WILL => 251, # I will use option - TELNET_SB => 250, # interpret as subnegotiation - TELNET_GA => 249, # you may reverse the line - TELNET_EL => 248, # erase the current line - TELNET_EC => 247, # erase the current character - TELNET_AYT => 246, # are you there - TELNET_AO => 245, # abort output--but let prog finish - TELNET_IP => 244, # interrupt process--permanently - TELNET_BREAK => 243, # break - TELNET_DM => 242, # data mark--for connect. cleaning - TELNET_NOP => 241, # nop - TELNET_SE => 240, # end sub negotiation - TELNET_EOR => 239, # end of record (transparent mode) - TELNET_ABORT => 238, # Abort process - TELNET_SUSP => 237, # Suspend process - TELNET_EOF => 236, # End of file: EOF is already used... - - TELNET_SYNCH => 242, # for telfunc calls -); - -while(($n,$v) = each %telnet) { eval "sub $n {$v}"; } - -sub telnet_command { - my $cmd = shift; - my($n,$v); - - while(($n,$v) = each %telnet) { - return $n - if($v == $cmd); - } - - return undef; -} - -# telnet options -my %telopt = ( - TELOPT_BINARY => 0, # 8-bit data path - TELOPT_ECHO => 1, # echo - TELOPT_RCP => 2, # prepare to reconnect - TELOPT_SGA => 3, # suppress go ahead - TELOPT_NAMS => 4, # approximate message size - TELOPT_STATUS => 5, # give status - TELOPT_TM => 6, # timing mark - TELOPT_RCTE => 7, # remote controlled transmission and echo - TELOPT_NAOL => 8, # negotiate about output line width - TELOPT_NAOP => 9, # negotiate about output page size - TELOPT_NAOCRD => 10, # negotiate about CR disposition - TELOPT_NAOHTS => 11, # negotiate about horizontal tabstops - TELOPT_NAOHTD => 12, # negotiate about horizontal tab disposition - TELOPT_NAOFFD => 13, # negotiate about formfeed disposition - TELOPT_NAOVTS => 14, # negotiate about vertical tab stops - TELOPT_NAOVTD => 15, # negotiate about vertical tab disposition - TELOPT_NAOLFD => 16, # negotiate about output LF disposition - TELOPT_XASCII => 17, # extended ascic character set - TELOPT_LOGOUT => 18, # force logout - TELOPT_BM => 19, # byte macro - TELOPT_DET => 20, # data entry terminal - TELOPT_SUPDUP => 21, # supdup protocol - TELOPT_SUPDUPOUTPUT => 22, # supdup output - TELOPT_SNDLOC => 23, # send location - TELOPT_TTYPE => 24, # terminal type - TELOPT_EOR => 25, # end or record - TELOPT_TUID => 26, # TACACS user identification - TELOPT_OUTMRK => 27, # output marking - TELOPT_TTYLOC => 28, # terminal location number - TELOPT_3270REGIME => 29, # 3270 regime - TELOPT_X3PAD => 30, # X.3 PAD - TELOPT_NAWS => 31, # window size - TELOPT_TSPEED => 32, # terminal speed - TELOPT_LFLOW => 33, # remote flow control - TELOPT_LINEMODE => 34, # Linemode option - TELOPT_XDISPLOC => 35, # X Display Location - TELOPT_OLD_ENVIRON => 36, # Old - Environment variables - TELOPT_AUTHENTICATION => 37, # Authenticate - TELOPT_ENCRYPT => 38, # Encryption option - TELOPT_NEW_ENVIRON => 39, # New - Environment variables - TELOPT_EXOPL => 255, # extended-options-list -); - -while(($n,$v) = each %telopt) { eval "sub $n {$v}"; } - -sub telnet_option { - my $cmd = shift; - my($n,$v); - - while(($n,$v) = each %telopt) { - return $n - if($v == $cmd); - } - - return undef; -} - -# sub-option qualifiers - -sub TELQUAL_IS {0} # option is... -sub TELQUAL_SEND {1} # send option -sub TELQUAL_INFO {2} # ENVIRON: informational version of IS -sub TELQUAL_REPLY {2} # AUTHENTICATION: client version of IS -sub TELQUAL_NAME {3} # AUTHENTICATION: client version of IS - -sub LFLOW_OFF {0} # Disable remote flow control -sub LFLOW_ON {1} # Enable remote flow control -sub LFLOW_RESTART_ANY {2} # Restart output on any char -sub LFLOW_RESTART_XON {3} # Restart output only on XON - -# LINEMODE suboptions - -sub LM_MODE {1} -sub LM_FORWARDMASK {2} -sub LM_SLC {3} - -sub MODE_EDIT {0x01} -sub MODE_TRAPSIG {0x02} -sub MODE_ACK {0x04} -sub MODE_SOFT_TAB {0x08} -sub MODE_LIT_ECHO {0x10} - -sub MODE_MASK {0x1f} - -# Not part of protocol, but needed to simplify things... -sub MODE_FLOW {0x0100} -sub MODE_ECHO {0x0200} -sub MODE_INBIN {0x0400} -sub MODE_OUTBIN {0x0800} -sub MODE_FORCE {0x1000} - -my %slc = ( - SLC_SYNCH => 1, - SLC_BRK => 2, - SLC_IP => 3, - SLC_AO => 4, - SLC_AYT => 5, - SLC_EOR => 6, - SLC_ABORT => 7, - SLC_EOF => 8, - SLC_SUSP => 9, - SLC_EC => 10, - SLC_EL => 11, - SLC_EW => 12, - SLC_RP => 13, - SLC_LNEXT => 14, - SLC_XON => 15, - SLC_XOFF => 16, - SLC_FORW1 => 17, - SLC_FORW2 => 18, -); - - -while(($n,$v) = each %slc) { eval "sub $n {$v}"; } - -sub telnet_slc { - my $cmd = shift; - my($n,$v); - - while(($n,$v) = each %slc) { - return $n - if($v == $cmd); - } - - return undef; -} - -sub NSLC {18} - -sub SLC_NOSUPPORT {0} -sub SLC_CANTCHANGE {1} -sub SLC_VARIABLE {2} -sub SLC_DEFAULT {3} -sub SLC_LEVELBITS {0x03} - -sub SLC_FUNC {0} -sub SLC_FLAGS {1} -sub SLC_VALUE {2} - -sub SLC_ACK {0x80} -sub SLC_FLUSHIN {0x40} -sub SLC_FLUSHOUT {0x20} - -sub OLD_ENV_VAR {1} -sub OLD_ENV_VALUE {0} -sub NEW_ENV_VAR {0} -sub NEW_ENV_VALUE {1} -sub ENV_ESC {2} -sub ENV_USERVAR {3} - -@EXPORT_OK = (keys %telnet, keys %telopt, keys %slc); - -sub telnet_pack { - my $r = ''; - - - $r; -} - -1; diff --git a/lib/Net/Time.pm b/lib/Net/Time.pm deleted file mode 100644 index a6b0b59e6c..0000000000 --- a/lib/Net/Time.pm +++ /dev/null @@ -1,112 +0,0 @@ -# Net::Time.pm -# -# Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights -# reserved. This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package Net::Time; - -=head1 NAME - -Net::Time - time and daytime network client interface - -=head1 SYNOPSIS - - use Net::Time qw(inet_time inet_daytime); - - print inet_time('localhost'); - print inet_time('localhost', 'tcp'); - - print inet_daytime('localhost'); - print inet_daytime('localhost', 'tcp'); - -=head1 DESCRIPTION - -C<Net::Time> provides subroutines that obtain the time on a remote machine. - -=over 4 - -=item inet_time ( HOST [, PROTOCOL]) - -Obtain the time on C<HOST> using the protocol as defined in RFC868. The -optional argument C<PROTOCOL> should define the protocol to use, either -C<tcp> or C<udp>. The result will be a unix-like time value or I<undef> -upon failure. - -=item inet_daytime ( HOST [, PROTOCOL]) - -Obtain the time on C<HOST> using the protocol as defined in RFC867. The -optional argument C<PROTOCOL> should define the protocol to use, either -C<tcp> or C<udp>. The result will be an ASCII string or I<undef> -upon failure. - -=back - -=head1 AUTHOR - -Graham Barr <Graham.Barr@tiuk.ti.com> - -=head1 REVISION - -$Revision: 2.0 $ - -=head1 COPYRIGHT - -Copyright (c) 1995 Graham Barr. All rights reserved. This program is free -software; you can redistribute it and/or modify it under the same terms -as Perl itself. - -=cut - -use strict; -use vars qw($VERSION @ISA @EXPORT_OK); -use Carp; -use IO::Socket; -require Exporter; - -@ISA = qw(Exporter); -@EXPORT_OK = qw(inet_time inet_daytime); - -$VERSION = sprintf("%d.%02d", q$Revision: 2.0 $ =~ /(\d+)\.(\d+)/); - -sub _socket -{ - my($pname,$pnum,$host,$proto) = @_; - - $proto ||= 'udp'; - - my $port = (getservbyname($pname, $proto))[2] || $pnum; - - my $me = IO::Socket::INET->new(PeerAddr => $host, - PeerPort => $port, - Proto => $proto - ); - - $me->send("\n") - if(defined $me && $proto eq 'udp'); - - $me; -} - -sub inet_time -{ - my $s = _socket('time',37,@_) || return undef; - my $buf = ''; - - # the time protocol return time in seconds since 1900, convert - # it to a unix time (seconds since 1970) - - $s->recv($buf, length(pack("N",0))) ? (unpack("N",$buf))[0] - 2208988800 - : undef; -} - -sub inet_daytime -{ - my $s = _socket('daytime',13,@_) || return undef; - my $buf = ''; - - $s->recv($buf, 1024) ? $buf - : undef; -} - -1; |