File Coverage

blib/lib/Net/POP3S.pm
Criterion Covered Total %
statement 15 115 13.0
branch 0 50 0.0
condition 0 41 0.0
subroutine 5 12 41.6
pod 5 6 83.3
total 25 224 11.1


line stmt bran cond sub pod time code
1             # ====
2             # SSL/STARTTLS extention for Graham Barr's Net::POP3.
3             # plus, enable arbitrary POP auth mechanism selection.
4             # IO::Socket::SSL (also Net::SSLeay openssl),
5             # Authen::SASL, MIME::Base64 should be installed.
6             #
7             package Net::POP3S;
8              
9 1     1   51103 use vars qw ( $VERSION @ISA );
  1         2  
  1         53  
10              
11             $VERSION = '0.08_1';
12              
13 1     1   5 use strict;
  1         1  
  1         20  
14 1     1   4 use base qw ( Net::POP3 );
  1         4  
  1         331  
15 1     1   65048 use Net::Cmd; # import CMD_OK, CMD_MORE, ...
  1         1  
  1         48  
16 1     1   5 use Net::Config;
  1         2  
  1         995  
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           $arg{SSL} = 1;
45             }
46 0 0 0       if (defined($arg{SSL}) && $arg{SSL} > 0) {
47 0           $ssl = 'ssl';
48 0   0       $arg{Port} ||= 995;
49             }
50              
51 0 0         my $hosts = defined $host ? $host : $NetConfig{pop3_hosts};
52 0           my $obj;
53              
54             # eliminate IO::Socket::SSL from @ISA for multiple call of new.
55 0           @ISA = grep { !/IO::Socket::SSL/ } @ISA;
  0            
56              
57 0           my %_args = map { +"$_" => $arg{$_} } grep {! /^SSL/} keys %arg;
  0            
  0            
58              
59 0           my $h;
60 0   0       $_args{PeerPort} = $_args{Port} || 'pop3(110)';
61 0           $_args{Proto} = 'tcp';
62 0 0         $_args{Timeout} = defined $_args{Timeout} ? $_args{Timeout} : 120;
63 0 0         if (exists $_args{ResvPort}) {
64 0           $_args{LocalPort} = delete $_args{ResvPort};
65             }
66              
67 0 0         foreach $h (@{ref($hosts) ? $hosts : [$hosts]}) {
  0            
68 0           $_args{PeerAddr} = ($host = $h);
69              
70 0 0         $obj = $type->SUPER::new(
71             %_args
72             )
73             and last;
74             }
75              
76             return undef
77 0 0         unless defined $obj;
78              
79 0           ${*$obj}{'net_pop3_host'} = $host;
  0            
80              
81 0           $obj->autoflush(1);
82 0 0         $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
83              
84             # common in SSL
85 0           my %ssl_args;
86 0 0 0       if ($ssl || defined($arg{SSL}) ) {
87             eval {
88 0           require IO::Socket::SSL;
89 0 0         } or do {
90 0           $obj->set_status(500, ["Need working IO::Socket::SSL"]);
91 0           $obj->close;
92 0           return undef;
93             };
94 0           %ssl_args = map { +"$_" => $arg{$_} } grep {/^SSL/} keys %arg;
  0            
  0            
95 0 0         $IO::Socket::SSL::DEBUG = (exists $arg{Debug} ? $arg{Debug} : undef);
96             }
97              
98             # OverSSL
99 0 0 0       if (defined($ssl) && $ssl =~ /ssl/i) {
100             $obj->ssl_start(\%ssl_args)
101 0 0         or do {
102 0           $obj->set_status(500, ["Cannot start SSL"]);
103 0           $obj->close;
104 0           return undef;
105             };
106             }
107              
108 0 0         unless ($obj->response() == CMD_OK) {
109 0           $obj->close();
110 0           return undef;
111             }
112              
113 0           ${*$obj}{'net_pop3_banner'} = $obj->message;
  0            
114 0           ${*$obj}{'net_pop3_arg'} = \%arg;
  0            
115              
116             # STARTTLS
117 0 0 0       if (defined($ssl) && $ssl =~ /starttls|stls/i ) {
118 0 0         unless ($obj->starttls()) {
119 0           return undef;
120             }
121             }
122              
123 0           $obj;
124             }
125              
126             sub ssl_start {
127 0     0 0   my ($self, $args) = @_;
128 0           my $type = ref($self);
129              
130 0 0 0       (unshift @ISA, 'IO::Socket::SSL'
      0        
      0        
131             and IO::Socket::SSL->start_SSL($self, %$args)
132             and $self->isa('IO::Socket::SSL')
133             and bless $self, $type # re-bless 'cause IO::Socket::SSL blesses himself.
134             ) or return undef;
135             }
136              
137             sub starttls {
138 0     0 1   my $self = shift;
139 0           my %arg = %{ ${*$self}{'net_pop3_arg'} };
  0            
  0            
140 0           my %ssl_args = map { +"$_" => $arg{$_} } grep {/^SSL/} keys %arg;
  0            
  0            
141 0           my $capa;
142             ($capa = $self->capa
143             and exists $capa->{STLS}
144             and $self->_STLS()
145             and $self->ssl_start(\%ssl_args, @_)
146 0 0 0       ) or do {
      0        
      0        
147 0           $self->set_status(500, ["Cannot start SSL session"]);
148 0           $self->close();
149 0           return undef;
150             };
151             }
152              
153             sub capa {
154 0     0 1   my $this = shift;
155              
156 0 0         if (exists ${*$this}{'net_pop3e_capabilities'}) {
  0            
157 0           return ${*$this}{'net_pop3e_capabilities'};
  0            
158             }
159 0           $this->SUPER::capa();
160             }
161              
162             # Override to specify a certain auth mechanism.
163             sub auth {
164 0     0 1   my ($self, $username, $password, $mech) = @_;
165              
166 0 0         if ($mech) {
167 0 0         $self->debug_print(1, "my favorite: ". $mech . "\n") if $self->debug;
168              
169 0           my @cl_mech = split /\s+/, $mech;
170 0           my @matched = ();
171 0   0       my $sv = $self->capa->{SASL} || 'CRAM-MD5';
172              
173 0           foreach my $i (@cl_mech) {
174 0 0 0       if (index($sv, $i) >= 0 && grep(/$i/i, @matched) == () ) {
175 0           push @matched, uc($i);
176             }
177             }
178 0 0         if (@matched) {
179             ## override AUTH mech as specified.
180             ## if multiple mechs are specified, priority is still up to Authen::SASL module.
181 0           ${*$self}{'net_pop3e_capabilities'}->{'SASL'} = join " ", @matched;
  0            
182             }
183             }
184 0           $self->SUPER::auth($username, $password);
185             }
186              
187 0     0     sub _STLS { shift->command("STLS")->response() == CMD_OK }
188              
189             # Fix #121006 no timeout issue.
190             sub getline {
191 0     0 1   my $self = shift;
192 0           $self->Net::Cmd::getline(@_);
193             }
194              
195             1;
196              
197             __END__