File Coverage

lib/Net/SSL.pm
Criterion Covered Total %
statement 62 240 25.8
branch 10 94 10.6
condition 5 64 7.8
subroutine 12 35 34.3
pod 7 25 28.0
total 96 458 21.0


line stmt bran cond sub pod time code
1             package Net::SSL;
2              
3 1     1   15 use strict;
  1         16  
  1         43  
4 1     1   14 use vars qw(@ISA $VERSION $NEW_ARGS);
  1         9  
  1         17  
5              
6 1     1   33 use MIME::Base64;
  1         10  
  1         21  
7 1     1   32 use Socket;
  1         10  
  1         23  
8 1     1   19 use Carp;
  1         9  
  1         72  
9              
10             require IO::Socket;
11             @ISA=qw(IO::Socket::INET);
12             my %REAL; # private to this package only
13             my $DEFAULT_VERSION = '23';
14             my $CRLF = "\015\012";
15              
16             require Crypt::SSLeay;
17             $VERSION = '2.78';
18              
19             sub _default_context
20             {
21 1     1   49     require Crypt::SSLeay::MainContext;
22 1         14     Crypt::SSLeay::MainContext::main_ctx(@_);
23             }
24              
25             sub new {
26 1     1 1 14     my($class, %arg) = @_;
27 1         10     local $NEW_ARGS = \%arg;
28 1         81     $class->SUPER::new(%arg);
29             }
30              
31             sub DESTROY {
32 1     1   10     my $self = shift;
33 1         14     delete $REAL{$self};
34 1         10     local $@;
35 1         9     eval { $self->SUPER::DESTROY; };
  1         28  
36             }
37              
38             sub configure
39             {
40 1     1 0 58     my($self, $arg) = @_;
41 1   33     27     my $ssl_version = delete $arg->{SSL_Version} ||
      33        
42                   $ENV{HTTPS_VERSION} || $DEFAULT_VERSION;
43 1   33     33     my $ssl_debug = delete $arg->{SSL_Debug} || $ENV{HTTPS_DEBUG} || 0;
      50        
44              
45 1   33     16     my $ctx = delete $arg->{SSL_Context} || _default_context($ssl_version);
46              
47 1         13     *$self->{'ssl_ctx'} = $ctx;
48 1         12     *$self->{'ssl_version'} = $ssl_version;
49 1         11     *$self->{'ssl_debug'} = $ssl_debug;
50 1         11     *$self->{'ssl_arg'} = $arg;
51 1         12     *$self->{'ssl_peer_addr'} = $arg->{PeerAddr};
52 1         12     *$self->{'ssl_peer_port'} = $arg->{PeerPort};
53 1         13     *$self->{'ssl_new_arg'} = $NEW_ARGS;
54 1         10     *$self->{'ssl_peer_verify'} = 0;
55              
56             ## Crypt::SSLeay must also aware the SSL Proxy before calling
57             ## $socket->configure($args). Because the $sock->configure() will
58             ## die when failed to resolve the destination server IP address,
59             ## whatever the SSL proxy is used or not!
60             ## - dqbai, 2003-05-10
61 1 50       14     if (my $proxy = $self->proxy) {
62 0         0 my ($host, $port) = split(':',$proxy);
63 0 0       0 $port || die("no port given for proxy server $proxy");
64 0         0 $arg->{PeerAddr} = $host;
65 0         0 $arg->{PeerPort} = $port;
66                 }
67              
68 1         33     $self->SUPER::configure($arg);
69             }
70              
71             # override to make sure there is really a timeout
72             sub timeout {
73 0 0   0 1 0     shift->SUPER::timeout || 60;
74             }
75              
76             sub connect {
77 1     1 0 3254     my $self = shift;
78              
79             # configure certs on connect() time, so we can throw an undef
80             # and have LWP understand the error
81 1         20     eval { $self->configure_certs(); };
  1         13  
82 1 50       11     if($@) {
83 0         0 $@ = "configure certs failed: $@, $!";
84 0         0 $self->die_with_error($@);
85                 }
86              
87             # finished, update set_verify status
88 1 50       60     if(my $rv = *$self->{'ssl_ctx'}->set_verify()) {
89 0         0 *$self->{'ssl_peer_verify'} = $rv;
90                 }
91              
92 1 50       12     if ($self->proxy) {
93             # don't die() in connect, just return undef and set $@
94 0         0 my $proxy_connect = eval { $self->proxy_connect_helper(@_); };
  0         0  
95 0 0 0     0 if(! $proxy_connect || $@) {
96 0         0 $@ = "proxy connect failed: $@; $!";
97 0         0 die $@;
98             }
99                 } else {
100 1 50       14 *$self->{io_socket_peername}=@_ == 1 ? $_[0] : IO::Socket::sockaddr_in(@_);
101 1 50       28 if(!$self->SUPER::connect(@_)) {
102             # better to die than return here
103 1         177 $@ = "Connect failed: $@; $!";
104 1         10 die $@;
105             }
106                 }
107              
108             # print "ssl_version ".*$self->{ssl_version}."\n";
109 0   0     0     my $debug = *$self->{'ssl_debug'} || 0;
110 0         0     my $ssl = Crypt::SSLeay::Conn->new(*$self->{'ssl_ctx'}, $debug, $self);
111 0         0     my $arg = *$self->{ssl_arg};
112 0         0     my $new_arg = *$self->{ssl_new_arg};
113 0         0     $arg->{SSL_Debug} = $debug;
114              
115 0         0     eval {
116 0     0   0 local $SIG{ALRM} = sub { $self->die_with_error("SSL connect timeout") };
  0         0  
117             # timeout / 2 because we have 3 possible connects here
118 0 0       0 alarm_ok() && alarm($self->timeout / 2);
119              
120 0         0 my $rv;
121             {
122 0         0 local $SIG{PIPE} = \¨
  0         0  
123 0         0 $rv = eval { $ssl->connect; };
  0         0  
124             }
125 0 0       0 if ($rv <= 0) {
126 0 0       0 alarm_ok() && alarm(0);
127 0         0 $ssl = undef;
128 0         0 my %args = (%$new_arg, %$arg);
129 0 0       0 if(*$self->{ssl_version} == 23) {
    0          
130 0         0 $args{SSL_Version} = 3;
131             # the new connect might itself be overridden with a REAL SSL
132 0         0 my $new_ssl = Net::SSL->new(%args);
133 0   0     0 $REAL{$self} = $REAL{$new_ssl} || $new_ssl;
134 0         0 return $REAL{$self};
135             } elsif(*$self->{ssl_version} == 3) {
136             # $self->die_with_error("SSL negotiation failed");
137 0         0 $args{SSL_Version} = 2;
138 0         0 my $new_ssl = Net::SSL->new(%args);
139 0         0 $REAL{$self} = $new_ssl;
140 0         0 return $new_ssl;
141             } else {
142             # don't die, but do set $@, and return undef
143 0         0 eval { $self->die_with_error("SSL negotiation failed") };
  0         0  
144 0         0 $@ = "$@; $!";
145 0         0 die $@;
146             }
147             }
148 0 0       0 alarm_ok() && alarm(0);
149                 };
150              
151             # odd error in eval {} block, maybe alarm outside the evals
152 0 0       0     if($@) {
153 0         0 $! = "$@; $!";
154 0         0 die $@;
155                 }
156              
157             # successful SSL connection gets stored
158 0         0     *$self->{'ssl_ssl'} = $ssl;
159 0         0     $self;
160             }
161              
162             sub accept
163             {
164 0     0 1 0     die "NYI";
165             }
166              
167             # Delegate these calls to the Crypt::SSLeay::Conn object
168             sub get_peer_certificate {
169 0     0 0 0     my $self = shift;
170 0   0     0     $self = $REAL{$self} || $self;
171 0         0     *$self->{'ssl_ssl'}->get_peer_certificate(@_);
172             }
173              
174             sub get_peer_verify {
175 0     0 0 0     my $self = shift;
176 0   0     0     $self = $REAL{$self} || $self;
177 0         0     *$self->{'ssl_peer_verify'};
178             }
179              
180             sub get_shared_ciphers {
181 0     0 0 0     my $self = shift;
182 0   0     0     $self = $REAL{$self} || $self;
183 0         0     *$self->{'ssl_ssl'}->get_shared_ciphers(@_);
184             }
185             sub get_cipher {
186 0     0 0 0     my $self = shift;
187 0   0     0     $self = $REAL{$self} || $self;
188 0         0     *$self->{'ssl_ssl'}->get_cipher(@_);
189             }
190              
191             #sub get_peer_certificate { *{shift()}->{'ssl_ssl'}->get_peer_certificate(@_) }
192             #sub get_shared_ciphers { *{shift()}->{'ssl_ssl'}->get_shared_ciphers(@_) }
193             #sub get_cipher { *{shift()}->{'ssl_ssl'}->get_cipher(@_) }
194              
195             sub ssl_context
196             {
197 0     0 0 0     my $self = shift;
198 0   0     0     $self = $REAL{$self} || $self;
199 0         0     *$self->{'ssl_ctx'};
200             }
201              
202             sub die_with_error
203             {
204 0     0 0 0     my $self=shift;
205 0         0     my $reason=shift;
206              
207 0         0     my $errs='';
208 0         0     while(my $err=Crypt::SSLeay::Err::get_error_string()) {
209 0 0       0        $errs.=" | " if $errs ne '';
210 0         0        $errs.=$err;
211                 }
212 0         0     die "$reason: $errs";
213             }
214              
215             sub alarm_ok() {
216 0     0 0 0     $^O ne 'MSWin32';
217             }
218              
219             sub read
220             {
221 0     0 0 0     my $self = shift;
222 0   0     0     $self = $REAL{$self} || $self;
223              
224 0         0     local $SIG{__DIE__} = \&Carp::confess;
225 0     0   0     local $SIG{ALRM} = sub { $self->die_with_error("SSL read timeout") };
  0         0  
226              
227 0 0       0     alarm_ok() && alarm($self->timeout);
228 0         0     my $n=*$self->{'ssl_ssl'}->read(@_);
229 0 0       0     $self->die_with_error("read failed") if !defined $n;
230 0 0       0     alarm_ok() && alarm(0);
231              
232 0         0     $n;
233             }
234              
235             sub write
236             {
237 0     0 1 0     my $self = shift;
238 0   0     0     $self = $REAL{$self} || $self;
239 0         0     my $n=*$self->{'ssl_ssl'}->write(@_);
240 0 0       0     $self->die_with_error("write failed") if !defined $n;
241 0         0     $n;
242             }
243              
244             *sysread  = \&read;
245             *syswrite = \&write;
246              
247             sub print
248             {
249 0     0 0 0     my $self = shift;
250 0   0     0     $self = $REAL{$self} || $self;
251             # should we care about $, and $\??
252             # I think it is too expensive...
253 0         0     $self->write(join("", @_));
254             }
255              
256             sub printf
257             {
258 0     0 0 0     my $self = shift;
259 0   0     0     $self = $REAL{$self} || $self;
260 0         0     my $fmt = shift;
261 0         0     $self->write(sprintf($fmt, @_));
262             }
263              
264              
265             sub getchunk
266             {
267 0     0 0 0     my $self = shift;
268 0   0     0     $self = $REAL{$self} || $self;
269 0         0     my $buf = ''; # warnings
270 0         0     my $n = $self->read($buf, 32*1024);
271 0 0       0     return unless defined $n;
272 0         0     $buf;
273             }
274              
275             # In order to implement these we will need to add a buffer in $self.
276             # Is it worth it?
277 0     0 0 0 sub getc { shift->_unimpl("getc"); }
278 0     0 1 0 sub ungetc { shift->_unimpl("ungetc"); }
279              
280             #sub getline { shift->_unimpl("getline"); }
281              
282             # This is really inefficient, but we only use it for reading the proxy response
283             # so that does not really matter.
284             sub getline {
285 0     0 1 0     my $self = shift;
286 0   0     0     $self = $REAL{$self} || $self;
287 0         0     my $val="";
288 0         0     my $buf;
289 0         0     do {
290 0         0 $self->SUPER::recv($buf, 1);
291 0         0 $val = $val . $buf;
292                 } until ($buf eq "\n");
293              
294 0         0     $val;
295             }
296              
297              
298 0     0 1 0 sub getlines { shift->_unimpl("getlines"); }
299              
300             # XXX: no way to disable <$sock>?? (tied handle perhaps?)
301              
302             sub _unimpl
303             {
304 0     0   0     my($self, $meth) = @_;
305 0         0     die "$meth not implemented for Net::SSL sockets";
306             }
307              
308             sub get_lwp_object {
309 0     0 0 0     my $self = shift;
310              
311 0         0     my $lwp_object;
312 0         0     my $i = 0;
313 0         0     while(1) {
314             package DB;
315 0         0 my @stack = caller($i++);
316 0 0       0 last unless @stack;
317 0         0 my @stack_args = @DB::args;
318 0   0     0 my $stack_object = $stack_args[0] || next;
319 0 0       0 ref($stack_object) || next;
320 0 0       0 if($stack_object->isa('LWP::UserAgent')) {
321 0         0 $lwp_object = $stack_object;
322 0         0 last;
323             }
324                 }
325              
326 0         0     $lwp_object;
327             }
328              
329             sub proxy_connect_helper {
330 0     0 0 0     my $self = shift;
331              
332 0         0     my $proxy = $self->proxy;
333 0         0     my ($host, $port) = split(':',$proxy);
334 0         0     my $conn_ok = 0;
335 0         0     my $need_auth = 0;
336 0         0     my $auth_basic = 0;
337 0         0     my $realm = "";
338 0         0     my $length = 0;
339 0         0     my $line = "<noline>";
340 0         0     my $lwp_object = $self->get_lwp_object;
341              
342 0         0     my $iaddr = gethostbyname($host);
343 0 0       0     $iaddr || die("can't resolve proxy server name: $host, $!");
344 0 0       0     $port || die("no port given for proxy server $proxy");
345                 
346 0 0       0     $self->SUPER::connect($port, $iaddr)
347                   || die("proxy connect to $host:$port failed: $!");
348                 
349 0         0     my($peer_port, $peer_addr) = (*$self->{ssl_peer_port}, *$self->{ssl_peer_addr});
350 0 0       0     $peer_port || die("no peer port given");
351 0 0       0     $peer_addr || die("no peer addr given");
352              
353 0         0     my $connect_string;
354 0 0 0     0     if ($ENV{"HTTPS_PROXY_USERNAME"} || $ENV{"HTTPS_PROXY_PASSWORD"}) {
355 0         0 my $user = $ENV{"HTTPS_PROXY_USERNAME"};
356 0         0 my $pass = $ENV{"HTTPS_PROXY_PASSWORD"};
357              
358 0         0 my $credentials = encode_base64("$user:$pass", "");
359 0         0 $connect_string = join($CRLF,
360             "CONNECT $peer_addr:$peer_port HTTP/1.0",
361             "Proxy-authorization: Basic $credentials"
362             );
363                 }else{
364 0         0 $connect_string = "CONNECT $peer_addr:$peer_port HTTP/1.0";
365                 }
366 0         0     $connect_string .= $CRLF;
367 0 0 0     0     if($lwp_object && $lwp_object->agent) {
368 0         0 $connect_string .= "User-Agent: ".$lwp_object->agent.$CRLF;
369                 }
370 0         0     $connect_string .= $CRLF;
371              
372 0         0     $self->SUPER::send($connect_string);
373 0         0     my $header;
374 0         0     my $n = $self->SUPER::sysread($header, 8192);
375 0 0       0     if($header =~ /HTTP\/\d+\.\d+\s+200\s+/is) {
376 0         0 $conn_ok = 1;
377                 }
378              
379 0 0       0     unless ($conn_ok) {
380 0         0         die("PROXY ERROR HEADER, could be non-SSL URL:\n$header");
381                 }
382              
383 0         0     $conn_ok;
384             }
385              
386             # code adapted from LWP::UserAgent, with $ua->env_proxy API
387             sub proxy {
388             # don't iterate through %ENV for speed
389 2     2 0 18     my $proxy_server;
390 2         21     for ('HTTPS_PROXY', 'https_proxy') {
391 4         36 $proxy_server = $ENV{$_};
392 4 50       45 last if $proxy_server;
393                 }
394 2 50       29     return unless $proxy_server;
395              
396 0         0     $proxy_server =~ s|^https?://||i;
397                 
398 0         0     $proxy_server;
399             }
400              
401             sub configure_certs {
402 1     1 0 14     my $self = shift;
403 1         15     my $ctx = *$self->{ssl_ctx};
404              
405 1         10     my $count = 0;
406 1         11     for ('HTTPS_PKCS12_FILE', 'HTTPS_CERT_FILE', 'HTTPS_KEY_FILE') {
407 3         28 my $file = $ENV{$_};
408 3 50       33 if($file) {
409 0 0       0 (-e $file) or die("$file file does not exist: $!");
410 0 0       0 (-r $file) or die("$file file is not readable");
411 0         0 $count++;
412 0 0       0 if (/PKCS12/) {
    0          
    0          
413 0         0 $count++;
414 0 0       0 $ctx->use_pkcs12_file($file ,$ENV{'HTTPS_PKCS12_PASSWORD'}) || die("failed to load $file: $!");
415 0         0 last;
416             } elsif (/CERT/) {
417 0 0       0 $ctx->use_certificate_file($file ,1) || die("failed to load $file: $!");
418             } elsif (/KEY/) {
419 0 0       0 $ctx->use_PrivateKey_file($file, 1) || die("failed to load $file: $!");
420             } else {
421 0         0 die("setting $_ not supported");
422             }
423             }
424                 }
425              
426             # if both configs are set, then verify them
427 1 50       13     if (($count == 2)) {
428 0 0       0 if (! $ctx->check_private_key) {
429 0         0 die("Private key and certificate do not match");
430             }
431                 }
432                 
433 1         11     $count; # number of successful cert loads/checks
434             }
435              
436             1;
437