From: Steve Peters Date: Tue, 6 Feb 2007 17:29:09 +0000 (+0000) Subject: Upgrade to libnet-1.20. Includes some additional version bumps where bleadperl X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7cf5cf7c1758b1eb1a7f98c7dcf213f949e5a5b4;p=p5sagit%2Fp5-mst-13.2.git Upgrade to libnet-1.20. Includes some additional version bumps where bleadperl differs from the CPAN version (Net::FTP and Net::NNTP). p4raw-id: //depot/perl@30144 --- diff --git a/lib/Net/Changes.libnet b/lib/Net/Changes.libnet index 724135c..2d74af5 100644 --- a/lib/Net/Changes.libnet +++ b/lib/Net/Changes.libnet @@ -1,3 +1,16 @@ +libnet 1.20 -- Fri Feb 2 19:42:51 CST 2007 + +Bug Fixes + * Fixed incorrect handling of CRLF that straddled two blocks + * Fix bug in response() which was too liberal in what it thought was a response line + * Silence uninitialized value warnings in Net::Cmd during testing on Win32 + * Documentations typos and updates + +Enhancements + * Added support for ORCPT into Net::SMTP + * Support for servers that expect the USER command in upper or lower case. Try USER + first then try user if that fails + libnet 1.19 -- Wed Jun 30 14:53:48 BST 2004 Bug Fixes diff --git a/lib/Net/Cmd.pm b/lib/Net/Cmd.pm index f7c7484..201349f 100644 --- a/lib/Net/Cmd.pm +++ b/lib/Net/Cmd.pm @@ -1,6 +1,6 @@ # Net::Cmd.pm $Id: //depot/libnet/Net/Cmd.pm#34 $ # -# Copyright (c) 1995-1997 Graham Barr . All rights reserved. +# Copyright (c) 1995-2006 Graham Barr . All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. @@ -21,7 +21,9 @@ BEGIN { } } -$VERSION = "2.26_01"; +my $doUTF8 = eval { require utf8 }; + +$VERSION = "2.27"; @ISA = qw(Exporter); @EXPORT = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING); @@ -266,7 +268,9 @@ sub getline { my $timeout = $cmd->timeout || undef; my $rout; - if (select($rout=$rin, undef, undef, $timeout)) + + my $select_ret = select($rout=$rin, undef, undef, $timeout); + if ($select_ret > 0) { unless (sysread($cmd, $buf="", 1024)) { @@ -287,7 +291,8 @@ sub getline } else { - carp("$cmd: Timeout") if($cmd->debug); + my $msg = $select_ret ? "Error or Interrupted: $!" : "Timeout"; + carp("$cmd: $msg") if($cmd->debug); return undef; } } @@ -390,6 +395,8 @@ sub datasend my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_; my $line = join("" ,@$arr); + utf8::encode($line) if $doUTF8; + return 0 unless defined(fileno($cmd)); my $last_ch = ${*$cmd}{'net_cmd_last_ch'}; @@ -767,12 +774,8 @@ Graham Barr =head1 COPYRIGHT -Copyright (c) 1995-1997 Graham Barr. All rights reserved. +Copyright (c) 1995-2006 Graham Barr. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. -=for html
- -I<$Id: //depot/libnet/Net/Cmd.pm#34 $> - =cut diff --git a/lib/Net/FTP.pm b/lib/Net/FTP.pm index 6b15b9c..99057af 100644 --- a/lib/Net/FTP.pm +++ b/lib/Net/FTP.pm @@ -22,7 +22,7 @@ use Net::Config; use Fcntl qw(O_WRONLY O_RDONLY O_APPEND O_CREAT O_TRUNC); # use AutoLoader qw(AUTOLOAD); -$VERSION = "2.75"; +$VERSION = "2.77_01"; @ISA = qw(Exporter Net::Cmd IO::Socket::INET); # Someday I will "use constant", when I am not bothered to much about @@ -1118,7 +1118,7 @@ sub response sub parse_response { return ($1, $2 eq "-") - if $_[1] =~ s/^(\d\d\d)(.?)//o; + if $_[1] =~ s/^(\d\d\d)([- ]?)//o; my $ftp = shift; @@ -1217,11 +1217,21 @@ sub _STOR { shift->command("STOR",@_)->response() == CMD_INFO } sub _STOU { shift->command("STOU",@_)->response() == CMD_INFO } sub _RNFR { shift->command("RNFR",@_)->response() == CMD_MORE } sub _REST { shift->command("REST",@_)->response() == CMD_MORE } -sub _USER { shift->command("user",@_)->response() } # A certain brain dead firewall :-) sub _PASS { shift->command("PASS",@_)->response() } sub _ACCT { shift->command("ACCT",@_)->response() } sub _AUTH { shift->command("AUTH",@_)->response() } +sub _USER { + my $ftp = shift; + my $ok = $ftp->command("USER",@_)->response(); + + # A certain brain dead firewall :-) + $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(@_) } diff --git a/lib/Net/FTP/A.pm b/lib/Net/FTP/A.pm index d068828..44b9cdb 100644 --- a/lib/Net/FTP/A.pm +++ b/lib/Net/FTP/A.pm @@ -10,7 +10,7 @@ use Carp; require Net::FTP::dataconn; @ISA = qw(Net::FTP::dataconn); -$VERSION = "1.16"; +$VERSION = "1.17"; sub read { my $data = shift; @@ -71,7 +71,10 @@ sub write { my $size = shift || croak 'write($buf,$size,[$timeout])'; my $timeout = @_ ? shift : $data->timeout; - (my $tmp = substr($buf,0,$size)) =~ s/\r?\n/\015\012/sg; + my $nr = (my $tmp = substr($buf,0,$size)) =~ tr/\r\n/\015\012/; + $tmp =~ s/[^\015]\012/\015\012/sg if $nr; + $tmp =~ s/^\012/\015\012/ unless ${*$data}{'net_ftp_outcr'}; + ${*$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 diff --git a/lib/Net/NNTP.pm b/lib/Net/NNTP.pm index fb4819a..d4ea3a9 100644 --- a/lib/Net/NNTP.pm +++ b/lib/Net/NNTP.pm @@ -14,7 +14,7 @@ use Carp; use Time::Local; use Net::Config; -$VERSION = "2.23"; +$VERSION = "2.23_01"; @ISA = qw(Net::Cmd IO::Socket::INET); sub new diff --git a/lib/Net/POP3.pm b/lib/Net/POP3.pm index 510d186..02c8bc6 100644 --- a/lib/Net/POP3.pm +++ b/lib/Net/POP3.pm @@ -13,7 +13,7 @@ use Net::Cmd; use Carp; use Net::Config; -$VERSION = "2.28"; +$VERSION = "2.28_2"; @ISA = qw(Net::Cmd IO::Socket::INET); @@ -380,12 +380,19 @@ sub capa { # Fake a capability here $capabilities{APOP} = '' if ($this->banner() =~ /<.*>/); - return \%capabilities unless $this->_CAPA(); - - $capa = $this->read_until_dot(); - %capabilities = map { /^\s*(\S+)\s*(.*)/ } @$capa; - $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 }; + } + } + return ${*$this}{'net_pop3e_capabilities'} = \%capabilities; } @@ -410,7 +417,25 @@ sub auth { if (ref($username) and UNIVERSAL::isa($username,'Authen::SASL')) { $sasl = $username; - $sasl->mechanism($mechanisms); + 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; @@ -423,8 +448,29 @@ sub auth { # 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('pop3',${*$self}{'net_pop3_host'},0); - my $str = $client->client_start; + 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 @@ -433,17 +479,29 @@ sub auth { my @cmd = ("AUTH", $client->mechanism); my $code; - push @cmd, MIME::Base64::encode_base64($str,'') - if defined $str and length $str; + 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( - $client->client_step( - MIME::Base64::decode_base64( - ($self->message)[0] - ) - ), '' - )); + defined $token ? $token : '', + '' + ) + ); } $code == CMD_OK; diff --git a/lib/Net/SMTP.pm b/lib/Net/SMTP.pm index 2e410dd..8069f88 100644 --- a/lib/Net/SMTP.pm +++ b/lib/Net/SMTP.pm @@ -16,7 +16,7 @@ use IO::Socket; use Net::Cmd; use Net::Config; -$VERSION = "2.29"; +$VERSION = "2.30"; @ISA = qw(Net::Cmd IO::Socket::INET); @@ -382,6 +382,18 @@ sub recipient } } + if(defined($v = delete $opt{ORcpt})) + { + if(exists $esmtp->{DSN}) + { + $opts .= " ORCPT=" . $v; + } + else + { + carp 'Net::SMTP::recipient: DSN option not supported by host'; + } + } + carp 'Net::SMTP::recipient: unknown option(s) ' . join(" ", keys %opt) . ' - ignored' @@ -628,7 +640,7 @@ Example: $smtp = Net::SMTP->new('mailhost', - Hello => 'my.mail.domain' + Hello => 'my.mail.domain', Timeout => 30, Debug => 1, ); @@ -636,14 +648,14 @@ Example: # the same $smtp = Net::SMTP->new( Host => 'mailhost', - Hello => 'my.mail.domain' + Hello => 'my.mail.domain', Timeout => 30, Debug => 1, ); # Connect to the default server from Net::config $smtp = Net::SMTP->new( - Hello => 'my.mail.domain' + Hello => 'my.mail.domain', Timeout => 30, ); @@ -732,6 +744,7 @@ The C method can also pass additional case-sensitive OPTIONS as an anonymous hash using key and value pairs. Possible options are: Notify => ['NEVER'] or ['SUCCESS','FAILURE','DELAY'] (see below) + ORcpt => SkipBad => 1 (to ignore bad addresses) If C is true the C will not return an error when a bad @@ -778,6 +791,11 @@ any conditions." $smtp->recipient(@recipients, { Notify => ['FAILURE','DELAY'], SkipBad => 1 }); # Good +ORcpt is also part of the SMTP DSN extension according to RFC3461. +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. + =item to ( ADDRESS [, ADDRESS [...]] ) =item cc ( ADDRESS [, ADDRESS [...]] )