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