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