File Coverage

blib/lib/Net/Server/Mail/ESMTP.pm
Criterion Covered Total %
statement 63 90 70.0
branch 10 28 35.7
condition 4 12 33.3
subroutine 15 18 83.3
pod 1 11 9.0
total 93 159 58.4


line stmt bran cond sub pod time code
1             package Net::Server::Mail::ESMTP;
2              
3 3     3   40073 use 5.006;
  3         21  
4 3     3   15 use strict;
  3         3  
  3         50  
5 3     3   12 use warnings;
  3         5  
  3         79  
6 3     3   13 use Carp;
  3         6  
  3         166  
7 3     3   16 use base qw(Net::Server::Mail::SMTP);
  3         5  
  3         1193  
8              
9             our $VERSION = "0.26";
10              
11             =pod
12              
13             =head1 NAME
14              
15             Net::Server::Mail::ESMTP - A module to implement the ESMTP protocol
16              
17             =head1 SYNOPSIS
18              
19             use Net::Server::Mail::ESMTP;
20              
21             my @local_domains = qw(example.com example.org);
22             my $server = IO::Socket::INET->new( Listen => 1, LocalPort => 25 );
23              
24             my $conn;
25             while($conn = $server->accept)
26             {
27             my $esmtp = Net::Server::Mail::ESMTP->new( socket => $conn );
28             # activate some extensions
29             $esmtp->register('Net::Server::Mail::ESMTP::8BITMIME');
30             $esmtp->register('Net::Server::Mail::ESMTP::PIPELINING');
31             # adding some handlers
32             $esmtp->set_callback(RCPT => \&validate_recipient);
33             $esmtp->set_callback(DATA => \&queue_message);
34             $esmtp->process();
35             $conn->close();
36             }
37              
38             sub validate_recipient
39             {
40             my($session, $recipient) = @_;
41              
42             my $domain;
43             if($recipient =~ /\@(.*)>\s*$/)
44             {
45             $domain = $1;
46             }
47              
48             if(not defined $domain)
49             {
50             return(0, 513, 'Syntax error.');
51             }
52             elsif(not(grep $domain eq $_, @local_domains))
53             {
54             return(0, 554, "$recipient: Recipient address rejected: Relay access denied");
55             }
56              
57             return(1);
58             }
59              
60             sub queue_message
61             {
62             my($session, $data) = @_;
63              
64             my $sender = $session->get_sender();
65             my @recipients = $session->get_recipients();
66              
67             return(0, 554, 'Error: no valid recipients')
68             unless(@recipients);
69              
70             my $msgid = add_queue($sender, \@recipients, $data)
71             or return(0);
72              
73             return(1, 250, "message queued $msgid");
74             }
75              
76             =head1 DESCRIPTION
77              
78             This class implement the ESMTP (RFC 2821) protocol.
79              
80             This class inherit from Net::Server::Mail::SMTP. Please see
81             L for documentation of common methods.
82              
83             =head1 METHODS
84              
85             ESMTP specific methods.
86              
87             =cut
88              
89             sub init {
90 7     7 0 26 my ( $self, @args ) = @_;
91 7         61 my $rv = $self->SUPER::init(@args);
92 7 50       21 return $rv unless $rv eq $self;
93              
94 7         21 $self->def_verb( EHLO => 'ehlo' );
95              
96 7         21 $self->{extend_mode} = 0;
97              
98 7         22 return $self;
99             }
100              
101             sub get_protoname {
102 7     7 0 30 return 'ESMTP';
103             }
104              
105             sub get_extensions {
106 9     9 0 17 my ($self) = @_;
107 9 50       16 return ( @{ $self->{extensions} || [] } );
  9         38  
108             }
109              
110             =pod
111              
112             =head2 register
113              
114             Activate an ESMTP extension. This method takes a module's name as
115             argument. This module must implement certain methods. See
116             L for more details.
117              
118             =cut
119              
120             sub register {
121 7     7 1 3602 my ( $self, $class ) = @_;
122              
123             # try to import class
124 7 50       711 eval "require $class" or croak("can't register module `$class'");
125              
126             # test mandatory methods
127 7         38 foreach my $method (qw(new verb keyword parameter option reply)) {
128 42 50       252 confess(
129             "Extension class `$class' doesn't implement mandatory method `$method'"
130             ) unless ( $class->can($method) );
131             }
132              
133 7 50       43 my $extend = $class->new($self) or return;
134 7         70 foreach my $verb_def ( $extend->verb ) {
135 7 50       20 $self->def_verb(@$verb_def) or return;
136             }
137              
138 7         28 foreach my $option_def ( $extend->option ) {
139 0         0 $self->sub_option(@$option_def);
140             }
141              
142 7         23 foreach my $reply_def ( $extend->reply ) {
143 0         0 $self->sub_reply(@$reply_def);
144             }
145              
146 7         12 push( @{ $self->{extensions} }, $extend );
  7         20  
147 7         13 return 1;
148             }
149              
150             sub sub_option {
151 0     0 0 0 my ( $self, $verb, $option_key, $code ) = @_;
152 0 0 0     0 confess("can't subscribe to option for verb `$verb'")
153             unless ( $verb eq 'MAIL' or $verb eq 'RCPT' );
154             confess("allready subscribed `$option_key'")
155 0 0       0 if ( exists $self->{xoption}->{$verb}->{$option_key} );
156 0         0 $self->{xoption}->{$verb}->{$option_key} = $code;
157             }
158              
159             sub sub_reply {
160 0     0 0 0 my ( $self, $verb, $code ) = @_;
161 0 0       0 confess("trying to subscribe to an unsupported verb `$verb'")
162             unless ( grep( $verb eq $_, $self->list_verb ) );
163 0         0 push( @{ $self->{xreply}->{$verb} }, $code );
  0         0  
164             }
165              
166             sub extend_mode {
167 9     9 0 20 my ( $self, $mode ) = @_;
168 9         16 $self->{extend_mode} = $mode;
169 9         11 for my $extend ( @{ $self->{extensions} } ) {
  9         24  
170 9 50       40 if ( $extend->can('extend_mode') ) {
171 0         0 $extend->extend_mode($mode);
172             }
173             }
174             }
175              
176             =pod
177              
178             =head1 EVENTS
179              
180             Descriptions of callback who's can be used with set_callback
181             method. All handle takes the Net::Server::Mail::ESMTP object as first
182             argument and specific callback's arguments.
183              
184             =head2 EHLO
185              
186             Takes the hostname given as argument. Engage the reverse path step on
187             success. RFC 2821 requires that EHLO command return the list of
188             supported extension. Default success reply implement this, so it is
189             deprecated to override this reply.
190              
191             You can rebuild extension list with get_extensions() method.
192              
193             Example:
194              
195             my @extends;
196             foreach my $extend ($esmtp->get_extensions())
197             {
198             push(@extends, join(' ', $extend->keyword(), $extend->parameter()));
199             }
200             my $extends_string = join("\n", @extends);
201              
202             =cut
203              
204             sub ehlo {
205 9     9 0 21 my ( $self, $hostname ) = @_;
206              
207 9 50 33     44 unless ( defined $hostname && length $hostname ) {
208 0         0 $self->reply( 501, 'Syntax error in parameters or arguments' );
209 0         0 return;
210             }
211              
212 9         42 my $response = $self->get_hostname . ' Service ready';
213              
214 9         28 my @extends;
215 9         23 foreach my $extend ( $self->get_extensions ) {
216 9         32 push( @extends, join( ' ', $extend->keyword, $extend->parameter ) );
217             }
218              
219 9         28 $self->extend_mode(1);
220             $self->make_event(
221             name => 'EHLO',
222             arguments => [ $hostname, \@extends ],
223             on_success => sub {
224              
225             # according to the RFC, EHLO ensures "that both the SMTP client
226             # and the SMTP server are in the initial state"
227 9     9   30 $self->step_reverse_path(1);
228 9         20 $self->step_forward_path(0);
229 9         28 $self->step_maildata_path(0);
230             },
231 9         101 success_reply => [ 250, [ $response, @extends ] ],
232             );
233              
234 9         53 return;
235             }
236              
237             sub helo {
238 0     0 0 0 my ( $self, $hostname ) = @_;
239 0         0 $self->{extend_mode} = 0;
240 0         0 $self->SUPER::helo($hostname);
241             }
242              
243             sub handle_options {
244 6     6 0 22 my ( $self, $verb, $address, @options ) = @_;
245              
246 6 50 33     18 if ( @options && !$self->{extend_mode} ) {
247 0         0 $self->reply( 555, "Unsupported option: $options[0]" );
248 0         0 return 0;
249             }
250              
251 6         20 for ( my $i = $#options ; $i >= 0 ; $i-- ) {
252 0         0 my ( $key, $value ) = split( /=/, $options[$i], 2 );
253 0         0 my $handler = $self->{xoption}->{$verb}->{$key};
254 0 0       0 if ( defined $handler ) {
255 3     3   27 no strict "refs";
  3         6  
  3         529  
256 0         0 &$handler( $self, $verb, $address, $key, $value );
257             }
258             else {
259 0         0 $self->reply( 555, "Unsupported option: $key" );
260 0         0 return 0;
261             }
262             }
263              
264 6         17 return 1;
265             }
266              
267             sub handle_reply {
268 31     31 0 70 my ( $self, $verb, $success, $code, $msg ) = @_;
269              
270 31 50 66     128 if ( $self->{extend_mode} && exists $self->{xreply}->{$verb} ) {
271 0         0 foreach my $handler ( @{ $self->{xreply}->{$verb} } ) {
  0         0  
272 0         0 ( $code, $msg ) = &$handler( $self, $verb, $success, $code, $msg );
273             }
274             }
275              
276 31         74 $self->reply( $code, $msg );
277             }
278              
279             =pod
280              
281             =head1 SEE ALSO
282              
283             Please, see L, L
284             and L.
285              
286             =head1 AUTHOR
287              
288             Olivier Poitrey Ers@rhapsodyk.netE
289              
290             =head1 AVAILABILITY
291              
292             Available on CPAN.
293              
294             anonymous Git repository:
295              
296             git clone git://github.com/rs/net-server-mail.git
297              
298             Git repository on the web:
299              
300             L
301              
302             =head1 BUGS
303              
304             Please use CPAN system to report a bug (http://rt.cpan.org/).
305              
306             =head1 LICENCE
307              
308             This library is free software; you can redistribute it and/or modify
309             it under the terms of the GNU Lesser General Public License as
310             published by the Free Software Foundation; either version 2.1 of the
311             License, or (at your option) any later version.
312              
313             This library is distributed in the hope that it will be useful, but
314             WITHOUT ANY WARRANTY; without even the implied warranty of
315             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
316             Lesser General Public License for more details.
317              
318             You should have received a copy of the GNU Lesser General Public
319             License along with this library; if not, write to the Free Software
320             Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
321             USA
322              
323             =head1 COPYRIGHT
324              
325             Copyright (C) 2002 - Olivier Poitrey, 2007 - Xavier Guimard
326              
327             =cut
328              
329             1;