File Coverage

blib/lib/Net/Server/Mail/SMTP.pm
Criterion Covered Total %
statement 109 181 60.2
branch 31 58 53.4
condition 2 8 25.0
subroutine 19 33 57.5
pod 2 24 8.3
total 163 304 53.6


line stmt bran cond sub pod time code
1             package Net::Server::Mail::SMTP;
2              
3 4     4   1355 use 5.006;
  4         12  
4 4     4   19 use strict;
  4         6  
  4         72  
5 4     4   13 use base 'Net::Server::Mail';
  4         8  
  4         1723  
6              
7             our $VERSION = "0.26";
8              
9             =pod
10              
11             =head1 NAME
12              
13             Net::Server::Mail::SMTP - A module to implement the SMTP protocol
14              
15             =head1 SYNOPSIS
16              
17             use Net::Server::Mail::SMTP;
18              
19             my @local_domains = qw(example.com example.org);
20             my $server = IO::Socket::INET->new( Listen => 1, LocalPort => 25 );
21              
22             my $conn;
23             while($conn = $server->accept)
24             {
25             my $smtp = Net::Server::Mail::SMTP->new( socket => $conn );
26             $smtp->set_callback(RCPT => \&validate_recipient);
27             $smtp->set_callback(DATA => \&queue_message);
28             $smtp->process();
29             $conn->close();
30             }
31              
32             sub validate_recipient
33             {
34             my($session, $recipient) = @_;
35              
36             my $domain;
37             if($recipient =~ /\@(.*)>\s*$/)
38             {
39             $domain = $1;
40             }
41              
42             if(not defined $domain)
43             {
44             return(0, 513, 'Syntax error.');
45             }
46             elsif(not(grep $domain eq $_, @local_domains))
47             {
48             return(0, 554, "$recipient: Recipient address rejected: Relay access denied");
49             }
50              
51             return(1);
52             }
53              
54             sub queue_message
55             {
56             my($session, $data) = @_;
57              
58             my $sender = $session->get_sender();
59             my @recipients = $session->get_recipients();
60              
61             return(0, 554, 'Error: no valid recipients')
62             unless(@recipients);
63              
64             my $msgid = add_queue($sender, \@recipients, $data)
65             or return(0);
66              
67             return(1, 250, "message queued $msgid");
68             }
69              
70             =head1 DESCRIPTION
71              
72             This class implement the SMTP (RFC 821) protocol. Notice that it don't
73             implement the extension mechanism introduce in RFC 2821. You have to
74             use Net::Server::Mail::ESMTP if you want this capability.
75              
76             This class inherit from Net::Server::Mail. Please see
77             L for documentation of common methods.
78              
79             =head1 METHODS
80              
81             SMTP specific methods.
82              
83             =cut
84              
85             sub init {
86 7     7 0 35 my ( $self, @args ) = @_;
87 7         52 my $rv = $self->SUPER::init(@args);
88 7 50       48 return $rv unless $rv eq $self;
89              
90 7         57 $self->def_verb( HELO => 'helo' );
91 7         41 $self->def_verb( VRFY => 'vrfy' );
92 7         19 $self->def_verb( EXPN => 'expn' );
93 7         32 $self->def_verb( TURN => 'turn' );
94 7         17 $self->def_verb( HELP => 'help' );
95 7         21 $self->def_verb( NOOP => 'noop' );
96 7         21 $self->def_verb( MAIL => 'mail' );
97 7         23 $self->def_verb( RCPT => 'rcpt' );
98 7         16 $self->def_verb( SEND => 'send' );
99 7         15 $self->def_verb( SOML => 'soml' );
100 7         26 $self->def_verb( SAML => 'saml' );
101 7         20 $self->def_verb( DATA => 'data' );
102 7         35 $self->def_verb( RSET => 'rset' );
103 7         20 $self->def_verb( QUIT => 'quit' );
104              
105             # go to the initial step
106 7         31 $self->step_reverse_path(0);
107 7         25 $self->step_forward_path(0);
108 7         23 $self->step_maildata_path(0);
109              
110             # handle data after the end of data indicator (.)
111 7         11 $self->{data_handle_more_data} = 0;
112              
113 7         21 return $self;
114             }
115              
116             sub step_reverse_path {
117 24     24 0 40 my ( $self, $bool ) = @_;
118 24 100       65 if ( defined $bool ) {
119 20         37 $self->{reverse_path} = $bool;
120             }
121              
122 24         47 return $self->{reverse_path};
123             }
124              
125             sub step_forward_path {
126 36     36 0 56 my ( $self, $bool ) = @_;
127 36 100       80 if ( defined $bool ) {
128 24         43 $self->{forward_path} = $bool;
129             }
130              
131 36         60 return $self->{forward_path};
132             }
133              
134             sub step_maildata_path {
135 24     24 0 44 my ( $self, $bool ) = @_;
136 24 100       47 if ( defined $bool ) {
137 22         43 $self->{maildata_path} = $bool;
138              
139             # initialise data container
140 22 100       56 if ( not $bool ) {
141 18         42 $self->{_data} = '';
142             }
143             }
144              
145 24         53 return $self->{maildata_path};
146             }
147              
148             sub get_protoname {
149 0     0 0 0 return 'SMTP';
150             }
151              
152             =pod
153              
154             =head2 get_sender
155              
156             Returns the sender of the current session. Return undefined if the
157             reverse path step is not complete.
158              
159             =cut
160              
161             sub get_sender {
162 2     2 1 60 my ($self) = @_;
163 2         10 my $sender = $self->step_reverse_path();
164 2 50       9 return ( $sender ? $sender : undef );
165             }
166              
167             =pod
168              
169             =head2 get_recipients
170              
171             Returns the list of recipients supplied by client. Returns undef if
172             forward_path step is not engaged. Returns an empty list if not
173             recipients succeed.
174              
175             =cut
176              
177             sub get_recipients {
178 2     2 1 902 my ($self) = @_;
179 2         6 my $recipients = $self->step_forward_path();
180 2 50       12 return ( ref $recipients ? @$recipients : undef );
181             }
182              
183             =pod
184              
185             =head1 EVENTS
186              
187             Descriptions of callback who's can be used with set_callback
188             method. All handle takes the Net::Server::Mail::SMTP object as first
189             argument and specific callback's arguments.
190              
191             =head2 HELO
192              
193             Takes the hostname given as argument. Engage the reverse path step on
194             success.
195              
196             sub helo_handle
197             {
198             my($session, $hostname) = @_;
199              
200             if($hostname eq 'localhost')
201             {
202             return(0, 553, q(I don't like this hostname, try again.));
203             }
204              
205             # don't forgot to return a success reply if you are happy with
206             # command's value
207             return 1;
208             }
209              
210             =cut
211              
212             sub helo {
213 0     0 0 0 my ( $self, $hostname ) = @_;
214              
215 0 0 0     0 unless ( defined $hostname && length $hostname ) {
216 0         0 $self->reply( 501, 'Syntax error in parameters or arguments' );
217 0         0 return;
218             }
219              
220             $self->make_event(
221             name => 'HELO',
222             arguments => [$hostname],
223             on_success => sub {
224              
225             # according to the RFC, HELO ensures "that both the SMTP client
226             # and the SMTP server are in the initial state"
227 0     0   0 $self->step_reverse_path(1);
228 0         0 $self->step_forward_path(0);
229 0         0 $self->step_maildata_path(0);
230             },
231 0         0 success_reply => [ 250, 'Requested mail action okay, completed' ],
232             );
233              
234 0         0 return;
235             }
236              
237             =pod
238              
239             =head2 NOOP
240              
241             This handler takes no argument
242              
243             =cut
244              
245             sub noop {
246 0     0 0 0 my ($self) = @_;
247 0         0 $self->make_event( name => 'NOOP' );
248 0         0 return;
249             }
250              
251             =pod
252              
253             =head2 EXPN
254              
255             Command not yet implemented.
256              
257             Handler takes address as argument.
258              
259             =cut
260              
261             sub expn {
262 0     0 0 0 my ( $self, $address ) = @_;
263 0         0 $self->make_event(
264             name => 'EXPN',
265             arguments => [$address],
266             default_reply => [ 502, 'Command not implemented' ]
267             );
268 0         0 return;
269             }
270              
271             =pod
272              
273             =head2 EXPN
274              
275             Command not implemented, deprecated by RFC 2821
276              
277             Handler takes no argument.
278              
279             =cut
280              
281             sub turn {
282              
283             # deprecated in RFC 2821
284 0     0 0 0 my ($self) = @_;
285 0         0 $self->reply( 502, 'Command not implemented' );
286 0         0 $self->make_event(
287             name => 'TURN',
288             default_reply => [ 502, 'Command not implemented' ]
289             );
290 0         0 return;
291             }
292              
293             =pod
294              
295             =head2 VRFY
296              
297             Command not yet implemented.
298              
299             Handler takes address as argument.
300              
301             =cut
302              
303             sub vrfy {
304 0     0 0 0 my ( $self, $address ) = @_;
305 0         0 $self->make_event(
306             name => 'VRFY',
307             arguments => [$address],
308             default_reply => [ 502, 'Command not implemented' ]
309             );
310 0         0 return;
311             }
312              
313             =pod
314              
315             =head2 HELP
316              
317             Command not yet implemented.
318              
319             Handler takes a command name as argument.
320              
321             =cut
322              
323             sub help {
324 0     0 0 0 my ( $self, $command ) = @_;
325 0         0 $self->make_event(
326             name => 'HELP',
327             arguments => [$command],
328             default_reply => [ 502, 'Command not implemented' ]
329             );
330 0         0 return;
331             }
332              
333             =pod
334              
335             =head2 MAIL
336              
337             Handler takes address as argument. On success, engage the forward path
338             step and keep the given address for later use (get it with
339             get_sender() method).
340              
341             =cut
342              
343             sub mail {
344 2     2 0 8 my ( $self, $args ) = @_;
345              
346 2 50       9 unless ( $self->step_reverse_path ) {
347 0         0 $self->reply( 503, 'Bad sequence of commands' );
348 0         0 return;
349             }
350              
351 2 50       21 unless ( $args =~ s/^from:\s*//i ) {
352 0         0 $self->reply( 501, 'Syntax error in parameters or arguments' );
353 0         0 return;
354             }
355              
356 2 50       9 if ( $self->step_forward_path ) {
357 0         0 $self->reply( 503, 'Bad sequence of commands' );
358 0         0 return;
359             }
360              
361 2         6 my ( $address, $rest, @options );
362 2 50       18 unless ( ( $address, $rest ) = $args =~ /^<(.*?)>(?: (\S.*))?$/ ) {
363 0         0 $self->reply( 501, 'Syntax error in parameters or arguments' );
364 0         0 return;
365             }
366 2 50       7 if ($rest) {
367 0         0 @options = split ' ', $rest;
368             }
369              
370 2 50       14 unless ( $self->handle_options( 'MAIL', $address, @options ) ) {
371 0         0 return;
372             }
373              
374             $self->make_event(
375             name => 'MAIL',
376             arguments => [$address],
377             on_success => sub {
378 2     2   7 $self->step_reverse_path($address);
379 2         5 $self->step_forward_path(1);
380             },
381 2         39 success_reply => [ 250, "sender $address OK" ],
382             failure_reply => [ 550, 'Failure' ],
383             );
384              
385 2         13 return;
386             }
387              
388             =pod
389              
390             =head2 RCPT
391              
392             Handler takes address as argument. On success, engage the mail data path step and
393             push the given address into the recipient list for later use (get it
394             with get_recipients() method).
395              
396             =cut
397              
398             sub rcpt {
399 4     4 0 10 my ( $self, $args ) = @_;
400              
401 4 50       9 unless ( $self->step_forward_path ) {
402 0         0 $self->reply( 503, 'Bad sequence of commands' );
403 0         0 return;
404             }
405              
406 4 50       18 unless ( $args =~ s/^to:\s*//i ) {
407 0         0 $self->reply( 501, 'Syntax error in parameters or arguments' );
408 0         0 return;
409             }
410              
411 4         7 my ( $address, $rest, @options );
412 4 50       25 unless ( ( $address, $rest ) = $args =~ /^<(.*?)>(?: (\S.*))?$/ ) {
413 0         0 $self->reply( 501, 'Syntax error in parameters or arguments' );
414 0         0 return;
415             }
416 4 50       8 if ($rest) {
417 0         0 @options = split ' ', $rest;
418             }
419              
420 4 50       13 unless ( $self->handle_options( 'RCPT', $address, @options ) ) {
421 0         0 return;
422             }
423              
424             $self->make_event(
425             name => 'RCPT',
426             arguments => [$address],
427             on_success => sub {
428 4     4   7 my $buffer = $self->step_forward_path();
429 4 100       13 $buffer = [] unless ref $buffer eq 'ARRAY';
430 4         7 push( @$buffer, $address );
431 4         18 $self->step_forward_path($buffer);
432 4         9 $self->step_maildata_path(1);
433             },
434 4         51 success_reply => [ 250, "recipient $address OK" ],
435             failure_reply => [ 550, 'Failure' ],
436             );
437              
438 4         23 return;
439             }
440              
441             =pod
442              
443             =head2 SEND
444              
445             Command not implemented.
446              
447             Handler takes no argument.
448              
449             =cut
450              
451             # we overwrite a perl command... we shouldn't need it in this class,
452             # but take care.
453             sub send {
454 0     0 0 0 my ($self) = @_;
455 0         0 $self->make_event(
456             name => 'SEND',
457             default_reply => [ 502, 'Command not implemented' ]
458             );
459 0         0 return;
460             }
461              
462             =pod
463              
464             =head2 SOML
465              
466             Command not implemented.
467              
468             Handler takes no argument.
469              
470             =cut
471              
472             sub soml {
473 0     0 0 0 my ($self) = @_;
474 0         0 $self->make_event(
475             name => 'SOML',
476             default_reply => [ 502, 'Command not implemented' ]
477             );
478 0         0 return;
479             }
480              
481             =pod
482              
483             =head2 SAML
484              
485             Command not implemented.
486              
487             Handler takes no argument.
488              
489             =cut
490              
491             sub saml {
492 0     0 0 0 my ($self) = @_;
493 0         0 $self->make_event(
494             name => 'SAML',
495             default_reply => [ 502, 'Command not implemented' ]
496             );
497 0         0 return;
498             }
499              
500             =pod
501              
502             =head2 DATA
503              
504             This handler is called after the final . sent by client. It takes data
505             as argument in a scalar reference. You should queue the message and
506             reply with the queue ID.
507              
508             =head2 DATA-INIT
509              
510             This handler is called before enter in the "waiting for data" step. The
511             default success reply is a 354 code telling the client to send the
512             mail content.
513              
514             =head2 DATA-PART
515              
516             This handler is called at each parts of mail content sent. It takes as
517             argument a scalar reference to the part of data received. It is
518             deprecated to change the contents of this scalar.
519              
520             =cut
521              
522             sub data {
523 2     2 0 7 my ( $self, $args ) = @_;
524              
525 2 50       5 unless ( $self->step_maildata_path ) {
526 0         0 $self->reply( 503, 'Bad sequence of commands' );
527 0         0 return;
528             }
529              
530 2 50 33     6 if ( defined $args && length $args ) {
531 0         0 $self->reply( 501, 'Syntax error in parameters or arguments' );
532 0         0 return;
533             }
534              
535 2         11 $self->{last_chunk} = '';
536             $self->make_event(
537             name => 'DATA-INIT',
538 2     2   9 on_success => sub { $self->next_input_to( \&data_part ); },
539 2         16 success_reply => [ 354, 'Start mail input; end with .' ]
540             );
541              
542 2         9 return;
543             }
544              
545             # Because data is cut into pieces (4096 bytes), we have to search
546             # "\r\n.\r\n" sequence in 2 consecutive pieces. $self->{last_chunk}
547             # contains the last 5 bytes.
548             sub data_part {
549 4     4 0 9 my ( $self, $data ) = @_;
550              
551             # search for end of data indicator
552 4   50     11 $data ||= '';
553 4 100       36 if ( "$self->{last_chunk}$data" =~ /\r?\n\.\r?\n/s ) {
554 2         7 my $more_data = $';
555 2 50       8 if ( length $more_data ) {
556              
557             # Client sent a command after the end of data indicator ".".
558 0 0       0 if ( !$self->{data_handle_more_data} ) {
559 0         0 $self->reply( 453,
560             "Command received prior to completion of"
561             . " previous command sequence" );
562 0         0 return;
563             }
564             }
565              
566             # RFC 821 compliance.
567 2         19 ( $data = "$self->{last_chunk}$data" ) =~
568             s/(\r?\n)\.\r?\n(QUIT\r?\n)?$/$1/s;
569 2         9 $self->{_data} .= $data;
570              
571             # RFC 2821 by the letter
572 2         8 $self->{_data} =~ s/^\.(.+\015\012)(?!\n)/$1/gm;
573 2         12 return $self->data_finished($more_data);
574             }
575              
576 2         4 my $tmp = $self->{last_chunk};
577 2         5 $self->{last_chunk} = substr $data, -5;
578 2 50       7 $data = $tmp . ( $data ? substr( $data, 0, -5 ) : '' );
579             $self->make_event(
580             name => 'DATA-PART',
581             arguments => [ \$data ],
582             on_success => sub {
583 2     2   35 $self->{_data} .= $data;
584              
585             # please, recall me soon !
586 2         8 $self->next_input_to( \&data_part );
587             },
588 2         29 success_reply => '', # don't send any reply !
589             );
590              
591 2         9 return;
592             }
593              
594             sub data_finished {
595 2     2 0 6 my ( $self, $more_data ) = @_;
596              
597             $self->make_event(
598             name => 'DATA',
599 2         14 arguments => [ \$self->{_data} ],
600             success_reply => [ 250, 'message sent' ],
601             );
602              
603             # reinitiate the connection
604 2         10 $self->step_reverse_path(1);
605 2         28 $self->step_forward_path(0);
606 2         6 $self->step_maildata_path(0);
607              
608             # if more data, handle it
609 2 50       6 if ($more_data) {
610 0         0 return $self->{process_operation}( $self, $more_data );
611             }
612             else {
613 2         6 return;
614             }
615             }
616              
617             =pod
618              
619             =head2 RSET
620              
621             Handler takes no argument.
622              
623             On success, all step are initialized and sender/recipients list are
624             flushed.
625              
626             =cut
627              
628             sub rset {
629 0     0 0 0 my ($self) = @_;
630              
631             $self->make_event(
632             name => 'RSET',
633             on_success => sub {
634 0 0   0   0 $self->step_reverse_path(1)
635             if ( $self->step_reverse_path() );
636 0         0 $self->step_forward_path(0);
637 0         0 $self->step_maildata_path(0);
638             },
639 0         0 success_reply => [ 250, 'Requested mail action okay, completed' ],
640             );
641              
642 0         0 return;
643             }
644              
645             =pod
646              
647             =head2 QUIT
648              
649             Handler takes no argument.
650              
651             Connection is closed after this command. This behavior may change in
652             future, you will probably be able to control the closing of
653             connection.
654              
655             =cut
656              
657             sub quit {
658 4     4 0 12 my ($self) = @_;
659              
660 4         18 $self->make_event(
661             name => 'QUIT',
662             success_reply => [
663             221, $self->get_hostname . ' Service closing transmission channel'
664             ],
665             );
666              
667 4         12 return 1; # close cnx
668             }
669              
670             ##########################################################################
671              
672             sub handle_options {
673              
674             # handle options for verb MAIL and RCPT
675 0     0 0   my ( $self, $verb, $address, @options ) = @_;
676              
677 0 0         if (@options) {
678 0           $self->reply( 555, "Unsupported option: $options[0]" );
679 0           return 0;
680             }
681              
682 0           return 1;
683             }
684              
685             =pod
686              
687             =head1 SEE ALSO
688              
689             Please, see L, L
690             and L.
691              
692             =head1 AUTHOR
693              
694             Olivier Poitrey Ers@rhapsodyk.netE
695              
696             =head1 AVAILABILITY
697              
698             Available on CPAN.
699              
700             anonymous Git repository:
701              
702             git clone git://github.com/rs/net-server-mail.git
703              
704             Git repository on the web:
705              
706             L
707              
708             =head1 BUGS
709              
710             Please use CPAN system to report a bug (http://rt.cpan.org/).
711              
712             =head1 LICENCE
713              
714             This library is free software; you can redistribute it and/or modify
715             it under the terms of the GNU Lesser General Public License as
716             published by the Free Software Foundation; either version 2.1 of the
717             License, or (at your option) any later version.
718              
719             This library is distributed in the hope that it will be useful, but
720             WITHOUT ANY WARRANTY; without even the implied warranty of
721             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
722             Lesser General Public License for more details.
723              
724             You should have received a copy of the GNU Lesser General Public
725             License along with this library; if not, write to the Free Software
726             Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
727             USA
728              
729             =head1 COPYRIGHT
730              
731             Copyright (C) 2002 - Olivier Poitrey, 2007 - Xavier Guimard
732              
733             =cut
734              
735             1;