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