lib/Net/FTP.pm libnet
lib/Net/hostent.pm By-name interface to Perl's builtin gethost*
lib/Net/hostent.t See if Net::hostent works
-lib/Net/Hostname.eg libnet
+lib/Net/Hostname.pm.eg libnet
lib/Net/libnetFAQ.pod libnet
lib/Net/netent.pm By-name interface to Perl's builtin getnet*
lib/Net/netent.t See if Net::netent works
+libnet 1.21 -- Sat May 19 08:53:09 CDT 2007
+
+Bug Fixes
+ * Fix bug causing utf8 encoding of 8bit strings in Net::Cmd
+ * Fix precedence issue in Net::NNTP. Patch from Brendan O'Dea
+ * Fixed bug causing removal of last character on the line when
+ doing ASCII FTP transfers
+
+Enhancements
+ * Add support for ENVID and AUTH to Net::SMTP. Patch by Mark Martinec
+ * Changed default for FTP transfers to be passive
+ * Added support for FTP FEAT command
+
libnet 1.20 -- Fri Feb 2 19:42:51 CST 2007
Bug Fixes
-# Net::Cmd.pm $Id: //depot/libnet/Net/Cmd.pm#34 $
+# Net::Cmd.pm
#
# Copyright (c) 1995-2006 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
BEGIN {
if ($^O eq 'os390') {
require Convert::EBCDIC;
-# Convert::EBCDIC->import;
+
+ # Convert::EBCDIC->import;
}
}
-$VERSION = "2.27_01";
+my $doUTF8 = eval { require utf8 };
+
+$VERSION = "2.28";
@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 }
+
+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 = ();
my $tr = $^O eq 'os390' ? Convert::EBCDIC->new() : undef;
-sub toebcdic
-{
- my $cmd = shift;
- unless (exists ${*$cmd}{'net_cmd_asciipeer'})
- {
- my $string = $_[0];
- my $ebcdicstr = $tr->toebcdic($string);
- ${*$cmd}{'net_cmd_asciipeer'} = $string !~ /^\d+/ && $ebcdicstr =~ /^\d+/;
+sub toebcdic {
+ my $cmd = shift;
+
+ unless (exists ${*$cmd}{'net_cmd_asciipeer'}) {
+ my $string = $_[0];
+ my $ebcdicstr = $tr->toebcdic($string);
+ ${*$cmd}{'net_cmd_asciipeer'} = $string !~ /^\d+/ && $ebcdicstr =~ /^\d+/;
}
${*$cmd}{'net_cmd_asciipeer'}
: $_[0];
}
-sub toascii
-{
+
+sub toascii {
my $cmd = shift;
${*$cmd}{'net_cmd_asciipeer'}
? $tr->toascii($_[0])
: $_[0];
}
-sub _print_isa
-{
- no strict qw(refs);
- my $pkg = shift;
- my $cmd = $pkg;
+sub _print_isa {
+ no strict qw(refs);
- $debug{$pkg} ||= 0;
+ my $pkg = shift;
+ my $cmd = $pkg;
- my %done = ();
- my @do = ($pkg);
- my %spc = ( $pkg , "");
+ $debug{$pkg} ||= 0;
- while ($pkg = shift @do)
- {
- next if defined $done{$pkg};
+ my %done = ();
+ my @do = ($pkg);
+ my %spc = ($pkg, "");
- $done{$pkg} = 1;
+ while ($pkg = shift @do) {
+ next if defined $done{$pkg};
- my $v = defined ${"${pkg}::VERSION"}
- ? "(" . ${"${pkg}::VERSION"} . ")"
- : "";
+ $done{$pkg} = 1;
- my $spc = $spc{$pkg};
- $cmd->debug_print(1,"${spc}${pkg}${v}\n");
+ my $v =
+ defined ${"${pkg}::VERSION"}
+ ? "(" . ${"${pkg}::VERSION"} . ")"
+ : "";
- if(@{"${pkg}::ISA"})
- {
- @spc{@{"${pkg}::ISA"}} = (" " . $spc{$pkg}) x @{"${pkg}::ISA"};
- unshift(@do, @{"${pkg}::ISA"});
+ my $spc = $spc{$pkg};
+ $cmd->debug_print(1, "${spc}${pkg}${v}\n");
+
+ if (@{"${pkg}::ISA"}) {
+ @spc{@{"${pkg}::ISA"}} = (" " . $spc{$pkg}) x @{"${pkg}::ISA"};
+ unshift(@do, @{"${pkg}::ISA"});
}
}
}
-sub debug
-{
- @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])';
- my($cmd,$level) = @_;
- my $pkg = ref($cmd) || $cmd;
- my $oldval = 0;
+sub debug {
+ @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])';
- if(ref($cmd))
- {
- $oldval = ${*$cmd}{'net_cmd_debug'} || 0;
+ 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;
+ else {
+ $oldval = $debug{$pkg} || 0;
}
- return $oldval
+ return $oldval
unless @_ == 2;
- $level = $debug{$pkg} || 0
+ $level = $debug{$pkg} || 0
unless defined $level;
- _print_isa($pkg)
- if($level && !exists $debug{$pkg});
+ _print_isa($pkg)
+ if ($level && !exists $debug{$pkg});
- if(ref($cmd))
- {
- ${*$cmd}{'net_cmd_debug'} = $level;
+ if (ref($cmd)) {
+ ${*$cmd}{'net_cmd_debug'} = $level;
}
- else
- {
- $debug{$pkg} = $level;
+ else {
+ $debug{$pkg} = $level;
}
- $oldval;
+ $oldval;
}
-sub message
-{
- @_ == 1 or croak 'usage: $obj->message()';
- my $cmd = shift;
+sub message {
+ @_ == 1 or croak 'usage: $obj->message()';
+
+ my $cmd = shift;
- wantarray ? @{${*$cmd}{'net_cmd_resp'}}
- : join("", @{${*$cmd}{'net_cmd_resp'}});
+ 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 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;
+sub code {
+ @_ == 1 or croak 'usage: $obj->code()';
+
+ my $cmd = shift;
- ${*$cmd}{'net_cmd_code'} = "000"
- unless exists ${*$cmd}{'net_cmd_code'};
+ ${*$cmd}{'net_cmd_code'} = "000"
+ unless exists ${*$cmd}{'net_cmd_code'};
- ${*$cmd}{'net_cmd_code'};
+ ${*$cmd}{'net_cmd_code'};
}
-sub status
-{
- @_ == 1 or croak 'usage: $obj->status()';
- my $cmd = shift;
+sub status {
+ @_ == 1 or croak 'usage: $obj->status()';
- substr(${*$cmd}{'net_cmd_code'},0,1);
+ my $cmd = shift;
+
+ substr(${*$cmd}{'net_cmd_code'}, 0, 1);
}
-sub set_status
-{
- @_ == 3 or croak 'usage: $obj->set_status(CODE, MESSAGE)';
- my $cmd = shift;
- my($code,$resp) = @_;
+sub set_status {
+ @_ == 3 or croak 'usage: $obj->set_status(CODE, MESSAGE)';
+
+ my $cmd = shift;
+ my ($code, $resp) = @_;
- $resp = [ $resp ]
- unless ref($resp);
+ $resp = [$resp]
+ unless ref($resp);
- (${*$cmd}{'net_cmd_code'},${*$cmd}{'net_cmd_resp'}) = ($code, $resp);
+ (${*$cmd}{'net_cmd_code'}, ${*$cmd}{'net_cmd_resp'}) = ($code, $resp);
- 1;
+ 1;
}
-sub command
-{
- my $cmd = shift;
- unless (defined fileno($cmd))
- {
+sub command {
+ my $cmd = shift;
+
+ unless (defined fileno($cmd)) {
$cmd->set_status("599", "Connection closed");
return $cmd;
}
- $cmd->dataend()
- if(exists ${*$cmd}{'net_cmd_last_ch'});
+ $cmd->dataend()
+ if (exists ${*$cmd}{'net_cmd_last_ch'});
- if (scalar(@_))
- {
- local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
+ if (scalar(@_)) {
+ local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
- my $str = join(" ", map { /\n/ ? do { my $n = $_; $n =~ tr/\n/ /; $n } : $_; } @_);
- $str = $cmd->toascii($str) if $tr;
- $str .= "\015\012";
+ my $str = join(
+ " ",
+ map {
+ /\n/
+ ? do { my $n = $_; $n =~ tr/\n/ /; $n }
+ : $_;
+ } @_
+ );
+ $str = $cmd->toascii($str) if $tr;
+ $str .= "\015\012";
- my $len = length $str;
- my $swlen;
+ my $len = length $str;
+ my $swlen;
- $cmd->close
- unless (defined($swlen = syswrite($cmd,$str,$len)) && $swlen == $len);
+ $cmd->close
+ unless (defined($swlen = syswrite($cmd, $str, $len)) && $swlen == $len);
- $cmd->debug_print(1,$str)
- if($cmd->debug);
+ $cmd->debug_print(1, $str)
+ if ($cmd->debug);
- ${*$cmd}{'net_cmd_resp'} = []; # the response
- ${*$cmd}{'net_cmd_code'} = "000"; # Made this one up :-)
+ ${*$cmd}{'net_cmd_resp'} = []; # the response
+ ${*$cmd}{'net_cmd_code'} = "000"; # Made this one up :-)
}
- $cmd;
+ $cmd;
}
-sub ok
-{
- @_ == 1 or croak 'usage: $obj->ok()';
- my $code = $_[0]->code;
- 0 < $code && $code < 400;
+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 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'} ||= [];
+sub getline {
+ my $cmd = shift;
+
+ ${*$cmd}{'net_cmd_lines'} ||= [];
- return shift @{${*$cmd}{'net_cmd_lines'}}
+ return shift @{${*$cmd}{'net_cmd_lines'}}
if scalar(@{${*$cmd}{'net_cmd_lines'}});
- my $partial = defined(${*$cmd}{'net_cmd_partial'})
- ? ${*$cmd}{'net_cmd_partial'} : "";
- my $fd = fileno($cmd);
+ my $partial = defined(${*$cmd}{'net_cmd_partial'}) ? ${*$cmd}{'net_cmd_partial'} : "";
+ my $fd = fileno($cmd);
- return undef
- unless defined $fd;
+ return undef
+ unless defined $fd;
- my $rin = "";
- vec($rin,$fd,1) = 1;
+ my $rin = "";
+ vec($rin, $fd, 1) = 1;
- my $buf;
+ my $buf;
- until(scalar(@{${*$cmd}{'net_cmd_lines'}}))
- {
- my $timeout = $cmd->timeout || undef;
- my $rout;
+ until (scalar(@{${*$cmd}{'net_cmd_lines'}})) {
+ my $timeout = $cmd->timeout || undef;
+ my $rout;
- my $select_ret = select($rout=$rin, undef, undef, $timeout);
- if ($select_ret > 0)
- {
- unless (sysread($cmd, $buf="", 1024))
- {
- carp(ref($cmd) . ": Unexpected EOF on command channel")
- if $cmd->debug;
- $cmd->close;
- return undef;
- }
+ my $select_ret = select($rout = $rin, undef, undef, $timeout);
+ if ($select_ret > 0) {
+ unless (sysread($cmd, $buf = "", 1024)) {
+ carp(ref($cmd) . ": Unexpected EOF on command channel")
+ if $cmd->debug;
+ $cmd->close;
+ return undef;
+ }
- substr($buf,0,0) = $partial; ## prepend from last sysread
+ substr($buf, 0, 0) = $partial; ## prepend from last sysread
- my @buf = split(/\015?\012/, $buf, -1); ## break into lines
+ my @buf = split(/\015?\012/, $buf, -1); ## break into lines
- $partial = pop @buf;
+ $partial = pop @buf;
- push(@{${*$cmd}{'net_cmd_lines'}}, map { "$_\n" } @buf);
+ push(@{${*$cmd}{'net_cmd_lines'}}, map {"$_\n"} @buf);
}
- else
- {
- my $msg = $select_ret ? "Error or Interrupted: $!" : "Timeout";
- carp("$cmd: $msg") if($cmd->debug);
- return undef;
+ else {
+ my $msg = $select_ret ? "Error or Interrupted: $!" : "Timeout";
+ carp("$cmd: $msg") if ($cmd->debug);
+ return undef;
}
}
- ${*$cmd}{'net_cmd_partial'} = $partial;
+ ${*$cmd}{'net_cmd_partial'} = $partial;
- if ($tr)
- {
- foreach my $ln (@{${*$cmd}{'net_cmd_lines'}})
- {
- $ln = $cmd->toebcdic($ln);
+ if ($tr) {
+ foreach my $ln (@{${*$cmd}{'net_cmd_lines'}}) {
+ $ln = $cmd->toebcdic($ln);
}
}
- shift @{${*$cmd}{'net_cmd_lines'}};
+ shift @{${*$cmd}{'net_cmd_lines'}};
}
-sub ungetline
-{
- my($cmd,$str) = @_;
- ${*$cmd}{'net_cmd_lines'} ||= [];
- unshift(@{${*$cmd}{'net_cmd_lines'}}, $str);
+sub ungetline {
+ my ($cmd, $str) = @_;
+
+ ${*$cmd}{'net_cmd_lines'} ||= [];
+ unshift(@{${*$cmd}{'net_cmd_lines'}}, $str);
}
-sub parse_response
-{
- return ()
+
+sub parse_response {
+ return ()
unless $_[1] =~ s/^(\d\d\d)(.?)//o;
- ($1, $2 eq "-");
+ ($1, $2 eq "-");
}
-sub response
-{
- my $cmd = shift;
- my($code,$more) = (undef) x 2;
- ${*$cmd}{'net_cmd_resp'} ||= [];
+sub response {
+ my $cmd = shift;
+ my ($code, $more) = (undef) x 2;
- while(1)
- {
- my $str = $cmd->getline();
+ ${*$cmd}{'net_cmd_resp'} ||= [];
- return CMD_ERROR
- unless defined($str);
+ while (1) {
+ my $str = $cmd->getline();
- $cmd->debug_print(0,$str)
- if ($cmd->debug);
+ return CMD_ERROR
+ unless defined($str);
- ($code,$more) = $cmd->parse_response($str);
- unless(defined $code)
- {
- $cmd->ungetline($str);
- last;
+ $cmd->debug_print(0, $str)
+ if ($cmd->debug);
+
+ ($code, $more) = $cmd->parse_response($str);
+ unless (defined $code) {
+ $cmd->ungetline($str);
+ last;
}
- ${*$cmd}{'net_cmd_code'} = $code;
+ ${*$cmd}{'net_cmd_code'} = $code;
- push(@{${*$cmd}{'net_cmd_resp'}},$str);
+ push(@{${*$cmd}{'net_cmd_resp'}}, $str);
- last unless($more);
- }
+ last unless ($more);
+ }
- substr($code,0,1);
+ substr($code, 0, 1);
}
-sub read_until_dot
-{
- my $cmd = shift;
- my $fh = shift;
- my $arr = [];
- while(1)
- {
- my $str = $cmd->getline() or return undef;
+sub read_until_dot {
+ my $cmd = shift;
+ my $fh = shift;
+ my $arr = [];
- $cmd->debug_print(0,$str)
- if ($cmd->debug & 4);
+ while (1) {
+ my $str = $cmd->getline() or return undef;
- last if($str =~ /^\.\r?\n/o);
+ $cmd->debug_print(0, $str)
+ if ($cmd->debug & 4);
- $str =~ s/^\.\././o;
+ last if ($str =~ /^\.\r?\n/o);
- if (defined $fh)
- {
- print $fh $str;
+ $str =~ s/^\.\././o;
+
+ if (defined $fh) {
+ print $fh $str;
}
- else
- {
- push(@$arr,$str);
+ else {
+ push(@$arr, $str);
}
}
- $arr;
+ $arr;
}
-sub datasend
-{
- my $cmd = shift;
- my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
- my $line = join("" ,@$arr);
- return 0 unless defined(fileno($cmd));
+sub datasend {
+ my $cmd = shift;
+ my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
+ my $line = join("", @$arr);
+
+ if ($doUTF8) {
+ # encode to individual utf8 bytes if
+ # $line is a string (in internal UTF-8)
+ utf8::encode($line) if utf8::is_utf8($line);
+ }
+
+ return 0 unless defined(fileno($cmd));
- my $last_ch = ${*$cmd}{'net_cmd_last_ch'};
- $last_ch = ${*$cmd}{'net_cmd_last_ch'} = "\012" unless defined $last_ch;
+ my $last_ch = ${*$cmd}{'net_cmd_last_ch'};
+ $last_ch = ${*$cmd}{'net_cmd_last_ch'} = "\012" unless defined $last_ch;
- return 1 unless length $line;
+ return 1 unless length $line;
- if($cmd->debug) {
- foreach my $b (split(/\n/,$line)) {
- $cmd->debug_print(1, "$b\n");
- }
+ if ($cmd->debug) {
+ foreach my $b (split(/\n/, $line)) {
+ $cmd->debug_print(1, "$b\n");
+ }
}
- $line =~ tr/\r\n/\015\012/ unless "\r" eq "\015";
+ $line =~ tr/\r\n/\015\012/ unless "\r" eq "\015";
my $first_ch = '';
$first_ch = "." if $line =~ /^\./;
}
- $line =~ s/\015?\012(\.?)/\015\012$1$1/sg;
+ $line =~ s/\015?\012(\.?)/\015\012$1$1/sg;
- substr($line,0,0) = $first_ch;
+ substr($line, 0, 0) = $first_ch;
- ${*$cmd}{'net_cmd_last_ch'} = substr($line,-1,1);
+ ${*$cmd}{'net_cmd_last_ch'} = substr($line, -1, 1);
- my $len = length($line);
- my $offset = 0;
- my $win = "";
- vec($win,fileno($cmd),1) = 1;
- my $timeout = $cmd->timeout || undef;
+ my $len = length($line);
+ my $offset = 0;
+ my $win = "";
+ vec($win, fileno($cmd), 1) = 1;
+ my $timeout = $cmd->timeout || undef;
- local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
+ local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
- while($len)
- {
- my $wout;
- my $s = select(undef,$wout=$win, undef, $timeout);
- if ((defined $s and $s > 0) or -f $cmd) # -f for testing on win32
+ while ($len) {
+ my $wout;
+ my $s = select(undef, $wout = $win, undef, $timeout);
+ if ((defined $s and $s > 0) or -f $cmd) # -f for testing on win32
{
- my $w = syswrite($cmd, $line, $len, $offset);
- unless (defined($w))
- {
- carp("$cmd: $!") if $cmd->debug;
- return undef;
+ my $w = syswrite($cmd, $line, $len, $offset);
+ unless (defined($w)) {
+ carp("$cmd: $!") if $cmd->debug;
+ return undef;
}
- $len -= $w;
- $offset += $w;
+ $len -= $w;
+ $offset += $w;
}
- else
- {
- carp("$cmd: Timeout") if($cmd->debug);
- return undef;
+ else {
+ carp("$cmd: Timeout") if ($cmd->debug);
+ return undef;
}
}
- 1;
+ 1;
}
-sub rawdatasend
-{
- my $cmd = shift;
- my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
- my $line = join("" ,@$arr);
- return 0 unless defined(fileno($cmd));
+sub rawdatasend {
+ my $cmd = shift;
+ my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
+ my $line = join("", @$arr);
- return 1
+ return 0 unless defined(fileno($cmd));
+
+ return 1
unless length($line);
- if($cmd->debug)
- {
- my $b = "$cmd>>> ";
- print STDERR $b,join("\n$b",split(/\n/,$line)),"\n";
+ if ($cmd->debug) {
+ my $b = "$cmd>>> ";
+ print STDERR $b, join("\n$b", split(/\n/, $line)), "\n";
}
- my $len = length($line);
- my $offset = 0;
- my $win = "";
- vec($win,fileno($cmd),1) = 1;
- my $timeout = $cmd->timeout || undef;
-
- local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
- while($len)
- {
- my $wout;
- if (select(undef,$wout=$win, undef, $timeout) > 0)
- {
- my $w = syswrite($cmd, $line, $len, $offset);
- unless (defined($w))
- {
- carp("$cmd: $!") if $cmd->debug;
- return undef;
+ my $len = length($line);
+ my $offset = 0;
+ my $win = "";
+ vec($win, fileno($cmd), 1) = 1;
+ my $timeout = $cmd->timeout || undef;
+
+ local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
+ while ($len) {
+ my $wout;
+ if (select(undef, $wout = $win, undef, $timeout) > 0) {
+ my $w = syswrite($cmd, $line, $len, $offset);
+ unless (defined($w)) {
+ carp("$cmd: $!") if $cmd->debug;
+ return undef;
}
- $len -= $w;
- $offset += $w;
+ $len -= $w;
+ $offset += $w;
}
- else
- {
- carp("$cmd: Timeout") if($cmd->debug);
- return undef;
+ else {
+ carp("$cmd: Timeout") if ($cmd->debug);
+ return undef;
}
}
- 1;
+ 1;
}
-sub dataend
-{
- my $cmd = shift;
- return 0 unless defined(fileno($cmd));
+sub dataend {
+ my $cmd = shift;
+
+ return 0 unless defined(fileno($cmd));
- my $ch = ${*$cmd}{'net_cmd_last_ch'};
- my $tosend;
+ my $ch = ${*$cmd}{'net_cmd_last_ch'};
+ my $tosend;
- if (!defined $ch) {
- return 1;
- }
- elsif ($ch ne "\012") {
- $tosend = "\015\012";
- }
+ if (!defined $ch) {
+ return 1;
+ }
+ elsif ($ch ne "\012") {
+ $tosend = "\015\012";
+ }
- $tosend .= ".\015\012";
+ $tosend .= ".\015\012";
- local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
+ local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
- $cmd->debug_print(1, ".\n")
- if($cmd->debug);
+ $cmd->debug_print(1, ".\n")
+ if ($cmd->debug);
- syswrite($cmd,$tosend, length $tosend);
+ syswrite($cmd, $tosend, length $tosend);
- delete ${*$cmd}{'net_cmd_last_ch'};
+ delete ${*$cmd}{'net_cmd_last_ch'};
- $cmd->response() == CMD_OK;
+ $cmd->response() == CMD_OK;
}
# read and write to tied filehandle
my $cmd = shift;
${*$cmd}{'net_cmd_readbuf'} = '';
my $fh = gensym();
- tie *$fh,ref($cmd),$cmd;
+ tie *$fh, ref($cmd), $cmd;
return $fh;
}
# tie to myself
sub TIEHANDLE {
my $class = shift;
- my $cmd = shift;
+ my $cmd = shift;
return $cmd;
}
# end-of-file when the dot is encountered.
sub READ {
my $cmd = shift;
- my ($len,$offset) = @_[1,2];
+ my ($len, $offset) = @_[1, 2];
return unless exists ${*$cmd}{'net_cmd_readbuf'};
my $done = 0;
while (!$done and length(${*$cmd}{'net_cmd_readbuf'}) < $len) {
- ${*$cmd}{'net_cmd_readbuf'} .= $cmd->getline() or return;
- $done++ if ${*$cmd}{'net_cmd_readbuf'} =~ s/^\.\r?\n\Z//m;
+ ${*$cmd}{'net_cmd_readbuf'} .= $cmd->getline() or return;
+ $done++ if ${*$cmd}{'net_cmd_readbuf'} =~ s/^\.\r?\n\Z//m;
}
$_[0] = '';
- substr($_[0],$offset+0) = substr(${*$cmd}{'net_cmd_readbuf'},0,$len);
- substr(${*$cmd}{'net_cmd_readbuf'},0,$len) = '';
+ substr($_[0], $offset + 0) = substr(${*$cmd}{'net_cmd_readbuf'}, 0, $len);
+ substr(${*$cmd}{'net_cmd_readbuf'}, 0, $len) = '';
delete ${*$cmd}{'net_cmd_readbuf'} if $done;
return length $_[0];
}
+
sub READLINE {
my $cmd = shift;
+
# in this context, we use the presence of readbuf to
# indicate that we have not yet reached the eof
return unless exists ${*$cmd}{'net_cmd_readbuf'};
$line;
}
+
sub PRINT {
my $cmd = shift;
- my ($buf,$len,$offset) = @_;
- $len ||= length ($buf);
+ my ($buf, $len, $offset) = @_;
+ $len ||= length($buf);
$offset += 0;
- return unless $cmd->datasend(substr($buf,$offset,$len));
- ${*$cmd}{'net_cmd_sending'}++; # flag that we should call dataend()
+ return unless $cmd->datasend(substr($buf, $offset, $len));
+ ${*$cmd}{'net_cmd_sending'}++; # flag that we should call dataend()
return $len;
}
+
sub CLOSE {
my $cmd = shift;
- my $r = exists(${*$cmd}{'net_cmd_sending'}) ? $cmd->dataend : 1;
+ my $r = exists(${*$cmd}{'net_cmd_sending'}) ? $cmd->dataend : 1;
delete ${*$cmd}{'net_cmd_readbuf'};
delete ${*$cmd}{'net_cmd_sending'};
$r;
@EXPORT = qw(%NetConfig);
@ISA = qw(Net::LocalCfg Exporter);
-$VERSION = "1.10"; # $Id: //depot/libnet/Net/Config.pm#17 $
+$VERSION = "1.11";
eval { local $SIG{__DIE__}; require Net::LocalCfg };
%NetConfig = (
- nntp_hosts => [],
- snpp_hosts => [],
- pop3_hosts => [],
- smtp_hosts => [],
- ph_hosts => [],
- daytime_hosts => [],
- time_hosts => [],
- inet_domain => undef,
- ftp_firewall => undef,
- ftp_ext_passive => 1,
- ftp_int_passive => 1,
- test_hosts => 1,
- test_exist => 1,
+ nntp_hosts => [],
+ snpp_hosts => [],
+ pop3_hosts => [],
+ smtp_hosts => [],
+ ph_hosts => [],
+ daytime_hosts => [],
+ time_hosts => [],
+ inet_domain => undef,
+ ftp_firewall => undef,
+ ftp_ext_passive => 1,
+ ftp_int_passive => 1,
+ test_hosts => 1,
+ test_exist => 1,
);
#
my $file = __FILE__;
my $ref;
$file =~ s/Config.pm/libnet.cfg/;
-if ( -f $file ) {
- $ref = eval { local $SIG{__DIE__}; do $file };
- if (ref($ref) eq 'HASH') {
- %NetConfig = (%NetConfig, %{ $ref });
- $LIBNET_CFG = $file;
- }
+if (-f $file) {
+ $ref = eval { local $SIG{__DIE__}; do $file };
+ if (ref($ref) eq 'HASH') {
+ %NetConfig = (%NetConfig, %{$ref});
+ $LIBNET_CFG = $file;
+ }
}
-if ($< == $> and !$CONFIGURE) {
- my $home = eval { local $SIG{__DIE__}; (getpwuid($>))[7] } || $ENV{HOME};
- $home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH}||'') if defined $ENV{HOMEDRIVE};
- if (defined $home) {
- $file = $home . "/.libnetrc";
- $ref = eval { local $SIG{__DIE__}; do $file } if -f $file;
- %NetConfig = (%NetConfig, %{ $ref })
- if ref($ref) eq 'HASH';
- }
+if ($< == $> and !$CONFIGURE) {
+ my $home = eval { local $SIG{__DIE__}; (getpwuid($>))[7] } || $ENV{HOME};
+ $home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH} || '') if defined $ENV{HOMEDRIVE};
+ if (defined $home) {
+ $file = $home . "/.libnetrc";
+ $ref = eval { local $SIG{__DIE__}; do $file } if -f $file;
+ %NetConfig = (%NetConfig, %{$ref})
+ if ref($ref) eq 'HASH';
+ }
}
-my ($k,$v);
-while(($k,$v) = each %NetConfig) {
- $NetConfig{$k} = [ $v ]
- if($k =~ /_hosts$/ and $k ne "test_hosts" and defined($v) and !ref($v));
+my ($k, $v);
+while (($k, $v) = each %NetConfig) {
+ $NetConfig{$k} = [$v]
+ if ($k =~ /_hosts$/ and $k ne "test_hosts" and defined($v) and !ref($v));
}
# Take a hostname and determine if it is inside the firewall
+
sub requires_firewall {
- shift; # ignore package
- my $host = shift;
-
- return 0 unless defined $NetConfig{'ftp_firewall'};
-
- $host = inet_aton($host) or return -1;
- $host = inet_ntoa($host);
-
- if(exists $NetConfig{'local_netmask'}) {
- my $quad = unpack("N",pack("C*",split(/\./,$host)));
- my $list = $NetConfig{'local_netmask'};
- $list = [$list] unless ref($list);
- foreach (@$list) {
- my($net,$bits) = (m#^(\d+\.\d+\.\d+\.\d+)/(\d+)$#) or next;
- my $mask = ~0 << (32 - $bits);
- my $addr = unpack("N",pack("C*",split(/\./,$net)));
-
- return 0 if (($addr & $mask) == ($quad & $mask));
- }
- return 1;
+ shift; # ignore package
+ my $host = shift;
+
+ return 0 unless defined $NetConfig{'ftp_firewall'};
+
+ $host = inet_aton($host) or return -1;
+ $host = inet_ntoa($host);
+
+ if (exists $NetConfig{'local_netmask'}) {
+ my $quad = unpack("N", pack("C*", split(/\./, $host)));
+ my $list = $NetConfig{'local_netmask'};
+ $list = [$list] unless ref($list);
+ foreach (@$list) {
+ my ($net, $bits) = (m#^(\d+\.\d+\.\d+\.\d+)/(\d+)$#) or next;
+ my $mask = ~0 << (32 - $bits);
+ my $addr = unpack("N", pack("C*", split(/\./, $net)));
+
+ return 0 if (($addr & $mask) == ($quad & $mask));
}
+ return 1;
+ }
- return 0;
+ return 0;
}
use vars qw(*is_external);
you want to transfer data you have to tell the server the address and
port to connect to. Passive mode is when the server provide the
address and port and you establish the connection.
-
+
With some firewalls active mode does not work as the server cannot
connect to your machine (because you are behind a firewall) and the firewall
does not re-write the command. In this case you should set C<ftp_ext_passive>
=back
-=for html <hr>
-
-I<$Id: //depot/libnet/Net/Config.pm#17 $>
-
=cut
use vars qw($VERSION @ISA @EXPORT_OK);
use Net::Config;
-@ISA = qw(Exporter);
+@ISA = qw(Exporter);
@EXPORT_OK = qw(hostname hostdomain hostfqdn domainname);
-$VERSION = "2.19_01"; # $Id: //depot/libnet/Net/Domain.pm#21 $
+$VERSION = "2.20";
-my($host,$domain,$fqdn) = (undef,undef,undef);
+my ($host, $domain, $fqdn) = (undef, undef, undef);
# Try every conceivable way to get hostname.
+
sub _hostname {
- # we already know it
- return $host
- if(defined $host);
-
- if ($^O eq 'MSWin32') {
- require Socket;
- my ($name,$alias,$type,$len,@addr) = gethostbyname($ENV{'COMPUTERNAME'}||'localhost');
- while (@addr)
- {
- my $a = shift(@addr);
- $host = gethostbyaddr($a,Socket::AF_INET());
- last if defined $host;
- }
- if (defined($host) && index($host,'.') > 0) {
- $fqdn = $host;
- ($host,$domain) = $fqdn =~ /^([^\.]+)\.(.*)$/;
- }
- return $host;
- }
- elsif ($^O eq 'MacOS') {
- chomp ($host = `hostname`);
+ # we already know it
+ return $host
+ if (defined $host);
+
+ if ($^O eq 'MSWin32') {
+ require Socket;
+ my ($name, $alias, $type, $len, @addr) = gethostbyname($ENV{'COMPUTERNAME'} || 'localhost');
+ while (@addr) {
+ my $a = shift(@addr);
+ $host = gethostbyaddr($a, Socket::AF_INET());
+ last if defined $host;
}
- elsif ($^O eq 'VMS') { ## multiple varieties of net s/w makes this hard
- $host = $ENV{'UCX$INET_HOST'} if defined($ENV{'UCX$INET_HOST'});
- $host = $ENV{'MULTINET_HOST_NAME'} if defined($ENV{'MULTINET_HOST_NAME'});
- if (index($host,'.') > 0) {
- $fqdn = $host;
- ($host,$domain) = $fqdn =~ /^([^\.]+)\.(.*)$/;
- }
- return $host;
+ if (defined($host) && index($host, '.') > 0) {
+ $fqdn = $host;
+ ($host, $domain) = $fqdn =~ /^([^\.]+)\.(.*)$/;
}
- else {
- local $SIG{'__DIE__'};
-
- # syscall is preferred since it avoids tainting problems
- eval {
- my $tmp = "\0" x 256; ## preload scalar
- eval {
- package main;
- require "syscall.ph";
- defined(&main::SYS_gethostname);
- }
- || eval {
- package main;
- require "sys/syscall.ph";
- defined(&main::SYS_gethostname);
- }
- and $host = (syscall(&main::SYS_gethostname, $tmp, 256) == 0)
- ? $tmp
- : undef;
- }
-
- # POSIX
- || eval {
- require POSIX;
- $host = (POSIX::uname())[1];
- }
-
- # trusty old hostname command
- || eval {
- chop($host = `(hostname) 2>/dev/null`); # BSD'ish
- }
-
- # sysV/POSIX uname command (may truncate)
- || eval {
- chop($host = `uname -n 2>/dev/null`); ## SYSV'ish && POSIX'ish
- }
-
- # Apollo pre-SR10
- || eval {
- $host = (split(/[:\. ]/,`/com/host`,6))[0];
- }
-
- || eval {
- $host = "";
- };
+ return $host;
+ }
+ elsif ($^O eq 'MacOS') {
+ chomp($host = `hostname`);
+ }
+ elsif ($^O eq 'VMS') { ## multiple varieties of net s/w makes this hard
+ $host = $ENV{'UCX$INET_HOST'} if defined($ENV{'UCX$INET_HOST'});
+ $host = $ENV{'MULTINET_HOST_NAME'} if defined($ENV{'MULTINET_HOST_NAME'});
+ if (index($host, '.') > 0) {
+ $fqdn = $host;
+ ($host, $domain) = $fqdn =~ /^([^\.]+)\.(.*)$/;
}
+ return $host;
+ }
+ else {
+ local $SIG{'__DIE__'};
- # remove garbage
- $host =~ s/[\0\r\n]+//go;
- $host =~ s/(\A\.+|\.+\Z)//go;
- $host =~ s/\.\.+/\./go;
-
- $host;
+ # syscall is preferred since it avoids tainting problems
+ eval {
+ my $tmp = "\0" x 256; ## preload scalar
+ eval {
+ package main;
+ require "syscall.ph";
+ defined(&main::SYS_gethostname);
+ }
+ || eval {
+ package main;
+ require "sys/syscall.ph";
+ defined(&main::SYS_gethostname);
+ }
+ and $host =
+ (syscall(&main::SYS_gethostname, $tmp, 256) == 0)
+ ? $tmp
+ : undef;
+ }
+
+ # POSIX
+ || eval {
+ require POSIX;
+ $host = (POSIX::uname())[1];
+ }
+
+ # trusty old hostname command
+ || eval {
+ chop($host = `(hostname) 2>/dev/null`); # BSD'ish
+ }
+
+ # sysV/POSIX uname command (may truncate)
+ || eval {
+ chop($host = `uname -n 2>/dev/null`); ## SYSV'ish && POSIX'ish
+ }
+
+ # Apollo pre-SR10
+ || eval { $host = (split(/[:\. ]/, `/com/host`, 6))[0]; }
+
+ || eval { $host = ""; };
+ }
+
+ # remove garbage
+ $host =~ s/[\0\r\n]+//go;
+ $host =~ s/(\A\.+|\.+\Z)//go;
+ $host =~ s/\.\.+/\./go;
+
+ $host;
}
+
sub _hostdomain {
- # we already know it
- return $domain
- if(defined $domain);
+ # we already know it
+ return $domain
+ if (defined $domain);
- local $SIG{'__DIE__'};
+ local $SIG{'__DIE__'};
+
+ return $domain = $NetConfig{'inet_domain'}
+ if defined $NetConfig{'inet_domain'};
+
+ # try looking in /etc/resolv.conf
+ # putting this here and assuming that it is correct, eliminates
+ # calls to gethostbyname, and therefore DNS lookups. This helps
+ # those on dialup systems.
+
+ local *RES;
+ local ($_);
- return $domain = $NetConfig{'inet_domain'}
- if defined $NetConfig{'inet_domain'};
+ if (open(RES, "/etc/resolv.conf")) {
+ while (<RES>) {
+ $domain = $1
+ if (/\A\s*(?:domain|search)\s+(\S+)/);
+ }
+ close(RES);
+
+ return $domain
+ if (defined $domain);
+ }
- # try looking in /etc/resolv.conf
- # putting this here and assuming that it is correct, eliminates
- # calls to gethostbyname, and therefore DNS lookups. This helps
- # those on dialup systems.
+ # just try hostname and system calls
- local *RES;
- local($_);
+ my $host = _hostname();
+ my (@hosts);
- if(open(RES,"/etc/resolv.conf")) {
- while(<RES>) {
- $domain = $1
- if(/\A\s*(?:domain|search)\s+(\S+)/);
- }
- close(RES);
+ @hosts = ($host, "localhost");
- return $domain
- if(defined $domain);
+ unless (defined($host) && $host =~ /\./) {
+ my $dom = undef;
+ eval {
+ my $tmp = "\0" x 256; ## preload scalar
+ eval {
+ package main;
+ require "syscall.ph";
+ }
+ || eval {
+ package main;
+ require "sys/syscall.ph";
+ }
+ and $dom =
+ (syscall(&main::SYS_getdomainname, $tmp, 256) == 0)
+ ? $tmp
+ : undef;
+ };
+
+ if ($^O eq 'VMS') {
+ $dom ||= $ENV{'TCPIP$INET_DOMAIN'}
+ || $ENV{'UCX$INET_DOMAIN'};
}
- # just try hostname and system calls
-
- my $host = _hostname();
- my(@hosts);
-
- @hosts = ($host,"localhost");
-
- unless (defined($host) && $host =~ /\./) {
- my $dom = undef;
- eval {
- my $tmp = "\0" x 256; ## preload scalar
- eval {
- package main;
- require "syscall.ph";
- }
- || eval {
- package main;
- require "sys/syscall.ph";
- }
- and $dom = (syscall(&main::SYS_getdomainname, $tmp, 256) == 0)
- ? $tmp
- : undef;
- };
-
- if ( $^O eq 'VMS' ) {
- $dom ||= $ENV{'TCPIP$INET_DOMAIN'}
- || $ENV{'UCX$INET_DOMAIN'};
- }
-
- chop($dom = `domainname 2>/dev/null`)
- unless(defined $dom || $^O =~ /^(?:cygwin|MSWin32)/);
-
- if(defined $dom) {
- my @h = ();
- $dom =~ s/^\.+//;
- while(length($dom)) {
- push(@h, "$host.$dom");
- $dom =~ s/^[^.]+.+// or last;
- }
- unshift(@hosts,@h);
- }
+ chop($dom = `domainname 2>/dev/null`)
+ unless (defined $dom || $^O =~ /^(?:cygwin|MSWin32)/);
+
+ if (defined $dom) {
+ my @h = ();
+ $dom =~ s/^\.+//;
+ while (length($dom)) {
+ push(@h, "$host.$dom");
+ $dom =~ s/^[^.]+.+// or last;
+ }
+ unshift(@hosts, @h);
}
+ }
- # Attempt to locate FQDN
+ # Attempt to locate FQDN
- foreach (grep {defined $_} @hosts) {
- my @info = gethostbyname($_);
+ foreach (grep { defined $_ } @hosts) {
+ my @info = gethostbyname($_);
- next unless @info;
+ next unless @info;
- # look at real name & aliases
- my $site;
- foreach $site ($info[0], split(/ /,$info[1])) {
- if(rindex($site,".") > 0) {
+ # look at real name & aliases
+ my $site;
+ foreach $site ($info[0], split(/ /, $info[1])) {
+ if (rindex($site, ".") > 0) {
- # Extract domain from FQDN
+ # Extract domain from FQDN
- ($domain = $site) =~ s/\A[^\.]+\.//;
- return $domain;
- }
- }
+ ($domain = $site) =~ s/\A[^\.]+\.//;
+ return $domain;
+ }
}
+ }
- # Look for environment variable
+ # Look for environment variable
- $domain ||= $ENV{LOCALDOMAIN} || $ENV{DOMAIN};
+ $domain ||= $ENV{LOCALDOMAIN} || $ENV{DOMAIN};
- if(defined $domain) {
- $domain =~ s/[\r\n\0]+//g;
- $domain =~ s/(\A\.+|\.+\Z)//g;
- $domain =~ s/\.\.+/\./g;
- }
+ if (defined $domain) {
+ $domain =~ s/[\r\n\0]+//g;
+ $domain =~ s/(\A\.+|\.+\Z)//g;
+ $domain =~ s/\.\.+/\./g;
+ }
- $domain;
+ $domain;
}
+
sub domainname {
- return $fqdn
- if(defined $fqdn);
+ return $fqdn
+ if (defined $fqdn);
- _hostname();
- _hostdomain();
+ _hostname();
+ _hostdomain();
- # Assumption: If the host name does not contain a period
- # and the domain name does, then assume that they are correct
- # this helps to eliminate calls to gethostbyname, and therefore
- # eleminate DNS lookups
+ # Assumption: If the host name does not contain a period
+ # and the domain name does, then assume that they are correct
+ # this helps to eliminate calls to gethostbyname, and therefore
+ # eleminate DNS lookups
- return $fqdn = $host . "." . $domain
- if(defined $host and defined $domain
- and $host !~ /\./ and $domain =~ /\./);
+ return $fqdn = $host . "." . $domain
+ if (defined $host
+ and defined $domain
+ and $host !~ /\./
+ and $domain =~ /\./);
- # For hosts that have no name, just an IP address
- return $fqdn = $host if defined $host and $host =~ /^\d+(\.\d+){3}$/;
+ # For hosts that have no name, just an IP address
+ return $fqdn = $host if defined $host and $host =~ /^\d+(\.\d+){3}$/;
- my @host = defined $host ? split(/\./, $host) : ('localhost');
- my @domain = defined $domain ? split(/\./, $domain) : ();
- my @fqdn = ();
+ my @host = defined $host ? split(/\./, $host) : ('localhost');
+ my @domain = defined $domain ? split(/\./, $domain) : ();
+ my @fqdn = ();
- # Determine from @host & @domain the FQDN
+ # Determine from @host & @domain the FQDN
- my @d = @domain;
+ 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;
+ 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;
+ if (@fqdn) {
+ $host = shift @fqdn;
+ until ((gethostbyname($host))[0]) {
+ $host .= "." . shift @fqdn;
}
-
- $fqdn;
+ $domain = join(".", @fqdn);
+ }
+ else {
+ undef $host;
+ undef $domain;
+ undef $fqdn;
+ }
+
+ $fqdn;
}
+
sub hostfqdn { domainname() }
+
sub hostname {
- domainname()
- unless(defined $host);
- return $host;
+ domainname()
+ unless (defined $host);
+ return $host;
}
+
sub hostdomain {
- domainname()
- unless(defined $domain);
- return $domain;
+ domainname()
+ unless (defined $domain);
+ return $domain;
}
-1; # Keep require happy
+1; # Keep require happy
__END__
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
-=for html <hr>
-
-I<$Id: //depot/libnet/Net/Domain.pm#21 $>
-
=cut
use Net::Cmd;
use Net::Config;
use Fcntl qw(O_WRONLY O_RDONLY O_APPEND O_CREAT O_TRUNC);
-# use AutoLoader qw(AUTOLOAD);
-$VERSION = "2.77_01";
+$VERSION = '2.77';
@ISA = qw(Exporter Net::Cmd IO::Socket::INET);
# Someday I will "use constant", when I am not bothered to much about
# compatability with older releases of perl
use vars qw($TELNET_IAC $TELNET_IP $TELNET_DM);
-($TELNET_IAC,$TELNET_IP,$TELNET_DM) = (255,244,242);
+($TELNET_IAC, $TELNET_IP, $TELNET_DM) = (255, 244, 242);
-# Name is too long for AutoLoad, it clashes with pasv_xfer
-sub pasv_xfer_unique {
- my($sftp,$sfile,$dftp,$dfile) = @_;
- $sftp->pasv_xfer($sfile,$dftp,$dfile,1);
-}
BEGIN {
+
# make a constant so code is fast'ish
my $is_os390 = $^O eq 'os390';
- *trEBCDIC = sub () { $is_os390 }
+ *trEBCDIC = sub () {$is_os390}
}
-1;
-# Having problems with AutoLoader
-#__END__
-
-sub new
-{
- my $pkg = shift;
- my ($peer,%arg);
- if (@_ % 2) {
- $peer = shift ;
- %arg = @_;
- } else {
- %arg = @_;
- $peer=delete $arg{Host};
- }
-
- my $host = $peer;
- my $fire = undef;
- my $fire_type = undef;
-
- if(exists($arg{Firewall}) || Net::Config->requires_firewall($peer))
- {
- $fire = $arg{Firewall}
- || $ENV{FTP_FIREWALL}
- || $NetConfig{ftp_firewall}
- || undef;
-
- if(defined $fire)
- {
- $peer = $fire;
- delete $arg{Port};
- $fire_type = $arg{FirewallType}
- || $ENV{FTP_FIREWALL_TYPE}
- || $NetConfig{firewall_type}
- || undef;
+
+sub new {
+ my $pkg = shift;
+ my ($peer, %arg);
+ if (@_ % 2) {
+ $peer = shift;
+ %arg = @_;
+ }
+ else {
+ %arg = @_;
+ $peer = delete $arg{Host};
+ }
+
+ my $host = $peer;
+ my $fire = undef;
+ my $fire_type = undef;
+
+ if (exists($arg{Firewall}) || Net::Config->requires_firewall($peer)) {
+ $fire = $arg{Firewall}
+ || $ENV{FTP_FIREWALL}
+ || $NetConfig{ftp_firewall}
+ || undef;
+
+ if (defined $fire) {
+ $peer = $fire;
+ delete $arg{Port};
+ $fire_type = $arg{FirewallType}
+ || $ENV{FTP_FIREWALL_TYPE}
+ || $NetConfig{firewall_type}
+ || undef;
}
}
- my $ftp = $pkg->SUPER::new(PeerAddr => $peer,
- PeerPort => $arg{Port} || 'ftp(21)',
- LocalAddr => $arg{'LocalAddr'},
- Proto => 'tcp',
- Timeout => defined $arg{Timeout}
- ? $arg{Timeout}
- : 120
- ) or return undef;
+ my $ftp = $pkg->SUPER::new(
+ PeerAddr => $peer,
+ PeerPort => $arg{Port} || 'ftp(21)',
+ LocalAddr => $arg{'LocalAddr'},
+ Proto => 'tcp',
+ Timeout => defined $arg{Timeout}
+ ? $arg{Timeout}
+ : 120
+ )
+ or return undef;
- ${*$ftp}{'net_ftp_host'} = $host; # Remote hostname
- ${*$ftp}{'net_ftp_type'} = 'A'; # ASCII/binary/etc mode
- ${*$ftp}{'net_ftp_blksize'} = abs($arg{'BlockSize'} || 10240);
+ ${*$ftp}{'net_ftp_host'} = $host; # Remote hostname
+ ${*$ftp}{'net_ftp_type'} = 'A'; # ASCII/binary/etc mode
+ ${*$ftp}{'net_ftp_blksize'} = abs($arg{'BlockSize'} || 10240);
- ${*$ftp}{'net_ftp_localaddr'} = $arg{'LocalAddr'};
+ ${*$ftp}{'net_ftp_localaddr'} = $arg{'LocalAddr'};
- ${*$ftp}{'net_ftp_firewall'} = $fire
- if(defined $fire);
- ${*$ftp}{'net_ftp_firewall_type'} = $fire_type
- if(defined $fire_type);
+ ${*$ftp}{'net_ftp_firewall'} = $fire
+ if (defined $fire);
+ ${*$ftp}{'net_ftp_firewall_type'} = $fire_type
+ if (defined $fire_type);
- ${*$ftp}{'net_ftp_passive'} = int
- exists $arg{Passive}
- ? $arg{Passive}
- : exists $ENV{FTP_PASSIVE}
- ? $ENV{FTP_PASSIVE}
- : defined $fire
- ? $NetConfig{ftp_ext_passive}
- : $NetConfig{ftp_int_passive}; # Whew! :-)
+ ${*$ftp}{'net_ftp_passive'} =
+ int exists $arg{Passive} ? $arg{Passive}
+ : exists $ENV{FTP_PASSIVE} ? $ENV{FTP_PASSIVE}
+ : defined $fire ? $NetConfig{ftp_ext_passive}
+ : $NetConfig{ftp_int_passive}; # Whew! :-)
- $ftp->hash(exists $arg{Hash} ? $arg{Hash} : 0, 1024);
+ $ftp->hash(exists $arg{Hash} ? $arg{Hash} : 0, 1024);
- $ftp->autoflush(1);
+ $ftp->autoflush(1);
- $ftp->debug(exists $arg{Debug} ? $arg{Debug} : undef);
+ $ftp->debug(exists $arg{Debug} ? $arg{Debug} : undef);
- unless ($ftp->response() == CMD_OK)
- {
- $ftp->close();
- $@ = $ftp->message;
- undef $ftp;
+ unless ($ftp->response() == CMD_OK) {
+ $ftp->close();
+ $@ = $ftp->message;
+ undef $ftp;
}
- $ftp;
+ $ftp;
}
##
sub host {
- my $me = shift;
- ${*$me}{'net_ftp_host'};
+ my $me = shift;
+ ${*$me}{'net_ftp_host'};
}
sub hash {
- my $ftp = shift; # self
+ my $ftp = shift; # self
- my($h,$b) = @_;
- unless($h) {
- delete ${*$ftp}{'net_ftp_hash'};
- return [\*STDERR,0];
- }
- ($h,$b) = (ref($h)? $h : \*STDERR, $b || 1024);
- select((select($h), $|=1)[0]);
- $b = 512 if $b < 512;
- ${*$ftp}{'net_ftp_hash'} = [$h, $b];
-}
-
-sub quit
-{
- my $ftp = shift;
-
- $ftp->_QUIT;
- $ftp->close;
+ my ($h, $b) = @_;
+ unless ($h) {
+ delete ${*$ftp}{'net_ftp_hash'};
+ return [\*STDERR, 0];
+ }
+ ($h, $b) = (ref($h) ? $h : \*STDERR, $b || 1024);
+ select((select($h), $| = 1)[0]);
+ $b = 512 if $b < 512;
+ ${*$ftp}{'net_ftp_hash'} = [$h, $b];
}
-sub DESTROY {}
-sub ascii { shift->type('A',@_); }
-sub binary { shift->type('I',@_); }
+sub quit {
+ my $ftp = shift;
-sub ebcdic
-{
- carp "TYPE E is unsupported, shall default to I";
- shift->type('E',@_);
+ $ftp->_QUIT;
+ $ftp->close;
}
-sub byte
-{
- carp "TYPE L is unsupported, shall default to I";
- shift->type('L',@_);
+
+sub DESTROY { }
+
+
+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 quot {
+ my $ftp = shift;
+ my $cmd = shift;
+
+ $ftp->command(uc $cmd, @_);
+ $ftp->response();
}
-sub site
-{
- my $ftp = shift;
- $ftp->command("SITE", @_);
- $ftp->response();
+sub site {
+ my $ftp = shift;
+
+ $ftp->command("SITE", @_);
+ $ftp->response();
}
-sub mdtm
-{
- my $ftp = shift;
- my $file = shift;
-
- # Server Y2K bug workaround
- #
- # sigh; some idiotic FTP servers use ("19%d",tm.tm_year) instead of
- # ("%d",tm.tm_year+1900). This results in an extra digit in the
- # string returned. To account for this we allow an optional extra
- # digit in the year. Then if the first two digits are 19 we use the
- # remainder, otherwise we subtract 1900 from the whole year.
-
- $ftp->_MDTM($file) && $ftp->message =~ /((\d\d)(\d\d\d?))(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/
- ? timegm($8,$7,$6,$5,$4-1,$2 eq '19' ? $3 : ($1-1900))
+
+sub mdtm {
+ my $ftp = shift;
+ my $file = shift;
+
+ # Server Y2K bug workaround
+ #
+ # sigh; some idiotic FTP servers use ("19%d",tm.tm_year) instead of
+ # ("%d",tm.tm_year+1900). This results in an extra digit in the
+ # string returned. To account for this we allow an optional extra
+ # digit in the year. Then if the first two digits are 19 we use the
+ # remainder, otherwise we subtract 1900 from the whole year.
+
+ $ftp->_MDTM($file)
+ && $ftp->message =~ /((\d\d)(\d\d\d?))(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/
+ ? timegm($8, $7, $6, $5, $4 - 1, $2 eq '19' ? $3 : ($1 - 1900))
: undef;
}
+
sub size {
my $ftp = shift;
my $file = shift;
my $io;
- if($ftp->supported("SIZE")) {
+ if ($ftp->supported("SIZE")) {
return $ftp->_SIZE($file)
- ? ($ftp->message =~ /(\d+)\s*(bytes?\s*)?$/)[0]
- : undef;
- }
- elsif($ftp->supported("STAT")) {
- my @msg;
- return undef
- unless $ftp->_STAT($file) && (@msg = $ftp->message) == 3;
- my $line;
- foreach $line (@msg) {
- return (split(/\s+/,$line))[4]
- if $line =~ /^[-rwxSsTt]{10}/
- }
- }
- else {
- my @files = $ftp->dir($file);
- if(@files) {
- return (split(/\s+/,$1))[4]
- if $files[0] =~ /^([-rwxSsTt]{10}.*)$/;
- }
- }
- undef;
+ ? ($ftp->message =~ /(\d+)\s*(bytes?\s*)?$/)[0]
+ : undef;
+ }
+ elsif ($ftp->supported("STAT")) {
+ my @msg;
+ return undef
+ unless $ftp->_STAT($file) && (@msg = $ftp->message) == 3;
+ my $line;
+ foreach $line (@msg) {
+ return (split(/\s+/, $line))[4]
+ if $line =~ /^[-rwxSsTt]{10}/;
+ }
+ }
+ else {
+ my @files = $ftp->dir($file);
+ if (@files) {
+ return (split(/\s+/, $1))[4]
+ if $files[0] =~ /^([-rwxSsTt]{10}.*)$/;
+ }
+ }
+ undef;
}
+
sub login {
- my($ftp,$user,$pass,$acct) = @_;
- my($ok,$ruser,$fwtype);
+ my ($ftp, $user, $pass, $acct) = @_;
+ my ($ok, $ruser, $fwtype);
unless (defined $user) {
require Net::Netrc;
my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'});
- ($user,$pass,$acct) = $rc->lpa()
- if ($rc);
- }
+ ($user, $pass, $acct) = $rc->lpa()
+ if ($rc);
+ }
$user ||= "anonymous";
$ruser = $user;
$fwtype = ${*$ftp}{'net_ftp_firewall_type'}
- || $NetConfig{'ftp_firewall_type'}
- || 0;
+ || $NetConfig{'ftp_firewall_type'}
+ || 0;
if ($fwtype && defined ${*$ftp}{'net_ftp_firewall'}) {
if ($fwtype == 1 || $fwtype == 7) {
my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});
- my($fwuser,$fwpass,$fwacct) = $rc ? $rc->lpa() : ();
+ my ($fwuser, $fwpass, $fwacct) = $rc ? $rc->lpa() : ();
if ($fwtype == 5) {
- $user = join('@',$user,$fwuser,${*$ftp}{'net_ftp_host'});
- $pass = $pass . '@' . $fwpass;
+ $user = join('@', $user, $fwuser, ${*$ftp}{'net_ftp_host'});
+ $pass = $pass . '@' . $fwpass;
}
else {
- if ($fwtype == 2) {
- $user .= '@' . ${*$ftp}{'net_ftp_host'};
- }
- elsif ($fwtype == 6) {
- $fwuser .= '@' . ${*$ftp}{'net_ftp_host'};
- }
+ if ($fwtype == 2) {
+ $user .= '@' . ${*$ftp}{'net_ftp_host'};
+ }
+ elsif ($fwtype == 6) {
+ $fwuser .= '@' . ${*$ftp}{'net_ftp_host'};
+ }
- $ok = $ftp->_USER($fwuser);
+ $ok = $ftp->_USER($fwuser);
- return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
+ return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
- $ok = $ftp->_PASS($fwpass || "");
+ $ok = $ftp->_PASS($fwpass || "");
- return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
+ return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
- $ok = $ftp->_ACCT($fwacct)
- if defined($fwacct);
+ $ok = $ftp->_ACCT($fwacct)
+ if defined($fwacct);
- if ($fwtype == 3) {
- $ok = $ftp->command("SITE",${*$ftp}{'net_ftp_host'})->response;
- }
- elsif ($fwtype == 4) {
- $ok = $ftp->command("OPEN",${*$ftp}{'net_ftp_host'})->response;
- }
+ if ($fwtype == 3) {
+ $ok = $ftp->command("SITE", ${*$ftp}{'net_ftp_host'})->response;
+ }
+ elsif ($fwtype == 4) {
+ $ok = $ftp->command("OPEN", ${*$ftp}{'net_ftp_host'})->response;
+ }
- return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
+ return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
}
}
}
# Some dumb firewalls don't prefix the connection messages
$ok = $ftp->response()
- if ($ok == CMD_OK && $ftp->code == 220 && $user =~ /\@/);
+ if ($ok == CMD_OK && $ftp->code == 220 && $user =~ /\@/);
if ($ok == CMD_MORE) {
- unless(defined $pass) {
+ unless (defined $pass) {
require Net::Netrc;
my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'}, $ruser);
- ($ruser,$pass,$acct) = $rc->lpa()
- if ($rc);
+ ($ruser, $pass, $acct) = $rc->lpa()
+ if ($rc);
$pass = '-anonymous@'
- if (!defined $pass && (!defined($ruser) || $ruser =~ /^anonymous/o));
+ if (!defined $pass && (!defined($ruser) || $ruser =~ /^anonymous/o));
}
$ok = $ftp->_PASS($pass || "");
}
$ok = $ftp->_ACCT($acct)
- if (defined($acct) && ($ok == CMD_MORE || $ok == CMD_OK));
+ if (defined($acct) && ($ok == CMD_MORE || $ok == CMD_OK));
if ($fwtype == 7 && $ok == CMD_OK && defined ${*$ftp}{'net_ftp_firewall'}) {
- my($f,$auth,$resp) = _auth_id($ftp);
- $ftp->authorize($auth,$resp) if defined($resp);
+ my ($f, $auth, $resp) = _auth_id($ftp);
+ $ftp->authorize($auth, $resp) if defined($resp);
}
$ok == CMD_OK;
}
-sub account
-{
- @_ == 2 or croak 'usage: $ftp->account( ACCT )';
- my $ftp = shift;
- my $acct = shift;
- $ftp->_ACCT($acct) == CMD_OK;
+
+sub account {
+ @_ == 2 or croak 'usage: $ftp->account( ACCT )';
+ my $ftp = shift;
+ my $acct = shift;
+ $ftp->_ACCT($acct) == CMD_OK;
}
+
sub _auth_id {
- my($ftp,$auth,$resp) = @_;
+ my ($ftp, $auth, $resp) = @_;
- unless(defined $resp)
- {
- require Net::Netrc;
+ unless (defined $resp) {
+ require Net::Netrc;
- $auth ||= eval { (getpwuid($>))[0] } || $ENV{NAME};
+ $auth ||= eval { (getpwuid($>))[0] } || $ENV{NAME};
- my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}, $auth)
- || Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});
+ my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}, $auth)
+ || Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});
- ($auth,$resp) = $rc->lpa()
- if ($rc);
+ ($auth, $resp) = $rc->lpa()
+ if ($rc);
}
- ($ftp,$auth,$resp);
+ ($ftp, $auth, $resp);
}
-sub authorize
-{
- @_ >= 1 || @_ <= 3 or croak 'usage: $ftp->authorize( [AUTH [, RESP]])';
- my($ftp,$auth,$resp) = &_auth_id;
+sub authorize {
+ @_ >= 1 || @_ <= 3 or croak 'usage: $ftp->authorize( [AUTH [, RESP]])';
+
+ my ($ftp, $auth, $resp) = &_auth_id;
- my $ok = $ftp->_AUTH($auth || "");
+ my $ok = $ftp->_AUTH($auth || "");
- $ok = $ftp->_RESP($resp || "")
- if ($ok == CMD_MORE);
+ $ok = $ftp->_RESP($resp || "")
+ if ($ok == CMD_MORE);
- $ok == CMD_OK;
+ $ok == CMD_OK;
}
-sub rename
-{
- @_ == 3 or croak 'usage: $ftp->rename(FROM, TO)';
- my($ftp,$from,$to) = @_;
+sub rename {
+ @_ == 3 or croak 'usage: $ftp->rename(FROM, TO)';
- $ftp->_RNFR($from)
+ 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);
+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,@_));
+ return undef
+ unless ($ftp->_TYPE($type, @_));
- ${*$ftp}{'net_ftp_type'} = join(" ",$type,@_);
+ ${*$ftp}{'net_ftp_type'} = join(" ", $type, @_);
- $oldval;
+ $oldval;
}
-sub alloc
-{
- my $ftp = shift;
- my $size = shift;
- my $oldval = ${*$ftp}{'net_ftp_allo'};
- return $oldval
- unless (defined $size);
+sub alloc {
+ my $ftp = shift;
+ my $size = shift;
+ my $oldval = ${*$ftp}{'net_ftp_allo'};
+
+ return $oldval
+ unless (defined $size);
- return undef
- unless ($ftp->_ALLO($size,@_));
+ return undef
+ unless ($ftp->_ALLO($size, @_));
- ${*$ftp}{'net_ftp_allo'} = join(" ",$size,@_);
+ ${*$ftp}{'net_ftp_allo'} = join(" ", $size, @_);
- $oldval;
+ $oldval;
}
-sub abort
-{
- my $ftp = shift;
- send($ftp,pack("CCC", $TELNET_IAC, $TELNET_IP, $TELNET_IAC),MSG_OOB);
+sub abort {
+ my $ftp = shift;
+
+ send($ftp, pack("CCC", $TELNET_IAC, $TELNET_IP, $TELNET_IAC), MSG_OOB);
- $ftp->command(pack("C",$TELNET_DM) . "ABOR");
+ $ftp->command(pack("C", $TELNET_DM) . "ABOR");
- ${*$ftp}{'net_ftp_dataconn'}->close()
+ ${*$ftp}{'net_ftp_dataconn'}->close()
if defined ${*$ftp}{'net_ftp_dataconn'};
- $ftp->response();
+ $ftp->response();
- $ftp->status == CMD_OK;
+ $ftp->status == CMD_OK;
}
-sub get
-{
- my($ftp,$remote,$local,$where) = @_;
- my($loc,$len,$buf,$resp,$data);
- local *FD;
+sub get {
+ my ($ftp, $remote, $local, $where) = @_;
- my $localfd = ref($local) || ref(\$local) eq "GLOB";
+ my ($loc, $len, $buf, $resp, $data);
+ local *FD;
- ($local = $remote) =~ s#^.*/##
- unless(defined $local);
+ my $localfd = ref($local) || ref(\$local) eq "GLOB";
- croak("Bad remote filename '$remote'\n")
- if $remote =~ /[\r\n]/s;
+ ($local = $remote) =~ s#^.*/##
+ unless (defined $local);
- ${*$ftp}{'net_ftp_rest'} = $where if defined $where;
+ croak("Bad remote filename '$remote'\n")
+ if $remote =~ /[\r\n]/s;
+
+ ${*$ftp}{'net_ftp_rest'} = $where if defined $where;
my $rest = ${*$ftp}{'net_ftp_rest'};
- delete ${*$ftp}{'net_ftp_port'};
- delete ${*$ftp}{'net_ftp_pasv'};
+ delete ${*$ftp}{'net_ftp_port'};
+ delete ${*$ftp}{'net_ftp_pasv'};
- $data = $ftp->retr($remote) or
- return undef;
+ $data = $ftp->retr($remote)
+ or return undef;
- if($localfd)
- {
- $loc = $local;
+ if ($localfd) {
+ $loc = $local;
}
- else
- {
- $loc = \*FD;
+ else {
+ $loc = \*FD;
- unless(sysopen($loc, $local, O_CREAT | O_WRONLY | ($rest ? O_APPEND : O_TRUNC)))
- {
- carp "Cannot open Local file $local: $!\n";
- $data->abort;
- return undef;
+ unless (sysopen($loc, $local, O_CREAT | O_WRONLY | ($rest ? O_APPEND: O_TRUNC))) {
+ carp "Cannot open Local file $local: $!\n";
+ $data->abort;
+ return undef;
}
}
- if($ftp->type eq 'I' && !binmode($loc))
- {
- carp "Cannot binmode Local file $local: $!\n";
- $data->abort;
- close($loc) unless $localfd;
- return undef;
+ if ($ftp->type eq 'I' && !binmode($loc)) {
+ carp "Cannot binmode Local file $local: $!\n";
+ $data->abort;
+ close($loc) unless $localfd;
+ return undef;
}
- $buf = '';
- my($count,$hashh,$hashb,$ref) = (0);
+ $buf = '';
+ my ($count, $hashh, $hashb, $ref) = (0);
- ($hashh,$hashb) = @$ref
- if($ref = ${*$ftp}{'net_ftp_hash'});
+ ($hashh, $hashb) = @$ref
+ if ($ref = ${*$ftp}{'net_ftp_hash'});
- my $blksize = ${*$ftp}{'net_ftp_blksize'};
- local $\; # Just in case
+ my $blksize = ${*$ftp}{'net_ftp_blksize'};
+ local $\; # Just in case
- while(1)
- {
- last unless $len = $data->read($buf,$blksize);
+ while (1) {
+ last unless $len = $data->read($buf, $blksize);
- if (trEBCDIC && $ftp->type ne 'I')
- {
- $buf = $ftp->toebcdic($buf);
- $len = length($buf);
+ if (trEBCDIC && $ftp->type ne 'I') {
+ $buf = $ftp->toebcdic($buf);
+ $len = length($buf);
}
- if($hashh) {
- $count += $len;
- print $hashh "#" x (int($count / $hashb));
- $count %= $hashb;
- }
- unless(print $loc $buf)
- {
- carp "Cannot write to Local file $local: $!\n";
- $data->abort;
- close($loc)
+ if ($hashh) {
+ $count += $len;
+ print $hashh "#" x (int($count / $hashb));
+ $count %= $hashb;
+ }
+ unless (print $loc $buf) {
+ carp "Cannot write to Local file $local: $!\n";
+ $data->abort;
+ close($loc)
unless $localfd;
- return undef;
+ return undef;
}
}
- print $hashh "\n" if $hashh;
+ print $hashh "\n" if $hashh;
- unless ($localfd)
- {
- unless (close($loc))
- {
- carp "Cannot close file $local (perhaps disk space) $!\n";
- return undef;
+ unless ($localfd) {
+ unless (close($loc)) {
+ carp "Cannot close file $local (perhaps disk space) $!\n";
+ return undef;
}
}
- unless ($data->close()) # implied $ftp->response
+ unless ($data->close()) # implied $ftp->response
{
- carp "Unable to close datastream";
- return undef;
+ carp "Unable to close datastream";
+ return undef;
}
- return $local;
+ return $local;
}
-sub cwd
-{
- @_ == 1 || @_ == 2 or croak 'usage: $ftp->cwd( [ DIR ] )';
- my($ftp,$dir) = @_;
+sub cwd {
+ @_ == 1 || @_ == 2 or croak 'usage: $ftp->cwd( [ DIR ] )';
+
+ my ($ftp, $dir) = @_;
- $dir = "/" unless defined($dir) && $dir =~ /\S/;
+ $dir = "/" unless defined($dir) && $dir =~ /\S/;
- $dir eq ".."
+ $dir eq ".."
? $ftp->_CDUP()
: $ftp->_CWD($dir);
}
-sub cdup
-{
- @_ == 1 or croak 'usage: $ftp->cdup()';
- $_[0]->_CDUP;
+
+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 pwd {
+ @_ == 1 || croak 'usage: $ftp->pwd()';
+ my $ftp = shift;
+
+ $ftp->_PWD();
+ $ftp->_extract_path;
}
# rmdir( $ftp, $dir, [ $recurse ] )
#
# Initial version contributed by Dinkum Software
#
-sub rmdir
-{
- @_ == 2 || @_ == 3 or croak('usage: $ftp->rmdir( DIR [, RECURSE ] )');
+sub rmdir {
+ @_ == 2 || @_ == 3 or croak('usage: $ftp->rmdir( DIR [, RECURSE ] )');
- # Pick off the args
- my ($ftp, $dir, $recurse) = @_ ;
- my $ok;
+ # Pick off the args
+ my ($ftp, $dir, $recurse) = @_;
+ my $ok;
- return $ok
- if $ok = $ftp->_RMD( $dir ) or !$recurse;
+ return $ok
+ if $ok = $ftp->_RMD($dir)
+ or !$recurse;
- # Try to delete the contents
- # Get a list of all the files in the directory
- my @filelist = grep { !/^\.{1,2}$/ } $ftp->ls($dir);
+ # Try to delete the contents
+ # Get a list of all the files in the directory
+ my @filelist = grep { !/^\.{1,2}$/ } $ftp->ls($dir);
- return undef
- unless @filelist; # failed, it is probably not a directory
-
- # Go thru and delete each file or the directory
- my $file;
- foreach $file (map { m,/, ? $_ : "$dir/$_" } @filelist)
- {
- next # successfully deleted the file
- if $ftp->delete($file);
-
- # Failed to delete it, assume its a directory
- # Recurse and ignore errors, the final rmdir() will
- # fail on any errors here
- return $ok
- unless $ok = $ftp->rmdir($file, 1) ;
- }
+ return undef
+ unless @filelist; # failed, it is probably not a directory
- # Directory should be empty
- # Try to remove the directory again
- # Pass results directly to caller
- # If any of the prior deletes failed, this
- # rmdir() will fail because directory is not empty
- return $ftp->_RMD($dir) ;
+ # Go thru and delete each file or the directory
+ my $file;
+ foreach $file (map { m,/, ? $_ : "$dir/$_" } @filelist) {
+ next # successfully deleted the file
+ if $ftp->delete($file);
+
+ # Failed to delete it, assume its a directory
+ # Recurse and ignore errors, the final rmdir() will
+ # fail on any errors here
+ return $ok
+ unless $ok = $ftp->rmdir($file, 1);
+ }
+
+ # Directory should be empty
+ # Try to remove the directory again
+ # Pass results directly to caller
+ # If any of the prior deletes failed, this
+ # rmdir() will fail because directory is not empty
+ return $ftp->_RMD($dir);
}
-sub restart
-{
+
+sub restart {
@_ == 2 || croak 'usage: $ftp->restart( BYTE_OFFSET )';
- my($ftp,$where) = @_;
+ my ($ftp, $where) = @_;
${*$ftp}{'net_ftp_rest'} = $where;
}
-sub mkdir
-{
- @_ == 2 || @_ == 3 or croak 'usage: $ftp->mkdir( DIR [, RECURSE ] )';
+sub mkdir {
+ @_ == 2 || @_ == 3 or croak 'usage: $ftp->mkdir( DIR [, RECURSE ] )';
- my($ftp,$dir,$recurse) = @_;
+ my ($ftp, $dir, $recurse) = @_;
- $ftp->_MKD($dir) || $recurse or
- return undef;
+ $ftp->_MKD($dir) || $recurse
+ or return undef;
- my $path = $dir;
+ my $path = $dir;
- unless($ftp->ok)
- {
- my @path = split(m#(?=/+)#, $dir);
+ unless ($ftp->ok) {
+ my @path = split(m#(?=/+)#, $dir);
- $path = "";
+ $path = "";
- while(@path)
- {
- $path .= shift @path;
+ while (@path) {
+ $path .= shift @path;
- $ftp->_MKD($path);
+ $ftp->_MKD($path);
- $path = $ftp->_extract_path($path);
+ $path = $ftp->_extract_path($path);
}
- # If the creation of the last element was not successful, see if we
- # can cd to it, if so then return path
+ # If the creation of the last element was not successful, see if we
+ # can cd to it, if so then return path
- unless($ftp->ok)
- {
- my($status,$message) = ($ftp->status,$ftp->message);
- my $pwd = $ftp->pwd;
+ unless ($ftp->ok) {
+ my ($status, $message) = ($ftp->status, $ftp->message);
+ my $pwd = $ftp->pwd;
- if($pwd && $ftp->cwd($dir))
- {
- $path = $dir;
- $ftp->cwd($pwd);
+ if ($pwd && $ftp->cwd($dir)) {
+ $path = $dir;
+ $ftp->cwd($pwd);
}
- else
- {
- undef $path;
+ else {
+ undef $path;
}
- $ftp->set_status($status,$message);
+ $ftp->set_status($status, $message);
}
}
- $path;
+ $path;
}
-sub delete
-{
- @_ == 2 || croak 'usage: $ftp->delete( FILENAME )';
- $_[0]->_DELE($_[1]);
+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 put { shift->_store_cmd("stor", @_) }
+sub put_unique { shift->_store_cmd("stou", @_) }
+sub append { shift->_store_cmd("appe", @_) }
-sub _store_cmd
-{
- my($ftp,$cmd,$local,$remote) = @_;
- my($loc,$sock,$len,$buf);
- local *FD;
- my $localfd = ref($local) || ref(\$local) eq "GLOB";
+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", @_) }
- unless(defined $remote)
- {
- croak 'Must specify remote filename with stream input'
- if $localfd;
- require File::Basename;
- $remote = File::Basename::basename($local);
+sub _store_cmd {
+ my ($ftp, $cmd, $local, $remote) = @_;
+ my ($loc, $sock, $len, $buf);
+ local *FD;
+
+ my $localfd = ref($local) || ref(\$local) eq "GLOB";
+
+ unless (defined $remote) {
+ croak 'Must specify remote filename with stream input'
+ if $localfd;
+
+ require File::Basename;
+ $remote = File::Basename::basename($local);
}
- if( defined ${*$ftp}{'net_ftp_allo'} )
- {
- delete ${*$ftp}{'net_ftp_allo'};
- } else
- {
- # if the user hasn't already invoked the alloc method since the last
- # _store_cmd call, figure out if the local file is a regular file(not
- # a pipe, or device) and if so get the file size from stat, and send
- # an ALLO command before sending the STOR, STOU, or APPE command.
- my $size = do { local $^W; -f $local && -s _ }; # no ALLO if sending data from a pipe
- $ftp->_ALLO($size) if $size;
+ if (defined ${*$ftp}{'net_ftp_allo'}) {
+ delete ${*$ftp}{'net_ftp_allo'};
}
- croak("Bad remote filename '$remote'\n")
- if $remote =~ /[\r\n]/s;
+ else {
+
+ # if the user hasn't already invoked the alloc method since the last
+ # _store_cmd call, figure out if the local file is a regular file(not
+ # a pipe, or device) and if so get the file size from stat, and send
+ # an ALLO command before sending the STOR, STOU, or APPE command.
+ my $size = do { local $^W; -f $local && -s _ }; # no ALLO if sending data from a pipe
+ $ftp->_ALLO($size) if $size;
+ }
+ croak("Bad remote filename '$remote'\n")
+ if $remote =~ /[\r\n]/s;
- if($localfd)
- {
- $loc = $local;
+ if ($localfd) {
+ $loc = $local;
}
- else
- {
- $loc = \*FD;
+ else {
+ $loc = \*FD;
- unless(sysopen($loc, $local, O_RDONLY))
- {
- carp "Cannot open Local file $local: $!\n";
- return undef;
+ unless (sysopen($loc, $local, O_RDONLY)) {
+ carp "Cannot open Local file $local: $!\n";
+ return undef;
}
}
- if($ftp->type eq 'I' && !binmode($loc))
- {
- carp "Cannot binmode Local file $local: $!\n";
- return undef;
+ if ($ftp->type eq 'I' && !binmode($loc)) {
+ carp "Cannot binmode Local file $local: $!\n";
+ return undef;
}
- delete ${*$ftp}{'net_ftp_port'};
- delete ${*$ftp}{'net_ftp_pasv'};
+ delete ${*$ftp}{'net_ftp_port'};
+ delete ${*$ftp}{'net_ftp_pasv'};
- $sock = $ftp->_data_cmd($cmd, $remote) or
- return undef;
+ $sock = $ftp->_data_cmd($cmd, $remote)
+ or return undef;
- $remote = ($ftp->message =~ /FILE:\s*(.*)/)[0]
- if 'STOU' eq uc $cmd;
+ $remote = ($ftp->message =~ /FILE:\s*(.*)/)[0]
+ if 'STOU' eq uc $cmd;
- my $blksize = ${*$ftp}{'net_ftp_blksize'};
+ my $blksize = ${*$ftp}{'net_ftp_blksize'};
- my($count,$hashh,$hashb,$ref) = (0);
+ my ($count, $hashh, $hashb, $ref) = (0);
- ($hashh,$hashb) = @$ref
- if($ref = ${*$ftp}{'net_ftp_hash'});
+ ($hashh, $hashb) = @$ref
+ if ($ref = ${*$ftp}{'net_ftp_hash'});
- while(1)
- {
- last unless $len = read($loc,$buf="",$blksize);
+ while (1) {
+ last unless $len = read($loc, $buf = "", $blksize);
- if (trEBCDIC && $ftp->type ne 'I')
- {
- $buf = $ftp->toascii($buf);
- $len = length($buf);
+ if (trEBCDIC && $ftp->type ne 'I') {
+ $buf = $ftp->toascii($buf);
+ $len = length($buf);
}
- if($hashh) {
- $count += $len;
- print $hashh "#" x (int($count / $hashb));
- $count %= $hashb;
- }
-
- my $wlen;
- unless(defined($wlen = $sock->write($buf,$len)) && $wlen == $len)
- {
- $sock->abort;
- close($loc)
- unless $localfd;
- print $hashh "\n" if $hashh;
- return undef;
+ if ($hashh) {
+ $count += $len;
+ print $hashh "#" x (int($count / $hashb));
+ $count %= $hashb;
+ }
+
+ my $wlen;
+ unless (defined($wlen = $sock->write($buf, $len)) && $wlen == $len) {
+ $sock->abort;
+ close($loc)
+ unless $localfd;
+ print $hashh "\n" if $hashh;
+ return undef;
}
}
- print $hashh "\n" if $hashh;
+ print $hashh "\n" if $hashh;
- close($loc)
- unless $localfd;
+ close($loc)
+ unless $localfd;
- $sock->close() or
- return undef;
+ $sock->close()
+ or return undef;
- if ('STOU' eq uc $cmd and $ftp->message =~ m/unique\s+file\s*name\s*:\s*(.*)\)|"(.*)"/)
- {
- require File::Basename;
- $remote = File::Basename::basename($+)
+ if ('STOU' eq uc $cmd and $ftp->message =~ m/unique\s+file\s*name\s*:\s*(.*)\)|"(.*)"/) {
+ require File::Basename;
+ $remote = File::Basename::basename($+);
}
- return $remote;
+ return $remote;
}
-sub port
-{
- @_ == 1 || @_ == 2 or croak 'usage: $ftp->port([PORT])';
- my($ftp,$port) = @_;
- my $ok;
+sub port {
+ @_ == 1 || @_ == 2 or croak 'usage: $ftp->port([PORT])';
- delete ${*$ftp}{'net_ftp_intern_port'};
+ my ($ftp, $port) = @_;
+ my $ok;
- unless(defined $port)
- {
- # create a Listen socket at same address as the command socket
+ delete ${*$ftp}{'net_ftp_intern_port'};
- ${*$ftp}{'net_ftp_listen'} ||= IO::Socket::INET->new(Listen => 5,
- Proto => 'tcp',
- Timeout => $ftp->timeout,
- LocalAddr => $ftp->sockhost,
- );
+ unless (defined $port) {
- my $listen = ${*$ftp}{'net_ftp_listen'};
+ # create a Listen socket at same address as the command socket
- my($myport, @myaddr) = ($listen->sockport, split(/\./,$listen->sockhost));
+ ${*$ftp}{'net_ftp_listen'} ||= IO::Socket::INET->new(
+ Listen => 5,
+ Proto => 'tcp',
+ Timeout => $ftp->timeout,
+ LocalAddr => $ftp->sockhost,
+ );
- $port = join(',', @myaddr, $myport >> 8, $myport & 0xff);
+ my $listen = ${*$ftp}{'net_ftp_listen'};
- ${*$ftp}{'net_ftp_intern_port'} = 1;
+ 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);
+ $ok = $ftp->_PORT($port);
- ${*$ftp}{'net_ftp_port'} = $port;
+ ${*$ftp}{'net_ftp_port'} = $port;
- $ok;
+ $ok;
}
-sub ls { shift->_list_cmd("NLST",@_); }
-sub dir { shift->_list_cmd("LIST",@_); }
-sub pasv
-{
- @_ == 1 or croak 'usage: $ftp->pasv()';
+sub ls { shift->_list_cmd("NLST", @_); }
+sub dir { shift->_list_cmd("LIST", @_); }
+
+
+sub pasv {
+ @_ == 1 or croak 'usage: $ftp->pasv()';
- my $ftp = shift;
+ my $ftp = shift;
- delete ${*$ftp}{'net_ftp_intern_port'};
+ delete ${*$ftp}{'net_ftp_intern_port'};
- $ftp->_PASV && $ftp->message =~ /(\d+(,\d+)+)/
+ $ftp->_PASV && $ftp->message =~ /(\d+(,\d+)+)/
? ${*$ftp}{'net_ftp_pasv'} = $1
- : undef;
+ : undef;
}
-sub unique_name
-{
- my $ftp = shift;
- ${*$ftp}{'net_ftp_unique'} || undef;
+
+sub unique_name {
+ my $ftp = shift;
+ ${*$ftp}{'net_ftp_unique'} || undef;
}
+
sub supported {
- @_ == 2 or croak 'usage: $ftp->supported( CMD )';
- my $ftp = shift;
- my $cmd = uc shift;
- my $hash = ${*$ftp}{'net_ftp_supported'} ||= {};
-
- return $hash->{$cmd}
- if exists $hash->{$cmd};
-
- return $hash->{$cmd} = 0
- unless $ftp->_HELP($cmd);
-
- my $text = $ftp->message;
- if($text =~ /following\s+commands/i) {
- $text =~ s/^.*\n//;
- while($text =~ /(\*?)(\w+)(\*?)/sg) {
- $hash->{"\U$2"} = !length("$1$3");
- }
- }
- else {
- $hash->{$cmd} = $text !~ /unimplemented/i;
+ @_ == 2 or croak 'usage: $ftp->supported( CMD )';
+ my $ftp = shift;
+ my $cmd = uc shift;
+ my $hash = ${*$ftp}{'net_ftp_supported'} ||= {};
+
+ return $hash->{$cmd}
+ if exists $hash->{$cmd};
+
+ return $hash->{$cmd} = 0
+ unless $ftp->_HELP($cmd);
+
+ my $text = $ftp->message;
+ if ($text =~ /following\s+commands/i) {
+ $text =~ s/^.*\n//;
+ while ($text =~ /(\*?)(\w+)(\*?)/sg) {
+ $hash->{"\U$2"} = !length("$1$3");
}
+ }
+ else {
+ $hash->{$cmd} = $text !~ /unimplemented/i;
+ }
- $hash->{$cmd} ||= 0;
+ $hash->{$cmd} ||= 0;
}
##
## Deprecated methods
##
-sub lsl
-{
- carp "Use of Net::FTP::lsl deprecated, use 'dir'"
+
+sub lsl {
+ carp "Use of Net::FTP::lsl deprecated, use 'dir'"
if $^W;
- goto &dir;
+ goto &dir;
}
-sub authorise
-{
- carp "Use of Net::FTP::authorise deprecated, use 'authorize'"
+
+sub authorise {
+ carp "Use of Net::FTP::authorise deprecated, use 'authorize'"
if $^W;
- goto &authorize;
+ goto &authorize;
}
## Private methods
##
-sub _extract_path
-{
- my($ftp, $path) = @_;
- # This tries to work both with and without the quote doubling
- # convention (RFC 959 requires it, but the first 3 servers I checked
- # didn't implement it). It will fail on a server which uses a quote in
- # the message which isn't a part of or surrounding the path.
- $ftp->ok &&
- $ftp->message =~ /(?:^|\s)\"(.*)\"(?:$|\s)/ &&
- ($path = $1) =~ s/\"\"/\"/g;
+sub _extract_path {
+ my ($ftp, $path) = @_;
- $path;
+ # This tries to work both with and without the quote doubling
+ # convention (RFC 959 requires it, but the first 3 servers I checked
+ # didn't implement it). It will fail on a server which uses a quote in
+ # the message which isn't a part of or surrounding the path.
+ $ftp->ok
+ && $ftp->message =~ /(?:^|\s)\"(.*)\"(?:$|\s)/
+ && ($path = $1) =~ s/\"\"/\"/g;
+
+ $path;
}
##
## Communication methods
##
-sub _dataconn
-{
- my $ftp = shift;
- my $data = undef;
- my $pkg = "Net::FTP::" . $ftp->type;
- eval "require " . $pkg;
+sub _dataconn {
+ my $ftp = shift;
+ my $data = undef;
+ my $pkg = "Net::FTP::" . $ftp->type;
- $pkg =~ s/ /_/g;
+ eval "require " . $pkg;
- delete ${*$ftp}{'net_ftp_dataconn'};
+ $pkg =~ s/ /_/g;
- if(defined ${*$ftp}{'net_ftp_pasv'})
- {
- my @port = map { 0+$_ } split(/,/,${*$ftp}{'net_ftp_pasv'});
+ delete ${*$ftp}{'net_ftp_dataconn'};
- $data = $pkg->new(PeerAddr => join(".",@port[0..3]),
- PeerPort => $port[4] * 256 + $port[5],
- LocalAddr => ${*$ftp}{'net_ftp_localaddr'},
- Proto => 'tcp'
- );
+ if (defined ${*$ftp}{'net_ftp_pasv'}) {
+ my @port = map { 0 + $_ } split(/,/, ${*$ftp}{'net_ftp_pasv'});
+
+ $data = $pkg->new(
+ PeerAddr => join(".", @port[0 .. 3]),
+ PeerPort => $port[4] * 256 + $port[5],
+ LocalAddr => ${*$ftp}{'net_ftp_localaddr'},
+ Proto => 'tcp'
+ );
}
- elsif(defined ${*$ftp}{'net_ftp_listen'})
- {
- $data = ${*$ftp}{'net_ftp_listen'}->accept($pkg);
- close(delete ${*$ftp}{'net_ftp_listen'});
+ elsif (defined ${*$ftp}{'net_ftp_listen'}) {
+ $data = ${*$ftp}{'net_ftp_listen'}->accept($pkg);
+ close(delete ${*$ftp}{'net_ftp_listen'});
}
- if($data)
- {
- ${*$data} = "";
- $data->timeout($ftp->timeout);
- ${*$ftp}{'net_ftp_dataconn'} = $data;
- ${*$data}{'net_ftp_cmd'} = $ftp;
- ${*$data}{'net_ftp_blksize'} = ${*$ftp}{'net_ftp_blksize'};
+ if ($data) {
+ ${*$data} = "";
+ $data->timeout($ftp->timeout);
+ ${*$ftp}{'net_ftp_dataconn'} = $data;
+ ${*$data}{'net_ftp_cmd'} = $ftp;
+ ${*$data}{'net_ftp_blksize'} = ${*$ftp}{'net_ftp_blksize'};
}
- $data;
+ $data;
}
-sub _list_cmd
-{
- my $ftp = shift;
- my $cmd = uc shift;
- delete ${*$ftp}{'net_ftp_port'};
- delete ${*$ftp}{'net_ftp_pasv'};
+sub _list_cmd {
+ my $ftp = shift;
+ my $cmd = uc shift;
- my $data = $ftp->_data_cmd($cmd,@_);
+ delete ${*$ftp}{'net_ftp_port'};
+ delete ${*$ftp}{'net_ftp_pasv'};
- return
- unless(defined $data);
+ my $data = $ftp->_data_cmd($cmd, @_);
- require Net::FTP::A;
- bless $data, "Net::FTP::A"; # Force ASCII mode
+ return
+ unless (defined $data);
- my $databuf = '';
- my $buf = '';
- my $blksize = ${*$ftp}{'net_ftp_blksize'};
+ require Net::FTP::A;
+ bless $data, "Net::FTP::A"; # Force ASCII mode
- while($data->read($databuf,$blksize)) {
- $buf .= $databuf;
- }
+ my $databuf = '';
+ my $buf = '';
+ my $blksize = ${*$ftp}{'net_ftp_blksize'};
- my $list = [ split(/\n/,$buf) ];
+ while ($data->read($databuf, $blksize)) {
+ $buf .= $databuf;
+ }
- $data->close();
+ my $list = [split(/\n/, $buf)];
- if (trEBCDIC)
- {
- for (@$list) { $_ = $ftp->toebcdic($_) }
+ $data->close();
+
+ if (trEBCDIC) {
+ for (@$list) { $_ = $ftp->toebcdic($_) }
}
- wantarray ? @{$list}
- : $list;
+ wantarray
+ ? @{$list}
+ : $list;
}
-sub _data_cmd
-{
- my $ftp = shift;
- my $cmd = uc shift;
- my $ok = 1;
- my $where = delete ${*$ftp}{'net_ftp_rest'} || 0;
- my $arg;
-
- for $arg (@_) {
- croak("Bad argument '$arg'\n")
- if $arg =~ /[\r\n]/s;
- }
-
- if(${*$ftp}{'net_ftp_passive'} &&
- !defined ${*$ftp}{'net_ftp_pasv'} &&
- !defined ${*$ftp}{'net_ftp_port'})
+
+sub _data_cmd {
+ my $ftp = shift;
+ my $cmd = uc shift;
+ my $ok = 1;
+ my $where = delete ${*$ftp}{'net_ftp_rest'} || 0;
+ my $arg;
+
+ for $arg (@_) {
+ croak("Bad argument '$arg'\n")
+ if $arg =~ /[\r\n]/s;
+ }
+
+ if ( ${*$ftp}{'net_ftp_passive'}
+ && !defined ${*$ftp}{'net_ftp_pasv'}
+ && !defined ${*$ftp}{'net_ftp_port'})
{
- my $data = undef;
-
- $ok = defined $ftp->pasv;
- $ok = $ftp->_REST($where)
- if $ok && $where;
-
- if($ok)
- {
- $ftp->command($cmd,@_);
- $data = $ftp->_dataconn();
- $ok = CMD_INFO == $ftp->response();
- if($ok)
- {
- $data->reading
- if $data && $cmd =~ /RETR|LIST|NLST/;
- return $data
+ my $data = undef;
+
+ $ok = defined $ftp->pasv;
+ $ok = $ftp->_REST($where)
+ if $ok && $where;
+
+ if ($ok) {
+ $ftp->command($cmd, @_);
+ $data = $ftp->_dataconn();
+ $ok = CMD_INFO == $ftp->response();
+ if ($ok) {
+ $data->reading
+ if $data && $cmd =~ /RETR|LIST|NLST/;
+ return $data;
}
- $data->_close
- if $data;
+ $data->_close
+ if $data;
}
- return undef;
+ return undef;
}
- $ok = $ftp->port
- unless (defined ${*$ftp}{'net_ftp_port'} ||
- defined ${*$ftp}{'net_ftp_pasv'});
+ $ok = $ftp->port
+ unless (defined ${*$ftp}{'net_ftp_port'}
+ || defined ${*$ftp}{'net_ftp_pasv'});
- $ok = $ftp->_REST($where)
+ $ok = $ftp->_REST($where)
if $ok && $where;
- return undef
+ return undef
unless $ok;
- $ftp->command($cmd,@_);
+ $ftp->command($cmd, @_);
- return 1
- if(defined ${*$ftp}{'net_ftp_pasv'});
+ return 1
+ if (defined ${*$ftp}{'net_ftp_pasv'});
- $ok = CMD_INFO == $ftp->response();
+ $ok = CMD_INFO == $ftp->response();
- return $ok
+ return $ok
unless exists ${*$ftp}{'net_ftp_intern_port'};
- if($ok) {
- my $data = $ftp->_dataconn();
+ if ($ok) {
+ my $data = $ftp->_dataconn();
- $data->reading
- if $data && $cmd =~ /RETR|LIST|NLST/;
+ $data->reading
+ if $data && $cmd =~ /RETR|LIST|NLST/;
- return $data;
- }
+ return $data;
+ }
- close(delete ${*$ftp}{'net_ftp_listen'});
+ close(delete ${*$ftp}{'net_ftp_listen'});
- return undef;
+ return undef;
}
##
## Over-ride methods (Net::Cmd)
##
+
sub debug_text { $_[2] =~ /^(pass|resp|acct)/i ? "$1 ....\n" : $_[2]; }
-sub command
-{
- my $ftp = shift;
- delete ${*$ftp}{'net_ftp_port'};
- $ftp->SUPER::command(@_);
+sub 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'}
+sub response {
+ my $ftp = shift;
+ my $code = $ftp->SUPER::response();
+
+ delete ${*$ftp}{'net_ftp_pasv'}
if ($code != CMD_MORE && $code != CMD_INFO);
- $code;
+ $code;
}
-sub parse_response
-{
- return ($1, $2 eq "-")
+
+sub parse_response {
+ return ($1, $2 eq "-")
if $_[1] =~ s/^(\d\d\d)([- ]?)//o;
- my $ftp = shift;
+ my $ftp = shift;
- # Darn MS FTP server is a load of CRAP !!!!
- return ()
- unless ${*$ftp}{'net_cmd_code'} + 0;
+ # Darn MS FTP server is a load of CRAP !!!!
+ return ()
+ unless ${*$ftp}{'net_cmd_code'} + 0;
- (${*$ftp}{'net_cmd_code'},1);
+ (${*$ftp}{'net_cmd_code'}, 1);
}
##
## Allow 2 servers to talk directly
##
+
+sub pasv_xfer_unique {
+ my ($sftp, $sfile, $dftp, $dfile) = @_;
+ $sftp->pasv_xfer($sfile, $dftp, $dfile, 1);
+}
+
+
sub pasv_xfer {
- my($sftp,$sfile,$dftp,$dfile,$unique) = @_;
+ my ($sftp, $sfile, $dftp, $dfile, $unique) = @_;
- ($dfile = $sfile) =~ s#.*/##
- unless(defined $dfile);
+ ($dfile = $sfile) =~ s#.*/##
+ unless (defined $dfile);
- my $port = $sftp->pasv or
- return undef;
+ my $port = $sftp->pasv
+ or return undef;
- $dftp->port($port) or
- return undef;
+ $dftp->port($port)
+ or return undef;
- return undef
- unless($unique ? $dftp->stou($dfile) : $dftp->stor($dfile));
+ return undef
+ unless ($unique ? $dftp->stou($dfile) : $dftp->stor($dfile));
- unless($sftp->retr($sfile) && $sftp->response == CMD_INFO) {
- $sftp->retr($sfile);
- $dftp->abort;
- $dftp->response();
- return undef;
- }
+ unless ($sftp->retr($sfile) && $sftp->response == CMD_INFO) {
+ $sftp->retr($sfile);
+ $dftp->abort;
+ $dftp->response();
+ return undef;
+ }
- $dftp->pasv_wait($sftp);
+ $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);
+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;
+}
+
- vec($rin='',fileno($ftp),1) = 1;
- select($rout=$rin, undef, undef, undef);
+sub feature {
+ @_ == 2 or croak 'usage: $ftp->feature( NAME )';
+ my ($ftp, $feat) = @_;
- $ftp->response();
- $non_pasv->response();
+ my $feature = ${*$ftp}{net_ftp_feature} ||= do {
+ my @feat;
- return undef
- unless $ftp->ok() && $non_pasv->ok();
+ # Example response
+ # 211-Features:
+ # MDTM
+ # REST STREAM
+ # SIZE
+ # 211 End
- return $1
- if $ftp->message =~ /unique file name:\s*(\S*)\s*\)/;
+ @feat = map { /^\s+(.*\S)/ } $ftp->message
+ if $ftp->_FEAT;
- return $1
- if $non_pasv->message =~ /unique file name:\s*(\S*)\s*\)/;
+ \@feat;
+ };
- return 1;
+ return grep { /^\Q$feat\E\b/i } @$feature;
}
+
sub cmd { shift->command(@_)->response() }
########################################
# RFC959 commands
#
-sub _ABOR { shift->command("ABOR")->response() == CMD_OK }
-sub _ALLO { shift->command("ALLO",@_)->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 _ABOR { shift->command("ABOR")->response() == CMD_OK }
+sub _ALLO { shift->command("ALLO", @_)->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 _PORT { shift->command("PORT", @_)->response() == CMD_OK }
sub _RMD { shift->command("RMD", @_)->response() == CMD_OK }
sub _MKD { shift->command("MKD", @_)->response() == CMD_OK }
sub _PWD { shift->command("PWD", @_)->response() == CMD_OK }
-sub _TYPE { shift->command("TYPE",@_)->response() == CMD_OK }
-sub _RNTO { shift->command("RNTO",@_)->response() == CMD_OK }
-sub _RESP { shift->command("RESP",@_)->response() == CMD_OK }
-sub _MDTM { shift->command("MDTM",@_)->response() == CMD_OK }
-sub _SIZE { shift->command("SIZE",@_)->response() == CMD_OK }
-sub _HELP { shift->command("HELP",@_)->response() == CMD_OK }
-sub _STAT { shift->command("STAT",@_)->response() == CMD_OK }
-sub _APPE { shift->command("APPE",@_)->response() == CMD_INFO }
-sub _LIST { shift->command("LIST",@_)->response() == CMD_INFO }
-sub _NLST { shift->command("NLST",@_)->response() == CMD_INFO }
-sub _RETR { shift->command("RETR",@_)->response() == CMD_INFO }
-sub _STOR { shift->command("STOR",@_)->response() == CMD_INFO }
-sub _STOU { shift->command("STOU",@_)->response() == CMD_INFO }
-sub _RNFR { shift->command("RNFR",@_)->response() == CMD_MORE }
-sub _REST { shift->command("REST",@_)->response() == CMD_MORE }
-sub _PASS { shift->command("PASS",@_)->response() }
-sub _ACCT { shift->command("ACCT",@_)->response() }
-sub _AUTH { shift->command("AUTH",@_)->response() }
+sub _TYPE { shift->command("TYPE", @_)->response() == CMD_OK }
+sub _RNTO { shift->command("RNTO", @_)->response() == CMD_OK }
+sub _RESP { shift->command("RESP", @_)->response() == CMD_OK }
+sub _MDTM { shift->command("MDTM", @_)->response() == CMD_OK }
+sub _SIZE { shift->command("SIZE", @_)->response() == CMD_OK }
+sub _HELP { shift->command("HELP", @_)->response() == CMD_OK }
+sub _STAT { shift->command("STAT", @_)->response() == CMD_OK }
+sub _FEAT { shift->command("FEAT", @_)->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 _PASS { shift->command("PASS", @_)->response() }
+sub _ACCT { shift->command("ACCT", @_)->response() }
+sub _AUTH { shift->command("AUTH", @_)->response() }
+
sub _USER {
my $ftp = shift;
- my $ok = $ftp->command("USER",@_)->response();
+ my $ok = $ftp->command("USER", @_)->response();
# A certain brain dead firewall :-)
- $ok = $ftp->command("user",@_)->response()
+ $ok = $ftp->command("user", @_)->response()
unless $ok == CMD_MORE or $ok == CMD_OK;
$ok;
}
+
sub _SMNT { shift->unsupported(@_) }
sub _MODE { shift->unsupported(@_) }
sub _SYST { shift->unsupported(@_) }
return value is a reference to an array of two: the filehandle glob reference
and the bytes per hash mark.
+=item feature ( NAME )
+
+Determine if the server supports the specified feature. The return
+value is a list of lines the server responded with to describe the
+options that it supports for the given feature. If the feature is
+unsupported then the empty list is returned.
+
+ if ($ftp->feature( 'MDTM' )) {
+ # Do something
+ }
+
+ if (grep { /\bTLS\b/ } $ftp->feature('AUTH')) {
+ # Server supports TLS
+ }
+
=back
The following methods can return different results depending on
-## $Id: //depot/libnet/Net/FTP/A.pm#17 $
+##
## Package to read/write on ASCII data connections
##
require Net::FTP::dataconn;
-@ISA = qw(Net::FTP::dataconn);
-$VERSION = "1.17";
+@ISA = qw(Net::FTP::dataconn);
+$VERSION = "1.18";
+
sub read {
- my $data = shift;
- local *buf = \$_[0]; shift;
- my $size = shift || croak 'read($buf,$size,[$offset])';
- my $timeout = @_ ? shift : $data->timeout;
+ my $data = shift;
+ local *buf = \$_[0];
+ shift;
+ my $size = shift || croak 'read($buf,$size,[$offset])';
+ my $timeout = @_ ? shift: $data->timeout;
if (length(${*$data}) < $size && !${*$data}{'net_ftp_eof'}) {
my $blksize = ${*$data}{'net_ftp_blksize'};
my $l = 0;
my $n;
- READ:
+ READ:
{
my $readbuf = defined(${*$data}{'net_ftp_cr'}) ? "\015" : '';
- $data->can_read($timeout) or
- croak "Timeout";
+ $data->can_read($timeout)
+ or croak "Timeout";
if ($n = sysread($data, $readbuf, $blksize, length $readbuf)) {
${*$data}{'net_ftp_bytesread'} += $n;
- ${*$data}{'net_ftp_cr'} = substr($readbuf,-1) eq "\015"
- ? chop($readbuf)
- : undef;
+ ${*$data}{'net_ftp_cr'} =
+ substr($readbuf, -1) eq "\015"
+ ? chop($readbuf)
+ : undef;
}
else {
return undef
- unless defined $n;
+ unless defined $n;
${*$data}{'net_ftp_eof'} = 1;
}
unless (length(${*$data})) {
redo READ
- if($n > 0);
+ if ($n > 0);
$size = length(${*$data})
- if($n == 0);
+ if ($n == 0);
}
}
}
- $buf = substr(${*$data},0,$size);
- substr(${*$data},0,$size) = '';
+ $buf = substr(${*$data}, 0, $size);
+ substr(${*$data}, 0, $size) = '';
length $buf;
}
-sub write {
- my $data = shift;
- local *buf = \$_[0]; shift;
- my $size = shift || croak 'write($buf,$size,[$timeout])';
- my $timeout = @_ ? shift : $data->timeout;
- my $nr = (my $tmp = substr($buf,0,$size)) =~ tr/\r\n/\015\012/;
- $tmp =~ s/[^\015]\012/\015\012/sg if $nr;
+sub write {
+ my $data = shift;
+ local *buf = \$_[0];
+ shift;
+ my $size = shift || croak 'write($buf,$size,[$timeout])';
+ my $timeout = @_ ? shift: $data->timeout;
+
+ my $nr = (my $tmp = substr($buf, 0, $size)) =~ tr/\r\n/\015\012/;
+ $tmp =~ s/([^\015])\012/$1\015\012/sg if $nr;
$tmp =~ s/^\012/\015\012/ unless ${*$data}{'net_ftp_outcr'};
- ${*$data}{'net_ftp_outcr'} = substr($tmp,-1) eq "\015";
+ ${*$data}{'net_ftp_outcr'} = substr($tmp, -1) eq "\015";
# If the remote server has closed the connection we will be signal'd
# when we write. This can happen if the disk on the remote server fills up
- local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
+ local $SIG{PIPE} = 'IGNORE'
+ unless ($SIG{PIPE} || '') eq 'IGNORE'
+ or $^O eq 'MacOS';
- my $len = length($tmp);
- my $off = 0;
+ my $len = length($tmp);
+ my $off = 0;
my $wrote = 0;
my $blksize = ${*$data}{'net_ftp_blksize'};
- while($len) {
- $data->can_write($timeout) or
- croak "Timeout";
+ while ($len) {
+ $data->can_write($timeout)
+ or croak "Timeout";
$off += $wrote;
- $wrote = syswrite($data, substr($tmp,$off), $len > $blksize ? $blksize : $len);
+ $wrote = syswrite($data, substr($tmp, $off), $len > $blksize ? $blksize : $len);
return undef
unless defined($wrote);
$len -= $wrote;
-## $Id: //depot/libnet/Net/FTP/I.pm#13 $
+##
## Package to read/write on BINARY data connections
##
require Net::FTP::dataconn;
-@ISA = qw(Net::FTP::dataconn);
-$VERSION = "1.12";
+@ISA = qw(Net::FTP::dataconn);
+$VERSION = "1.12";
+
sub read {
- my $data = shift;
- local *buf = \$_[0]; shift;
- my $size = shift || croak 'read($buf,$size,[$timeout])';
- my $timeout = @_ ? shift : $data->timeout;
+ my $data = shift;
+ local *buf = \$_[0];
+ shift;
+ my $size = shift || croak 'read($buf,$size,[$timeout])';
+ my $timeout = @_ ? shift: $data->timeout;
my $n;
if ($size > length ${*$data} and !${*$data}{'net_ftp_eof'}) {
- $data->can_read($timeout) or
- croak "Timeout";
+ $data->can_read($timeout)
+ or croak "Timeout";
my $blksize = ${*$data}{'net_ftp_blksize'};
$blksize = $size if $size > $blksize;
}
}
- $buf = substr(${*$data},0,$size);
+ $buf = substr(${*$data}, 0, $size);
$n = length($buf);
- substr(${*$data},0,$n) = '';
+ substr(${*$data}, 0, $n) = '';
${*$data}{'net_ftp_bytesread'} += $n;
$n;
}
+
sub write {
- my $data = shift;
- local *buf = \$_[0]; shift;
- my $size = shift || croak 'write($buf,$size,[$timeout])';
- my $timeout = @_ ? shift : $data->timeout;
+ my $data = shift;
+ local *buf = \$_[0];
+ shift;
+ my $size = shift || croak 'write($buf,$size,[$timeout])';
+ my $timeout = @_ ? shift: $data->timeout;
# If the remote server has closed the connection we will be signal'd
# when we write. This can happen if the disk on the remote server fills up
- local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
+ local $SIG{PIPE} = 'IGNORE'
+ unless ($SIG{PIPE} || '') eq 'IGNORE'
+ or $^O eq 'MacOS';
my $sent = $size;
- my $off = 0;
+ my $off = 0;
my $blksize = ${*$data}{'net_ftp_blksize'};
- while($sent > 0) {
- $data->can_write($timeout) or
- croak "Timeout";
+ while ($sent > 0) {
+ $data->can_write($timeout)
+ or croak "Timeout";
- my $n = syswrite($data, $buf, $sent > $blksize ? $blksize : $sent ,$off);
+ my $n = syswrite($data, $buf, $sent > $blksize ? $blksize : $sent, $off);
return undef unless defined($n);
$sent -= $n;
$off += $n;
use Errno;
$VERSION = '0.11';
-@ISA = qw(IO::Socket::INET);
+@ISA = qw(IO::Socket::INET);
-sub reading
-{
- my $data = shift;
- ${*$data}{'net_ftp_bytesread'} = 0;
-}
-sub abort
-{
- my $data = shift;
- my $ftp = ${*$data}{'net_ftp_cmd'};
+sub reading {
+ my $data = shift;
+ ${*$data}{'net_ftp_bytesread'} = 0;
+}
- # no need to abort if we have finished the xfer
- return $data->close
- if ${*$data}{'net_ftp_eof'};
- # for some reason if we continously open RETR connections and not
- # read a single byte, then abort them after a while the server will
- # close our connection, this prevents the unexpected EOF on the
- # command channel -- GMB
- if(exists ${*$data}{'net_ftp_bytesread'}
- && (${*$data}{'net_ftp_bytesread'} == 0)) {
- my $buf="";
- my $timeout = $data->timeout;
- $data->can_read($timeout) && sysread($data,$buf,1);
- }
+sub abort {
+ my $data = shift;
+ my $ftp = ${*$data}{'net_ftp_cmd'};
- ${*$data}{'net_ftp_eof'} = 1; # fake
+ # no need to abort if we have finished the xfer
+ return $data->close
+ if ${*$data}{'net_ftp_eof'};
- $ftp->abort; # this will close me
+ # for some reason if we continously open RETR connections and not
+ # read a single byte, then abort them after a while the server will
+ # close our connection, this prevents the unexpected EOF on the
+ # command channel -- GMB
+ if (exists ${*$data}{'net_ftp_bytesread'}
+ && (${*$data}{'net_ftp_bytesread'} == 0))
+ {
+ my $buf = "";
+ my $timeout = $data->timeout;
+ $data->can_read($timeout) && sysread($data, $buf, 1);
+ }
+
+ ${*$data}{'net_ftp_eof'} = 1; # fake
+
+ $ftp->abort; # this will close me
}
-sub _close
-{
- my $data = shift;
- my $ftp = ${*$data}{'net_ftp_cmd'};
- $data->SUPER::close();
+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'};
+ delete ${*$ftp}{'net_ftp_dataconn'}
+ if exists ${*$ftp}{'net_ftp_dataconn'}
+ && $data == ${*$ftp}{'net_ftp_dataconn'};
}
-sub close
-{
- my $data = shift;
- my $ftp = ${*$data}{'net_ftp_cmd'};
- if(exists ${*$data}{'net_ftp_bytesread'} && !${*$data}{'net_ftp_eof'}) {
- my $junk;
- $data->read($junk,1,0);
- return $data->abort unless ${*$data}{'net_ftp_eof'};
- }
+sub close {
+ my $data = shift;
+ my $ftp = ${*$data}{'net_ftp_cmd'};
+
+ if (exists ${*$data}{'net_ftp_bytesread'} && !${*$data}{'net_ftp_eof'}) {
+ my $junk;
+ $data->read($junk, 1, 0);
+ return $data->abort unless ${*$data}{'net_ftp_eof'};
+ }
- $data->_close;
+ $data->_close;
- $ftp->response() == CMD_OK &&
- $ftp->message =~ /unique file name:\s*(\S*)\s*\)/ &&
- (${*$ftp}{'net_ftp_unique'} = $1);
+ $ftp->response() == CMD_OK
+ && $ftp->message =~ /unique file name:\s*(\S*)\s*\)/
+ && (${*$ftp}{'net_ftp_unique'} = $1);
- $ftp->status == CMD_OK;
+ $ftp->status == CMD_OK;
}
+
sub _select {
- my ($data, $timeout, $do_read) = @_;
- my ($rin,$rout,$win,$wout,$tout,$nfound);
+ my ($data, $timeout, $do_read) = @_;
+ my ($rin, $rout, $win, $wout, $tout, $nfound);
+
+ vec($rin = '', fileno($data), 1) = 1;
- vec($rin='',fileno($data),1) = 1;
+ ($win, $rin) = ($rin, $win) unless $do_read;
- ($win, $rin) = ($rin, $win) unless $do_read;
+ while (1) {
+ $nfound = select($rout = $rin, $wout = $win, undef, $tout = $timeout);
- while (1) {
- $nfound = select($rout=$rin, $wout=$win, undef, $tout=$timeout);
+ last if $nfound >= 0;
- last if $nfound >= 0;
-
- croak "select: $!"
- unless $!{EINTR};
- }
+ croak "select: $!"
+ unless $!{EINTR};
+ }
- $nfound;
+ $nfound;
}
-sub can_read
-{
- _select(@_[0,1],1);
+
+sub can_read {
+ _select(@_[0, 1], 1);
}
-sub can_write
-{
- _select(@_[0,1],0);
+
+sub can_write {
+ _select(@_[0, 1], 0);
}
-sub cmd
-{
- my $ftp = shift;
- ${*$ftp}{'net_ftp_cmd'};
+sub cmd {
+ my $ftp = shift;
+
+ ${*$ftp}{'net_ftp_cmd'};
}
+
sub bytes_read {
- my $ftp = shift;
+ my $ftp = shift;
- ${*$ftp}{'net_ftp_bytesread'} || 0;
+ ${*$ftp}{'net_ftp_bytesread'} || 0;
}
1;
-# This is an example Hostname.pm.
+#
package Sys::Hostname;
use Time::Local;
use Net::Config;
-$VERSION = "2.23_01";
+$VERSION = "2.24";
@ISA = qw(Net::Cmd IO::Socket::INET);
-sub new
-{
- my $self = shift;
- my $type = ref($self) || $self;
- my ($host,%arg);
- if (@_ % 2) {
- $host = shift ;
- %arg = @_;
- } else {
- %arg = @_;
- $host=delete $arg{Host};
- }
- my $obj;
-
- $host ||= $ENV{NNTPSERVER} || $ENV{NEWSHOST};
-
- my $hosts = defined $host ? [ $host ] : $NetConfig{nntp_hosts};
-
- @{$hosts} = qw(news)
- unless @{$hosts};
-
- my $h;
- foreach $h (@{$hosts})
- {
- $obj = $type->SUPER::new(PeerAddr => ($host = $h),
- PeerPort => $arg{Port} || 'nntp(119)',
- Proto => 'tcp',
- Timeout => defined $arg{Timeout}
- ? $arg{Timeout}
- : 120
- ) and last;
+
+sub new {
+ my $self = shift;
+ my $type = ref($self) || $self;
+ my ($host, %arg);
+ if (@_ % 2) {
+ $host = shift;
+ %arg = @_;
+ }
+ else {
+ %arg = @_;
+ $host = delete $arg{Host};
+ }
+ my $obj;
+
+ $host ||= $ENV{NNTPSERVER} || $ENV{NEWSHOST};
+
+ my $hosts = defined $host ? [$host] : $NetConfig{nntp_hosts};
+
+ @{$hosts} = qw(news)
+ unless @{$hosts};
+
+ my $h;
+ foreach $h (@{$hosts}) {
+ $obj = $type->SUPER::new(
+ PeerAddr => ($host = $h),
+ PeerPort => $arg{Port} || 'nntp(119)',
+ Proto => 'tcp',
+ Timeout => defined $arg{Timeout}
+ ? $arg{Timeout}
+ : 120
+ )
+ and last;
}
- return undef
- unless defined $obj;
+ return undef
+ unless defined $obj;
- ${*$obj}{'net_nntp_host'} = $host;
+ ${*$obj}{'net_nntp_host'} = $host;
- $obj->autoflush(1);
- $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
+ $obj->autoflush(1);
+ $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
- unless ($obj->response() == CMD_OK)
- {
- $obj->close;
- return undef;
+ unless ($obj->response() == CMD_OK) {
+ $obj->close;
+ return undef;
}
- my $c = $obj->code;
- my @m = $obj->message;
+ my $c = $obj->code;
+ my @m = $obj->message;
+
+ unless (exists $arg{Reader} && $arg{Reader} == 0) {
+
+ # if server is INN and we have transfer rights the we are currently
+ # talking to innd not nnrpd
+ if ($obj->reader) {
- unless(exists $arg{Reader} && $arg{Reader} == 0) {
- # if server is INN and we have transfer rights the we are currently
- # talking to innd not nnrpd
- if($obj->reader)
- {
- # If reader suceeds the we need to consider this code to determine postok
- $c = $obj->code;
+ # If reader suceeds the we need to consider this code to determine postok
+ $c = $obj->code;
}
- else
- {
- # I want to ignore this failure, so restore the previous status.
- $obj->set_status($c,\@m);
+ else {
+
+ # I want to ignore this failure, so restore the previous status.
+ $obj->set_status($c, \@m);
}
- }
+ }
- ${*$obj}{'net_nntp_post'} = $c == 200 ? 1 : 0;
+ ${*$obj}{'net_nntp_post'} = $c == 200 ? 1 : 0;
- $obj;
+ $obj;
}
+
sub host {
- my $me = shift;
- ${*$me}{'net_nntp_host'};
+ my $me = shift;
+ ${*$me}{'net_nntp_host'};
}
-sub debug_text
-{
- my $nntp = shift;
- my $inout = shift;
- my $text = shift;
- if((ref($nntp) and $nntp->code == 350 and $text =~ /^(\S+)/)
- || ($text =~ /^(authinfo\s+pass)/io))
+sub debug_text {
+ my $nntp = shift;
+ my $inout = shift;
+ my $text = shift;
+
+ if ( (ref($nntp) and $nntp->code == 350 and $text =~ /^(\S+)/)
+ || ($text =~ /^(authinfo\s+pass)/io))
{
- $text = "$1 ....\n"
+ $text = "$1 ....\n";
}
- $text;
+ $text;
}
-sub postok
-{
- @_ == 1 or croak 'usage: $nntp->postok()';
- my $nntp = shift;
- ${*$nntp}{'net_nntp_post'} || 0;
+
+sub postok {
+ @_ == 1 or croak 'usage: $nntp->postok()';
+ my $nntp = shift;
+ ${*$nntp}{'net_nntp_post'} || 0;
}
-sub article
-{
- @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->article( [ MSGID ], [ FH ] )';
- my $nntp = shift;
- my @fh;
- @fh = (pop) if @_ == 2 || (@_ && (ref($_[0]) || ref(\$_[0]) eq 'GLOB'));
+sub article {
+ @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->article( [ MSGID ], [ FH ] )';
+ my $nntp = shift;
+ my @fh;
+
+ @fh = (pop) if @_ == 2 || (@_ && (ref($_[0]) || ref(\$_[0]) eq 'GLOB'));
- $nntp->_ARTICLE(@_)
+ $nntp->_ARTICLE(@_)
? $nntp->read_until_dot(@fh)
: undef;
}
+
sub articlefh {
- @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->articlefh( [ MSGID ] )';
- my $nntp = shift;
+ @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->articlefh( [ MSGID ] )';
+ my $nntp = shift;
- return unless $nntp->_ARTICLE(@_);
- return $nntp->tied_fh;
+ return unless $nntp->_ARTICLE(@_);
+ return $nntp->tied_fh;
}
-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 {
+ @_ == 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 authinfo_simple {
+ @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )';
+ my ($nntp, $user, $pass) = @_;
+
+ $nntp->_AUTHINFO('SIMPLE') == CMD_MORE
+ && $nntp->command($user, $pass)->response == CMD_OK;
}
-sub body
-{
- @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->body( [ MSGID ], [ FH ] )';
- my $nntp = shift;
- my @fh;
- @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB');
+sub body {
+ @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->body( [ MSGID ], [ FH ] )';
+ my $nntp = shift;
+ my @fh;
+
+ @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB');
- $nntp->_BODY(@_)
+ $nntp->_BODY(@_)
? $nntp->read_until_dot(@fh)
: undef;
}
-sub bodyfh
-{
- @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->bodyfh( [ MSGID ] )';
- my $nntp = shift;
- return unless $nntp->_BODY(@_);
- return $nntp->tied_fh;
+
+sub bodyfh {
+ @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->bodyfh( [ MSGID ] )';
+ my $nntp = shift;
+ return unless $nntp->_BODY(@_);
+ return $nntp->tied_fh;
}
-sub head
-{
- @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->head( [ MSGID ], [ FH ] )';
- my $nntp = shift;
- my @fh;
- @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB');
+sub head {
+ @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->head( [ MSGID ], [ FH ] )';
+ my $nntp = shift;
+ my @fh;
- $nntp->_HEAD(@_)
+ @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB');
+
+ $nntp->_HEAD(@_)
? $nntp->read_until_dot(@fh)
: undef;
}
-sub headfh
-{
- @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->headfh( [ MSGID ] )';
- my $nntp = shift;
- return unless $nntp->_HEAD(@_);
- return $nntp->tied_fh;
+
+sub headfh {
+ @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->headfh( [ MSGID ] )';
+ my $nntp = shift;
+ return unless $nntp->_HEAD(@_);
+ return $nntp->tied_fh;
}
-sub nntpstat
-{
- @_ == 1 || @_ == 2 or croak 'usage: $nntp->nntpstat( [ MSGID ] )';
- my $nntp = shift;
- $nntp->_STAT(@_) && $nntp->message =~ /(<[^>]+>)/o
+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;
+sub group {
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->group( [ GROUP ] )';
+ my $nntp = shift;
+ my $grp = ${*$nntp}{'net_nntp_group'} || undef;
- return $grp
- unless(@_ || wantarray);
+ return $grp
+ unless (@_ || wantarray);
- my $newgrp = shift;
+ my $newgrp = shift;
- return wantarray ? () : undef
- unless $nntp->_GROUP($newgrp || $grp || "")
- && $nntp->message =~ /(\d+)\s+(\d+)\s+(\d+)\s+(\S+)/;
+ 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);
+ my ($count, $first, $last, $group) = ($1, $2, $3, $4);
- # group may be replied as '(current group)'
- $group = ${*$nntp}{'net_nntp_group'}
+ # group may be replied as '(current group)'
+ $group = ${*$nntp}{'net_nntp_group'}
if $group =~ /\(/;
- ${*$nntp}{'net_nntp_group'} = $group;
+ ${*$nntp}{'net_nntp_group'} = $group;
- wantarray
- ? ($count,$first,$last,$group)
+ wantarray
+ ? ($count, $first, $last, $group)
: $group;
}
-sub help
-{
- @_ == 1 or croak 'usage: $nntp->help()';
- my $nntp = shift;
- $nntp->_HELP
+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(@_)
+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
+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
+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})
+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->_NEWGROUPS($time, $dist)
? $nntp->_grouplist
: undef;
}
-sub newnews
-{
- @_ >= 2 && @_ <= 4 or
- croak 'usage: $nntp->newnews( SINCE [, GROUPS [, DISTRIBUTIONS ]])';
- my $nntp = shift;
- my $time = _timestr(shift);
- my $grp = @_ ? shift : $nntp->group;
- my $dist = shift || "";
-
- $grp ||= "*";
- $grp = join(",", @{$grp})
+
+sub newnews {
+ @_ >= 2 && @_ <= 4
+ or croak 'usage: $nntp->newnews( SINCE [, GROUPS [, DISTRIBUTIONS ]])';
+ my $nntp = shift;
+ my $time = _timestr(shift);
+ my $grp = @_ ? shift: $nntp->group;
+ my $dist = shift || "";
+
+ $grp ||= "*";
+ $grp = join(",", @{$grp})
if ref($grp);
- $dist = join(",", @{$dist})
+ $dist = join(",", @{$dist})
if ref($dist);
- $nntp->_NEWNEWS($grp,$time,$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
+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(@_)
+sub post {
+ @_ >= 1 or croak 'usage: $nntp->post( [ MESSAGE ] )';
+ my $nntp = shift;
+
+ $nntp->_POST() && $nntp->datasend(@_)
? @_ == 0 || $nntp->dataend
: undef;
}
+
sub postfh {
my $nntp = shift;
return unless $nntp->_POST();
return $nntp->tied_fh;
}
-sub quit
-{
- @_ == 1 or croak 'usage: $nntp->quit()';
- my $nntp = shift;
- $nntp->_QUIT;
- $nntp->close;
+sub quit {
+ @_ == 1 or croak 'usage: $nntp->quit()';
+ my $nntp = shift;
+
+ $nntp->_QUIT;
+ $nntp->close;
}
-sub slave
-{
- @_ == 1 or croak 'usage: $nntp->slave()';
- my $nntp = shift;
- $nntp->_SLAVE;
+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',@_)
+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')
+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')
+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 $_;
+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]
+ $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',@_)
+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 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')
+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(@_)
+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 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(@_)
+sub xgtitle {
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->xgtitle( [ PATTERN ] )';
+ my $nntp = shift;
+
+ $nntp->_XGTITLE(@_)
? $nntp->_description
: undef;
}
-sub xhdr
-{
- @_ >= 2 && @_ <= 4 or croak 'usage: $nntp->xhdr( HEADER, [ MESSAGE-SPEC ] )';
- my $nntp = shift;
- my $hdr = shift;
- my $arg = _msg_arg(@_);
- $nntp->_XHDR($hdr, $arg)
- ? $nntp->_description
- : undef;
+sub xhdr {
+ @_ >= 2 && @_ <= 4 or croak 'usage: $nntp->xhdr( HEADER, [ MESSAGE-SPEC ] )';
+ my $nntp = shift;
+ my $hdr = shift;
+ my $arg = _msg_arg(@_);
+
+ $nntp->_XHDR($hdr, $arg)
+ ? $nntp->_description
+ : undef;
}
-sub xover
-{
- @_ == 2 || @_ == 3 or croak 'usage: $nntp->xover( MESSAGE-SPEC )';
- my $nntp = shift;
- my $arg = _msg_arg(@_);
- $nntp->_XOVER($arg)
- ? $nntp->_fieldlist
- : undef;
+sub xover {
+ @_ == 2 || @_ == 3 or croak 'usage: $nntp->xover( MESSAGE-SPEC )';
+ my $nntp = shift;
+ my $arg = _msg_arg(@_);
+
+ $nntp->_XOVER($arg)
+ ? $nntp->_fieldlist
+ : undef;
}
-sub xpat
-{
- @_ == 4 || @_ == 5 or croak '$nntp->xpat( HEADER, PATTERN, MESSAGE-SPEC )';
- my $nntp = shift;
- my $hdr = shift;
- my $pat = shift;
- my $arg = _msg_arg(@_);
- $pat = join(" ", @$pat)
+sub xpat {
+ @_ == 4 || @_ == 5 or croak '$nntp->xpat( HEADER, PATTERN, MESSAGE-SPEC )';
+ my $nntp = shift;
+ my $hdr = shift;
+ my $pat = shift;
+ my $arg = _msg_arg(@_);
+
+ $pat = join(" ", @$pat)
if ref($pat);
- $nntp->_XPAT($hdr,$arg,$pat)
- ? $nntp->_description
- : undef;
+ $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);
+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;
+ my $m;
+ ($m = $nntp->message) =~ s/^\d+\s+//o;
+ my @p = split /\s+/, $m;
- wantarray ? @p : $p[0];
+ wantarray ? @p : $p[0];
}
-sub xrover
-{
- @_ == 2 || @_ == 3 or croak 'usage: $nntp->xrover( MESSAGE-SPEC )';
- my $nntp = shift;
- my $arg = _msg_arg(@_);
- $nntp->_XROVER($arg)
- ? $nntp->_description
- : undef;
+sub xrover {
+ @_ == 2 || @_ == 3 or croak 'usage: $nntp->xrover( MESSAGE-SPEC )';
+ my $nntp = shift;
+ my $arg = _msg_arg(@_);
+
+ $nntp->_XROVER($arg)
+ ? $nntp->_description
+ : undef;
}
-sub date
-{
- @_ == 1 or croak 'usage: $nntp->date()';
- my $nntp = shift;
- $nntp->_DATE && $nntp->message =~ /(\d{4})(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/
- ? timegm($6,$5,$4,$3,$2-1,$1 - 1900)
+sub date {
+ @_ == 1 or croak 'usage: $nntp->date()';
+ my $nntp = shift;
+
+ $nntp->_DATE
+ && $nntp->message =~ /(\d{4})(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/
+ ? timegm($6, $5, $4, $3, $2 - 1, $1 - 1900)
: undef;
}
## Private subroutines
##
-sub _msg_arg
-{
- my $spec = shift;
- my $arg = "";
- if(@_)
- {
- carp "Depriciated passing of two message numbers, "
- . "pass a reference"
- if $^W;
- $spec = [ $spec, $_[0] ];
+sub _msg_arg {
+ my $spec = shift;
+ my $arg = "";
+
+ if (@_) {
+ carp "Depriciated passing of two message numbers, " . "pass a reference"
+ if $^W;
+ $spec = [$spec, $_[0]];
}
- if(defined $spec)
- {
- if(ref($spec))
- {
- $arg = $spec->[0];
- if(defined $spec->[1])
- {
- $arg .= "-"
- if $spec->[1] != $spec->[0];
- $arg .= $spec->[1]
- if $spec->[1] > $spec->[0];
+ if (defined $spec) {
+ if (ref($spec)) {
+ $arg = $spec->[0];
+ if (defined $spec->[1]) {
+ $arg .= "-"
+ if $spec->[1] != $spec->[0];
+ $arg .= $spec->[1]
+ if $spec->[1] > $spec->[0];
}
}
- else
- {
- $arg = $spec;
+ else {
+ $arg = $spec;
}
}
- $arg;
+ $arg;
}
-sub _timestr
-{
- my $time = shift;
- my @g = reverse((gmtime($time))[0..5]);
- $g[1] += 1;
- $g[0] %= 100;
- sprintf "%02d%02d%02d %02d%02d%02d GMT", @g;
+
+sub _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;
+sub _grouplist {
+ my $nntp = shift;
+ my $arr = $nntp->read_until_dot
+ or return undef;
- foreach $ln (@$arr)
- {
- my @a = split(/[\s\n]+/,$ln);
- $hash->{$a[0]} = [ @a[1,2,3] ];
+ my $hash = {};
+ my $ln;
+
+ foreach $ln (@$arr) {
+ my @a = split(/[\s\n]+/, $ln);
+ $hash->{$a[0]} = [@a[1, 2, 3]];
}
- $hash;
+ $hash;
}
-sub _fieldlist
-{
- my $nntp = shift;
- my $arr = $nntp->read_until_dot or
- return undef;
- my $hash = {};
- my $ln;
+sub _fieldlist {
+ my $nntp = shift;
+ my $arr = $nntp->read_until_dot
+ or return undef;
- foreach $ln (@$arr)
- {
- my @a = split(/[\t\n]/,$ln);
- my $m = shift @a;
- $hash->{$m} = [ @a ];
+ my $hash = {};
+ my $ln;
+
+ foreach $ln (@$arr) {
+ my @a = split(/[\t\n]/, $ln);
+ my $m = shift @a;
+ $hash->{$m} = [@a];
}
- $hash;
+ $hash;
}
-sub _articlelist
-{
- my $nntp = shift;
- my $arr = $nntp->read_until_dot;
- chomp(@$arr)
+sub _articlelist {
+ my $nntp = shift;
+ my $arr = $nntp->read_until_dot;
+
+ chomp(@$arr)
if $arr;
- $arr;
+ $arr;
}
-sub _description
-{
- my $nntp = shift;
- my $arr = $nntp->read_until_dot or
- return undef;
- my $hash = {};
- my $ln;
+sub _description {
+ my $nntp = shift;
+ my $arr = $nntp->read_until_dot
+ or return undef;
+
+ my $hash = {};
+ my $ln;
- foreach $ln (@$arr)
- {
- chomp($ln);
+ foreach $ln (@$arr) {
+ chomp($ln);
- $hash->{$1} = $ln
- if $ln =~ s/^\s*(\S+)\s*//o;
+ $hash->{$1} = $ln
+ if $ln =~ s/^\s*(\S+)\s*//o;
}
- $hash;
+ $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 _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 _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 _LIST { shift->command('LIST', @_)->response == CMD_OK }
+sub _LISTGROUP { shift->command('LISTGROUP', @_)->response == CMD_OK }
+sub _NEWGROUPS { shift->command('NEWGROUPS', @_)->response == CMD_OK }
+sub _NEWNEWS { shift->command('NEWNEWS', @_)->response == CMD_OK }
sub _NEXT { shift->command('NEXT')->response == CMD_OK }
-sub _POST { shift->command('POST',@_)->response == CMD_MORE }
-sub _QUIT { shift->command('QUIT',@_)->response == CMD_OK }
-sub _SLAVE { shift->command('SLAVE',@_)->response == CMD_OK }
-sub _STAT { shift->command('STAT',@_)->response == CMD_OK }
-sub _MODE { shift->command('MODE',@_)->response == CMD_OK }
-sub _XGTITLE { shift->command('XGTITLE',@_)->response == CMD_OK }
-sub _XHDR { shift->command('XHDR',@_)->response == CMD_OK }
-sub _XPAT { shift->command('XPAT',@_)->response == CMD_OK }
-sub _XPATH { shift->command('XPATH',@_)->response == CMD_OK }
-sub _XOVER { shift->command('XOVER',@_)->response == CMD_OK }
-sub _XROVER { shift->command('XROVER',@_)->response == CMD_OK }
+sub _POST { shift->command('POST', @_)->response == CMD_MORE }
+sub _QUIT { shift->command('QUIT', @_)->response == CMD_OK }
+sub _SLAVE { shift->command('SLAVE', @_)->response == CMD_OK }
+sub _STAT { shift->command('STAT', @_)->response == CMD_OK }
+sub _MODE { shift->command('MODE', @_)->response == CMD_OK }
+sub _XGTITLE { shift->command('XGTITLE', @_)->response == CMD_OK }
+sub _XHDR { shift->command('XHDR', @_)->response == CMD_OK }
+sub _XPAT { shift->command('XPAT', @_)->response == CMD_OK }
+sub _XPATH { shift->command('XPATH', @_)->response == CMD_OK }
+sub _XOVER { shift->command('XOVER', @_)->response == CMD_OK }
+sub _XROVER { shift->command('XROVER', @_)->response == CMD_OK }
sub _XTHREAD { shift->unsupported }
sub _XSEARCH { shift->unsupported }
sub _XINDEX { shift->unsupported }
## IO/perl methods
##
-sub DESTROY
-{
- my $nntp = shift;
- defined(fileno($nntp)) && $nntp->quit
+
+sub DESTROY {
+ my $nntp = shift;
+ defined(fileno($nntp)) && $nntp->quit;
}
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
-=for html <hr>
-
-I<$Id: //depot/libnet/Net/NNTP.pm#18 $>
-
=cut
use FileHandle;
use vars qw($VERSION);
-$VERSION = "2.12"; # $Id: //depot/libnet/Net/Netrc.pm#13 $
+$VERSION = "2.12";
my %netrc = ();
-sub _readrc
-{
- my $host = shift;
- my($home,$file);
-
- if($^O eq "MacOS") {
- $home = $ENV{HOME} || `pwd`;
- chomp($home);
- $file = ($home =~ /:$/ ? $home . "netrc" : $home . ":netrc");
- } else {
- # Some OS's don't have `getpwuid', so we default to $ENV{HOME}
- $home = eval { (getpwuid($>))[7] } || $ENV{HOME};
- $home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH}||'') if defined $ENV{HOMEDRIVE};
- $file = $home . "/.netrc";
- }
-
- my($login,$pass,$acct) = (undef,undef,undef);
- my $fh;
- local $_;
-
- $netrc{default} = undef;
-
- # OS/2 and Win32 do not handle stat in a way compatable with this check :-(
- unless($^O eq 'os2'
- || $^O eq 'MSWin32'
- || $^O eq 'MacOS'
- || $^O =~ /^cygwin/)
- {
- my @stat = stat($file);
-
- if(@stat)
- {
- if($stat[2] & 077)
- {
- carp "Bad permissions: $file";
- return;
+
+sub _readrc {
+ my $host = shift;
+ my ($home, $file);
+
+ if ($^O eq "MacOS") {
+ $home = $ENV{HOME} || `pwd`;
+ chomp($home);
+ $file = ($home =~ /:$/ ? $home . "netrc" : $home . ":netrc");
+ }
+ else {
+
+ # Some OS's don't have `getpwuid', so we default to $ENV{HOME}
+ $home = eval { (getpwuid($>))[7] } || $ENV{HOME};
+ $home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH} || '') if defined $ENV{HOMEDRIVE};
+ $file = $home . "/.netrc";
+ }
+
+ my ($login, $pass, $acct) = (undef, undef, undef);
+ my $fh;
+ local $_;
+
+ $netrc{default} = undef;
+
+ # OS/2 and Win32 do not handle stat in a way compatable with this check :-(
+ unless ($^O eq 'os2'
+ || $^O eq 'MSWin32'
+ || $^O eq 'MacOS'
+ || $^O =~ /^cygwin/)
+ {
+ my @stat = stat($file);
+
+ if (@stat) {
+ if ($stat[2] & 077) {
+ carp "Bad permissions: $file";
+ return;
}
- if($stat[4] != $<)
- {
- carp "Not owner: $file";
- return;
+ if ($stat[4] != $<) {
+ carp "Not owner: $file";
+ return;
}
}
}
- if($fh = FileHandle->new($file,"r"))
- {
- my($mach,$macdef,$tok,@tok) = (0,0);
+ if ($fh = FileHandle->new($file, "r")) {
+ my ($mach, $macdef, $tok, @tok) = (0, 0);
- while(<$fh>)
- {
- undef $macdef if /\A\n\Z/;
+ while (<$fh>) {
+ undef $macdef if /\A\n\Z/;
- if($macdef)
- {
- push(@$macdef,$_);
- next;
+ if ($macdef) {
+ push(@$macdef, $_);
+ next;
}
- s/^\s*//;
- chomp;
+ s/^\s*//;
+ chomp;
- while(length && s/^("((?:[^"]+|\\.)*)"|((?:[^\\\s]+|\\.)*))\s*//) {
- (my $tok = $+) =~ s/\\(.)/$1/g;
- push(@tok, $tok);
- }
+ while (length && s/^("((?:[^"]+|\\.)*)"|((?:[^\\\s]+|\\.)*))\s*//) {
+ (my $tok = $+) =~ s/\\(.)/$1/g;
+ push(@tok, $tok);
+ }
-TOKEN:
- while(@tok)
- {
- if($tok[0] eq "default")
- {
- shift(@tok);
- $mach = bless {};
- $netrc{default} = [$mach];
+ TOKEN:
+ while (@tok) {
+ if ($tok[0] eq "default") {
+ shift(@tok);
+ $mach = bless {};
+ $netrc{default} = [$mach];
- next TOKEN;
+ next TOKEN;
}
- last TOKEN
- unless @tok > 1;
+ last TOKEN
+ unless @tok > 1;
- $tok = shift(@tok);
+ $tok = shift(@tok);
- if($tok eq "machine")
- {
- my $host = shift @tok;
- $mach = bless {machine => $host};
+ if ($tok eq "machine") {
+ my $host = shift @tok;
+ $mach = bless {machine => $host};
- $netrc{$host} = []
+ $netrc{$host} = []
unless exists($netrc{$host});
- push(@{$netrc{$host}}, $mach);
+ push(@{$netrc{$host}}, $mach);
}
- elsif($tok =~ /^(login|password|account)$/)
- {
- next TOKEN unless $mach;
- my $value = shift @tok;
- # Following line added by rmerrell to remove '/' escape char in .netrc
- $value =~ s/\/\\/\\/g;
- $mach->{$1} = $value;
+ elsif ($tok =~ /^(login|password|account)$/) {
+ next TOKEN unless $mach;
+ my $value = shift @tok;
+
+ # Following line added by rmerrell to remove '/' escape char in .netrc
+ $value =~ s/\/\\/\\/g;
+ $mach->{$1} = $value;
}
- elsif($tok eq "macdef")
- {
- next TOKEN unless $mach;
- my $value = shift @tok;
- $mach->{macdef} = {}
+ elsif ($tok eq "macdef") {
+ next TOKEN unless $mach;
+ my $value = shift @tok;
+ $mach->{macdef} = {}
unless exists $mach->{macdef};
- $macdef = $mach->{machdef}{$value} = [];
+ $macdef = $mach->{machdef}{$value} = [];
}
}
}
- $fh->close();
+ $fh->close();
}
}
-sub lookup
-{
- my($pkg,$mach,$login) = @_;
- _readrc()
+sub lookup {
+ my ($pkg, $mach, $login) = @_;
+
+ _readrc()
unless exists $netrc{default};
- $mach ||= 'default';
- undef $login
+ $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);
+ 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 undef;
}
- return $netrc{$mach}->[0]
+ return $netrc{$mach}->[0];
}
- return $netrc{default}->[0]
+ return $netrc{default}->[0]
if defined $netrc{default};
- return undef;
+ return undef;
}
-sub login
-{
- my $me = shift;
- exists $me->{login}
+sub login {
+ my $me = shift;
+
+ exists $me->{login}
? $me->{login}
: undef;
}
-sub account
-{
- my $me = shift;
- exists $me->{account}
+sub account {
+ my $me = shift;
+
+ exists $me->{account}
? $me->{account}
: undef;
}
-sub password
-{
- my $me = shift;
- exists $me->{password}
+sub password {
+ my $me = shift;
+
+ exists $me->{password}
? $me->{password}
: undef;
}
-sub lpa
-{
- my $me = shift;
- ($me->login, $me->password, $me->account);
+
+sub lpa {
+ my $me = shift;
+ ($me->login, $me->password, $me->account);
}
1;
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
-=for html <hr>
-
-$Id: //depot/libnet/Net/Netrc.pm#13 $
-
=cut
use Carp;
use Net::Config;
-$VERSION = "2.28_2";
+$VERSION = "2.29";
@ISA = qw(Net::Cmd IO::Socket::INET);
-sub new
-{
- my $self = shift;
- my $type = ref($self) || $self;
- my ($host,%arg);
- if (@_ % 2) {
- $host = shift ;
- %arg = @_;
- } else {
- %arg = @_;
- $host=delete $arg{Host};
- }
- my $hosts = defined $host ? [ $host ] : $NetConfig{pop3_hosts};
- my $obj;
- my @localport = exists $arg{ResvPort} ? ( LocalPort => $arg{ResvPort} ): ();
-
- my $h;
- foreach $h (@{$hosts})
- {
- $obj = $type->SUPER::new(PeerAddr => ($host = $h),
- PeerPort => $arg{Port} || 'pop3(110)',
- Proto => 'tcp',
- @localport,
- Timeout => defined $arg{Timeout}
- ? $arg{Timeout}
- : 120
- ) and last;
+
+sub new {
+ my $self = shift;
+ my $type = ref($self) || $self;
+ my ($host, %arg);
+ if (@_ % 2) {
+ $host = shift;
+ %arg = @_;
+ }
+ else {
+ %arg = @_;
+ $host = delete $arg{Host};
+ }
+ my $hosts = defined $host ? [$host] : $NetConfig{pop3_hosts};
+ my $obj;
+ my @localport = exists $arg{ResvPort} ? (LocalPort => $arg{ResvPort}) : ();
+
+ my $h;
+ foreach $h (@{$hosts}) {
+ $obj = $type->SUPER::new(
+ PeerAddr => ($host = $h),
+ PeerPort => $arg{Port} || 'pop3(110)',
+ Proto => 'tcp',
+ @localport,
+ Timeout => defined $arg{Timeout}
+ ? $arg{Timeout}
+ : 120
+ )
+ and last;
}
- return undef
- unless defined $obj;
+ return undef
+ unless defined $obj;
- ${*$obj}{'net_pop3_host'} = $host;
+ ${*$obj}{'net_pop3_host'} = $host;
- $obj->autoflush(1);
- $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
+ $obj->autoflush(1);
+ $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
- unless ($obj->response() == CMD_OK)
- {
- $obj->close();
- return undef;
+ unless ($obj->response() == CMD_OK) {
+ $obj->close();
+ return undef;
}
- ${*$obj}{'net_pop3_banner'} = $obj->message;
+ ${*$obj}{'net_pop3_banner'} = $obj->message;
- $obj;
+ $obj;
}
+
sub host {
- my $me = shift;
- ${*$me}{'net_pop3_host'};
+ my $me = shift;
+ ${*$me}{'net_pop3_host'};
}
##
## 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) {
- ($user, $pass) = $me->_lookup_credentials($user);
- }
+sub login {
+ @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->login( USER, PASS )';
+ my ($me, $user, $pass) = @_;
+
+ if (@_ <= 2) {
+ ($user, $pass) = $me->_lookup_credentials($user);
+ }
- $me->user($user) and
- $me->pass($pass);
+ $me->user($user)
+ and $me->pass($pass);
}
-sub apop
-{
- @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->apop( USER, PASS )';
- my($me,$user,$pass) = @_;
- my $banner;
- my $md;
- if (eval { local $SIG{__DIE__}; require Digest::MD5 }) {
- $md = Digest::MD5->new();
- } elsif (eval { local $SIG{__DIE__}; require MD5 }) {
- $md = MD5->new();
- } else {
- carp "You need to install Digest::MD5 or MD5 to use the APOP command";
- return undef;
- }
+sub apop {
+ @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->apop( USER, PASS )';
+ my ($me, $user, $pass) = @_;
+ my $banner;
+ my $md;
- return undef
- unless ( $banner = (${*$me}{'net_pop3_banner'} =~ /(<.*>)/)[0] );
+ if (eval { local $SIG{__DIE__}; require Digest::MD5 }) {
+ $md = Digest::MD5->new();
+ }
+ elsif (eval { local $SIG{__DIE__}; require MD5 }) {
+ $md = MD5->new();
+ }
+ else {
+ carp "You need to install Digest::MD5 or MD5 to use the APOP command";
+ return undef;
+ }
+
+ return undef
+ unless ($banner = (${*$me}{'net_pop3_banner'} =~ /(<.*>)/)[0]);
- if (@_ <= 2) {
- ($user, $pass) = $me->_lookup_credentials($user);
- }
+ if (@_ <= 2) {
+ ($user, $pass) = $me->_lookup_credentials($user);
+ }
- $md->add($banner,$pass);
+ $md->add($banner, $pass);
- return undef
- unless($me->_APOP($user,$md->hexdigest));
+ return undef
+ unless ($me->_APOP($user, $md->hexdigest));
- $me->_get_mailbox_count();
+ $me->_get_mailbox_count();
}
-sub user
-{
- @_ == 2 or croak 'usage: $pop3->user( USER )';
- $_[0]->_USER($_[1]) ? 1 : undef;
+
+sub user {
+ @_ == 2 or croak 'usage: $pop3->user( USER )';
+ $_[0]->_USER($_[1]) ? 1 : undef;
}
-sub pass
-{
- @_ == 2 or croak 'usage: $pop3->pass( PASS )';
- my($me,$pass) = @_;
+sub pass {
+ @_ == 2 or croak 'usage: $pop3->pass( PASS )';
- return undef
- unless($me->_PASS($pass));
+ my ($me, $pass) = @_;
- $me->_get_mailbox_count();
+ return undef
+ unless ($me->_PASS($pass));
+
+ $me->_get_mailbox_count();
}
-sub reset
-{
- @_ == 1 or croak 'usage: $obj->reset()';
- my $me = shift;
+sub reset {
+ @_ == 1 or croak 'usage: $obj->reset()';
+
+ my $me = shift;
- return 0
- unless($me->_RSET);
+ return 0
+ unless ($me->_RSET);
- if(defined ${*$me}{'net_pop3_mail'})
- {
- local $_;
- foreach (@{${*$me}{'net_pop3_mail'}})
- {
- delete $_->{'net_pop3_deleted'};
+ 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
+sub last {
+ @_ == 1 or croak 'usage: $obj->last()';
+
+ return undef
unless $_[0]->_LAST && $_[0]->message =~ /(\d+)/;
- return $1;
+ return $1;
}
-sub top
-{
- @_ == 2 || @_ == 3 or croak 'usage: $pop3->top( MSGNUM [, NUMLINES ])';
- my $me = shift;
- return undef
+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;
+ $me->read_until_dot;
}
-sub popstat
-{
- @_ == 1 or croak 'usage: $pop3->popstat()';
- my $me = shift;
- return ()
+sub popstat {
+ @_ == 1 or croak 'usage: $pop3->popstat()';
+ my $me = shift;
+
+ return ()
unless $me->_STAT && $me->message =~ /(\d+)\D+(\d+)/;
- ($1 || 0, $2 || 0);
+ ($1 || 0, $2 || 0);
}
-sub list
-{
- @_ == 1 || @_ == 2 or croak 'usage: $pop3->list( [ MSGNUM ] )';
- my $me = shift;
- return undef
+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;
+ if (@_) {
+ $me->message =~ /\d+\D+(\d+)/;
+ return $1 || undef;
}
- my $info = $me->read_until_dot
- or return undef;
+ my $info = $me->read_until_dot
+ or return undef;
- my %hash = map { (/(\d+)\D+(\d+)/) } @$info;
+ my %hash = map { (/(\d+)\D+(\d+)/) } @$info;
- return \%hash;
+ return \%hash;
}
-sub get
-{
- @_ == 2 or @_ == 3 or croak 'usage: $pop3->get( MSGNUM [, FH ])';
- my $me = shift;
- return undef
+sub get {
+ @_ == 2 or @_ == 3 or croak 'usage: $pop3->get( MSGNUM [, FH ])';
+ my $me = shift;
+
+ return undef
unless $me->_RETR(shift);
- $me->read_until_dot(@_);
+ $me->read_until_dot(@_);
}
-sub getfh
-{
- @_ == 2 or croak 'usage: $pop3->getfh( MSGNUM )';
- my $me = shift;
- return unless $me->_RETR(shift);
- return $me->tied_fh;
-}
+sub getfh {
+ @_ == 2 or croak 'usage: $pop3->getfh( MSGNUM )';
+ my $me = shift;
+ return unless $me->_RETR(shift);
+ return $me->tied_fh;
+}
-sub delete
-{
- @_ == 2 or croak 'usage: $pop3->delete( MSGNUM )';
- my $me = shift;
- return 0 unless $me->_DELE(@_);
- ${*$me}{'net_pop3_deleted'} = 1;
+sub delete {
+ @_ == 2 or croak 'usage: $pop3->delete( MSGNUM )';
+ my $me = shift;
+ return 0 unless $me->_DELE(@_);
+ ${*$me}{'net_pop3_deleted'} = 1;
}
-sub uidl
-{
- @_ == 1 || @_ == 2 or croak 'usage: $pop3->uidl( [ MSGNUM ] )';
- my $me = shift;
- my $uidl;
- $me->_UIDL(@_) or
- return undef;
- if(@_)
- {
- $uidl = ($me->message =~ /\d+\s+([\041-\176]+)/)[0];
+sub uidl {
+ @_ == 1 || @_ == 2 or croak 'usage: $pop3->uidl( [ MSGNUM ] )';
+ my $me = shift;
+ my $uidl;
+
+ $me->_UIDL(@_)
+ or return undef;
+ if (@_) {
+ $uidl = ($me->message =~ /\d+\s+([\041-\176]+)/)[0];
}
- else
- {
- my $ref = $me->read_until_dot
- or return undef;
- my $ln;
- $uidl = {};
- foreach $ln (@$ref) {
- my($msg,$uid) = $ln =~ /^\s*(\d+)\s+([\041-\176]+)/;
- $uidl->{$msg} = $uid;
- }
+ else {
+ my $ref = $me->read_until_dot
+ or return undef;
+ my $ln;
+ $uidl = {};
+ foreach $ln (@$ref) {
+ my ($msg, $uid) = $ln =~ /^\s*(\d+)\s+([\041-\176]+)/;
+ $uidl->{$msg} = $uid;
+ }
}
- return $uidl;
+ return $uidl;
}
-sub ping
-{
- @_ == 2 or croak 'usage: $pop3->ping( USER )';
- my $me = shift;
- return () unless $me->_PING(@_) && $me->message =~ /(\d+)\D+(\d+)/;
+sub ping {
+ @_ == 2 or croak 'usage: $pop3->ping( USER )';
+ my $me = shift;
+
+ return () unless $me->_PING(@_) && $me->message =~ /(\d+)\D+(\d+)/;
- ($1 || 0, $2 || 0);
+ ($1 || 0, $2 || 0);
}
-sub _lookup_credentials
-{
+
+sub _lookup_credentials {
my ($me, $user) = @_;
require Net::Netrc;
- $user ||= eval { local $SIG{__DIE__}; (getpwuid($>))[0] } ||
- $ENV{NAME} || $ENV{USER} || $ENV{LOGNAME};
+ $user ||= eval { local $SIG{__DIE__}; (getpwuid($>))[0] }
+ || $ENV{NAME}
+ || $ENV{USER}
+ || $ENV{LOGNAME};
- my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'},$user);
+ my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'}, $user);
$m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'});
- my $pass = $m ? $m->password || ""
- : "";
+ my $pass = $m
+ ? $m->password || ""
+ : "";
($user, $pass);
}
-sub _get_mailbox_count
-{
+
+sub _get_mailbox_count {
my ($me) = @_;
- my $ret = ${*$me}{'net_pop3_count'} = ($me->message =~ /(\d+)\s+message/io)
- ? $1 : ($me->popstat)[0];
+ my $ret = ${*$me}{'net_pop3_count'} =
+ ($me->message =~ /(\d+)\s+message/io) ? $1 : ($me->popstat)[0];
$ret ? $ret : "0E0";
}
sub _STAT { shift->command('STAT')->response() == CMD_OK }
-sub _LIST { shift->command('LIST',@_)->response() == CMD_OK }
-sub _RETR { shift->command('RETR',$_[0])->response() == CMD_OK }
-sub _DELE { shift->command('DELE',$_[0])->response() == CMD_OK }
+sub _LIST { shift->command('LIST', @_)->response() == CMD_OK }
+sub _RETR { shift->command('RETR', $_[0])->response() == CMD_OK }
+sub _DELE { shift->command('DELE', $_[0])->response() == CMD_OK }
sub _NOOP { shift->command('NOOP')->response() == CMD_OK }
sub _RSET { shift->command('RSET')->response() == CMD_OK }
sub _QUIT { shift->command('QUIT')->response() == CMD_OK }
sub _TOP { shift->command('TOP', @_)->response() == CMD_OK }
-sub _UIDL { shift->command('UIDL',@_)->response() == CMD_OK }
-sub _USER { shift->command('USER',$_[0])->response() == CMD_OK }
-sub _PASS { shift->command('PASS',$_[0])->response() == CMD_OK }
-sub _APOP { shift->command('APOP',@_)->response() == CMD_OK }
-sub _PING { shift->command('PING',$_[0])->response() == CMD_OK }
+sub _UIDL { shift->command('UIDL', @_)->response() == CMD_OK }
+sub _USER { shift->command('USER', $_[0])->response() == CMD_OK }
+sub _PASS { shift->command('PASS', $_[0])->response() == CMD_OK }
+sub _APOP { shift->command('APOP', @_)->response() == CMD_OK }
+sub _PING { shift->command('PING', $_[0])->response() == CMD_OK }
-sub _RPOP { shift->command('RPOP',$_[0])->response() == CMD_OK }
+
+sub _RPOP { shift->command('RPOP', $_[0])->response() == CMD_OK }
sub _LAST { shift->command('LAST')->response() == CMD_OK }
+
sub _CAPA { shift->command('CAPA')->response() == CMD_OK }
-sub quit
-{
- my $me = shift;
- $me->_QUIT;
- $me->close;
+sub quit {
+ my $me = shift;
+
+ $me->_QUIT;
+ $me->close;
}
-sub DESTROY
-{
- my $me = shift;
- if(defined fileno($me) and ${*$me}{'net_pop3_deleted'})
- {
- $me->reset;
- $me->quit;
+sub DESTROY {
+ my $me = shift;
+
+ if (defined fileno($me) and ${*$me}{'net_pop3_deleted'}) {
+ $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() or return undef;
sub capa {
- my $this = shift;
- my ($capa, %capabilities);
+ my $this = shift;
+ my ($capa, %capabilities);
- # Fake a capability here
- $capabilities{APOP} = '' if ($this->banner() =~ /<.*>/);
+ # Fake a capability here
+ $capabilities{APOP} = '' if ($this->banner() =~ /<.*>/);
- if ($this->_CAPA()) {
- $capabilities{CAPA} = 1;
- $capa = $this->read_until_dot();
- %capabilities = (%capabilities, map { /^\s*(\S+)\s*(.*)/ } @$capa);
- }
- else {
- # Check AUTH for SASL capabilities
- if ( $this->command('AUTH')->response() == CMD_OK ) {
- my $mechanism = $this->read_until_dot();
- $capabilities{SASL} = join " ", map { m/([A-Z0-9_-]+)/ } @{ $mechanism };
- }
+ if ($this->_CAPA()) {
+ $capabilities{CAPA} = 1;
+ $capa = $this->read_until_dot();
+ %capabilities = (%capabilities, map {/^\s*(\S+)\s*(.*)/} @$capa);
+ }
+ else {
+
+ # Check AUTH for SASL capabilities
+ if ($this->command('AUTH')->response() == CMD_OK) {
+ my $mechanism = $this->read_until_dot();
+ $capabilities{SASL} = join " ", map {m/([A-Z0-9_-]+)/} @{$mechanism};
}
-
- return ${*$this}{'net_pop3e_capabilities'} = \%capabilities;
+ }
+
+ return ${*$this}{'net_pop3e_capabilities'} = \%capabilities;
}
+
sub capabilities {
- my $this = shift;
+ my $this = shift;
- ${*$this}{'net_pop3e_capabilities'} || $this->capa;
+ ${*$this}{'net_pop3e_capabilities'} || $this->capa;
}
-
-sub auth {
- my ($self, $username, $password) = @_;
-
- eval {
- require MIME::Base64;
- require Authen::SASL;
- } or $self->set_status(500,["Need MIME::Base64 and Authen::SASL todo auth"]), return 0;
-
- my $capa = $self->capa;
- my $mechanisms = $capa->{SASL} || 'CRAM-MD5';
-
- my $sasl;
-
- if (ref($username) and UNIVERSAL::isa($username,'Authen::SASL')) {
- $sasl = $username;
- my $user_mech = $sasl->mechanism || '';
- my @user_mech = split(/\s+/, $user_mech);
- my %user_mech; @user_mech{@user_mech} = ();
-
- my @server_mech = split(/\s+/,$mechanisms);
- my @mech = @user_mech
- ? grep { exists $user_mech{$_} } @server_mech
- : @server_mech;
- unless (@mech) {
- $self->set_status(500,
- [ 'Client SASL mechanisms (',
- join(', ', @user_mech),
- ') do not match the SASL mechnism the server announces (',
- join(', ', @server_mech), ')',
- ]);
- return 0;
- }
- $sasl->mechanism(join(" ",@mech));
- }
- else {
- die "auth(username, password)" if not length $username;
- $sasl = Authen::SASL->new(mechanism=> $mechanisms,
- callback => { user => $username,
- pass => $password,
- authname => $username,
- });
- }
- # We should probably allow the user to pass the host, but I don't
- # currently know and SASL mechanisms that are used by smtp that need it
- my ( $hostname ) = split /:/ , ${*$self}{'net_pop3_host'};
- my $client = eval { $sasl->client_new('pop',$hostname,0) };
-
- unless ($client) {
- my $mech = $sasl->mechanism;
- $self->set_status(500, [
- " Authen::SASL failure: $@",
- '(please check if your local Authen::SASL installation',
- "supports mechanism '$mech'"
- ]);
+sub auth {
+ my ($self, $username, $password) = @_;
+
+ eval {
+ require MIME::Base64;
+ require Authen::SASL;
+ } or $self->set_status(500, ["Need MIME::Base64 and Authen::SASL todo auth"]), return 0;
+
+ my $capa = $self->capa;
+ my $mechanisms = $capa->{SASL} || 'CRAM-MD5';
+
+ my $sasl;
+
+ if (ref($username) and UNIVERSAL::isa($username, 'Authen::SASL')) {
+ $sasl = $username;
+ my $user_mech = $sasl->mechanism || '';
+ my @user_mech = split(/\s+/, $user_mech);
+ my %user_mech;
+ @user_mech{@user_mech} = ();
+
+ my @server_mech = split(/\s+/, $mechanisms);
+ my @mech = @user_mech
+ ? grep { exists $user_mech{$_} } @server_mech
+ : @server_mech;
+ unless (@mech) {
+ $self->set_status(
+ 500,
+ [ 'Client SASL mechanisms (',
+ join(', ', @user_mech),
+ ') do not match the SASL mechnism the server announces (',
+ join(', ', @server_mech), ')',
+ ]
+ );
return 0;
}
-
- my ($token) = $client->client_start
- or do {
- my $mech = $client->mechanism;
- $self->set_status(500, [
- ' Authen::SASL failure: $client->client_start ',
- "mechanism '$mech' hostname #$hostname#",
- $client->error
- ]);
- return 0;
- };
-
- # We dont support sasl mechanisms that encrypt the socket traffic.
- # todo that we would really need to change the ISA hierarchy
- # so we dont inherit from IO::Socket, but instead hold it in an attribute
-
- my @cmd = ("AUTH", $client->mechanism);
- my $code;
-
- push @cmd, MIME::Base64::encode_base64($token,'')
- if defined $token and length $token;
-
- while (($code = $self->command(@cmd)->response()) == CMD_MORE) {
-
- my ( $token ) = $client->client_step(
- MIME::Base64::decode_base64(
- ($self->message)[0]
- )
- ) or do {
- $self->set_status(500, [
- ' Authen::SASL failure: $client->client_step ',
- "mechanism '", $client->mechanism ," hostname #$hostname#, ",
+
+ $sasl->mechanism(join(" ", @mech));
+ }
+ else {
+ die "auth(username, password)" if not length $username;
+ $sasl = Authen::SASL->new(
+ mechanism => $mechanisms,
+ callback => {
+ user => $username,
+ pass => $password,
+ authname => $username,
+ }
+ );
+ }
+
+ # We should probably allow the user to pass the host, but I don't
+ # currently know and SASL mechanisms that are used by smtp that need it
+ my ($hostname) = split /:/, ${*$self}{'net_pop3_host'};
+ my $client = eval { $sasl->client_new('pop', $hostname, 0) };
+
+ unless ($client) {
+ my $mech = $sasl->mechanism;
+ $self->set_status(
+ 500,
+ [ " Authen::SASL failure: $@",
+ '(please check if your local Authen::SASL installation',
+ "supports mechanism '$mech'"
+ ]
+ );
+ return 0;
+ }
+
+ my ($token) = $client->client_start
+ or do {
+ my $mech = $client->mechanism;
+ $self->set_status(
+ 500,
+ [ ' Authen::SASL failure: $client->client_start ',
+ "mechanism '$mech' hostname #$hostname#",
+ $client->error
+ ]
+ );
+ return 0;
+ };
+
+ # We dont support sasl mechanisms that encrypt the socket traffic.
+ # todo that we would really need to change the ISA hierarchy
+ # so we dont inherit from IO::Socket, but instead hold it in an attribute
+
+ my @cmd = ("AUTH", $client->mechanism);
+ my $code;
+
+ push @cmd, MIME::Base64::encode_base64($token, '')
+ if defined $token and length $token;
+
+ while (($code = $self->command(@cmd)->response()) == CMD_MORE) {
+
+ my ($token) = $client->client_step(MIME::Base64::decode_base64(($self->message)[0])) or do {
+ $self->set_status(
+ 500,
+ [ ' Authen::SASL failure: $client->client_step ',
+ "mechanism '", $client->mechanism, " hostname #$hostname#, ",
$client->error
- ]);
- return 0;
- };
-
- @cmd = (MIME::Base64::encode_base64(
- defined $token ? $token : '',
- ''
- )
+ ]
);
- }
+ return 0;
+ };
+
+ @cmd = (MIME::Base64::encode_base64(defined $token ? $token : '', ''));
+ }
- $code == CMD_OK;
+ $code == CMD_OK;
}
+
sub banner {
- my $this = shift;
+ my $this = shift;
- return ${*$this}{'net_pop3_banner'};
+ return ${*$this}{'net_pop3_banner'};
}
1;
The subversion source repository can be browsed at
- http://svn.mutatus.co.uk/browse/libnet/
+ http://svn.goingon.net/viewvc/libnet/
If you have a subversion client, then you can checkout the latest code with
- svn co http://svn.mutatus.co.uk/repos/libnet/trunk libnet
+ svn co http://svn.goingon.net/repos/libnet/trunk libnet
INSTALLATION
COPYRIGHT
- © 1996-2004 Graham Barr. All rights reserved.
+ (C) 1996-2007 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.
use Net::Cmd;
use Net::Config;
-$VERSION = "2.30";
+$VERSION = "2.31";
@ISA = qw(Net::Cmd IO::Socket::INET);
-sub new
-{
- my $self = shift;
- my $type = ref($self) || $self;
- my ($host,%arg);
- if (@_ % 2) {
- $host = shift ;
- %arg = @_;
- } else {
- %arg = @_;
- $host=delete $arg{Host};
- }
- my $hosts = defined $host ? $host : $NetConfig{smtp_hosts};
- my $obj;
-
- my $h;
- foreach $h (@{ref($hosts) ? $hosts : [ $hosts ]})
- {
- $obj = $type->SUPER::new(PeerAddr => ($host = $h),
- PeerPort => $arg{Port} || 'smtp(25)',
- LocalAddr => $arg{LocalAddr},
- LocalPort => $arg{LocalPort},
- Proto => 'tcp',
- Timeout => defined $arg{Timeout}
- ? $arg{Timeout}
- : 120
- ) and last;
+
+sub new {
+ my $self = shift;
+ my $type = ref($self) || $self;
+ my ($host, %arg);
+ if (@_ % 2) {
+ $host = shift;
+ %arg = @_;
+ }
+ else {
+ %arg = @_;
+ $host = delete $arg{Host};
+ }
+ my $hosts = defined $host ? $host : $NetConfig{smtp_hosts};
+ my $obj;
+
+ my $h;
+ foreach $h (@{ref($hosts) ? $hosts : [$hosts]}) {
+ $obj = $type->SUPER::new(
+ PeerAddr => ($host = $h),
+ PeerPort => $arg{Port} || 'smtp(25)',
+ LocalAddr => $arg{LocalAddr},
+ LocalPort => $arg{LocalPort},
+ Proto => 'tcp',
+ Timeout => defined $arg{Timeout}
+ ? $arg{Timeout}
+ : 120
+ )
+ and last;
}
- return undef
- unless defined $obj;
+ return undef
+ unless defined $obj;
- $obj->autoflush(1);
+ $obj->autoflush(1);
- $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
+ $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
- unless ($obj->response() == CMD_OK)
- {
- $obj->close();
- return undef;
+ unless ($obj->response() == CMD_OK) {
+ $obj->close();
+ return undef;
}
- ${*$obj}{'net_smtp_exact_addr'} = $arg{ExactAddresses};
- ${*$obj}{'net_smtp_host'} = $host;
+ ${*$obj}{'net_smtp_exact_addr'} = $arg{ExactAddresses};
+ ${*$obj}{'net_smtp_host'} = $host;
- (${*$obj}{'net_smtp_banner'}) = $obj->message;
- (${*$obj}{'net_smtp_domain'}) = $obj->message =~ /\A\s*(\S+)/;
+ (${*$obj}{'net_smtp_banner'}) = $obj->message;
+ (${*$obj}{'net_smtp_domain'}) = $obj->message =~ /\A\s*(\S+)/;
- unless($obj->hello($arg{Hello} || ""))
- {
- $obj->close();
- return undef;
+ unless ($obj->hello($arg{Hello} || "")) {
+ $obj->close();
+ return undef;
}
- $obj;
+ $obj;
}
+
sub host {
- my $me = shift;
- ${*$me}{'net_smtp_host'};
+ my $me = shift;
+ ${*$me}{'net_smtp_host'};
}
##
## User interface methods
##
-sub banner
-{
- my $me = shift;
- return ${*$me}{'net_smtp_banner'} || undef;
+sub banner {
+ my $me = shift;
+
+ return ${*$me}{'net_smtp_banner'} || undef;
}
-sub domain
-{
- my $me = shift;
- return ${*$me}{'net_smtp_domain'} || undef;
+sub domain {
+ my $me = shift;
+
+ return ${*$me}{'net_smtp_domain'} || undef;
}
+
sub etrn {
- my $self = shift;
- defined($self->supports('ETRN',500,["Command unknown: 'ETRN'"])) &&
- $self->_ETRN(@_);
+ my $self = shift;
+ defined($self->supports('ETRN', 500, ["Command unknown: 'ETRN'"]))
+ && $self->_ETRN(@_);
}
+
sub auth {
- my ($self, $username, $password) = @_;
+ my ($self, $username, $password) = @_;
- eval {
- require MIME::Base64;
- require Authen::SASL;
- } or $self->set_status(500,["Need MIME::Base64 and Authen::SASL todo auth"]), return 0;
+ eval {
+ require MIME::Base64;
+ require Authen::SASL;
+ } or $self->set_status(500, ["Need MIME::Base64 and Authen::SASL todo auth"]), return 0;
- my $mechanisms = $self->supports('AUTH',500,["Command unknown: 'AUTH'"]);
- return unless defined $mechanisms;
+ my $mechanisms = $self->supports('AUTH', 500, ["Command unknown: 'AUTH'"]);
+ return unless defined $mechanisms;
- my $sasl;
+ my $sasl;
- if (ref($username) and UNIVERSAL::isa($username,'Authen::SASL')) {
- $sasl = $username;
- $sasl->mechanism($mechanisms);
- }
- else {
- die "auth(username, password)" if not length $username;
- $sasl = Authen::SASL->new(mechanism=> $mechanisms,
- callback => { user => $username,
- pass => $password,
- authname => $username,
- });
- }
+ if (ref($username) and UNIVERSAL::isa($username, 'Authen::SASL')) {
+ $sasl = $username;
+ $sasl->mechanism($mechanisms);
+ }
+ else {
+ die "auth(username, password)" if not length $username;
+ $sasl = Authen::SASL->new(
+ mechanism => $mechanisms,
+ callback => {
+ user => $username,
+ pass => $password,
+ authname => $username,
+ }
+ );
+ }
- # We should probably allow the user to pass the host, but I don't
- # currently know and SASL mechanisms that are used by smtp that need it
- my $client = $sasl->client_new('smtp',${*$self}{'net_smtp_host'},0);
- my $str = $client->client_start;
- # We dont support sasl mechanisms that encrypt the socket traffic.
- # todo that we would really need to change the ISA hierarchy
- # so we dont inherit from IO::Socket, but instead hold it in an attribute
-
- my @cmd = ("AUTH", $client->mechanism);
- my $code;
-
- push @cmd, MIME::Base64::encode_base64($str,'')
- if defined $str and length $str;
-
- while (($code = $self->command(@cmd)->response()) == CMD_MORE) {
- @cmd = (MIME::Base64::encode_base64(
- $client->client_step(
- MIME::Base64::decode_base64(
- ($self->message)[0]
- )
- ), ''
- ));
- }
+ # We should probably allow the user to pass the host, but I don't
+ # currently know and SASL mechanisms that are used by smtp that need it
+ my $client = $sasl->client_new('smtp', ${*$self}{'net_smtp_host'}, 0);
+ my $str = $client->client_start;
+
+ # We dont support sasl mechanisms that encrypt the socket traffic.
+ # todo that we would really need to change the ISA hierarchy
+ # so we dont inherit from IO::Socket, but instead hold it in an attribute
+
+ my @cmd = ("AUTH", $client->mechanism);
+ my $code;
+
+ push @cmd, MIME::Base64::encode_base64($str, '')
+ if defined $str and length $str;
+
+ while (($code = $self->command(@cmd)->response()) == CMD_MORE) {
+ @cmd = (
+ MIME::Base64::encode_base64(
+ $client->client_step(MIME::Base64::decode_base64(($self->message)[0])), ''
+ )
+ );
+ }
- $code == CMD_OK;
+ $code == CMD_OK;
}
-sub hello
-{
- my $me = shift;
- my $domain = shift || "localhost.localdomain";
- my $ok = $me->_EHLO($domain);
- my @msg = $me->message;
-
- if($ok)
- {
- my $h = ${*$me}{'net_smtp_esmtp'} = {};
- my $ln;
- foreach $ln (@msg) {
- $h->{uc $1} = $2
- if $ln =~ /(\w+)\b[= \t]*([^\n]*)/;
+
+sub hello {
+ my $me = shift;
+ my $domain = shift || "localhost.localdomain";
+ my $ok = $me->_EHLO($domain);
+ my @msg = $me->message;
+
+ if ($ok) {
+ my $h = ${*$me}{'net_smtp_esmtp'} = {};
+ my $ln;
+ foreach $ln (@msg) {
+ $h->{uc $1} = $2
+ if $ln =~ /(\w+)\b[= \t]*([^\n]*)/;
}
}
- elsif($me->status == CMD_ERROR)
- {
- @msg = $me->message
- if $ok = $me->_HELO($domain);
+ elsif ($me->status == CMD_ERROR) {
+ @msg = $me->message
+ if $ok = $me->_HELO($domain);
}
- return undef unless $ok;
+ return undef unless $ok;
- $msg[0] =~ /\A\s*(\S+)/;
- return ($1 || " ");
+ $msg[0] =~ /\A\s*(\S+)/;
+ return ($1 || " ");
}
+
sub supports {
- my $self = shift;
- my $cmd = uc shift;
- return ${*$self}{'net_smtp_esmtp'}->{$cmd}
- if exists ${*$self}{'net_smtp_esmtp'}->{$cmd};
- $self->set_status(@_)
- if @_;
- return;
+ my $self = shift;
+ my $cmd = uc shift;
+ return ${*$self}{'net_smtp_esmtp'}->{$cmd}
+ if exists ${*$self}{'net_smtp_esmtp'}->{$cmd};
+ $self->set_status(@_)
+ if @_;
+ return;
}
+
sub _addr {
my $self = shift;
my $addr = shift;
"<$addr>";
}
-sub mail
-{
- my $me = shift;
- my $addr = _addr($me, 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
+
+sub mail {
+ my $me = shift;
+ my $addr = _addr($me, 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';
+ 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) eq "FULL") ? "FULL" : "HDRS");
+ if (defined($v = delete $opt{Return})) {
+ if (exists $esmtp->{DSN}) {
+ $opts .= " RET=" . ((uc($v) eq "FULL") ? "FULL" : "HDRS");
}
- else
- {
- carp 'Net::SMTP::mail: DSN option not supported by host';
+ else {
+ carp 'Net::SMTP::mail: DSN option not supported by host';
}
}
- if(defined($v = delete $opt{Bits}))
- {
- if($v eq "8")
- {
- if(exists $esmtp->{'8BITMIME'})
- {
- $opts .= " BODY=8BITMIME";
+ if (defined($v = delete $opt{Bits})) {
+ if ($v eq "8") {
+ if (exists $esmtp->{'8BITMIME'}) {
+ $opts .= " BODY=8BITMIME";
}
- else
- {
- carp 'Net::SMTP::mail: 8BITMIME option not supported by host';
+ else {
+ carp 'Net::SMTP::mail: 8BITMIME option not supported by host';
}
}
- elsif($v eq "binary")
- {
- if(exists $esmtp->{'BINARYMIME'} && exists $esmtp->{'CHUNKING'})
- {
- $opts .= " BODY=BINARYMIME";
- ${*$me}{'net_smtp_chunking'} = 1;
+ elsif ($v eq "binary") {
+ if (exists $esmtp->{'BINARYMIME'} && exists $esmtp->{'CHUNKING'}) {
+ $opts .= " BODY=BINARYMIME";
+ ${*$me}{'net_smtp_chunking'} = 1;
}
- else
- {
- carp 'Net::SMTP::mail: BINARYMIME option not supported by host';
+ else {
+ carp 'Net::SMTP::mail: BINARYMIME option not supported by host';
}
}
- elsif(exists $esmtp->{'8BITMIME'} or exists $esmtp->{'BINARYMIME'})
- {
- $opts .= " BODY=7BIT";
+ elsif (exists $esmtp->{'8BITMIME'} or exists $esmtp->{'BINARYMIME'}) {
+ $opts .= " BODY=7BIT";
+ }
+ else {
+ carp 'Net::SMTP::mail: 8BITMIME and BINARYMIME options not supported by host';
+ }
+ }
+
+ if (defined($v = delete $opt{Transaction})) {
+ if (exists $esmtp->{CHECKPOINT}) {
+ $opts .= " TRANSID=" . _addr($me, $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: 8BITMIME and BINARYMIME options not supported by host';
+ else {
+ carp 'Net::SMTP::mail: DSN option not supported by host';
}
}
- if(defined($v = delete $opt{Transaction}))
- {
- if(exists $esmtp->{CHECKPOINT})
- {
- $opts .= " TRANSID=" . _addr($me, $v);
+ if (defined($v = delete $opt{ENVID})) {
+
+ # expected to be in a format as required by RFC 3461, xtext-encoded
+ if (exists $esmtp->{DSN}) {
+ $opts .= " ENVID=$v";
}
- else
- {
- carp 'Net::SMTP::mail: CHECKPOINT option not supported by host';
+ else {
+ carp 'Net::SMTP::mail: DSN 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"
+ if (defined($v = delete $opt{AUTH})) {
+
+ # expected to be in a format as required by RFC 2554,
+ # rfc2821-quoted and xtext-encoded, or <>
+ if (exists $esmtp->{AUTH}) {
+ $v = '<>' if !defined($v) || $v eq '';
+ $opts .= " AUTH=$v";
}
- else
- {
- carp 'Net::SMTP::mail: DSN option not supported by host';
+ else {
+ carp 'Net::SMTP::mail: AUTH option not supported by host';
}
}
- if(defined($v = delete $opt{XVERP}))
- {
- if(exists $esmtp->{'XVERP'})
- {
- $opts .= " XVERP"
+ if (defined($v = delete $opt{XVERP})) {
+ if (exists $esmtp->{'XVERP'}) {
+ $opts .= " XVERP";
}
- else
- {
- carp 'Net::SMTP::mail: XVERP option not supported by host';
+ else {
+ carp 'Net::SMTP::mail: XVERP option not supported by host';
}
}
- carp 'Net::SMTP::recipient: unknown option(s) '
- . join(" ", keys %opt)
- . ' - ignored'
- if scalar keys %opt;
+ 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 :-(';
+ else {
+ carp 'Net::SMTP::mail: ESMTP not supported by host - options discarded :-(';
}
}
- $me->_MAIL("FROM:".$addr.$opts);
+ $me->_MAIL("FROM:" . $addr . $opts);
}
-sub send { my $me = shift; $me->_SEND("FROM:" . _addr($me, $_[0])) }
+
+sub send { my $me = shift; $me->_SEND("FROM:" . _addr($me, $_[0])) }
sub send_or_mail { my $me = shift; $me->_SOML("FROM:" . _addr($me, $_[0])) }
sub send_and_mail { my $me = shift; $me->_SAML("FROM:" . _addr($me, $_[0])) }
-sub reset
-{
- my $me = shift;
- $me->dataend()
- if(exists ${*$me}{'net_smtp_lastch'});
+sub reset {
+ my $me = shift;
- $me->_RSET();
+ $me->dataend()
+ if (exists ${*$me}{'net_smtp_lastch'});
+
+ $me->_RSET();
}
-sub recipient
-{
- my $smtp = shift;
- my $opts = "";
- my $skip_bad = 0;
+sub recipient {
+ my $smtp = shift;
+ my $opts = "";
+ my $skip_bad = 0;
- if(@_ && ref($_[-1]))
- {
- my %opt = %{pop(@_)};
- my $v;
+ if (@_ && ref($_[-1])) {
+ my %opt = %{pop(@_)};
+ my $v;
- $skip_bad = delete $opt{'SkipBad'};
+ $skip_bad = delete $opt{'SkipBad'};
- if(exists ${*$smtp}{'net_smtp_esmtp'})
- {
- my $esmtp = ${*$smtp}{'net_smtp_esmtp'};
+ 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)
+ 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';
+ else {
+ carp 'Net::SMTP::recipient: DSN option not supported by host';
}
}
- if(defined($v = delete $opt{ORcpt}))
- {
- if(exists $esmtp->{DSN})
- {
- $opts .= " ORCPT=" . $v;
+ if (defined($v = delete $opt{ORcpt})) {
+ if (exists $esmtp->{DSN}) {
+ $opts .= " ORCPT=" . $v;
}
- else
- {
- carp 'Net::SMTP::recipient: DSN option not supported by host';
+ 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;
+ carp 'Net::SMTP::recipient: unknown option(s) ' . join(" ", keys %opt) . ' - ignored'
+ if scalar keys %opt;
}
- elsif(%opt)
- {
- carp 'Net::SMTP::recipient: ESMTP not supported by host - options discarded :-(';
+ elsif (%opt) {
+ carp 'Net::SMTP::recipient: ESMTP not supported by host - options discarded :-(';
}
}
- my @ok;
- my $addr;
- foreach $addr (@_)
- {
- if($smtp->_RCPT("TO:" . _addr($smtp, $addr) . $opts)) {
- push(@ok,$addr) if $skip_bad;
+ my @ok;
+ my $addr;
+ foreach $addr (@_) {
+ if ($smtp->_RCPT("TO:" . _addr($smtp, $addr) . $opts)) {
+ push(@ok, $addr) if $skip_bad;
}
- elsif(!$skip_bad) {
+ elsif (!$skip_bad) {
return 0;
}
}
- return $skip_bad ? @ok : 1;
+ return $skip_bad ? @ok : 1;
}
BEGIN {
*bcc = \&recipient;
}
-sub data
-{
- my $me = shift;
- if(exists ${*$me}{'net_smtp_chunking'})
- {
- carp 'Net::SMTP::data: CHUNKING extension in use, must call bdat instead';
+sub data {
+ my $me = shift;
+
+ if (exists ${*$me}{'net_smtp_chunking'}) {
+ carp 'Net::SMTP::data: CHUNKING extension in use, must call bdat instead';
}
- else
- {
- my $ok = $me->_DATA() && $me->datasend(@_);
+ else {
+ my $ok = $me->_DATA() && $me->datasend(@_);
- $ok && @_ ? $me->dataend
- : $ok;
+ $ok && @_
+ ? $me->dataend
+ : $ok;
}
}
-sub bdat
-{
- my $me = shift;
- if(exists ${*$me}{'net_smtp_chunking'})
- {
- my $data = shift;
+sub bdat {
+ my $me = shift;
+
+ if (exists ${*$me}{'net_smtp_chunking'}) {
+ my $data = shift;
- $me->_BDAT(length $data) && $me->rawdatasend($data) &&
- $me->response() == CMD_OK;
+ $me->_BDAT(length $data)
+ && $me->rawdatasend($data)
+ && $me->response() == CMD_OK;
}
- else
- {
- carp 'Net::SMTP::bdat: CHUNKING extension is not in use, call data instead';
+ else {
+ carp 'Net::SMTP::bdat: CHUNKING extension is not in use, call data instead';
}
}
-sub bdatlast
-{
- my $me = shift;
- if(exists ${*$me}{'net_smtp_chunking'})
- {
- my $data = shift;
+sub bdatlast {
+ my $me = shift;
+
+ if (exists ${*$me}{'net_smtp_chunking'}) {
+ my $data = shift;
- $me->_BDAT(length $data, "LAST") && $me->rawdatasend($data) &&
- $me->response() == CMD_OK;
+ $me->_BDAT(length $data, "LAST")
+ && $me->rawdatasend($data)
+ && $me->response() == CMD_OK;
}
- else
- {
- carp 'Net::SMTP::bdat: CHUNKING extension is not in use, call data instead';
+ else {
+ carp 'Net::SMTP::bdat: CHUNKING extension is not in use, call data instead';
}
}
+
sub datafh {
my $me = shift;
return unless $me->_DATA();
return $me->tied_fh;
}
-sub expand
-{
- my $me = shift;
- $me->_EXPN(@_) ? ($me->message)
- : ();
+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 help {
+ my $me = shift;
+
+ $me->_HELP(@_)
+ ? scalar $me->message
+ : undef;
}
-sub quit
-{
- my $me = shift;
- $me->_QUIT;
- $me->close;
+sub quit {
+ my $me = shift;
+
+ $me->_QUIT;
+ $me->close;
}
-sub DESTROY
-{
-# ignore
+
+sub DESTROY {
+
+ # ignore
}
##
## RFC821 commands
##
-sub _EHLO { shift->command("EHLO", @_)->response() == CMD_OK }
-sub _HELO { shift->command("HELO", @_)->response() == CMD_OK }
-sub _MAIL { shift->command("MAIL", @_)->response() == CMD_OK }
-sub _RCPT { shift->command("RCPT", @_)->response() == CMD_OK }
-sub _SEND { shift->command("SEND", @_)->response() == CMD_OK }
-sub _SAML { shift->command("SAML", @_)->response() == CMD_OK }
-sub _SOML { shift->command("SOML", @_)->response() == CMD_OK }
-sub _VRFY { shift->command("VRFY", @_)->response() == CMD_OK }
-sub _EXPN { shift->command("EXPN", @_)->response() == CMD_OK }
-sub _HELP { shift->command("HELP", @_)->response() == CMD_OK }
-sub _RSET { shift->command("RSET")->response() == CMD_OK }
-sub _NOOP { shift->command("NOOP")->response() == CMD_OK }
-sub _QUIT { shift->command("QUIT")->response() == CMD_OK }
-sub _DATA { shift->command("DATA")->response() == CMD_MORE }
+
+sub _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 _BDAT { shift->command("BDAT", @_) }
-sub _TURN { shift->unsupported(@_); }
-sub _ETRN { shift->command("ETRN", @_)->response() == CMD_OK }
-sub _AUTH { shift->command("AUTH", @_)->response() == CMD_OK }
+sub _TURN { shift->unsupported(@_); }
+sub _ETRN { shift->command("ETRN", @_)->response() == CMD_OK }
+sub _AUTH { shift->command("AUTH", @_)->response() == CMD_OK }
1;
Return => "FULL" | "HDRS"
Bits => "7" | "8" | "binary"
Transaction => <ADDRESS>
- Envelope => <ENVID>
+ Envelope => <ENVID> # xtext-encodes its argument
+ ENVID => <ENVID> # similar to Envelope, but expects argument encoded
XVERP => 1
+ AUTH => <submitter> # encoded address according to RFC 2554
The C<Return> and C<Envelope> parameters are used for DSN (Delivery
Status Notification).
+The submitter address in C<AUTH> option is expected to be in a format as
+required by RFC 2554, in an RFC2821-quoted form and xtext-encoded, or <> .
+
=item reset ()
Reset the status of the server. This may be called after a message has been
It is used to pass along the original recipient that the mail was first
sent to. The machine that generates a DSN will use this address to inform
the sender, because he can't know if recipients get rewritten by mail servers.
+It is expected to be in a format as required by RFC3461, xtext-encoded.
=item to ( ADDRESS [, ADDRESS [...]] )
use Net::Config;
use IO::Select;
-@ISA = qw(Exporter);
+@ISA = qw(Exporter);
@EXPORT_OK = qw(inet_time inet_daytime);
$VERSION = "2.10";
$TIMEOUT = 120;
-sub _socket
-{
- my($pname,$pnum,$host,$proto,$timeout) = @_;
- $proto ||= 'udp';
+sub _socket {
+ my ($pname, $pnum, $host, $proto, $timeout) = @_;
- my $port = (getservbyname($pname, $proto))[2] || $pnum;
+ $proto ||= 'udp';
- my $hosts = defined $host ? [ $host ] : $NetConfig{$pname . '_hosts'};
+ my $port = (getservbyname($pname, $proto))[2] || $pnum;
- my $me;
+ my $hosts = defined $host ? [$host] : $NetConfig{$pname . '_hosts'};
- foreach $host (@$hosts)
- {
- $me = IO::Socket::INET->new(PeerAddr => $host,
- PeerPort => $port,
- Proto => $proto
- ) and last;
+ my $me;
+
+ foreach $host (@$hosts) {
+ $me = IO::Socket::INET->new(
+ PeerAddr => $host,
+ PeerPort => $port,
+ Proto => $proto
+ )
+ and last;
}
- return unless $me;
+ return unless $me;
- $me->send("\n")
- if $proto eq 'udp';
+ $me->send("\n")
+ if $proto eq 'udp';
- $timeout = $TIMEOUT
- unless defined $timeout;
+ $timeout = $TIMEOUT
+ unless defined $timeout;
- IO::Select->new($me)->can_read($timeout)
- ? $me
- : undef;
+ IO::Select->new($me)->can_read($timeout)
+ ? $me
+ : undef;
}
-sub inet_time
-{
- my $s = _socket('time',37,@_) || return undef;
- my $buf = '';
- my $offset = 0 | 0;
- return undef
- unless defined $s->recv($buf, length(pack("N",0)));
+sub inet_time {
+ my $s = _socket('time', 37, @_) || return undef;
+ my $buf = '';
+ my $offset = 0 | 0;
+
+ return undef
+ unless defined $s->recv($buf, length(pack("N", 0)));
- # unpack, we | 0 to ensure we have an unsigned
- my $time = (unpack("N",$buf))[0] | 0;
+ # unpack, we | 0 to ensure we have an unsigned
+ my $time = (unpack("N", $buf))[0] | 0;
- # the time protocol return time in seconds since 1900, convert
- # it to a the required format
+ # the time protocol return time in seconds since 1900, convert
+ # it to a the required format
- if($^O eq "MacOS") {
- # MacOS return seconds since 1904, 1900 was not a leap year.
- $offset = (4 * 31536000) | 0;
- }
- else {
- # otherwise return seconds since 1972, there were 17 leap years between
- # 1900 and 1972
- $offset = (70 * 31536000 + 17 * 86400) | 0;
- }
+ if ($^O eq "MacOS") {
+
+ # MacOS return seconds since 1904, 1900 was not a leap year.
+ $offset = (4 * 31536000) | 0;
+ }
+ else {
- $time - $offset;
+ # otherwise return seconds since 1972, there were 17 leap years between
+ # 1900 and 1972
+ $offset = (70 * 31536000 + 17 * 86400) | 0;
+ }
+
+ $time - $offset;
}
-sub inet_daytime
-{
- my $s = _socket('daytime',13,@_) || return undef;
- my $buf = '';
- defined($s->recv($buf, 1024)) ? $buf
- : undef;
+sub inet_daytime {
+ my $s = _socket('daytime', 13, @_) || return undef;
+ my $buf = '';
+
+ defined($s->recv($buf, 1024))
+ ? $buf
+ : undef;
}
1;
Copyright (c) 1997 Graham Barr.
All rights reserved.
-=for html <hr>
-
-I<$Id: //depot/libnet/Net/libnetFAQ.pod#6 $>
-
projects / p5sagit/p5-mst-13.2.git / commitdiff