lib/Net/SMTP.pm

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