(retracted by #17444)

[p5sagit/p5-mst-13.2.git] / lib / Net / SMTP.pm

diff --git a/lib/Net/SMTP.pm b/lib/Net/SMTP.pm
index ce5777d..4da0d78 100644 (file)
--- 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.17"; # $Id: //depot/libnet/Net/SMTP.pm#17 $
+$VERSION = "2.24"; # $Id: //depot/libnet/Net/SMTP.pm#25 $
 
 @ISA = qw(Net::Cmd IO::Socket::INET);
 
@@ -34,6 +34,8 @@ sub new
   {
    $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}
@@ -92,15 +94,58 @@ sub etrn {
        $self->_ETRN(@_);
 }
 
+sub auth {
+    my ($self, $username, $password) = @_;
+
+    require MIME::Base64;
+    require Authen::SASL;
+
+    my $mechanisms = $self->supports('AUTH',500,["Command unknown: 'AUTH'"]);
+    return unless defined $mechanisms;
+
+    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, MIME::Base64::encode_base64($str,''));
+    my $code;
+
+    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;
+}
+
 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;
 
@@ -110,7 +155,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) 
@@ -134,20 +179,13 @@ sub supports {
     return;
 }
 
-sub _addr
-{
- my $addr = shift || "";
-
- return $1
-    if $addr =~ /(<[^>]+>)/so;
-
- $addr =~ s/\n/ /sog;
- $addr =~ s/(\A\s+|\s+\Z)//sog;
-
- return "<" . $addr . ">";
+sub _addr {
+  my $addr = shift;
+  $addr = "" unless defined $addr;
+  $addr =~ s/^\s*<?\s*|\s*>?\s*$//sg;
+  "<$addr>";
 }
 
-
 sub mail
 {
  my $me = shift;
@@ -324,6 +362,12 @@ sub data
           : $ok;
 }
 
+sub datafh {
+  my $me = shift;
+  return unless $me->_DATA();
+  return $me->tied_fh;
+}
+
 sub expand
 {
  my $me = shift;
@@ -376,6 +420,7 @@ sub _QUIT { shift->command("QUIT")->response()          == CMD_OK }
 sub _DATA { shift->command("DATA")->response()     == CMD_MORE } 
 sub _TURN { shift->unsupported(@_); }                            
 sub _ETRN { shift->command("ETRN", @_)->response()  == CMD_OK }
+sub _AUTH { shift->command("AUTH", @_)->response()  == CMD_OK }   
 
 1;
 
@@ -456,6 +501,9 @@ B<Hello> - 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.
 
+B<LocalAddr> and B<LocalPort> - These parameters are passed directly
+to IO::Socket to allow binding the socket to a local port.
+
 B<Timeout> - Maximum time, in seconds, to wait for a response from the
 SMTP server (default: 120)
 
@@ -503,6 +551,10 @@ normally not have to call it manually.
 
 Request a queue run for the DOMAIN given.
 
+=item auth ( USERNAME, PASSWORD )
+
+Attempt SASL authentication.
+
 =item mail ( ADDRESS [, OPTIONS] )
 
 =item send ( ADDRESS )
@@ -593,6 +645,15 @@ Send the QUIT command to the remote SMTP server and close the socket connection.
 
 =back
 
+=head1 ADDRESSES
+
+All methods that accept addresses expect the address to 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<Net::Cmd>
@@ -609,6 +670,6 @@ it under the same terms as Perl itself.
 
 =for html <hr>
 
-I<$Id: //depot/libnet/Net/SMTP.pm#17 $>
+I<$Id: //depot/libnet/Net/SMTP.pm#25 $>
 
 =cut