+++ /dev/null
-# 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;
+++ /dev/null
-# 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
+++ /dev/null
-# 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;
+++ /dev/null
-# 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;
-
+++ /dev/null
-# 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;
+++ /dev/null
-# 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;
+++ /dev/null
-# 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;
+++ /dev/null
-# 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;
-
+++ /dev/null
-# 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;
+++ /dev/null
-
-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;
+++ /dev/null
-# 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;
projects / platform / upstream / perl.git / commitdiff