X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FNet%2FSMTP.pm;h=44a955a8dd1e371402a7c83493b63292a2f86857;hb=53273a086103cdbbf7ebdd5f1a18b2c0777cbc1b;hp=627903d08b4d0f1b7580eb51aa5a3671c993a86c;hpb=c85707204c5d2a93ef021c88e43a92ba2d602304;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Net/SMTP.pm b/lib/Net/SMTP.pm index 627903d..44a955a 100644 --- a/lib/Net/SMTP.pm +++ b/lib/Net/SMTP.pm @@ -1,6 +1,6 @@ # Net::SMTP.pm # -# Copyright (c) 1995-1997 Graham Barr . All rights reserved. +# Copyright (c) 1995-2004 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. @@ -16,7 +16,7 @@ use IO::Socket; use Net::Cmd; use Net::Config; -$VERSION = "2.18"; # $Id: //depot/libnet/Net/SMTP.pm#19 $ +$VERSION = "2.29"; @ISA = qw(Net::Cmd IO::Socket::INET); @@ -24,16 +24,24 @@ sub new { my $self = shift; my $type = ref($self) || $self; - my $host = shift if @_ % 2; - my %arg = @_; - my $hosts = defined $host ? [ $host ] : $NetConfig{smtp_hosts}; + 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 (@{$hosts}) + 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} @@ -54,6 +62,7 @@ sub new return undef; } + ${*$obj}{'net_smtp_exact_addr'} = $arg{ExactAddresses}; ${*$obj}{'net_smtp_host'} = $host; (${*$obj}{'net_smtp_banner'}) = $obj->message; @@ -68,6 +77,11 @@ sub new $obj; } +sub host { + my $me = shift; + ${*$me}{'net_smtp_host'}; +} + ## ## User interface methods ## @@ -92,40 +106,63 @@ sub etrn { $self->_ETRN(@_); } -sub auth { # auth(username, password) by mengwong 20011106. the only supported mechanism at this time is PLAIN. - # - # my $auth = $smtp->supports("AUTH"); - # $smtp->auth("username", "password") or die $smtp->message; - # +sub auth { + my ($self, $username, $password) = @_; - require MIME::Base64; - - my $self = shift; - my ($username, $password) = @_; - die "auth(username, password)" if not length $username; + 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; - if (not grep { uc $_ eq "PLAIN" } split ' ', $mechanisms) { - $self->set_status(500, ["PLAIN mechanism not supported; server supports $mechanisms"]); - return; + 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, + }); + } + + # 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] + ) + ), '' + )); } - my $authstring = MIME::Base64::encode_base64(join "\0", ($username)x2, $password); - $authstring =~ s/\n//g; # wrap long lines - $self->_AUTH("PLAIN $authstring"); + $code == CMD_OK; } sub hello { my $me = shift; - my $domain = shift || - eval { - require Net::Domain; - Net::Domain::hostfqdn(); - } || - ""; + my $domain = shift || "localhost.localdomain"; my $ok = $me->_EHLO($domain); my @msg = $me->message; @@ -135,7 +172,7 @@ sub hello my $ln; foreach $ln (@msg) { $h->{uc $1} = $2 - if $ln =~ /(\S+)\b[ \t]*([^\n]*)/; + if $ln =~ /(\w+)\b[= \t]*([^\n]*)/; } } elsif($me->status == CMD_ERROR) @@ -144,9 +181,10 @@ sub hello if $ok = $me->_HELO($domain); } - $ok && $msg[0] =~ /\A\s*(\S+)/ - ? $1 - : undef; + return undef unless $ok; + + $msg[0] =~ /\A\s*(\S+)/; + return ($1 || " "); } sub supports { @@ -159,24 +197,26 @@ sub supports { return; } -sub _addr -{ - my $addr = shift || ""; - - return $1 - if $addr =~ /(<[^>]+>)/so; +sub _addr { + my $self = shift; + my $addr = shift; + $addr = "" unless defined $addr; - $addr =~ s/\n/ /sog; - $addr =~ s/(\A\s+|\s+\Z)//sog; + if (${*$self}{'net_smtp_exact_addr'}) { + return $1 if $addr =~ /^\s*(<.*>)\s*$/s; + } + else { + return $1 if $addr =~ /(<[^>]*>)/; + $addr =~ s/^\s+|\s+$//sg; + } - return "<" . $addr . ">"; + "<$addr>"; } - sub mail { my $me = shift; - my $addr = _addr(shift); + my $addr = _addr($me, shift); my $opts = ""; if(@_) @@ -204,7 +244,7 @@ sub mail { if(exists $esmtp->{DSN}) { - $opts .= " RET=" . uc $v + $opts .= " RET=" . ((uc($v) eq "FULL") ? "FULL" : "HDRS"); } else { @@ -214,13 +254,36 @@ sub mail if(defined($v = delete $opt{Bits})) { - if(exists $esmtp->{'8BITMIME'}) + if($v eq "8") + { + if(exists $esmtp->{'8BITMIME'}) + { + $opts .= " BODY=8BITMIME"; + } + else + { + carp 'Net::SMTP::mail: 8BITMIME option not supported by host'; + } + } + elsif($v eq "binary") { - $opts .= $v == 8 ? " BODY=8BITMIME" : " BODY=7BIT" + 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'; + } + } + elsif(exists $esmtp->{'8BITMIME'} or exists $esmtp->{'BINARYMIME'}) + { + $opts .= " BODY=7BIT"; } else { - carp 'Net::SMTP::mail: 8BITMIME option not supported by host'; + carp 'Net::SMTP::mail: 8BITMIME and BINARYMIME options not supported by host'; } } @@ -228,7 +291,7 @@ sub mail { if(exists $esmtp->{CHECKPOINT}) { - $opts .= " TRANSID=" . _addr($v); + $opts .= " TRANSID=" . _addr($me, $v); } else { @@ -249,6 +312,18 @@ sub mail } } + if(defined($v = delete $opt{XVERP})) + { + if(exists $esmtp->{'XVERP'}) + { + $opts .= " XVERP" + } + else + { + carp 'Net::SMTP::mail: XVERP option not supported by host'; + } + } + carp 'Net::SMTP::recipient: unknown option(s) ' . join(" ", keys %opt) . ' - ignored' @@ -263,9 +338,9 @@ sub mail $me->_MAIL("FROM:".$addr.$opts); } -sub send { shift->_SEND("FROM:" . _addr($_[0])) } -sub send_or_mail { shift->_SOML("FROM:" . _addr($_[0])) } -sub send_and_mail { shift->_SAML("FROM:" . _addr($_[0])) } +sub 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 { @@ -322,7 +397,7 @@ sub recipient my $addr; foreach $addr (@_) { - if($smtp->_RCPT("TO:" . _addr($addr) . $opts)) { + if($smtp->_RCPT("TO:" . _addr($smtp, $addr) . $opts)) { push(@ok,$addr) if $skip_bad; } elsif(!$skip_bad) { @@ -343,10 +418,57 @@ sub data { my $me = shift; - my $ok = $me->_DATA() && $me->datasend(@_); + 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(@_); + + $ok && @_ ? $me->dataend + : $ok; + } +} + +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; + } + 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; + + $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'; + } +} - $ok && @_ ? $me->dataend - : $ok; +sub datafh { + my $me = shift; + return unless $me->_DATA(); + return $me->tied_fh; } sub expand @@ -399,6 +521,7 @@ 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 } @@ -467,24 +590,37 @@ known as mailhost: =over 4 -=item new Net::SMTP [ HOST, ] [ OPTIONS ] +=item new ( [ HOST ] [, OPTIONS ] ) This is the constructor for a new Net::SMTP object. C is the name of the remote host to which an SMTP connection is required. -If C is not given, then the C specified in C -will be used. +C is optional. If C is not given then it may instead be +passed as the C option described below. If neither is given then +the C specified in C will be used. C are passed in a hash like fashion, using key and value pairs. Possible options are: B - SMTP requires that you identify yourself. This option -specifies a string to pass as your mail domain. If not -given a guess will be taken. +specifies a string to pass as your mail domain. If not given localhost.localdomain +will be used. + +B - SMTP host to connect to. It may be a single scalar, as defined for +the C option in L, or a reference to +an array with hosts to try in turn. The L method will return the value +which was used to connect to the host. + +B and B - These parameters are passed directly +to IO::Socket to allow binding the socket to a local port. B - Maximum time, in seconds, to wait for a response from the SMTP server (default: 120) +B - If true the all ADDRESS arguments must be as +defined by C in RFC2822. If not given, or false, then +Net::SMTP will attempt to extract the address from the value passed. + B - Enable debugging information @@ -497,6 +633,20 @@ Example: Debug => 1, ); + # the same + $smtp = Net::SMTP->new( + Host => 'mailhost', + Hello => 'my.mail.domain' + Timeout => 30, + Debug => 1, + ); + + # Connect to the default server from Net::config + $smtp = Net::SMTP->new( + Hello => 'my.mail.domain' + Timeout => 30, + ); + =back =head1 METHODS @@ -525,15 +675,18 @@ command (or HELO if EHLO fails). Since this method is invoked automatically when the Net::SMTP object is constructed the user should normally not have to call it manually. +=item host () + +Returns the value used by the constructor, and passed to IO::Socket::INET, +to connect to the host. + =item etrn ( DOMAIN ) Request a queue run for the DOMAIN given. =item auth ( USERNAME, PASSWORD ) -Attempt SASL authentication. At this time only the PLAIN mechanism is supported. - -At some point in the future support for using Authen::SASL will be added +Attempt SASL authentication. =item mail ( ADDRESS [, OPTIONS] ) @@ -552,11 +705,14 @@ The C method can some additional ESMTP OPTIONS which is passed in hash like fashion, using key and value pairs. Possible options are: Size => - Return => - Bits => "7" | "8" + Return => "FULL" | "HDRS" + Bits => "7" | "8" | "binary" Transaction =>
Envelope => + XVERP => 1 +The C and C parameters are used for DSN (Delivery +Status Notification). =item reset () @@ -564,27 +720,63 @@ Reset the status of the server. This may be called after a message has been initiated, but before any data has been sent, to cancel the sending of the message. -=item recipient ( ADDRESS [, ADDRESS [ ...]] [, OPTIONS ] ) +=item recipient ( ADDRESS [, ADDRESS, [...]] [, OPTIONS ] ) Notify the server that the current message should be sent to all of the addresses given. Each address is sent as a separate command to the server. -Should the sending of any address result in a failure then the -process is aborted and a I value is returned. It is up to the -user to call C if they so desire. +Should the sending of any address result in a failure then the process is +aborted and a I value is returned. It is up to the user to call +C if they so desire. -The C method can some additional OPTIONS which is passed -in hash like fashion, using key and value pairs. Possible options are: +The C method can also pass additional case-sensitive OPTIONS as an +anonymous hash using key and value pairs. Possible options are: - Notify => - SkipBad => ignore bad addresses + Notify => ['NEVER'] or ['SUCCESS','FAILURE','DELAY'] (see below) + SkipBad => 1 (to ignore bad addresses) -If C is true the C will not return an error when a -bad address is encountered and it will return an array of addresses -that did succeed. +If C is true the C will not return an error when a bad +address is encountered and it will return an array of addresses that did +succeed. $smtp->recipient($recipient1,$recipient2); # Good $smtp->recipient($recipient1,$recipient2, { SkipBad => 1 }); # Good - $smtp->recipient("$recipient,$recipient2"); # BAD + $smtp->recipient($recipient1,$recipient2, { Notify => ['FAILURE','DELAY'], SkipBad => 1 }); # Good + @goodrecips=$smtp->recipient(@recipients, { Notify => ['FAILURE'], SkipBad => 1 }); # Good + $smtp->recipient("$recipient,$recipient2"); # BAD + +Notify is used to request Delivery Status Notifications (DSNs), but your +SMTP/ESMTP service may not respect this request depending upon its version and +your site's SMTP configuration. + +Leaving out the Notify option usually defaults an SMTP service to its default +behavior equivalent to ['FAILURE'] notifications only, but again this may be +dependent upon your site's SMTP configuration. + +The NEVER keyword must appear by itself if used within the Notify option and "requests +that a DSN not be returned to the sender under any conditions." + + {Notify => ['NEVER']} + + $smtp->recipient(@recipients, { Notify => ['NEVER'], SkipBad => 1 }); # Good + +You may use any combination of these three values 'SUCCESS','FAILURE','DELAY' in +the anonymous array reference as defined by RFC3461 (see http://rfc.net/rfc3461.html +for more information. Note: quotations in this topic from same.). + +A Notify parameter of 'SUCCESS' or 'FAILURE' "requests that a DSN be issued on +successful delivery or delivery failure, respectively." + +A Notify parameter of 'DELAY' "indicates the sender's willingness to receive +delayed DSNs. Delayed DSNs may be issued if delivery of a message has been +delayed for an unusual amount of time (as determined by the Message Transfer +Agent (MTA) at which the message is delayed), but the final delivery status +(whether successful or failure) cannot be determined. The absence of the DELAY +keyword in a NOTIFY parameter requests that a "delayed" DSN NOT be issued under +any conditions." + + {Notify => ['SUCCESS','FAILURE','DELAY']} + + $smtp->recipient(@recipients, { Notify => ['FAILURE','DELAY'], SkipBad => 1 }); # Good =item to ( ADDRESS [, ADDRESS [...]] ) @@ -615,6 +807,9 @@ which contains the text read from the server. Verify that C
is a legitimate mailing address. +Most sites usually disable this feature in their SMTP service configuration. +Use "Debug => 1" option under new() to see if disabled. + =item help ( [ $subject ] ) Request help text from the server. Returns the text or undef upon failure @@ -625,6 +820,22 @@ Send the QUIT command to the remote SMTP server and close the socket connection. =back +=head1 ADDRESSES + +Net::SMTP attempts to DWIM with addresses that are passed. For +example an application might extract The From: line from an email +and pass that to mail(). While this may work, it is not reccomended. +The application should really use a module like L +to extract the mail address and pass that. + +If C is passed to the contructor, then addresses +should be a valid rfc2821-quoted address, although Net::SMTP will +accept accept the address surrounded by angle brackets. + + funny user@domain WRONG + "funny user"@domain RIGHT, recommended + <"funny user"@domain> OK + =head1 SEE ALSO L @@ -635,12 +846,8 @@ Graham Barr =head1 COPYRIGHT -Copyright (c) 1995-1997 Graham Barr. All rights reserved. +Copyright (c) 1995-2004 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/SMTP.pm#19 $> - =cut