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