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