File Coverage

blib/lib/Net/Server/Mail/ESMTP/STARTTLS.pm
Criterion Covered Total %
statement 35 39 89.7
branch 6 10 60.0
condition 5 12 41.6
subroutine 9 9 100.0
pod 0 3 0.0
total 55 73 75.3


line stmt bran cond sub pod time code
1             #
2             # Copyright 2013 Mytram . All rights reserved.
3             #
4             # This program is free software; you can redistribute it and/or
5             # modify it under the same terms as Perl itself.
6             #
7              
8             package Net::Server::Mail::ESMTP::STARTTLS;
9              
10 2     2   780 use 5.006;
  2         6  
11 2     2   8 use strict;
  2         4  
  2         64  
12 2     2   12 use warnings;
  2         2  
  2         58  
13              
14             # IO::Socket::SSL v1.831 fixed a readline() behavioural deviation in
15             # list context on nonblocking sockets, which caused Net::Server::Mail
16             # to fail to read commands correctly
17              
18 2     2   1286 use IO::Socket::SSL 1.831;
  2         100416  
  2         14  
19 2     2   974 use Net::Server::Mail::ESMTP::Extension;
  2         6  
  2         108  
20             our @ISA = qw(Net::Server::Mail::ESMTP::Extension);
21              
22             our $VERSION = 0.26;
23              
24             use constant {
25 2         636 REPLY_READY_TO_START => 220,
26             REPLY_SYNTAX_ERROR => 502,
27             REPLY_NOT_AVAILABLE => 454,
28 2     2   12 };
  2         2  
29              
30             # https://tools.ietf.org/html/rfc2487
31              
32             sub verb {
33 7     7 0 31 my $self = shift;
34 7         36 return ( [ 'STARTTLS' => \&starttls ] );
35             }
36              
37 9     9 0 41 sub keyword { 'STARTTLS' }
38              
39             # Return a non undef to signal the server to close the socket.
40             sub starttls {
41 6     6 0 14 my $server = shift;
42 6         10 my $args = shift;
43              
44 6 100       16 if ($args) {
45              
46             # No parameter verb
47 1         8 $server->reply( REPLY_SYNTAX_ERROR,
48             'Syntax error (no parameters allowed)' );
49 1         6 return;
50             }
51              
52             my $ssl_config = $server->{options}{ssl_config}
53 5 50       28 if exists $server->{options}{ssl_config};
54 5 50 33     54 if ( !$ssl_config || ref $ssl_config ne 'HASH' ) {
55 0         0 $server->reply( REPLY_NOT_AVAILABLE,
56             'TLS not available due to temporary reason' );
57 0         0 return;
58             }
59              
60 5         24 $server->reply( REPLY_READY_TO_START, 'Ready to start TLS' );
61              
62             my $ssl_socket = IO::Socket::SSL->start_SSL( $server->{options}{socket},
63 5         134 %$ssl_config, SSL_server => 1, );
64              
65             # Use SSL_startHandshake to control nonblocking behaviour
66             # See perldoc IO::Socket::SSL for more
67              
68 5 100 66     103114 if ( !$ssl_socket || !$ssl_socket->isa('IO::Socket::SSL') ) {
69 2         7 $server->reply( REPLY_NOT_AVAILABLE,
70             'TLS not available due to temporary reason ['
71             . IO::Socket::SSL::errstr()
72             . ']' );
73 2         19 return 0; # to single the server to close the socket
74             }
75              
76 3         18 my $ref = $server->{callback}->{STARTTLS};
77 3 0 33     13 if ( defined $ref && ref $ref eq 'ARRAY' && ref $ref->[0] eq 'CODE' ) {
      33        
78 0         0 my $code = $ref->[0];
79 0         0 &$code($server);
80             }
81              
82 3         14 return ();
83             }
84              
85             1;
86              
87             =head1 NAME
88              
89             Net::Server::Mail::ESMTP::STARTTLS - A module to support the STARTTLS command in Net::Server::Mail::ESMTP
90              
91             =head1 SYNOPSIS
92              
93             use strict;
94             use Net::Server::Mail::ESMTP;
95              
96             my @local_domains = qw(example.com example.org);
97             my $server = IO::Socket::INET->new( Listen => 1, LocalPort => 25 );
98              
99             my $conn;
100             while($conn = $server->accept)
101             {
102             my $esmtp = Net::Server::Mail::ESMTP->new(
103             socket => $conn,
104             SSL_config => {
105             SSL_cert_file => 'your_cert.pem',
106             SSL_key_file => 'your_key.key',
107             # Any other options taken by IO::Socket::SSL
108             }
109             );
110            
111             # activate some extensions
112             $esmtp->register('Net::Server::Mail::ESMTP::STARTTLS');
113            
114             # adding optional STARTTLS handler
115             $esmtp->set_callback(STARTTLS => \&tls_started);
116             $esmtp->process();
117             $conn->close();
118             }
119            
120             sub tls_started {
121             my ($session) = @_;
122              
123             # Now, allow authentication
124             $session->register('Net::Server::Mail::ESMTP::AUTH');
125             }
126              
127             =head1 DESCRIPTION
128              
129             This module conducts a TLS handshake with the client upon receiving
130             the STARTTLS command. It uses IO::Socket::SSL, requiring 1.831+, to
131             perform the handshake and secure traffic.
132              
133             An additional option, SSL_config, is passed to
134             Net::Server::Mail::ESMTP's constructor. It contains options for
135             IO::Socket::SSL's constructor. Please refer to IO::Socket::SSL's
136             perldoc for details.
137              
138             =head1 SEE ALSO
139              
140             Please, see L
141              
142             =head1 AUTHOR
143              
144             This module has been written by Xavier Guimard using libs
145             written by:
146              
147             =over
148              
149             =item Mytram
150              
151             =item Dan Moore C<< >>
152              
153             =back
154              
155             =head1 AVAILABILITY
156              
157             Available on CPAN.
158              
159             anonymous Git repository:
160              
161             git clone git://github.com/rs/net-server-mail.git
162              
163             Git repository on the web:
164              
165             L
166              
167             =head1 BUGS
168              
169             Please use CPAN system to report a bug (http://rt.cpan.org/).
170              
171             =head1 LICENSE AND COPYRIGHT
172              
173             =over
174              
175             =item Copyright (C) 2009 - Dan Moore
176              
177             =item Copyright (C) 2013 - Mytram
178              
179             =item Copyright (C) 2013 - Xavier Guimard
180              
181             =back
182              
183             This program is free software; you can redistribute it and/or modify it
184             under the terms of either: the GNU General Public License as published
185             by the Free Software Foundation; or the Artistic License.
186              
187             See http://dev.perl.org/licenses/ for more information.
188              
189             =cut