File Coverage

blib/lib/Net/SSLGlue/SMTP.pm
Criterion Covered Total %
statement 29 53 54.7
branch 1 12 8.3
condition 0 2 0.0
subroutine 9 9 100.0
pod n/a
total 39 76 51.3


line stmt bran cond sub pod time code
1 1     1   69925 use strict;
  1         1  
  1         25  
2 1     1   3 use warnings;
  1         2  
  1         38  
3              
4             package Net::SSLGlue::SMTP;
5 1     1   12 use IO::Socket::SSL 1.19;
  1         12  
  1         5  
6 1     1   130 use Net::SMTP;
  1         1  
  1         181  
7             our $VERSION = 1.001;
8              
9             my $DONT;
10             BEGIN {
11 1 50   1   6 if (defined &Net::SMTP::starttls) {
12 1         32 warn "using SSL support of Net::SMTP $Net::SMTP::VERSION instead of SSLGlue";
13 1         2 $DONT = 1;
14 1         3 goto DONE;
15             }
16              
17             ##############################################################################
18             # mix starttls method into Net::SMTP which on SSL handshake success
19             # upgrades the class to Net::SSLGlue::SMTP::_SSLified
20             ##############################################################################
21             *Net::SMTP::starttls = sub {
22 0         0 my $self = shift;
23 0 0       0 $self->_STARTTLS or return;
24 0         0 my $host = $self->host;
25             # for name verification strip port from domain:port, ipv4:port, [ipv6]:port
26 0         0 $host =~s{(?
27              
28 0 0       0 Net::SSLGlue::SMTP::_SSLified->start_SSL( $self,
29             SSL_verify_mode => 1,
30             SSL_verifycn_scheme => 'smtp',
31             SSL_verifycn_name => $host,
32             @_
33             ) or return;
34              
35             # another hello after starttls to read new ESMTP capabilities
36 0         0 return $self->hello(${*$self}{net_smtp_hello_domain});
  0         0  
37 0         0 };
38              
39             *Net::SMTP::_STARTTLS = sub {
40 0         0 shift->command("STARTTLS")->response() == Net::SMTP::CMD_OK
41 0         0 };
42              
43 1     1   4 no warnings 'redefine';
  1         1  
  1         145  
44 0         0 my $old_new = \&Net::SMTP::new;
45             *Net::SMTP::new = sub {
46 0         0 my $class = shift;
47 0 0       0 my %arg = @_ % 2 == 0 ? @_ : ( Host => shift,@_ );
48 0 0       0 if ( delete $arg{SSL} ) {
49 0   0     0 $arg{Port} ||= 465;
50 0         0 return Net::SSLGlue::SMTP::_SSLified->new(%arg);
51             } else {
52 0         0 return $old_new->($class,%arg);
53             }
54 0         0 };
55              
56 0         0 my $old_hello = \&Net::SMTP::hello;
57             *Net::SMTP::hello = sub {
58 0         0 my ($self,$domain) = @_;
59 0 0       0 ${*$self}{net_smtp_hello_domain} = $domain if $domain;
  0         0  
60 0         0 goto &$old_hello;
61 0         0 };
62              
63 1         134 DONE:
64             1;
65             }
66              
67             ##############################################################################
68             # Socket class derived from IO::Socket::SSL
69             # strict certificate verification per default
70             ##############################################################################
71             our %SSLopts;
72             {
73             package Net::SSLGlue::SMTP::_SSL_Socket;
74             goto DONE if $DONT;
75             our @ISA = 'IO::Socket::SSL';
76             *configure_SSL = sub {
77             my ($self,$arg_hash) = @_;
78              
79             # set per default strict certificate verification
80             $arg_hash->{SSL_verify_mode} = 1
81             if ! exists $arg_hash->{SSL_verify_mode};
82             $arg_hash->{SSL_verifycn_scheme} = 'smtp'
83             if ! exists $arg_hash->{SSL_verifycn_scheme};
84             $arg_hash->{SSL_verifycn_name} = $self->host
85             if ! exists $arg_hash->{SSL_verifycn_name};
86              
87             # force keys from %SSLopts
88             while ( my ($k,$v) = each %SSLopts ) {
89             $arg_hash->{$k} = $v;
90             }
91             return $self->SUPER::configure_SSL($arg_hash)
92             };
93              
94             DONE:
95             1;
96             }
97              
98              
99             ##############################################################################
100             # Net::SMTP derived from Net::SSLGlue::SMTP::_SSL_Socket instead of IO::Socket::INET
101             # this talks SSL to the peer
102             ##############################################################################
103             {
104             package Net::SSLGlue::SMTP::_SSLified;
105 1     1   4 use Carp 'croak';
  1         1  
  1         53  
106             goto DONE if $DONT;
107              
108             # deriving does not work because we need to replace a superclass
109             # from Net::SMTP, so just copy the class into the new one and then
110             # change it
111              
112             # copy subs
113             for ( keys %{Net::SMTP::} ) {
114 1     1   4 no strict 'refs';
  1         1  
  1         93  
115             *{$_} = \&{ "Net::SMTP::$_" } if defined &{ "Net::SMTP::$_" };
116             }
117              
118             # copy + fix @ISA
119             our @ISA = @Net::SMTP::ISA;
120             grep { s{^IO::Socket::INET$}{Net::SSLGlue::SMTP::_SSL_Socket} } @ISA
121             or die "cannot find and replace IO::Socket::INET superclass";
122              
123             # we are already sslified
124 1     1   3 no warnings 'redefine';
  1         1  
  1         159  
125             *starttls = sub { croak "have already TLS\n" };
126              
127             my $old_new = \&new;
128             *new = sub {
129             my $class = shift;
130             my %arg = @_ % 2 == 0 ? @_ : ( Host => shift,@_ );
131             local %SSLopts;
132             $SSLopts{$_} = delete $arg{$_} for ( grep { /^SSL_/ } keys %arg );
133             return $old_new->($class,%arg);
134             };
135              
136             DONE:
137             1;
138             }
139              
140             1;
141              
142             =head1 NAME
143              
144             Net::SSLGlue::SMTP - make Net::SMTP able to use SSL
145              
146             =head1 SYNOPSIS
147              
148             use Net::SSLGlue::SMTP;
149             my $smtp_ssl = Net::SMTP->new( $host,
150             SSL => 1,
151             SSL_ca_path => ...
152             );
153              
154             my $smtp_plain = Net::SMTP->new( $host );
155             $smtp_plain->starttls( SSL_ca_path => ... );
156              
157             =head1 DESCRIPTION
158              
159             L extends L so one can either start directly with SSL
160             or switch later to SSL using the STARTTLS command.
161              
162             By default it will take care to verify the certificate according to the rules
163             for SMTP implemented in L.
164              
165             =head1 METHODS
166              
167             =over 4
168              
169             =item new
170              
171             The method C of L is now able to start directly with SSL when
172             the argument C< 1>> is given. In this case it will not create an
173             L object but an L object. One can give the
174             usual C parameter of L to C.
175              
176             =item starttls
177              
178             If the connection is not yet SSLified it will issue the STARTTLS command and
179             change the object, so that SSL will now be used. The usual C parameter of
180             L will be given.
181              
182             =item peer_certificate ...
183              
184             Once the SSL connection is established the object is derived from
185             L so that you can use this method to get information about the
186             certificate. See the L documentation.
187              
188             =back
189              
190             All of these methods can take the C parameter from L to
191             change the behavior of the SSL connection. The following parameters are
192             especially useful:
193              
194             =over 4
195              
196             =item SSL_ca_path, SSL_ca_file
197              
198             Specifies the path or a file where the CAs used for checking the certificates
199             are located. This is typically L on UNIX systems.
200              
201             =item SSL_verify_mode
202              
203             If set to 0, verification of the certificate will be disabled. By default
204             it is set to 1 which means that the peer certificate is checked.
205              
206             =item SSL_verifycn_name
207              
208             Usually the name given as the hostname in the constructor is used to verify the
209             identity of the certificate. If you want to check the certificate against
210             another name you can specify it with this parameter.
211              
212             =back
213              
214             =head1 SEE ALSO
215              
216             IO::Socket::SSL, Net::SMTP
217              
218             =head1 COPYRIGHT
219              
220             This module is copyright (c) 2008, Steffen Ullrich.
221             All Rights Reserved.
222             This module is free software. It may be used, redistributed and/or modified
223             under the same terms as Perl itself.
224