X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FNet%2FSMTP.pm;h=a28496d68867903deee5b51ca360d6cad75088ee;hb=23f6cb285656c85849665669b0a13828f0d8b395;hp=8069f8888467e268b24f763fb697c28135aa0658;hpb=7cf5cf7c1758b1eb1a7f98c7dcf213f949e5a5b4;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Net/SMTP.pm b/lib/Net/SMTP.pm index 8069f88..a28496d 100644 --- a/lib/Net/SMTP.pm +++ b/lib/Net/SMTP.pm @@ -16,187 +16,192 @@ use IO::Socket; 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; @@ -213,211 +218,194 @@ sub _addr { "<$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 { @@ -426,117 +414,119 @@ 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; @@ -720,12 +710,17 @@ in hash like fashion, using key and value pairs. Possible options are: Return => "FULL" | "HDRS" Bits => "7" | "8" | "binary" Transaction =>
- Envelope =>