diff -r 6d08f4a05d93 -r 3145852acc89 releasing/cbrtools/perl/Net/SMTP.pm
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/releasing/cbrtools/perl/Net/SMTP.pm	Fri Jun 25 18:37:20 2010 +0800
@@ -0,0 +1,770 @@
+# Net::SMTP.pm
+#
+# Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com>. 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 strict;
+use vars qw($VERSION @ISA);
+use Socket 1.3;
+use Carp;
+use IO::Socket;
+use Net::Cmd;
+use Net::Config;
+
+$VERSION = "2.26"; # $Id: //depot/libnet/Net/SMTP.pm#31 $
+
+@ISA = qw(Net::Cmd IO::Socket::INET);
+
+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 $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;
+
+ $obj->autoflush(1);
+
+ $obj->debug(exists $arg{Debug} ? $arg{Debug} : 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_banner'}) = $obj->message;
+ (${*$obj}{'net_smtp_domain'}) = $obj->message =~ /\A\s*(\S+)/;
+
+ unless($obj->hello($arg{Hello} || ""))
+  {
+   $obj->close();
+   return undef;
+  }
+
+ $obj;
+}
+
+##
+## User interface methods
+##
+
+sub banner
+{
+ my $me = shift;
+
+ return ${*$me}{'net_smtp_banner'} || 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(@_);
+}
+
+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);
+    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;
+}
+
+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);
+  }
+
+ return undef unless $ok;
+
+ $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;
+}
+
+sub _addr {
+  my $self = shift;
+  my $addr = shift;
+  $addr = "" unless defined $addr;
+
+  if (${*$self}{'net_smtp_exact_addr'}) {
+    return $1 if $addr =~ /^\s*(<.*>)\s*$/s;
+  }
+  else {
+    return $1 if $addr =~ /(<[^>]*>)/;
+    $addr =~ s/^\s+|\s+$//sg;
+  }
+
+  "<$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
+        }
+       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");
+        }
+       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";
+          }
+         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;
+          }
+         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 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: DSN option not supported by host';
+        }
+      }
+
+     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 :-(';
+    }
+  }
+
+ $me->_MAIL("FROM:".$addr.$opts);
+}
+
+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'});
+
+ $me->_RSET();
+}
+
+
+sub recipient
+{
+ my $smtp = shift;
+ my $opts = "";
+ my $skip_bad = 0;
+
+ if(@_ && ref($_[-1]))
+  {
+   my %opt = %{pop(@_)};
+   my $v;
+
+   $skip_bad = delete $opt{'SkipBad'};
+
+   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)
+        }
+       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;
+    }
+   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;
+    }
+    elsif(!$skip_bad) {
+      return 0;
+    }
+  }
+
+ return $skip_bad ? @ok : 1;
+}
+
+BEGIN {
+  *to  = \&recipient;
+  *cc  = \&recipient;
+  *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';
+  }
+ 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';
+  }
+}
+
+sub datafh {
+  my $me = shift;
+  return unless $me->_DATA();
+  return $me->tied_fh;
+}
+
+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 quit
+{
+ my $me = shift;
+
+ $me->_QUIT;
+ $me->close;
+}
+
+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 _BDAT { shift->command("BDAT", @_) }
+sub _TURN { shift->unsupported(@_); } 			   	  
+sub _ETRN { shift->command("ETRN", @_)->response()  == CMD_OK }
+sub _AUTH { shift->command("AUTH", @_)->response()  == CMD_OK }   
+
+1;
+
+__END__
+
+=head1 NAME
+
+Net::SMTP - Simple Mail Transfer Protocol Client
+
+=head1 SYNOPSIS
+
+    use Net::SMTP;
+
+    # Constructors
+    $smtp = Net::SMTP->new('mailhost');
+    $smtp = Net::SMTP->new('mailhost', Timeout => 60);
+
+=head1 DESCRIPTION
+
+This module implements a client interface to the SMTP and ESMTP
+protocol, enabling a perl5 application to talk to SMTP servers. This
+documentation assumes that you are familiar with the concepts of the
+SMTP protocol described in RFC821.
+
+A new Net::SMTP object must be created with the I<new> method. Once
+this has been done, all SMTP commands are accessed through this object.
+
+The Net::SMTP class is a subclass of Net::Cmd and IO::Socket::INET.
+
+=head1 EXAMPLES
+
+This example prints the mail domain name of the SMTP server known as mailhost:
+
+    #!/usr/local/bin/perl -w
+
+    use Net::SMTP;
+
+    $smtp = Net::SMTP->new('mailhost');
+    print $smtp->domain,"\n";
+    $smtp->quit;
+
+This example sends a small message to the postmaster at the SMTP server
+known as mailhost:
+
+    #!/usr/local/bin/perl -w
+
+    use Net::SMTP;
+
+    $smtp = Net::SMTP->new('mailhost');
+
+    $smtp->mail($ENV{USER});
+    $smtp->to('postmaster');
+
+    $smtp->data();
+    $smtp->datasend("To: postmaster\n");
+    $smtp->datasend("\n");
+    $smtp->datasend("A simple test message\n");
+    $smtp->dataend();
+
+    $smtp->quit;
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new Net::SMTP [ HOST, ] [ OPTIONS ]
+
+This is the constructor for a new Net::SMTP object. C<HOST> is the
+name of the remote host to which an SMTP connection is required.
+
+If C<HOST> is an array reference then each value will be attempted
+in turn until a connection is made.
+
+If C<HOST> is not given, then the C<SMTP_Host> specified in C<Net::Config>
+will be used.
+
+C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
+Possible options are:
+
+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)
+
+B<ExactAddresses> - If true the all ADDRESS arguments must be as
+defined by C<addr-spec> in RFC2822. If not given, or false, then
+Net::SMTP will attempt to extract the address from the value passed.
+
+B<Debug> - Enable debugging information
+
+
+Example:
+
+
+    $smtp = Net::SMTP->new('mailhost',
+			   Hello => 'my.mail.domain'
+			   Timeout => 30,
+                           Debug   => 1,
+			  );
+
+=back
+
+=head1 METHODS
+
+Unless otherwise stated all methods return either a I<true> or I<false>
+value, with I<true> meaning that the operation was a success. When a method
+states that it returns a value, failure will be returned as I<undef> or an
+empty list.
+
+=over 4
+
+=item banner ()
+
+Returns the banner message which the server replied with when the
+initial connection was made.
+
+=item domain ()
+
+Returns the domain that the remote SMTP server identified itself as during
+connection.
+
+=item hello ( DOMAIN )
+
+Tell the remote server the mail domain which you are in using the EHLO
+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 etrn ( DOMAIN )
+
+Request a queue run for the DOMAIN given.
+
+=item auth ( USERNAME, PASSWORD )
+
+Attempt SASL authentication.
+
+=item mail ( ADDRESS [, OPTIONS] )
+
+=item send ( ADDRESS )
+
+=item send_or_mail ( ADDRESS )
+
+=item send_and_mail ( ADDRESS )
+
+Send the appropriate command to the server MAIL, SEND, SOML or SAML. C<ADDRESS>
+is the address of the sender. This initiates the sending of a message. The
+method C<recipient> should be called for each address that the message is to
+be sent to.
+
+The C<mail> method can some additional ESMTP OPTIONS which is passed
+in hash like fashion, using key and value pairs.  Possible options are:
+
+ Size        => <bytes>
+ Return      => "FULL" | "HDRS"
+ Bits        => "7" | "8" | "binary"
+ Transaction => <ADDRESS>
+ Envelope    => <ENVID>
+
+The C<Return> and C<Envelope> parameters are used for DSN (Delivery
+Status Notification).
+
+=item reset ()
+
+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 ] )
+
+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<false> value is returned. It is up to the
+user to call C<reset> if they so desire.
+
+The C<recipient> method can some additional OPTIONS which is passed
+in hash like fashion, using key and value pairs.  Possible options are:
+
+ Notify    =>
+ SkipBad   => ignore bad addresses
+
+If C<SkipBad> is true the C<recipient> 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   
+
+=item to ( ADDRESS [, ADDRESS [...]] )
+
+=item cc ( ADDRESS [, ADDRESS [...]] )
+
+=item bcc ( ADDRESS [, ADDRESS [...]] )
+
+Synonyms for C<recipient>.
+
+=item data ( [ DATA ] )
+
+Initiate the sending of the data from the current message. 
+
+C<DATA> may be a reference to a list or a list. If specified the contents
+of C<DATA> and a termination string C<".\r\n"> is sent to the server. And the
+result will be true if the data was accepted.
+
+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 expand ( ADDRESS )
+
+Request the server to expand the given address Returns an array
+which contains the text read from the server.
+
+=item verify ( ADDRESS )
+
+Verify that C<ADDRESS> is a legitimate mailing address.
+
+=item help ( [ $subject ] )
+
+Request help text from the server. Returns the text or undef upon failure
+
+=item quit ()
+
+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<Mail::Address>
+to extract the mail address and pass that.
+
+If C<ExactAddresses> 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<Net::Cmd>
+
+=head1 AUTHOR
+
+Graham Barr <gbarr@pobox.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995-1997 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 <hr>
+
+I<$Id: //depot/libnet/Net/SMTP.pm#31 $>
+
+=cut