File Coverage

blib/lib/Test/Mock/Net/Server/Mail.pm
Criterion Covered Total %
statement 72 143 50.3
branch 13 50 26.0
condition 0 3 0.0
subroutine 19 30 63.3
pod 10 12 83.3
total 114 238 47.9


line stmt bran cond sub pod time code
1             package Test::Mock::Net::Server::Mail;
2              
3 2     2   3112 use Moose;
  2         938541  
  2         13  
4              
5             # ABSTRACT: mock SMTP server for use in tests
6             our $VERSION = '1.01'; # VERSION
7              
8              
9 2     2   17141 use Net::Server::Mail::ESMTP;
  2         30781  
  2         64  
10 2     2   497 use IO::Socket::INET;
  2         12182  
  2         24  
11 2     2   2265 use IO::File;
  2         3986  
  2         258  
12 2     2   13 use Test::More;
  2         5  
  2         25  
13 2     2   1611 use Test::Exception;
  2         6402  
  2         15  
14 2     2   1785 use JSON;
  2         16554  
  2         16  
15 2     2   1650 use File::Temp;
  2         18151  
  2         3606  
16              
17              
18             has 'bind_address' => ( is => 'ro', isa => 'Str', default => '127.0.0.1' );
19             has 'port' => ( is => 'rw', isa => 'Maybe[Int]' );
20             has 'pid' => ( is => 'rw', isa => 'Maybe[Int]' );
21              
22             has 'start_port' => ( is => 'rw', isa => 'Int', lazy => 1,
23             default => sub {
24             return 50000 + int(rand(10000));
25             },
26             );
27              
28             has 'socket' => ( is => 'ro', isa => 'IO::Socket::INET', lazy => 1,
29             default => sub {
30             my $self = shift;
31             my $cur_port = $self->start_port;
32             my $socket;
33             for( my $i = 0 ; $i < 100 ; $i++ ) {
34             $socket = IO::Socket::INET->new(
35             Listen => 1,
36             LocalPort => $cur_port,
37             LocalAddr => $self->bind_address,
38             );
39             if( defined $socket ) {
40             last;
41             }
42             $cur_port += 10;
43             }
44             if( ! defined $socket ) {
45             die("giving up to find free port to bind: $@");
46             }
47             $self->port( $cur_port );
48             return $socket;
49             },
50             );
51              
52             has 'support_8bitmime' => ( is => 'ro', isa => 'Bool', default => 1 );
53             has 'support_pipelining' => ( is => 'ro', isa => 'Bool', default => 1 );
54             has 'support_starttls' => ( is => 'ro', isa => 'Bool', default => 1 );
55              
56             has 'mock_verbs' => (
57             is => 'ro',
58             isa => 'ArrayRef[Str]',
59             default => sub { [ qw(
60             EHLO
61             HELO
62             MAIL
63             RCPT
64             DATA
65             QUIT
66             ) ] },
67             );
68              
69             has 'logging' => (
70             is => 'ro',
71             isa => 'Bool',
72             default => 1,
73             );
74              
75             sub BUILD {
76 1     1 0 2679 my $self = shift;
77 1 50       37 if( $self->logging ) {
78 1         5 $self->_init_log;
79             }
80 1         5 return;
81             }
82              
83             has '_log_fh' => (
84             is => 'rw',
85             isa => 'IO::Handle',
86             );
87              
88             sub _init_log {
89 1     1   3 my $self = shift;
90 1         7 $self->_log_fh(File::Temp->new);
91 1         4 return;
92             }
93              
94             sub _reopen_log {
95 0     0   0 my $self = shift;
96 0 0       0 my $fh = IO::File->new($self->_log_fh->filename, O_WRONLY|O_APPEND)
97             or die('cannot reopen temporary logfile: '.$!);
98 0         0 $self->_log_fh($fh);
99 0         0 return;
100             }
101              
102             sub _write_log {
103 0     0   0 my $self = shift;
104 0         0 $self->_log_fh->print(join('',@_));
105 0         0 $self->_log_fh->flush;
106 0         0 return;
107             }
108              
109              
110             sub next_log {
111 9     9 1 20 my $self = shift;
112 9         393 my $line = $self->_log_fh->getline;
113 9 50       390 if($line) {
114 9         22 chomp $line;
115 9         102 return decode_json $line;
116             }
117 0         0 return;
118             }
119              
120              
121             sub next_log_ok {
122 9     9 1 105090 my ($self, $verb, $params, $text) = @_;
123 9         34 my $log = $self->next_log;
124 9 50       32 if(!defined $log) {
125 0         0 fail($text);
126 0         0 diag('no more logs to read!');
127 0         0 return;
128             }
129              
130 9 50       29 if($log->{'verb'} ne $verb) {
131 0         0 fail($text);
132 0         0 diag('expected verb '.$verb.' but got '.$log->{'verb'});
133 0         0 return;
134             }
135              
136 9 100       19 if(defined $params) {
137 8 100       23 if(ref($params) eq 'Regexp') {
138 1         14 like($log->{'params'}, $params, $text);
139 1         319 return;
140             }
141 7         35 cmp_ok($log->{'params'}, 'eq', $params, $text);
142 7         2325 return;
143             }
144              
145 1         24 pass($text);
146 1         301 return;
147             }
148              
149             sub _process_callback {
150 0     0   0 my ($self, $verb, $session, $params) = @_;
151              
152 0 0       0 if($self->logging) {
153 0         0 $self->_log_callback($verb, $params);
154             }
155              
156 0         0 my $method = "process_".lc($verb);
157 0 0       0 if($self->can($method)) {
158 0         0 return $self->$method($session, $params);
159             }
160 0         0 return;
161             }
162              
163             sub _log_callback {
164 0     0   0 my ($self, $verb, $params) = @_;
165 0         0 my $params_out;
166 0 0       0 if(ref($params) eq '') {
    0          
167 0         0 $params_out = $params;
168             } elsif(ref($params) eq 'SCALAR') {
169 0         0 $params_out = $$params;
170             } else {
171 0         0 $params_out = $verb.' passed unprintable '.ref($params);
172             }
173 0 0       0 $self->_write_log(
174             encode_json( {
175             verb => $verb,
176             defined $params_out ? (params => $params_out) : (),
177             } )."\n"
178             );
179 0         0 return;
180             }
181              
182             sub _process_connection {
183 0     0   0 my ( $self, $conn ) = @_;
184 0         0 my $smtp = Net::Server::Mail::ESMTP->new(
185             socket => $conn,
186             );
187              
188 0 0       0 $self->support_8bitmime
189             && $smtp->register('Net::Server::Mail::ESMTP::8BITMIME');
190 0 0       0 $self->support_pipelining
191             && $smtp->register('Net::Server::Mail::ESMTP::PIPELINING');
192 0 0       0 $self->support_starttls
193             && $smtp->register('Net::Server::Mail::ESMTP::STARTTLS');
194              
195 0         0 foreach my $verb (@{$self->mock_verbs}) {
  0         0  
196             $smtp->set_callback($verb => sub {
197 0     0   0 my ( $session, $params ) = @_;
198 0         0 return $self->_process_callback( $verb, $session, $params );
199 0         0 } );
200             }
201              
202 0         0 $self->before_process( $smtp );
203 0         0 $smtp->process();
204 0         0 $conn->close();
205            
206 0         0 return;
207             };
208              
209              
210              
211             sub before_process {
212 0     0 1 0 my ( $self, $smtp ) = @_;
213 0         0 return;
214             }
215              
216              
217             sub process_ehlo {
218 0     0 1 0 my ( $self, $session, $name ) = @_;
219 0 0       0 if( $name =~ /^bad/) {
220 0         0 return(1, 501, "$name is a bad helo name");
221             }
222 0         0 return 1;
223             }
224              
225             sub process_mail_rcpt {
226 0     0 0 0 my ( $self, $session, $rcpt ) = @_;
227 0         0 my ( $user, $domain ) = split('@', $rcpt, 2);
228 0 0       0 if( ! defined $user ) {
229 0         0 return(0, 513, 'Syntax error.');
230             }
231 0 0       0 if( $user =~ /^bad/ ) {
232 0         0 return(0, 552, "$rcpt Recipient address rejected: bad user");
233             }
234 0 0 0     0 if( defined $domain && $domain =~ /^bad/ ) {
235 0         0 return(0, 552, "$rcpt Recipient address rejected: bad domain");
236             }
237 0         0 return(1);
238             }
239             *process_mail = \&process_mail_rcpt;
240             *process_rcpt = \&process_mail_rcpt;
241              
242             sub process_data {
243 0     0 1 0 my ( $self, $session, $data ) = @_;
244 0 0       0 if( $$data =~ /bad mail content/msi ) {
245 0         0 return(0, 554, 'Message rejected: bad mail content');
246             }
247 0         0 return 1;
248             }
249              
250              
251             sub main_loop {
252 0     0 1 0 my $self = shift;
253              
254 0         0 $self->_reopen_log;
255              
256 0         0 while( my $conn = $self->socket->accept ) {
257 0         0 $self->_process_connection( $conn );
258             }
259              
260 0         0 exit 1;
261 0         0 return;
262             }
263              
264              
265             sub start {
266 1     1 1 3 my $self = shift;
267 1 50       51 if( defined $self->pid ) {
268 0         0 die('already running with pid '.$self->pid);
269             }
270              
271             # make sure socket is initialized
272             # we need to know the port number in parent
273 1         35 $self->socket;
274              
275 1         1774 my $pid = fork;
276 1 50       83 if( $pid == 0 ) {
277 0         0 $self->main_loop;
278             } else {
279 1         262 $self->pid( $pid );
280             }
281              
282 1         89 return;
283             }
284              
285              
286             sub start_ok {
287 1     1 1 462 my ( $self, $text ) = @_;
288             lives_ok {
289 1     1   45 $self->start;
290 1 50       13 } defined $text ? $text : 'start smtp mock server';
291 1         1394 return;
292             }
293              
294              
295             sub stop {
296 2     2 1 9 my $self = shift;
297 2         122 my $pid = $self->pid;
298 2 50       10 if( defined $pid ) {
299 2         259 kill( 'QUIT', $pid );
300 2         66559 waitpid( $pid, 0 );
301             }
302              
303 2         45 return;
304             }
305              
306             sub DESTROY {
307 1     1   3 my $self = shift;
308             # try to stop server when going out of scope
309 1         6 $self->stop;
310 1         55 return;
311             }
312              
313              
314             sub stop_ok {
315 1     1 1 9 my ( $self, $text ) = @_;
316             lives_ok {
317 1     1   129 $self->stop;
318 1 50       30 } defined $text ? $text : 'stop smtp mock server';
319 1         758 return;
320             }
321              
322             1;
323              
324             __END__
325              
326             =pod
327              
328             =encoding UTF-8
329              
330             =head1 NAME
331              
332             Test::Mock::Net::Server::Mail - mock SMTP server for use in tests
333              
334             =head1 VERSION
335              
336             version 1.01
337              
338             =head1 SYNOPSIS
339              
340             In a test:
341              
342             use Test::More;
343             use Test::Mock::Net::Server::Mail;
344              
345             use_ok(Net::YourClient);
346              
347             my $s = Test::Mock::Net::Server::Mail->new;
348             $s->start_ok;
349              
350             my $c = Net::YourClient->new(
351             host => $s->bind_address,
352             port => $s->port,
353             );
354             # check...
355              
356             $s->stop_ok;
357              
358             =head1 DESCRIPTION
359              
360             Test::Mock::Net::Server::Mail is a mock SMTP server based on Net::Server::Mail.
361             If could be used in unit tests to check SMTP clients.
362              
363             It will accept all MAIL FROM and RCPT TO commands except they start
364             with 'bad' in the user or domain part.
365             And it will accept all mail except mail containing the string 'bad mail content'.
366              
367             If a different behaviour is need a subclass could be used to overwrite process_<verb> methods.
368              
369             =head1 LOGGING
370              
371             If the logging option is enabled (by default) the mock server will log
372             received commands in a temporary log file. The content of this log file
373             can be inspected with the methods next_log() or tested with next_log_ok().
374              
375             # setup server($s) and client($c)...
376              
377             $c->ehlo('localhost');
378             $s->next_log;
379             # {"verb" => "EHLO","params" => "localhost"}
380            
381             $c->mail_from('user@domain.tld');
382             $s->next_log_ok('MAIL', 'user@domain.tld, 'server received MAIL cmd');
383            
384             $c->rcpt_to('targetuser@targetdomain.tld');
385             $s->next_log_ok('RCPT', qr/target/, 'server received RCPT cmd');
386              
387             # shutdown...
388              
389             =head1 ATTRIBUTES
390              
391             =head2 bind_address (default: "127.0.0.1")
392              
393             The address to bind to.
394              
395             =head2 start_port (default: random port > 50000)
396              
397             First port number to try when searching for a free port.
398              
399             =head2 support_8bitmime (default: 1)
400              
401             Load 8BITMIME extension?
402              
403             =head2 support_pipelining (default: 1)
404              
405             Load PIPELINING extension?
406              
407             =head2 support_starttls (default: 1)
408              
409             Load STARTTLS extension?
410              
411             =head2 logging (default: 1)
412              
413             Log commands received by the server.
414              
415             =head2 mock_verbs (ArrayRef)
416              
417             Which verbs the server should add mockup to.
418              
419             By default:
420              
421             qw(
422             EHLO
423             HELO
424             MAIL
425             RCPT
426             DATA
427             QUIT
428             )
429              
430             =head1 METHODS
431              
432             =head2 port
433              
434             Retrieve the port of the running mock server.
435              
436             =head2 pid
437              
438             Retrieve the process id of the running mock server.
439              
440             =head2 next_log
441              
442             Reads one log from the servers log and returns a hashref.
443              
444             Example:
445              
446             {"verb"=>"EHLO","params"=>"localhost"}
447              
448             =head2 next_log_ok($verb, $expect, $text)
449              
450             Will read a log using next_log() and test it.
451              
452             The logs 'verb' must exactly match $verb.
453              
454             The logs 'params' are checked against $expected. It must be a
455             string,regexp or undef.
456              
457             Examples:
458              
459             $s->next_log_ok('EHLO', 'localhost', 'server received EHLO command');
460             $s->next_log_ok('MAIL', 'gooduser@gooddomain', 'server received MAIL command');
461             $s->next_log_ok('RCPT', 'gooduser@gooddomain', 'server received RCPT command');
462             $s->next_log_ok('DATA', qr/bad mail content/, 'server received DATA command');
463             $s->next_log_ok('QUIT', undef, 'server received QUIT command');
464              
465             =head2 before_process( $smtp )
466              
467             Overwrite this method in a subclass if you need to register additional
468             command callbacks via Net::Server::Mail.
469              
470             Net::Server::Mail object is passed via $smtp.
471              
472             =head2 process_ehlo( $session, $name )
473              
474             Will refuse EHLO names containing the string 'bad'
475             otherwise will accept any EHLO.
476              
477             =head2 process_mail( $session, $addr )
478              
479             Will accept all senders except senders where
480             user or domain starts with 'bad'.
481              
482             =head2 process_rcpt( $session, $addr )
483              
484             Will accept all reciepients except recipients where
485             user or domain starts with 'bad'.
486              
487             =head2 process_data( $session, \$data )
488              
489             Overwrite on of this methods in a subclass if you need to
490             implement your own handler.
491              
492             =head2 main_loop
493              
494             Start main loop.
495              
496             Will accept connections forever and will never return.
497              
498             =head2 start
499              
500             Start mock server in background (fork).
501              
502             After the server is started $obj->port and $obj->pid will be set.
503              
504             =head2 start_ok( $msg )
505              
506             Start the mock server and return a test result.
507              
508             =head2 stop
509              
510             Stop mock smtp server.
511              
512             =head2 stop_ok( $msg )
513              
514             Stop the mock server and return a test result.
515              
516             =head1 AUTHOR
517              
518             Markus Benning <ich@markusbenning.de>
519              
520             =head1 COPYRIGHT AND LICENSE
521              
522             This software is copyright (c) 2015 by Markus Benning <ich@markusbenning.de>.
523              
524             This is free software; you can redistribute it and/or modify it under
525             the same terms as the Perl 5 programming language system itself.
526              
527             =cut