File Coverage

blib/lib/Test/Mock/Net/Server/Mail.pm
Criterion Covered Total %
statement 33 82 40.2
branch 5 26 19.2
condition 0 3 0.0
subroutine 10 21 47.6
pod 8 10 80.0
total 56 142 39.4


line stmt bran cond sub pod time code
1             package Test::Mock::Net::Server::Mail;
2              
3 2     2   3450 use Moose;
  2         928669  
  2         12  
4              
5             # ABSTRACT: mock SMTP server for use in tests
6             our $VERSION = '1.00'; # VERSION
7              
8 2     2   15804 use Net::Server::Mail::ESMTP;
  2         33143  
  2         63  
9 2     2   855 use IO::Socket::INET;
  2         14805  
  2         26  
10 2     2   3210 use Test::Exception;
  2         6820  
  2         10  
11              
12              
13             has 'bind_address' => ( is => 'ro', isa => 'Str', default => '127.0.0.1' );
14             has 'port' => ( is => 'rw', isa => 'Maybe[Int]' );
15             has 'pid' => ( is => 'rw', isa => 'Maybe[Int]' );
16              
17             has 'start_port' => ( is => 'rw', isa => 'Int', lazy => 1,
18             default => sub {
19             return 50000 + int(rand(10000));
20             },
21             );
22              
23             has 'socket' => ( is => 'ro', isa => 'IO::Socket::INET', lazy => 1,
24             default => sub {
25             my $self = shift;
26             my $cur_port = $self->start_port;
27             my $socket;
28             for( my $i = 0 ; $i < 100 ; $i++ ) {
29             $socket = IO::Socket::INET->new(
30             Listen => 1,
31             LocalPort => $cur_port,
32             LocalAddr => $self->bind_address,
33             );
34             if( defined $socket ) {
35             last;
36             }
37             $cur_port += 10;
38             }
39             if( ! defined $socket ) {
40             die("giving up to find free port to bind: $@");
41             }
42             $self->port( $cur_port );
43             return $socket;
44             },
45             );
46              
47             has 'support_8bitmime' => ( is => 'ro', isa => 'Bool', default => 1 );
48             has 'support_pipelining' => ( is => 'ro', isa => 'Bool', default => 1 );
49             has 'support_starttls' => ( is => 'ro', isa => 'Bool', default => 1 );
50              
51             sub process_connection {
52 0     0 0 0 my ( $self, $conn ) = @_;
53 0         0 my $smtp = Net::Server::Mail::ESMTP->new(
54             socket => $conn,
55             );
56              
57 0 0       0 $self->support_8bitmime
58             && $smtp->register('Net::Server::Mail::ESMTP::8BITMIME');
59 0 0       0 $self->support_pipelining
60             && $smtp->register('Net::Server::Mail::ESMTP::PIPELINING');
61 0 0       0 $self->support_starttls
62             && $smtp->register('Net::Server::Mail::ESMTP::STARTTLS');
63              
64             $smtp->set_callback(EHLO => sub {
65 0     0   0 my ( $session, $name ) = @_;
66 0         0 return $self->process_ehlo( $session, $name );
67 0         0 } );
68             $smtp->set_callback(HELO => sub {
69 0     0   0 my ( $session, $name ) = @_;
70 0         0 return $self->process_ehlo( $session, $name );
71 0         0 } );
72             $smtp->set_callback(MAIL => sub {
73 0     0   0 my ( $session, $addr ) = @_;
74 0         0 return $self->process_mail( $session, $addr );
75 0         0 } );
76             $smtp->set_callback(RCPT => sub {
77 0     0   0 my ( $session, $addr ) = @_;
78 0         0 return $self->process_rcpt( $session, $addr );
79 0         0 } );
80             $smtp->set_callback(DATA => sub {
81 0     0   0 my ( $session, $data ) = @_;
82 0         0 return $self->process_data( $session, $data );
83 0         0 } );
84              
85 0         0 $self->before_process( $smtp );
86 0         0 $smtp->process();
87 0         0 $conn->close();
88            
89 0         0 return;
90             };
91              
92              
93             sub before_process {
94 0     0 1 0 my ( $self, $smtp ) = @_;
95 0         0 return;
96             }
97              
98              
99             sub process_ehlo {
100 0     0 1 0 my ( $self, $session, $name ) = @_;
101 0 0       0 if( $name =~ /^bad/) {
102 0         0 return(1, 501, "$name is a bad helo name");
103             }
104 0         0 return 1;
105             }
106              
107             sub process_mail_rcpt {
108 0     0 0 0 my ( $self, $session, $rcpt ) = @_;
109 0         0 my ( $user, $domain ) = split('@', $rcpt, 2);
110 0 0       0 if( ! defined $user ) {
111 0         0 return(0, 513, 'Syntax error.');
112             }
113 0 0       0 if( $user =~ /^bad/ ) {
114 0         0 return(0, 552, "$rcpt Recipient address rejected: bad user");
115             }
116 0 0 0     0 if( defined $domain && $domain =~ /^bad/ ) {
117 0         0 return(0, 552, "$rcpt Recipient address rejected: bad domain");
118             }
119 0         0 return(1);
120             }
121             *process_mail = \&process_mail_rcpt;
122             *process_rcpt = \&process_mail_rcpt;
123              
124             sub process_data {
125 0     0 1 0 my ( $self, $session, $data ) = @_;
126 0 0       0 if( $$data =~ /bad mail content/msi ) {
127 0         0 return(0, 554, 'Message rejected: bad mail content');
128             }
129 0         0 return 1;
130             }
131              
132              
133             sub main_loop {
134 0     0 1 0 my $self = shift;
135              
136 0         0 while( my $conn = $self->socket->accept ) {
137 0         0 $self->process_connection( $conn );
138             }
139              
140 0         0 return;
141             }
142              
143              
144             sub start {
145 1     1 1 3 my $self = shift;
146 1 50       43 if( defined $self->pid ) {
147 0         0 die('already running with pid '.$self->pid);
148             }
149              
150             # make sure socket is initialized
151             # we need to know the port number in parent
152 1         39 $self->socket;
153              
154 1         2209 my $pid = fork;
155 1 50       65 if( $pid == 0 ) {
156 0         0 $self->main_loop;
157             } else {
158 1         226 $self->pid( $pid );
159             }
160              
161 1         83 return;
162             }
163              
164              
165             sub start_ok {
166 1     1 1 2880 my ( $self, $text ) = @_;
167             lives_ok {
168 1     1   31 $self->start;
169 1 50       14 } defined $text ? $text : 'start smtp mock server';
170 1         944 return;
171             }
172              
173              
174             sub stop {
175 1     1 1 3 my $self = shift;
176 1         63 my $pid = $self->pid;
177 1 50       7 if( defined $pid ) {
178 1         43 kill( 'QUIT', $pid );
179 1         4226 waitpid( $pid, 0 );
180             }
181              
182 1         24 return;
183             }
184              
185              
186             sub stop_ok {
187 1     1 1 100907 my ( $self, $text ) = @_;
188             lives_ok {
189 1     1   38 $self->stop;
190 1 50       24 } defined $text ? $text : 'stop smtp mock server';
191 1         974 return;
192             }
193              
194             1;
195              
196             __END__
197              
198             =pod
199              
200             =encoding UTF-8
201              
202             =head1 NAME
203              
204             Test::Mock::Net::Server::Mail - mock SMTP server for use in tests
205              
206             =head1 VERSION
207              
208             version 1.00
209              
210             =head1 SYNOPSIS
211              
212             In a test:
213              
214             use Test::More;
215             use Test::Mock::Net::Server::Mail;
216              
217             use_ok(Net::YourClient);
218              
219             my $s = Test::Mock::Net::Server::Mail->new;
220             $s->start_ok;
221              
222             my $c = Net::YourClient->new(
223             host => $s->bind_address,
224             port => $s->port,
225             );
226             # check...
227              
228             $s->stop_ok;
229              
230             =head1 DESCRIPTION
231              
232             Test::Mock::Net::Server::Mail is a mock SMTP server based on Net::Server::Mail.
233             If could be used in unit tests to check SMTP clients.
234              
235             It will accept all MAIL FROM and RCPT TO commands except they start
236             with 'bad' in the user or domain part.
237             And it will accept all mail except mail containing the string 'bad mail content'.
238              
239             If a different behaviour is need a subclass could be used to overwrite process_<cmd> methods.
240              
241             =head1 ATTRIBUTES
242              
243             =head2 bind_address (default: "127.0.0.1")
244              
245             The address to bind to.
246              
247             =head2 start_port (default: random port > 50000)
248              
249             First port number to try when searching for a free port.
250              
251             =head2 support_8bitmime (default: 1)
252              
253             Load 8BITMIME extension?
254              
255             =head2 support_pipelining (default: 1)
256              
257             Load PIPELINING extension?
258              
259             =head2 support_starttls (default: 1)
260              
261             Load STARTTLS extension?
262              
263             =head1 METHODS
264              
265             =head2 port
266              
267             Retrieve the port of the running mock server.
268              
269             =head2 pid
270              
271             Retrieve the process id of the running mock server.
272              
273             =head2 before_process( $smtp )
274              
275             Overwrite this method in a subclass if you need to register additional
276             command callbacks via Net::Server::Mail.
277              
278             Net::Server::Mail object is passed via $smtp.
279              
280             =head2 process_ehlo( $session, $name )
281              
282             =head2 process_mail( $session, $addr )
283              
284             =head2 process_rcpt( $session, $addr )
285              
286             =head2 process_data( $session, \$data )
287              
288             Overwrite on of this methods in a subclass if you need to
289             implement your own handler.
290              
291             =head2 main_loop
292              
293             Start main loop.
294              
295             Will accept connections forever and will never return.
296              
297             =head2 start
298              
299             Start mock server in background (fork).
300              
301             After the server is started $obj->port and $obj->pid will be set.
302              
303             =head2 start_ok( $msg )
304              
305             Start the mock server and return a test result.
306              
307             =head2 stop
308              
309             Stop mock smtp server.
310              
311             =head2 stop_ok( $msg )
312              
313             Stop the mock server and return a test result.
314              
315             =head1 AUTHOR
316              
317             Markus Benning <ich@markusbenning.de>
318              
319             =head1 COPYRIGHT AND LICENSE
320              
321             This software is copyright (c) 2015 by Markus Benning <ich@markusbenning.de>.
322              
323             This is free software; you can redistribute it and/or modify it under
324             the same terms as the Perl 5 programming language system itself.
325              
326             =cut