Net::SMTP

- Use Authen::SASL to do auth

1 files changed, 50 insertions, 20 deletions

diff --git a/Net/SMTP.pm b/Net/SMTP.pm
index a7096cc..4da0d78 100644
--- a/Net/SMTP.pm
+++ b/Net/SMTP.pm
@@ -16,7 +16,7 @@ use IO::Socket;
 use Net::Cmd;
 use Net::Config;
 
-$VERSION = "2.23"; # $Id: //depot/libnet/Net/SMTP.pm#24 $
+$VERSION = "2.24"; # $Id: //depot/libnet/Net/SMTP.pm#25 $
 
 @ISA = qw(Net::Cmd IO::Socket::INET);
 
@@ -94,29 +94,52 @@ 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;
+    require Authen::SASL;
 
     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, 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]
+          )
+        ), ''
+      ));
     }
-    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
@@ -530,9 +553,7 @@ 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] )
 
@@ -624,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>
@@ -640,6 +670,6 @@ it under the same terms as Perl itself.
 
 =for html <hr>
 
-I<$Id: //depot/libnet/Net/SMTP.pm#24 $>
+I<$Id: //depot/libnet/Net/SMTP.pm#25 $>
 
 =cut