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

# 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
Commit	Line	Data
406c51ee	1	# Net::SMTP.pm
	2	#
	3	# Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
	4	# This program is free software; you can redistribute it and/or
	5	# modify it under the same terms as Perl itself.
	6
	7	package Net::SMTP;
	8
	9	require 5.001;
	10
	11	use strict;
	12	use vars qw($VERSION @ISA);
	13	use Socket 1.3;
	14	use Carp;
	15	use IO::Socket;
	16	use Net::Cmd;
	17	use Net::Config;
	18
dea4d7df	19	$VERSION = "2.26"; # $Id: //depot/libnet/Net/SMTP.pm#31 $
406c51ee	20
	21	@ISA = qw(Net::Cmd IO::Socket::INET);
	22
	23	sub new
	24	{
	25	my $self = shift;
	26	my $type = ref($self) \|\| $self;
	27	my $host = shift if @_ % 2;
	28	my %arg = @_;
dea4d7df	29	my $hosts = defined $host ? $host : $NetConfig{smtp_hosts};
406c51ee	30	my $obj;
	31
	32	my $h;
dea4d7df	33	foreach $h (@{ref($hosts) ? $hosts : [ $hosts ]})
406c51ee	34	{
	35	$obj = $type->SUPER::new(PeerAddr => ($host = $h),
	36	PeerPort => $arg{Port} \|\| 'smtp(25)',
12df23ee	37	LocalAddr => $arg{LocalAddr},
12df23ee	38	LocalPort => $arg{LocalPort},
406c51ee	39	Proto => 'tcp',
	40	Timeout => defined $arg{Timeout}
	41	? $arg{Timeout}
	42	: 120
	43	) and last;
	44	}
	45
	46	return undef
	47	unless defined $obj;
	48
	49	$obj->autoflush(1);
	50
	51	$obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
	52
	53	unless ($obj->response() == CMD_OK)
	54	{
	55	$obj->close();
	56	return undef;
	57	}
	58
dea4d7df	59	${*$obj}{'net_smtp_exact_addr'} = $arg{ExactAddresses};
406c51ee	60	${*$obj}{'net_smtp_host'} = $host;
	61
	62	(${*$obj}{'net_smtp_banner'}) = $obj->message;
	63	(${$obj}{'net_smtp_domain'}) = $obj->message =~ /\A\s(\S+)/;
	64
	65	unless($obj->hello($arg{Hello} \|\| ""))
	66	{
	67	$obj->close();
	68	return undef;
	69	}
	70
	71	$obj;
	72	}
	73
	74	##
	75	## User interface methods
	76	##
	77
	78	sub banner
	79	{
	80	my $me = shift;
	81
	82	return ${*$me}{'net_smtp_banner'} \|\| undef;
	83	}
	84
	85	sub domain
	86	{
	87	my $me = shift;
	88
	89	return ${*$me}{'net_smtp_domain'} \|\| undef;
	90	}
	91
	92	sub etrn {
	93	my $self = shift;
	94	defined($self->supports('ETRN',500,["Command unknown: 'ETRN'"])) &&
	95	$self->_ETRN(@_);
	96	}
	97
16f7bb68	98	sub auth {
16f7bb68	99	my ($self, $username, $password) = @_;
c8570720	100
c8570720	101	require MIME::Base64;
16f7bb68	102	require Authen::SASL;
c8570720	103
	104	my $mechanisms = $self->supports('AUTH',500,["Command unknown: 'AUTH'"]);
	105	return unless defined $mechanisms;
	106
16f7bb68	107	my $sasl;
	108
	109	if (ref($username) and UNIVERSAL::isa($username,'Authen::SASL')) {
	110	$sasl = $username;
	111	$sasl->mechanism($mechanisms);
	112	}
	113	else {
	114	die "auth(username, password)" if not length $username;
	115	$sasl = Authen::SASL->new(mechanism=> $mechanisms,
	116	callback => { user => $username,
	117	pass => $password,
	118	authname => $username,
	119	});
	120	}
	121
	122	# We should probably allow the user to pass the host, but I don't
	123	# currently know and SASL mechanisms that are used by smtp that need it
	124	my $client = $sasl->client_new('smtp',${*$self}{'net_smtp_host'},0);
	125	my $str = $client->client_start;
	126	# We dont support sasl mechanisms that encrypt the socket traffic.
	127	# todo that we would really need to change the ISA hierarchy
	128	# so we dont inherit from IO::Socket, but instead hold it in an attribute
	129
edd55068	130	my @cmd = ("AUTH", $client->mechanism);
16f7bb68	131	my $code;
16f7bb68	132
edd55068	133	push @cmd, MIME::Base64::encode_base64($str,'')
	134	if defined $str and length $str;
	135
16f7bb68	136	while (($code = $self->command(@cmd)->response()) == CMD_MORE) {
	137	@cmd = (MIME::Base64::encode_base64(
	138	$client->client_step(
	139	MIME::Base64::decode_base64(
	140	($self->message)[0]
	141	)
	142	), ''
	143	));
c8570720	144	}
c8570720	145
16f7bb68	146	$code == CMD_OK;
c8570720	147	}
c8570720	148
406c51ee	149	sub hello
	150	{
	151	my $me = shift;
046d9f47	152	my $domain = shift \|\| "localhost.localdomain";
406c51ee	153	my $ok = $me->_EHLO($domain);
	154	my @msg = $me->message;
	155
	156	if($ok)
	157	{
	158	my $h = ${*$me}{'net_smtp_esmtp'} = {};
	159	my $ln;
	160	foreach $ln (@msg) {
686337f3	161	$h->{uc $1} = $2
67ada6d4	162	if $ln =~ /(\w+)\b[= \t]([^\n])/;
406c51ee	163	}
	164	}
	165	elsif($me->status == CMD_ERROR)
	166	{
	167	@msg = $me->message
	168	if $ok = $me->_HELO($domain);
	169	}
	170
dea4d7df	171	return undef unless $ok;
	172
	173	$msg[0] =~ /\A\s*(\S+)/;
	174	return ($1 \|\| " ");
406c51ee	175	}
	176
	177	sub supports {
	178	my $self = shift;
	179	my $cmd = uc shift;
	180	return ${*$self}{'net_smtp_esmtp'}->{$cmd}
	181	if exists ${*$self}{'net_smtp_esmtp'}->{$cmd};
	182	$self->set_status(@_)
	183	if @_;
	184	return;
	185	}
	186
16f7bb68	187	sub _addr {
dea4d7df	188	my $self = shift;
16f7bb68	189	my $addr = shift;
16f7bb68	190	$addr = "" unless defined $addr;
dea4d7df	191
	192	if (${*$self}{'net_smtp_exact_addr'}) {
	193	return $1 if $addr =~ /^\s(<.>)\s*$/s;
	194	}
	195	else {
	196	return $1 if $addr =~ /(<[^>]*>)/;
	197	$addr =~ s/^\s+\|\s+$//sg;
	198	}
	199
16f7bb68	200	"<$addr>";
406c51ee	201	}
406c51ee	202
406c51ee	203	sub mail
	204	{
	205	my $me = shift;
dea4d7df	206	my $addr = _addr($me, shift);
406c51ee	207	my $opts = "";
	208
	209	if(@_)
	210	{
	211	my %opt = @_;
	212	my($k,$v);
	213
	214	if(exists ${*$me}{'net_smtp_esmtp'})
	215	{
	216	my $esmtp = ${*$me}{'net_smtp_esmtp'};
	217
	218	if(defined($v = delete $opt{Size}))
	219	{
	220	if(exists $esmtp->{SIZE})
	221	{
	222	$opts .= sprintf " SIZE=%d", $v + 0
	223	}
	224	else
	225	{
	226	carp 'Net::SMTP::mail: SIZE option not supported by host';
	227	}
	228	}
	229
	230	if(defined($v = delete $opt{Return}))
	231	{
	232	if(exists $esmtp->{DSN})
	233	{
dea4d7df	234	$opts .= " RET=" . ((uc($v) eq "FULL") ? "FULL" : "HDRS");
406c51ee	235	}
	236	else
	237	{
	238	carp 'Net::SMTP::mail: DSN option not supported by host';
	239	}
	240	}
	241
	242	if(defined($v = delete $opt{Bits}))
	243	{
dea4d7df	244	if($v eq "8")
	245	{
	246	if(exists $esmtp->{'8BITMIME'})
	247	{
	248	$opts .= " BODY=8BITMIME";
	249	}
	250	else
	251	{
	252	carp 'Net::SMTP::mail: 8BITMIME option not supported by host';
	253	}
	254	}
	255	elsif($v eq "binary")
	256	{
	257	if(exists $esmtp->{'BINARYMIME'} && exists $esmtp->{'CHUNKING'})
	258	{
	259	$opts .= " BODY=BINARYMIME";
	260	${*$me}{'net_smtp_chunking'} = 1;
	261	}
	262	else
	263	{
	264	carp 'Net::SMTP::mail: BINARYMIME option not supported by host';
	265	}
	266	}
	267	elsif(exists $esmtp->{'8BITMIME'} or exists $esmtp->{'BINARYMIME'})
406c51ee	268	{
dea4d7df	269	$opts .= " BODY=7BIT";
406c51ee	270	}
	271	else
	272	{
dea4d7df	273	carp 'Net::SMTP::mail: 8BITMIME and BINARYMIME options not supported by host';
406c51ee	274	}
	275	}
	276
	277	if(defined($v = delete $opt{Transaction}))
	278	{
	279	if(exists $esmtp->{CHECKPOINT})
	280	{
dea4d7df	281	$opts .= " TRANSID=" . _addr($me, $v);
406c51ee	282	}
	283	else
	284	{
	285	carp 'Net::SMTP::mail: CHECKPOINT option not supported by host';
	286	}
	287	}
	288
	289	if(defined($v = delete $opt{Envelope}))
	290	{
	291	if(exists $esmtp->{DSN})
	292	{
	293	$v =~ s/([^\041-\176]\|=\|\+)/sprintf "+%02x", ord($1)/sge;
	294	$opts .= " ENVID=$v"
	295	}
	296	else
	297	{
	298	carp 'Net::SMTP::mail: DSN option not supported by host';
	299	}
	300	}
	301
	302	carp 'Net::SMTP::recipient: unknown option(s) '
	303	. join(" ", keys %opt)
	304	. ' - ignored'
	305	if scalar keys %opt;
	306	}
	307	else
	308	{
	309	carp 'Net::SMTP::mail: ESMTP not supported by host - options discarded :-(';
	310	}
	311	}
	312
	313	$me->_MAIL("FROM:".$addr.$opts);
	314	}
	315
dea4d7df	316	sub send { my $me = shift; $me->_SEND("FROM:" . _addr($me, $_[0])) }
	317	sub send_or_mail { my $me = shift; $me->_SOML("FROM:" . _addr($me, $_[0])) }
	318	sub send_and_mail { my $me = shift; $me->_SAML("FROM:" . _addr($me, $_[0])) }
406c51ee	319
	320	sub reset
	321	{
	322	my $me = shift;
	323
	324	$me->dataend()
	325	if(exists ${*$me}{'net_smtp_lastch'});
	326
	327	$me->_RSET();
	328	}
	329
	330
	331	sub recipient
	332	{
	333	my $smtp = shift;
	334	my $opts = "";
	335	my $skip_bad = 0;
	336
	337	if(@_ && ref($_[-1]))
	338	{
	339	my %opt = %{pop(@_)};
	340	my $v;
	341
	342	$skip_bad = delete $opt{'SkipBad'};
	343
	344	if(exists ${*$smtp}{'net_smtp_esmtp'})
	345	{
	346	my $esmtp = ${*$smtp}{'net_smtp_esmtp'};
	347
	348	if(defined($v = delete $opt{Notify}))
	349	{
	350	if(exists $esmtp->{DSN})
	351	{
	352	$opts .= " NOTIFY=" . join(",",map { uc $_ } @$v)
	353	}
	354	else
	355	{
	356	carp 'Net::SMTP::recipient: DSN option not supported by host';
	357	}
	358	}
	359
	360	carp 'Net::SMTP::recipient: unknown option(s) '
	361	. join(" ", keys %opt)
	362	. ' - ignored'
	363	if scalar keys %opt;
	364	}
	365	elsif(%opt)
	366	{
	367	carp 'Net::SMTP::recipient: ESMTP not supported by host - options discarded :-(';
	368	}
	369	}
	370
	371	my @ok;
	372	my $addr;
	373	foreach $addr (@_)
	374	{
dea4d7df	375	if($smtp->_RCPT("TO:" . _addr($smtp, $addr) . $opts)) {
406c51ee	376	push(@ok,$addr) if $skip_bad;
	377	}
	378	elsif(!$skip_bad) {
	379	return 0;
	380	}
	381	}
	382
	383	return $skip_bad ? @ok : 1;
	384	}
	385
686337f3	386	BEGIN {
	387	*to = \&recipient;
	388	*cc = \&recipient;
	389	*bcc = \&recipient;
	390	}
406c51ee	391
	392	sub data
	393	{
	394	my $me = shift;
	395
dea4d7df	396	if(exists ${*$me}{'net_smtp_chunking'})
	397	{
	398	carp 'Net::SMTP::data: CHUNKING extension in use, must call bdat instead';
	399	}
	400	else
	401	{
	402	my $ok = $me->_DATA() && $me->datasend(@_);
	403
	404	$ok && @_ ? $me->dataend
	405	: $ok;
	406	}
	407	}
	408
	409	sub bdat
	410	{
	411	my $me = shift;
	412
	413	if(exists ${*$me}{'net_smtp_chunking'})
	414	{
	415	my $data = shift;
406c51ee	416
dea4d7df	417	$me->_BDAT(length $data) && $me->rawdatasend($data) &&
	418	$me->response() == CMD_OK;
	419	}
	420	else
	421	{
	422	carp 'Net::SMTP::bdat: CHUNKING extension is not in use, call data instead';
	423	}
	424	}
	425
	426	sub bdatlast
	427	{
	428	my $me = shift;
	429
	430	if(exists ${*$me}{'net_smtp_chunking'})
	431	{
	432	my $data = shift;
	433
	434	$me->_BDAT(length $data, "LAST") && $me->rawdatasend($data) &&
	435	$me->response() == CMD_OK;
	436	}
	437	else
	438	{
	439	carp 'Net::SMTP::bdat: CHUNKING extension is not in use, call data instead';
	440	}
406c51ee	441	}
406c51ee	442
12df23ee	443	sub datafh {
	444	my $me = shift;
	445	return unless $me->_DATA();
	446	return $me->tied_fh;
	447	}
	448
406c51ee	449	sub expand
	450	{
	451	my $me = shift;
	452
	453	$me->_EXPN(@_) ? ($me->message)
	454	: ();
	455	}
	456
	457
	458	sub verify { shift->_VRFY(@_) }
	459
	460	sub help
	461	{
	462	my $me = shift;
	463
	464	$me->_HELP(@_) ? scalar $me->message
	465	: undef;
	466	}
	467
	468	sub quit
	469	{
	470	my $me = shift;
	471
	472	$me->_QUIT;
	473	$me->close;
	474	}
	475
	476	sub DESTROY
	477	{
	478	# ignore
	479	}
	480
	481	##
	482	## RFC821 commands
	483	##
	484
	485	sub _EHLO { shift->command("EHLO", @_)->response() == CMD_OK }
	486	sub _HELO { shift->command("HELO", @_)->response() == CMD_OK }
	487	sub _MAIL { shift->command("MAIL", @_)->response() == CMD_OK }
	488	sub _RCPT { shift->command("RCPT", @_)->response() == CMD_OK }
	489	sub _SEND { shift->command("SEND", @_)->response() == CMD_OK }
	490	sub _SAML { shift->command("SAML", @_)->response() == CMD_OK }
	491	sub _SOML { shift->command("SOML", @_)->response() == CMD_OK }
	492	sub _VRFY { shift->command("VRFY", @_)->response() == CMD_OK }
	493	sub _EXPN { shift->command("EXPN", @_)->response() == CMD_OK }
	494	sub _HELP { shift->command("HELP", @_)->response() == CMD_OK }
	495	sub _RSET { shift->command("RSET")->response() == CMD_OK }
	496	sub _NOOP { shift->command("NOOP")->response() == CMD_OK }
	497	sub _QUIT { shift->command("QUIT")->response() == CMD_OK }
	498	sub _DATA { shift->command("DATA")->response() == CMD_MORE }
dea4d7df	499	sub _BDAT { shift->command("BDAT", @_) }
406c51ee	500	sub _TURN { shift->unsupported(@_); }
406c51ee	501	sub _ETRN { shift->command("ETRN", @_)->response() == CMD_OK }
c8570720	502	sub _AUTH { shift->command("AUTH", @_)->response() == CMD_OK }
406c51ee	503
	504	1;
	505
	506	__END__
	507
	508	=head1 NAME
	509
	510	Net::SMTP - Simple Mail Transfer Protocol Client
	511
	512	=head1 SYNOPSIS
	513
	514	use Net::SMTP;
686337f3	515
406c51ee	516	# Constructors
	517	$smtp = Net::SMTP->new('mailhost');
	518	$smtp = Net::SMTP->new('mailhost', Timeout => 60);
	519
	520	=head1 DESCRIPTION
	521
	522	This module implements a client interface to the SMTP and ESMTP
	523	protocol, enabling a perl5 application to talk to SMTP servers. This
	524	documentation assumes that you are familiar with the concepts of the
	525	SMTP protocol described in RFC821.
	526
	527	A new Net::SMTP object must be created with the I<new> method. Once
	528	this has been done, all SMTP commands are accessed through this object.
	529
	530	The Net::SMTP class is a subclass of Net::Cmd and IO::Socket::INET.
	531
	532	=head1 EXAMPLES
	533
	534	This example prints the mail domain name of the SMTP server known as mailhost:
	535
	536	#!/usr/local/bin/perl -w
686337f3	537
406c51ee	538	use Net::SMTP;
686337f3	539
406c51ee	540	$smtp = Net::SMTP->new('mailhost');
	541	print $smtp->domain,"\n";
	542	$smtp->quit;
	543
	544	This example sends a small message to the postmaster at the SMTP server
	545	known as mailhost:
	546
	547	#!/usr/local/bin/perl -w
686337f3	548
406c51ee	549	use Net::SMTP;
686337f3	550
406c51ee	551	$smtp = Net::SMTP->new('mailhost');
686337f3	552
406c51ee	553	$smtp->mail($ENV{USER});
406c51ee	554	$smtp->to('postmaster');
686337f3	555
406c51ee	556	$smtp->data();
	557	$smtp->datasend("To: postmaster\n");
	558	$smtp->datasend("\n");
	559	$smtp->datasend("A simple test message\n");
	560	$smtp->dataend();
686337f3	561
406c51ee	562	$smtp->quit;
	563
	564	=head1 CONSTRUCTOR
	565
	566	=over 4
	567
	568	=item new Net::SMTP [ HOST, ] [ OPTIONS ]
	569
	570	This is the constructor for a new Net::SMTP object. C<HOST> is the
d1be9408	571	name of the remote host to which an SMTP connection is required.
406c51ee	572
dea4d7df	573	If C<HOST> is an array reference then each value will be attempted
	574	in turn until a connection is made.
	575
406c51ee	576	If C<HOST> is not given, then the C<SMTP_Host> specified in C<Net::Config>
	577	will be used.
	578
	579	C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
	580	Possible options are:
	581
	582	B<Hello> - SMTP requires that you identify yourself. This option
	583	specifies a string to pass as your mail domain. If not
	584	given a guess will be taken.
	585
12df23ee	586	B<LocalAddr> and B<LocalPort> - These parameters are passed directly
	587	to IO::Socket to allow binding the socket to a local port.
	588
406c51ee	589	B<Timeout> - Maximum time, in seconds, to wait for a response from the
	590	SMTP server (default: 120)
	591
dea4d7df	592	B<ExactAddresses> - If true the all ADDRESS arguments must be as
	593	defined by C<addr-spec> in RFC2822. If not given, or false, then
	594	Net::SMTP will attempt to extract the address from the value passed.
	595
406c51ee	596	B<Debug> - Enable debugging information
	597
	598
	599	Example:
	600
	601
	602	$smtp = Net::SMTP->new('mailhost',
	603	Hello => 'my.mail.domain'
	604	Timeout => 30,
	605	Debug => 1,
	606	);
	607
686337f3	608	=back
686337f3	609
406c51ee	610	=head1 METHODS
	611
	612	Unless otherwise stated all methods return either a I<true> or I<false>
	613	value, with I<true> meaning that the operation was a success. When a method
	614	states that it returns a value, failure will be returned as I<undef> or an
	615	empty list.
	616
	617	=over 4
	618
	619	=item banner ()
	620
	621	Returns the banner message which the server replied with when the
	622	initial connection was made.
	623
	624	=item domain ()
	625
	626	Returns the domain that the remote SMTP server identified itself as during
	627	connection.
	628
	629	=item hello ( DOMAIN )
	630
	631	Tell the remote server the mail domain which you are in using the EHLO
	632	command (or HELO if EHLO fails). Since this method is invoked
	633	automatically when the Net::SMTP object is constructed the user should
	634	normally not have to call it manually.
	635
	636	=item etrn ( DOMAIN )
	637
	638	Request a queue run for the DOMAIN given.
	639
c8570720	640	=item auth ( USERNAME, PASSWORD )
c8570720	641
16f7bb68	642	Attempt SASL authentication.
c8570720	643
406c51ee	644	=item mail ( ADDRESS [, OPTIONS] )
	645
	646	=item send ( ADDRESS )
	647
	648	=item send_or_mail ( ADDRESS )
	649
	650	=item send_and_mail ( ADDRESS )
	651
	652	Send the appropriate command to the server MAIL, SEND, SOML or SAML. C<ADDRESS>
	653	is the address of the sender. This initiates the sending of a message. The
	654	method C<recipient> should be called for each address that the message is to
	655	be sent to.
	656
	657	The C<mail> method can some additional ESMTP OPTIONS which is passed
	658	in hash like fashion, using key and value pairs. Possible options are:
	659
	660	Size => <bytes>
dea4d7df	661	Return => "FULL" \| "HDRS"
dea4d7df	662	Bits => "7" \| "8" \| "binary"
406c51ee	663	Transaction => <ADDRESS>
	664	Envelope => <ENVID>
	665
dea4d7df	666	The C<Return> and C<Envelope> parameters are used for DSN (Delivery
dea4d7df	667	Status Notification).
406c51ee	668
	669	=item reset ()
	670
	671	Reset the status of the server. This may be called after a message has been
	672	initiated, but before any data has been sent, to cancel the sending of the
	673	message.
	674
	675	=item recipient ( ADDRESS [, ADDRESS [ ...]] [, OPTIONS ] )
	676
	677	Notify the server that the current message should be sent to all of the
	678	addresses given. Each address is sent as a separate command to the server.
	679	Should the sending of any address result in a failure then the
	680	process is aborted and a I<false> value is returned. It is up to the
	681	user to call C<reset> if they so desire.
	682
	683	The C<recipient> method can some additional OPTIONS which is passed
	684	in hash like fashion, using key and value pairs. Possible options are:
	685
	686	Notify =>
	687	SkipBad => ignore bad addresses
	688
	689	If C<SkipBad> is true the C<recipient> will not return an error when a
	690	bad address is encountered and it will return an array of addresses
	691	that did succeed.
	692
686337f3	693	$smtp->recipient($recipient1,$recipient2); # Good
	694	$smtp->recipient($recipient1,$recipient2, { SkipBad => 1 }); # Good
	695	$smtp->recipient("$recipient,$recipient2"); # BAD
	696
406c51ee	697	=item to ( ADDRESS [, ADDRESS [...]] )
406c51ee	698
686337f3	699	=item cc ( ADDRESS [, ADDRESS [...]] )
	700
	701	=item bcc ( ADDRESS [, ADDRESS [...]] )
	702
	703	Synonyms for C<recipient>.
406c51ee	704
	705	=item data ( [ DATA ] )
	706
	707	Initiate the sending of the data from the current message.
	708
	709	C<DATA> may be a reference to a list or a list. If specified the contents
	710	of C<DATA> and a termination string C<".\r\n"> is sent to the server. And the
	711	result will be true if the data was accepted.
	712
	713	If C<DATA> is not specified then the result will indicate that the server
	714	wishes the data to be sent. The data must then be sent using the C<datasend>
	715	and C<dataend> methods described in L<Net::Cmd>.
	716
	717	=item expand ( ADDRESS )
	718
	719	Request the server to expand the given address Returns an array
	720	which contains the text read from the server.
	721
	722	=item verify ( ADDRESS )
	723
	724	Verify that C<ADDRESS> is a legitimate mailing address.
	725
	726	=item help ( [ $subject ] )
	727
	728	Request help text from the server. Returns the text or undef upon failure
	729
	730	=item quit ()
	731
	732	Send the QUIT command to the remote SMTP server and close the socket connection.
	733
	734	=back
	735
16f7bb68	736	=head1 ADDRESSES
16f7bb68	737
dea4d7df	738	Net::SMTP attempts to DWIM with addresses that are passed. For
	739	example an application might extract The From: line from an email
	740	and pass that to mail(). While this may work, it is not reccomended.
	741	The application should really use a module like L<Mail::Address>
	742	to extract the mail address and pass that.
	743
	744	If C<ExactAddresses> is passed to the contructor, then addresses
	745	should be a valid rfc2821-quoted address, although Net::SMTP will
	746	accept accept the address surrounded by angle brackets.
16f7bb68	747
	748	funny user@domain WRONG
	749	"funny user"@domain RIGHT, recommended
	750	<"funny user"@domain> OK
	751
406c51ee	752	=head1 SEE ALSO
	753
	754	L<Net::Cmd>
	755
	756	=head1 AUTHOR
	757
	758	Graham Barr <gbarr@pobox.com>
	759
	760	=head1 COPYRIGHT
	761
	762	Copyright (c) 1995-1997 Graham Barr. All rights reserved.
	763	This program is free software; you can redistribute it and/or modify
	764	it under the same terms as Perl itself.
	765
686337f3	766	=for html <hr>
686337f3	767
dea4d7df	768	I<$Id: //depot/libnet/Net/SMTP.pm#31 $>
686337f3	769
406c51ee	770	=cut