File Coverage

blib/lib/Net/SMTPS.pm
Criterion Covered Total %
statement 15 114 13.1
branch 0 52 0.0
condition 0 34 0.0
subroutine 5 11 45.4
pod 4 5 80.0
total 24 216 11.1


line stmt bran cond sub pod time code
1             # ====
2             # SSL/STARTTLS extention for G.Barr's Net::SMTP.
3             # plus, enable arbitrary SMTP auth mechanism selection.
4             # IO::Socket::SSL (also Net::SSLeay openssl),
5             # Authen::SASL, MIME::Base64 should be installed.
6             #
7             package Net::SMTPS;
8              
9 1     1   82450 use vars qw ( $VERSION @ISA );
  1         2  
  1         56  
10              
11             $VERSION = '0.09';
12              
13 1     1   4 use strict;
  1         2  
  1         20  
14 1     1   3 use base qw ( Net::SMTP );
  1         2  
  1         340  
15 1     1   78385 use Net::Cmd; # import CMD_OK, CMD_MORE, ...
  1         3  
  1         61  
16 1     1   6 use Net::Config;
  1         1  
  1         966  
17              
18             eval {
19             require IO::Socket::IP
20             and unshift @ISA, 'IO::Socket::IP';
21             } or eval {
22             require IO::Socket::INET6
23             and unshift @ISA, 'IO::Socket::INET6';
24             } or do {
25             require IO::Socket::INET
26             and unshift @ISA, 'IO::Socket::INET';
27             };
28              
29             # Override to support SSL/TLS.
30             sub new {
31 0     0 1   my $self = shift;
32 0   0       my $type = ref($self) || $self;
33 0           my ($host, %arg);
34 0 0         if (@_ % 2) {
35 0           $host = shift;
36 0           %arg = @_;
37             }
38             else {
39 0           %arg = @_;
40 0           $host = delete $arg{Host};
41             }
42 0           my $ssl = delete $arg{doSSL};
43 0 0         if ($ssl =~ /ssl/i) {
44 0   0       $arg{Port} ||= 465;
45             }
46              
47 0 0         my $hosts = defined $host ? $host : $NetConfig{smtp_hosts};
48 0           my $obj;
49              
50             # eliminate IO::Socket::SSL from @ISA for multiple call of new.
51 0           @ISA = grep { !/IO::Socket::SSL/ } @ISA;
  0            
52              
53 0           my %_args = map { +"$_" => $arg{$_} } grep {! /^SSL/} keys %arg;
  0            
  0            
54              
55 0           my $h;
56 0   0       $_args{PeerPort} = $_args{Port} || 'smtp(25)';
57 0           $_args{Proto} = 'tcp';
58 0 0         $_args{Timeout} = defined $_args{Timeout} ? $_args{Timeout} : 120;
59              
60 0 0         foreach $h (@{ref($hosts) ? $hosts : [$hosts]}) {
  0            
61 0           $_args{PeerAddr} = ($host = $h);
62              
63             #if ($_args{Debug}) {
64             # foreach my $i (keys %_args) {
65             # print STDERR "$type>>> arg $i: $_args{$i}\n";
66             # }
67             #}
68              
69 0 0         $obj = $type->SUPER::new(
70             %_args
71             )
72             and last;
73             }
74              
75             return undef
76 0 0         unless defined $obj;
77              
78 0           $obj->autoflush(1);
79              
80 0 0         $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
81              
82 0           ${*$obj}{'net_smtp_arg'} = \%arg;
  0            
83              
84             # OverSSL
85 0 0 0       if (defined($ssl) && $ssl =~ /ssl/i) {
86             $obj->ssl_start()
87 0 0         or do {
88 0           $obj->set_status(500, ["Cannot start SSL"]);
89 0           $obj->close;
90 0           return undef;
91             };
92             }
93              
94 0 0         unless ($obj->response() == CMD_OK) {
95 0           $obj->close();
96 0           return undef;
97             }
98              
99 0           ${*$obj}{'net_smtp_exact_addr'} = $arg{ExactAddresses};
  0            
100 0           ${*$obj}{'net_smtp_host'} = $host;
  0            
101              
102 0           (${*$obj}{'net_smtp_banner'}) = $obj->message;
  0            
103 0           (${*$obj}{'net_smtp_domain'}) = $obj->message =~ /\A\s*(\S+)/;
  0            
104              
105 0 0 0       unless ($obj->hello($arg{Hello} || "")) {
106 0           $obj->close();
107 0           return undef;
108             }
109              
110             # STARTTLS
111 0 0 0       if (defined($ssl) && $ssl =~ /starttls/i && defined($obj->supports('STARTTLS')) ) {
      0        
112             #123006 $obj->supports('STARTTLS') returns '' issue.
113 0 0         unless ($obj->starttls()) {
114 0           return undef;
115             }
116 0   0       $obj->hello($arg{Hello} || "");
117             }
118              
119 0           $obj;
120             }
121              
122             sub ssl_start {
123 0     0 0   my $self = shift;
124 0           my $type = ref($self);
125 0           my %arg = %{ ${*$self}{'net_smtp_arg'} };
  0            
  0            
126 0           my %ssl_args = map { +"$_" => $arg{$_} } grep {/^SSL/} keys %arg;
  0            
  0            
127              
128             eval {
129 0           require IO::Socket::SSL;
130 0 0         } or do {
131 0           $self->set_status(500, ["Need working IO::Socket::SSL"]);
132 0           $self->close;
133 0           return undef;
134             };
135              
136 0 0         my $ssl_debug = (exists $arg{Debug} ? $arg{Debug} : undef);
137 0 0         $ssl_debug = (exists $arg{Debug_SSL} ? $arg{Debug_SSL} : $ssl_debug);
138            
139 0           local $IO::Socket::SSL::DEBUG = $ssl_debug;
140            
141 0 0 0       (unshift @ISA, 'IO::Socket::SSL'
      0        
      0        
142             and IO::Socket::SSL->start_SSL($self, %ssl_args, @_)
143             and $self->isa('IO::Socket::SSL')
144             and bless $self, $type # re-bless 'cause IO::Socket::SSL blesses himself.
145             ) or return undef;
146             }
147              
148             sub starttls {
149 0     0 1   my $self = shift;
150             (
151             $self->_STARTTLS()
152             and $self->ssl_start(@_)
153 0 0 0       ) or do {
154 0           $self->set_status(500, ["Cannot start SSL session"]);
155 0           $self->close();
156 0           return undef;
157             };
158             }
159              
160              
161             # Override to specify a certain auth mechanism.
162             sub auth {
163 0     0 1   my ($self, $username, $password, $mech) = @_;
164              
165 0 0         if ($mech) {
166 0 0         $self->debug_print(1, "AUTH-my favorite: ". $mech . "\n") if $self->debug;
167              
168 0           my @cl_mech = split /\s+/, $mech;
169 0           my @matched = ();
170 0 0         if (exists ${*$self}{'net_smtp_esmtp'}->{'AUTH'}) {
  0            
171 0           my $sv = ${*$self}{'net_smtp_esmtp'}->{'AUTH'};
  0            
172 0 0         $self->debug_print(1, "AUTH-server offerred: ". $sv . "\n") if $self->debug;
173              
174 0           foreach my $i (@cl_mech) {
175 0 0 0       if (index($sv, $i) >= 0 && grep(/$i/i, @matched) == () ) {
176 0           push @matched, uc($i);
177             }
178             }
179             }
180 0 0         if (@matched) {
181             ## override AUTH mech as specified.
182             ## if multiple mechs are specified, priority is still up to Authen::SASL module.
183 0           ${*$self}{'net_smtp_esmtp'}->{'AUTH'} = join " ", @matched;
  0            
184 0 0         $self->debug_print(1, "AUTH-negotiated: ". ${*$self}{'net_smtp_esmtp'}->{'AUTH'} . "\n") if $self->debug;
  0            
185             }
186             }
187 0           $self->SUPER::auth($username, $password);
188             }
189              
190              
191             # Fix #121006 no timeout issue.
192             sub getline {
193 0     0 1   my $self = shift;
194 0           $self->Net::Cmd::getline(@_);
195             }
196              
197 0     0     sub _STARTTLS { shift->command("STARTTLS")->response() == CMD_OK }
198              
199             1;
200              
201             __END__