diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Net/SMTP.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Net/SMTP.pm | 215 |
1 files changed, 176 insertions, 39 deletions
diff --git a/Master/tlpkg/tlperl/lib/Net/SMTP.pm b/Master/tlpkg/tlperl/lib/Net/SMTP.pm index 705b5c5ab51..afd017aa0ef 100644 --- a/Master/tlpkg/tlperl/lib/Net/SMTP.pm +++ b/Master/tlpkg/tlperl/lib/Net/SMTP.pm @@ -1,25 +1,53 @@ # Net::SMTP.pm # -# Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>. All rights reserved. +# Versions up to 2.31_1 Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>. +# All rights reserved. +# Changes in Version 2.31_2 onwards Copyright (C) 2013-2014 Steve Hay. All +# rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. package Net::SMTP; -require 5.001; +use 5.008001; use strict; -use vars qw($VERSION @ISA); -use Socket 1.3; +use warnings; + use Carp; use IO::Socket; use Net::Cmd; use Net::Config; +use Socket; + +our $VERSION = "3.05"; + +# Code for detecting if we can use SSL +my $ssl_class = eval { + require IO::Socket::SSL; + # first version with default CA on most platforms + no warnings 'numeric'; + IO::Socket::SSL->VERSION(2.007); +} && 'IO::Socket::SSL'; -$VERSION = "2.33"; +my $nossl_warn = !$ssl_class && + 'To use SSL please install IO::Socket::SSL with version>=2.007'; -@ISA = qw(Net::Cmd IO::Socket::INET); +# Code for detecting if we can use IPv6 +my $inet6_class = eval { + require IO::Socket::IP; + no warnings 'numeric'; + IO::Socket::IP->VERSION(0.20); +} && 'IO::Socket::IP' || eval { + require IO::Socket::INET6; + no warnings 'numeric'; + IO::Socket::INET6->VERSION(2.62); +} && 'IO::Socket::INET6'; +sub can_ssl { $ssl_class }; +sub can_inet6 { $inet6_class }; + +our @ISA = ('Net::Cmd', $inet6_class || 'IO::Socket::INET'); sub new { my $self = shift; @@ -33,27 +61,41 @@ sub new { %arg = @_; $host = delete $arg{Host}; } + + if ($arg{SSL}) { + # SSL from start + die $nossl_warn if !$ssl_class; + $arg{Port} ||= 465; + } + my $hosts = defined $host ? $host : $NetConfig{smtp_hosts}; my $obj; - my $h; - foreach $h (@{ref($hosts) ? $hosts : [$hosts]}) { + $arg{Timeout} = 120 if ! defined $arg{Timeout}; + + foreach my $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 + Timeout => $arg{Timeout} ) and last; } - return undef + return unless defined $obj; + ${*$obj}{'net_smtp_arg'} = \%arg; + ${*$obj}{'net_smtp_host'} = $host; + + if ($arg{SSL}) { + Net::SMTP::_SSL->start_SSL($obj,%arg) + or return; + } + $obj->autoflush(1); $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef); @@ -62,11 +104,10 @@ sub new { my $err = ref($obj) . ": " . $obj->code . " " . $obj->message; $obj->close(); $@ = $err; - return undef; + return; } ${*$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+)/; @@ -75,7 +116,7 @@ sub new { my $err = ref($obj) . ": " . $obj->code . " " . $obj->message; $obj->close(); $@ = $err; - return undef; + return; } $obj; @@ -128,7 +169,10 @@ sub auth { if (ref($username) and UNIVERSAL::isa($username, 'Authen::SASL')) { $sasl = $username; - $sasl->mechanism($mechanisms); + my $requested_mechanisms = $sasl->mechanism(); + if (! defined($requested_mechanisms) || $requested_mechanisms eq '') { + $sasl->mechanism($mechanisms); + } } else { die "auth(username, password)" if not length $username; @@ -138,14 +182,31 @@ sub auth { user => $username, pass => $password, authname => $username, - } + }, + debug => $self->debug ); } - # 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; + my $client; + my $str; + do { + if ($client) { + # $client mechanism failed, so we need to exclude this mechanism from list + my $failed_mechanism = $client->mechanism; + return unless defined $failed_mechanism; + $self->debug_text("Auth mechanism failed: $failed_mechanism") + if $self->debug; + $mechanisms =~ s/\b\Q$failed_mechanism\E\b//; + return unless $mechanisms =~ /\S/; + $sasl->mechanism($mechanisms); + } + + # 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 + + $client = $sasl->client_new('smtp', ${*$self}{'net_smtp_host'}, 0); + $str = $client->client_start; + } while (!defined $str); # We don't support sasl mechanisms that encrypt the socket traffic. # todo that we would really need to change the ISA hierarchy @@ -177,8 +238,7 @@ sub hello { if ($ok) { my $h = ${*$me}{'net_smtp_esmtp'} = {}; - my $ln; - foreach $ln (@msg) { + foreach my $ln (@msg) { $h->{uc $1} = $2 if $ln =~ /([-\w]+)\b[= \t]*([^\n]*)/; } @@ -188,12 +248,26 @@ sub hello { if $ok = $me->_HELO($domain); } - return undef unless $ok; + return unless $ok; + ${*$me}{net_smtp_hello_domain} = $domain; $msg[0] =~ /\A\s*(\S+)/; return ($1 || " "); } +sub starttls { + my $self = shift; + $ssl_class or die $nossl_warn; + $self->_STARTTLS or return; + Net::SMTP::_SSL->start_SSL($self, + %{ ${*$self}{'net_smtp_arg'} }, # (ssl) args given in new + @_ # more (ssl) args + ) or return; + + # another hello after starttls to read new ESMTP capabilities + return $self->hello(${*$self}{net_smtp_hello_domain}); +} + sub supports { my $self = shift; @@ -399,8 +473,7 @@ sub recipient { } my @ok; - my $addr; - foreach $addr (@_) { + foreach my $addr (@_) { if ($smtp->_RCPT("TO:" . _addr($smtp, $addr) . $opts)) { push(@ok, $addr) if $skip_bad; } @@ -531,6 +604,28 @@ 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 _STARTTLS { shift->command("STARTTLS")->response() == CMD_OK } + + +{ + package Net::SMTP::_SSL; + our @ISA = ( $ssl_class ? ($ssl_class):(), 'Net::SMTP' ); + sub starttls { die "SMTP connection is already in SSL mode" } + sub start_SSL { + my ($class,$smtp,%arg) = @_; + delete @arg{ grep { !m{^SSL_} } keys %arg }; + ( $arg{SSL_verifycn_name} ||= $smtp->host ) + =~s{(?<!:):[\w()]+$}{}; # strip port + $arg{SSL_hostname} = $arg{SSL_verifycn_name} + if ! defined $arg{SSL_hostname} && $class->can_client_sni; + $arg{SSL_verifycn_scheme} ||= 'smtp'; + my $ok = $class->SUPER::start_SSL($smtp,%arg); + $@ = $ssl_class->errstr if !$ok; + return $ok; + } +} + + 1; @@ -621,9 +716,15 @@ B<Host> - SMTP host to connect to. It may be a single scalar (hostname[:port]), as defined for the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to an array with hosts to try in turn. The L</host> method will return the value which was used to connect to the host. +Format - C<PeerHost> from L<IO::Socket::INET> new method. -B<Port> - port to connect to. Format - C<PeerHost> from L<IO::Socket::INET> new method. -Default - 25. +B<Port> - port to connect to. +Default - 25 for plain SMTP and 465 for immediate SSL. + +B<SSL> - If the connection should be done from start with SSL, contrary to later +upgrade with C<starttls>. +You can use SSL arguments as documented in L<IO::Socket::SSL>, but it will +usually use the right arguments already. B<LocalAddr> and B<LocalPort> - These parameters are passed directly to IO::Socket to allow binding the socket to a local port. @@ -642,24 +743,32 @@ Example: $smtp = Net::SMTP->new('mailhost', - Hello => 'my.mail.domain', - Timeout => 30, + Hello => 'my.mail.domain', + Timeout => 30, Debug => 1, - ); + ); # the same $smtp = Net::SMTP->new( - Host => 'mailhost', + Host => 'mailhost', + Hello => 'my.mail.domain', + Timeout => 30, + Debug => 1, + ); + + # the same with direct SSL + $smtp = Net::SMTP->new('mailhost', Hello => 'my.mail.domain', Timeout => 30, - Debug => 1, + Debug => 1, + SSL => 1, ); # Connect to the default server from Net::config $smtp = Net::SMTP->new( - Hello => 'my.mail.domain', - Timeout => 30, - ); + Hello => 'my.mail.domain', + Timeout => 30, + ); =back @@ -702,6 +811,12 @@ to connect to the host. Request a queue run for the DOMAIN given. +=item starttls ( SSLARGS ) + +Upgrade existing plain connection to SSL. +You can use SSL arguments as documented in L<IO::Socket::SSL>, but it will +usually use the right arguments already. + =item auth ( USERNAME, PASSWORD ) Attempt SASL authentication. Requires Authen::SASL module. @@ -828,6 +943,13 @@ If C<DATA> is not specified then the result will indicate that the server wishes the data to be sent. The data must then be sent using the C<datasend> and C<dataend> methods described in L<Net::Cmd>. +=item bdat ( DATA ) + +=item bdatlast ( DATA ) + +Use the alternate DATA command "BDAT" of the data chunking service extension +defined in RFC1830 for efficiently sending large MIME messages. + =item expand ( ADDRESS ) Request the server to expand the given address Returns an array @@ -848,6 +970,14 @@ Request help text from the server. Returns the text or undef upon failure Send the QUIT command to the remote SMTP server and close the socket connection. +=item can_inet6 () + +Returns whether we can use IPv6. + +=item can_ssl () + +Returns whether we can use SSL. + =back =head1 ADDRESSES @@ -868,15 +998,22 @@ accept the address surrounded by angle brackets. =head1 SEE ALSO -L<Net::Cmd> +L<Net::Cmd>, +L<IO::Socket::SSL> =head1 AUTHOR -Graham Barr <gbarr@pobox.com> +Graham Barr E<lt>F<gbarr@pobox.com>E<gt> + +Steve Hay E<lt>F<shay@cpan.org>E<gt> is now maintaining libnet as of version +1.22_02 =head1 COPYRIGHT -Copyright (c) 1995-2004 Graham Barr. All rights reserved. +Versions up to 2.31_1 Copyright (c) 1995-2004 Graham Barr. All rights reserved. +Changes in Version 2.31_2 onwards Copyright (C) 2013-2014 Steve Hay. All rights +reserved. + This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. |