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