This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[inseparable changes from patch from perl5.003_12 to perl5.003_13]
[perl5.git] / lib / Net / SMTP.pm
1 # Net::SMTP.pm
2 #
3 # Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
4 # reserved. 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 =head1 NAME
10
11 Net::SMTP - Simple Mail transfer Protocol Client
12
13 =head1 SYNOPSIS
14
15     use Net::SMTP;
16     
17     # Constructors
18     $smtp = Net::SMTP->new('mailhost');
19     $smtp = Net::SMTP->new('mailhost', Timeout => 60);
20
21 =head1 DESCRIPTION
22
23 This module implements a client interface to the SMTP protocol, enabling
24 a perl5 application to talk to SMTP servers. This documentation assumes
25 that you are familiar with the SMTP protocol described in RFC821.
26
27 A new Net::SMTP object must be created with the I<new> method. Once
28 this has been done, all SMTP commands are accessed through this object.
29
30 =head1 EXAMPLES
31
32 This example prints the mail domain name of the SMTP server known as mailhost:
33
34     #!/usr/local/bin/perl -w
35     
36     use Net::SMTP;
37     
38     $smtp = Net::SMTP->new('mailhost');
39     
40     print $smtp->domain,"\n";
41     
42     $smtp->quit;
43
44 This example sends a small message to the postmaster at the SMTP server
45 known as mailhost:
46
47     #!/usr/local/bin/perl -w
48     
49     use Net::SMTP;
50     
51     $smtp = Net::SMTP->new('mailhost');
52     
53     $smtp->mail($ENV{USER});
54     
55     $smtp->to('postmaster');
56     
57     $smtp->data();
58     
59     $smtp->datasend("To: postmaster\n");
60     $smtp->datasend("\n");
61     $smtp->datasend("A simple test message\n");
62     
63     $smtp->dataend();
64     
65     $smtp->quit;
66
67 =head1 CONSTRUCTOR
68
69 =over 4
70
71 =item new ( HOST, [ OPTIONS ] )
72
73 This is the constructor for a new Net::SMTP object. C<HOST> is the
74 name of the remote host to which a SMTP connection is required.
75
76 C<OPTIONS> are passed in a hash like fasion, using key and value pairs.
77 Possible options are:
78
79 B<Hello> - SMTP requires that you identify yourself. This option
80 specifies a string to pass as your mail domain. If not
81 given a guess will be taken.
82
83 B<Timeout> - Maximum time, in seconds, to wait for a response from the
84 SMTP server (default: 120)
85
86 B<Debug> - Enable debugging information
87
88
89 Example:
90
91
92     $smtp = Net::SMTP->new('mailhost',
93                            Hello => 'my.mail.domain'
94                           );
95
96 =head1 METHODS
97
98 Unless otherwise stated all methods return either a I<true> or I<false>
99 value, with I<true> meaning that the operation was a success. When a method
100 states that it returns a value, falure will be returned as I<undef> or an
101 empty list.
102
103 =over 4
104
105 =item domain ()
106
107 Returns the domain that the remote SMTP server identified itself as during
108 connection.
109
110 =item hello ( DOMAIN )
111
112 Tell the remote server the mail domain which you are in using the HELO
113 command.
114
115 =item mail ( ADDRESS )
116
117 =item send ( ADDRESS )
118
119 =item send_or_mail ( ADDRESS )
120
121 =item send_and_mail ( ADDRESS )
122
123 Send the appropriate command to the server MAIL, SEND, SOML or SAML. C<ADDRESS>
124 is the address of the sender. This initiates the sending of a message. The
125 method C<recipient> should be called for each address that the message is to
126 be sent to.
127
128 =item reset ()
129
130 Reset the status of the server. This may be called after a message has been 
131 initiated, but before any data has been sent, to cancel the sending of the
132 message.
133
134 =item recipient ( ADDRESS [, ADDRESS [ ...]] )
135
136 Notify the server that the current message should be sent to all of the
137 addresses given. Each address is sent as a separate command to the server.
138 Should the sending of any address result in a failure then the
139 process is aborted and a I<false> value is returned. It is up to the
140 user to call C<reset> if they so desire.
141
142 =item to ()
143
144 A synonym for recipient
145
146 =item data ( [ DATA ] )
147
148 Initiate the sending of the data fro the current message. 
149
150 C<DATA> may be a reference to a list or a list. If specified the contents
151 of C<DATA> and a termination string C<".\r\n"> is sent to the server. And the
152 result will be true if the data was accepted.
153
154 If C<DATA> is not specified then the result will indicate that the server
155 wishes the data to be sent. The data must then be sent using the C<datasend>
156 and C<dataend> methods defined in C<Net::Cmd>.
157
158 =item expand ( ADDRESS )
159
160 Request the server to expand the given address Returns a reference to an array
161 which contains the text read from the server.
162
163 =item verify ( ADDRESS )
164
165 Verify that C<ADDRESS> is a legitimate mailing address.
166
167 =item help ( [ $subject ] )
168
169 Request help text from the server. Returns the text or undef upon failure
170
171 =item quit ()
172
173 Send the QUIT command to the remote SMTP server and close the socket connection.
174
175 =back
176
177 =head1 SEE ALSO
178
179 L<Net::Cmd>
180
181 =head1 AUTHOR
182
183 Graham Barr <Graham.Barr@tiuk.ti.com>
184
185 =head1 REVISION
186
187 $Revision: 2.1 $
188 $Date: 1996/08/20 20:23:56 $
189
190 The VERSION is derived from the revision by changing each number after the
191 first dot into a 2 digit number so
192
193         Revision 1.8   => VERSION 1.08
194         Revision 1.2.3 => VERSION 1.0203
195
196 =head1 COPYRIGHT
197
198 Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
199 software; you can redistribute it and/or modify it under the same terms
200 as Perl itself.
201
202 =cut
203
204 require 5.001;
205
206 use strict;
207 use vars qw($VERSION @ISA);
208 use Socket 1.3;
209 use Carp;
210 use IO::Socket;
211 use Net::Cmd;
212
213 $VERSION = do{my @r=(q$Revision: 2.1 $=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r};
214
215 @ISA = qw(Net::Cmd IO::Socket::INET);
216
217 sub new
218 {
219  my $self = shift;
220  my $type = ref($self) || $self;
221  my $host = shift;
222  my %arg  = @_; 
223  my $obj = $type->SUPER::new(PeerAddr => $host, 
224                              PeerPort => $arg{Port} || 'smtp(25)',
225                              Proto    => 'tcp',
226                              Timeout  => defined $arg{Timeout}
227                                                 ? $arg{Timeout}
228                                                 : 120
229                             ) or return undef;
230
231  $obj->autoflush(1);
232
233  $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
234
235  unless ($obj->response() == CMD_OK)
236   {
237    $obj->SUPER::close();
238    return undef;
239   }
240
241  ${*$obj}{'net_smtp_host'} = $host;
242
243  (${*$obj}{'net_smtp_domain'}) = $obj->message =~ /\A\s*(\S+)/;
244
245  $obj->hello($arg{Hello} || "");
246
247  $obj;
248 }
249
250 ##
251 ## User interface methods
252 ##
253
254 sub domain
255 {
256  my $me = shift;
257
258  return ${*$me}{'net_smtp_domain'} || undef;
259 }
260
261 sub hello
262 {
263  my $me = shift;
264  my $domain = shift ||
265               eval {
266                     require Net::Domain;
267                     Net::Domain::hostdomain();
268                    } ||
269                 "";
270  my $ok = $me->_EHLO($domain);
271  my $msg;
272
273  if($ok)
274   {
275    $msg = $me->message;
276
277    my $h = ${*$me}{'net_smtp_esmtp'} = {};
278    my $ext;
279    foreach $ext (qw(8BITMIME CHECKPOINT DSN SIZE))
280     {
281      $h->{$ext} = 1
282         if $msg =~ /\b${ext}\b/;
283     }
284   }
285  else
286   {
287    $msg = $me->message
288         if $me->_HELO($domain);
289   }
290
291  $ok && $msg =~ /\A(\S+)/
292         ? $1
293         : undef;
294 }
295
296 sub _addr
297 {
298  my $addr = shift || "";
299
300  return $1
301     if $addr =~ /(<[^>]+>)/so;
302
303  $addr =~ s/\n/ /sog;
304  $addr =~ s/(\A\s+|\s+\Z)//sog;
305
306  return "<" . $addr . ">";
307 }
308
309
310 sub mail
311 {
312  my $me = shift;
313  my $addr = _addr(shift);
314  my $opts = "";
315
316  if(@_)
317   {
318    my %opt = @_;
319    my($k,$v);
320
321    if(exists ${*$me}{'net_smtp_esmtp'})
322     {
323      my $esmtp = ${*$me}{'net_smtp_esmtp'};
324
325      if(defined($v = delete $opt{Size}))
326       {
327        if(exists $esmtp->{SIZE})
328         {
329          $opts .= sprintf " SIZE=%d", $v + 0
330         }
331        else
332         {
333          carp 'Net::SMTP::mail: SIZE option not supported by host';
334         }
335       }
336
337      if(defined($v = delete $opt{Return}))
338       {
339        if(exists $esmtp->{DSN})
340         {
341          $opts .= " RET=" . uc $v
342         }
343        else
344         {
345          carp 'Net::SMTP::mail: DSN option not supported by host';
346         }
347       }
348
349      if(defined($v = delete $opt{Bits}))
350       {
351        if(exists $esmtp->{'8BITMIME'})
352         {
353          $opts .= $v == 8 ? " BODY=8BITMIME" : " BODY=7BIT"
354         }
355        else
356         {
357          carp 'Net::SMTP::mail: 8BITMIME option not supported by host';
358         }
359       }
360
361      if(defined($v = delete $opt{Transaction}))
362       {
363        if(exists $esmtp->{CHECKPOINT})
364         {
365          $opts .= " TRANSID=" . _addr($v);
366         }
367        else
368         {
369          carp 'Net::SMTP::mail: CHECKPOINT option not supported by host';
370         }
371       }
372
373      if(defined($v = delete $opt{Envelope}))
374       {
375        if(exists $esmtp->{DSN})
376         {
377          $v =~ s/([^\041-\176]|=|\+)/sprintf "+%02x", ord($1)/sge;
378          $opts .= " ENVID=$v"
379         }
380        else
381         {
382          carp 'Net::SMTP::mail: DSN option not supported by host';
383         }
384       }
385
386      carp 'Net::SMTP::recipient: unknown option(s) '
387                 . join(" ", keys %opt)
388                 . ' - ignored'
389         if scalar keys %opt;
390     }
391    else
392     {
393      carp 'Net::SMTP::mail: ESMTP not supported by host - options discarded :-(';
394     }
395   }
396
397  $me->_MAIL("FROM:".$addr.$opts);
398 }
399
400 sub send          { shift->_SEND("FROM:" . _addr($_[0])) }
401 sub send_or_mail  { shift->_SOML("FROM:" . _addr($_[0])) }
402 sub send_and_mail { shift->_SAML("FROM:" . _addr($_[0])) }
403
404 sub reset
405 {
406  my $me = shift;
407
408  $me->dataend()
409         if(exists ${*$me}{'net_smtp_lastch'});
410
411  $me->_RSET();
412 }
413
414
415 sub recipient
416 {
417  my $smtp = shift;
418  my $ok = 1;
419  my $opts = "";
420
421  if(@_ && ref($_[-1]))
422   {
423    my %opt = %{pop(@_)};
424    my $v;
425
426    if(exists ${*$smtp}{'net_smtp_esmtp'})
427     {
428      my $esmtp = ${*$smtp}{'net_smtp_esmtp'};
429
430      if(defined($v = delete $opt{Notify}))
431       {
432        if(exists $esmtp->{DSN})
433         {
434          $opts .= " NOTIFY=" . join(",",map { uc $_ } @$v)
435         }
436        else
437         {
438          carp 'Net::SMTP::recipient: DSN option not supported by host';
439         }
440       }
441
442      carp 'Net::SMTP::recipient: unknown option(s) '
443                 . join(" ", keys %opt)
444                 . ' - ignored'
445         if scalar keys %opt;
446     }
447    else
448     {
449      carp 'Net::SMTP::recipient: ESMTP not supported by host - options discarded :-(';
450     }
451   }
452
453  while($ok && scalar(@_))
454   {
455    $ok = $smtp->_RCPT("TO:" . _addr(shift) . $opts);
456   }
457
458  return $ok;
459 }
460
461 *to = \&recipient;
462
463 sub data
464 {
465  my $me = shift;
466
467  my $ok = $me->_DATA() && $me->datasend(@_);
468
469  $ok && @_ ? $me->dataend
470            : $ok;
471 }
472
473 sub expand
474 {
475  my $me = shift;
476
477  $me->_EXPN(@_) ? ($me->message)
478                 : ();
479 }
480
481
482 sub verify { shift->_VRFY(@_) }
483
484 sub help
485 {
486  my $me = shift;
487
488  $me->_HELP(@_) ? scalar $me->message
489                 : undef;
490 }
491
492 sub close
493 {
494  my $me = shift;
495
496  return 1
497    unless (ref($me) && defined fileno($me));
498
499  $me->_QUIT && $me->SUPER::close;
500 }
501
502 sub DESTROY { shift->close }
503 sub quit    { shift->close }
504
505 ##
506 ## RFC821 commands
507 ##
508
509 sub _EHLO { shift->command("EHLO", @_)->response()  == CMD_OK }   
510 sub _HELO { shift->command("HELO", @_)->response()  == CMD_OK }   
511 sub _MAIL { shift->command("MAIL", @_)->response()  == CMD_OK }   
512 sub _RCPT { shift->command("RCPT", @_)->response()  == CMD_OK }   
513 sub _SEND { shift->command("SEND", @_)->response()  == CMD_OK }   
514 sub _SAML { shift->command("SAML", @_)->response()  == CMD_OK }   
515 sub _SOML { shift->command("SOML", @_)->response()  == CMD_OK }   
516 sub _VRFY { shift->command("VRFY", @_)->response()  == CMD_OK }   
517 sub _EXPN { shift->command("EXPN", @_)->response()  == CMD_OK }   
518 sub _HELP { shift->command("HELP", @_)->response()  == CMD_OK }   
519 sub _RSET { shift->command("RSET")->response()      == CMD_OK }   
520 sub _NOOP { shift->command("NOOP")->response()      == CMD_OK }   
521 sub _QUIT { shift->command("QUIT")->response()      == CMD_OK }   
522 sub _DATA { shift->command("DATA")->response()      == CMD_MORE } 
523 sub _TURN { shift->unsupported(@_); }                             
524
525 1;
526