File Coverage

blib/lib/MongoDB/_Link.pm
Criterion Covered Total %
statement 77 238 32.3
branch 14 110 12.7
condition 12 44 27.2
subroutine 20 31 64.5
pod 0 9 0.0
total 123 432 28.4


line stmt bran cond sub pod time code
1             # Copyright 2014 - present MongoDB, Inc.
2             #
3             # Licensed under the Apache License, Version 2.0 (the "License");
4             # you may not use this file except in compliance with the License.
5             # You may obtain a copy of the License at
6             #
7             # http://www.apache.org/licenses/LICENSE-2.0
8             #
9             # Unless required by applicable law or agreed to in writing, software
10             # distributed under the License is distributed on an "AS IS" BASIS,
11             # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
12             # See the License for the specific language governing permissions and
13             # limitations under the License.
14              
15             # Some portions of this code were copied and adapted from the Perl module
16             # HTTP::Tiny, which is copyright Christian Hansen, David Golden and other
17             # contributors and used with permission under the terms of the Artistic License
18              
19 61     61   1343 use v5.8.0;
  61         202  
20 61     61   288 use strict;
  61         115  
  61         1071  
21 61     61   320 use warnings;
  61         134  
  61         1991  
22              
23             package MongoDB::_Link;
24              
25 61     61   345 use version;
  61         143  
  61         280  
26             our $VERSION = 'v2.2.2';
27              
28 61     61   4836 use Moo;
  61         133  
  61         382  
29 61     61   17415 use Errno qw[EINTR EPIPE];
  61         148  
  61         8968  
30 61     61   29437 use IO::Socket qw[SOCK_STREAM];
  61         707025  
  61         279  
31 61     61   12419 use Scalar::Util qw/refaddr/;
  61         160  
  61         2753  
32 61     61   315 use Socket qw/SOL_SOCKET SO_KEEPALIVE SO_RCVBUF IPPROTO_TCP TCP_NODELAY AF_INET/;
  61         147  
  61         2857  
33 61     61   411 use Time::HiRes qw/time/;
  61         122  
  61         558  
34 61     61   6071 use MongoDB::Error;
  61         141  
  61         6228  
35 61     61   417 use MongoDB::_Constants;
  61         123  
  61         6233  
36 61     61   1650 use MongoDB::_Protocol;
  61         127  
  61         1812  
37 61         576 use MongoDB::_Types qw(
38             Boolish
39             HostAddress
40             NonNegNum
41             Numish
42             ServerDesc
43 61     61   358 );
  61         135  
44 61         437 use Types::Standard qw(
45             HashRef
46             Maybe
47             Str
48             Undef
49 61     61   88504 );
  61         138  
50 61     61   55266 use namespace::clean;
  61         151  
  61         510  
51              
52             my $SOCKET_CLASS =
53             eval { require IO::Socket::IP; IO::Socket::IP->VERSION(0.32) }
54             ? 'IO::Socket::IP'
55             : 'IO::Socket::INET';
56              
57             has address => (
58             is => 'ro',
59             required => 1,
60             isa => HostAddress,
61             );
62              
63             has connect_timeout => (
64             is => 'ro',
65             default => 20,
66             isa => Numish,
67             );
68              
69             has socket_timeout => (
70             is => 'ro',
71             default => 30,
72             isa => Numish|Undef,
73             );
74              
75             has with_ssl => (
76             is => 'ro',
77             isa => Boolish,
78             );
79              
80             has SSL_options => (
81             is => 'ro',
82             default => sub { {} },
83             isa => HashRef,
84             );
85              
86             has server => (
87             is => 'rwp',
88             init_arg => undef,
89             isa => Maybe[ServerDesc],
90             );
91              
92             has host => (
93             is => 'lazy',
94             init_arg => undef,
95             isa => Str,
96             );
97              
98             sub _build_host {
99 0     0   0 my ($self) = @_;
100 0         0 my ($host, $port) = split /:/, $self->address;
101 0         0 return $host;
102             }
103              
104             my @is_master_fields= qw(
105             min_wire_version max_wire_version
106             max_message_size_bytes max_write_batch_size max_bson_object_size
107             );
108              
109             for my $f ( @is_master_fields ) {
110             has $f => (
111             is => 'rwp',
112             init_arg => undef,
113             isa => Maybe[NonNegNum],
114             );
115             }
116              
117             # wire version >= 2
118             has supports_write_commands => (
119             is => 'rwp',
120             init_arg => undef,
121             isa => Boolish,
122             );
123              
124             # wire version >= 3
125             has supports_list_commands => (
126             is => 'rwp',
127             init_arg => undef,
128             isa => Boolish,
129             );
130              
131             has supports_scram_sha1 => (
132             is => 'rwp',
133             init_arg => undef,
134             isa => Boolish,
135             );
136              
137             # wire version >= 4
138             has supports_document_validation => (
139             is => 'rwp',
140             init_arg => undef,
141             isa => Boolish,
142             );
143              
144             has supports_explain_command => (
145             is => 'rwp',
146             init_arg => undef,
147             isa => Boolish,
148             );
149              
150             has supports_query_commands => (
151             is => 'rwp',
152             init_arg => undef,
153             isa => Boolish,
154             );
155              
156             has supports_find_modify_write_concern => (
157             is => 'rwp',
158             init_arg => undef,
159             isa => Boolish,
160             );
161              
162             has supports_fsync_command => (
163             is => 'rwp',
164             init_arg => undef,
165             isa => Boolish,
166             );
167              
168             has supports_read_concern => (
169             is => 'rwp',
170             init_arg => undef,
171             isa => Boolish,
172             );
173              
174             # wire version >= 5
175             has supports_collation => (
176             is => 'rwp',
177             init_arg => undef,
178             isa => Boolish,
179             );
180              
181             has supports_helper_write_concern => (
182             is => 'rwp',
183             init_arg => undef,
184             isa => Boolish,
185             );
186              
187             has supports_x509_user_from_cert => (
188             is => 'rwp',
189             init_arg => undef,
190             isa => Boolish,
191             );
192              
193             # for caching wire version >=6
194             has supports_arrayFilters => (
195             is => 'rwp',
196             init_arg => undef,
197             isa => Boolish,
198             );
199              
200             has supports_clusterTime => (
201             is => 'rwp',
202             init_arg => undef,
203             isa => Boolish,
204             );
205              
206             has supports_db_aggregation => (
207             is => 'rwp',
208             init_arg => undef,
209             isa => Boolish,
210             );
211              
212             has supports_retryWrites => (
213             is => 'rwp',
214             init_arg => undef,
215             isa => Boolish,
216             );
217              
218             has supports_op_msg => (
219             is => 'rwp',
220             init_arg => undef,
221             isa => Boolish,
222             );
223              
224             has supports_retryReads => (
225             is => 'rwp',
226             init_arg => undef,
227             isa => Boolish,
228             );
229              
230             # for wire version >= 7
231             has supports_4_0_changestreams => (
232             is => 'rwp',
233             init_arg => undef,
234             isa => Boolish,
235             );
236              
237             # wire version >= 8
238             has supports_aggregate_out_read_concern => (
239             is => 'rwp',
240             init_arg => undef,
241             isa => Boolish,
242             );
243              
244             my @connection_state_fields = qw(
245             fh connected rcvbuf last_used fdset is_ssl
246             );
247              
248             for my $f ( @connection_state_fields ) {
249             has $f => (
250             is => 'rwp',
251             clearer => "_clear_$f",
252             init_arg => undef,
253             );
254             }
255              
256             around BUILDARGS => sub {
257             my $orig = shift;
258             my $class = shift;
259             my $hr = $class->$orig(@_);
260              
261             # shortcut on missing required field
262             return $hr unless exists $hr->{address};
263              
264             ($hr->{host}, $hr->{port}) = split /:/, $hr->{address};
265              
266             return $hr;
267             };
268              
269             sub connect {
270 108 50   108 0 10866 @_ == 1 || MongoDB::UsageError->throw( q/Usage: $handle->connect()/ . "\n" );
271 108         327 my ($self) = @_;
272              
273 108 50       567 if ( $self->with_ssl ) {
274 0         0 $self->_assert_ssl;
275             # XXX possibly make SOCKET_CLASS an instance variable and set it here to IO::Socket::SSL
276             }
277              
278 108         683 my ($host, $port) = split /:/, $self->address;
279              
280             # PERL-715: For 'localhost' where MongoDB is only listening on IPv4 and
281             # getaddrinfo returns an IPv6 address before an IPv4 address, some
282             # operating systems tickle a bug in IO::Socket::IP that causes
283             # connection attempts to fail before trying the IPv4 address. As a
284             # workaround, we always force 'localhost' to use IPv4.
285              
286             my $fh = $SOCKET_CLASS->new(
287 108 50 33     2606 PeerHost => $ENV{TEST_MONGO_SOCKET_HOST} || $host,
    50          
    50          
288             PeerPort => $port,
289             ( lc($host) eq 'localhost' ? ( Family => AF_INET ) : () ),
290             Proto => 'tcp',
291             Type => SOCK_STREAM,
292             Timeout => $self->connect_timeout >= 0 ? $self->connect_timeout : undef,
293             )
294             or
295 108         185009 MongoDB::NetworkError->throw(qq/Could not connect to '@{[$self->address]}': $@\n/);
296              
297 0 0       0 unless ( binmode($fh) ) {
298 0         0 undef $fh;
299 0         0 MongoDB::InternalError->throw(qq/Could not binmode() socket: '$!'\n/);
300             }
301              
302 0 0       0 unless ( defined( $fh->setsockopt( IPPROTO_TCP, TCP_NODELAY, 1 ) ) ) {
303 0         0 undef $fh;
304 0         0 MongoDB::InternalError->throw(qq/Could not set TCP_NODELAY on socket: '$!'\n/);
305             }
306              
307 0 0       0 unless ( defined( $fh->setsockopt( SOL_SOCKET, SO_KEEPALIVE, 1 ) ) ) {
308 0         0 undef $fh;
309 0         0 MongoDB::InternalError->throw(qq/Could not set SO_KEEPALIVE on socket: '$!'\n/);
310             }
311              
312 0         0 $self->_set_fh($fh);
313 0         0 $self->_set_connected(1);
314              
315 0         0 my $fd = fileno $fh;
316 0 0 0     0 unless ( defined $fd && $fd >= 0 ) {
317 0         0 $self->_close;
318 0         0 MongoDB::InternalError->throw(qq/select(2): 'Bad file descriptor'\n/);
319             }
320 0         0 vec( my $fdset = '', $fd, 1 ) = 1;
321 0         0 $self->_set_fdset( $fdset );
322              
323 0 0       0 $self->start_ssl($host) if $self->with_ssl;
324              
325 0         0 $self->_set_last_used( time );
326 0         0 $self->_set_rcvbuf( $fh->sockopt(SO_RCVBUF) );
327              
328             # Default max msg size is 2 * max BSON object size (DRIVERS-1)
329 0         0 $self->_set_max_message_size_bytes( 2 * MAX_BSON_OBJECT_SIZE );
330              
331 0         0 return $self;
332             }
333              
334             sub set_metadata {
335 1     1 0 34 my ( $self, $server ) = @_;
336 1         18 $self->_set_server($server);
337 1   50     167 $self->_set_min_wire_version( $server->is_master->{minWireVersion} || "0" );
338 1   50     50 $self->_set_max_wire_version( $server->is_master->{maxWireVersion} || "0" );
339             $self->_set_max_bson_object_size( $server->is_master->{maxBsonObjectSize}
340 1   50     47 || MAX_BSON_OBJECT_SIZE );
341             $self->_set_max_write_batch_size( $server->is_master->{maxWriteBatchSize}
342 1   50     53 || MAX_WRITE_BATCH_SIZE );
343              
344             # Default is 2 * max BSON object size (DRIVERS-1)
345             $self->_set_max_message_size_bytes( $server->is_master->{maxMessageSizeBytes}
346 1   33     45 || 2 * $self->max_bson_object_size );
347              
348 1 50       35 if ( $self->accepts_wire_version(2) ) {
349 0         0 $self->_set_supports_write_commands(1);
350             }
351 1 50       3 if ( $self->accepts_wire_version(3) ) {
352 0         0 $self->_set_supports_list_commands(1);
353 0         0 $self->_set_supports_scram_sha1(1);
354             }
355 1 50       5 if ( $self->accepts_wire_version(4) ) {
356 0         0 $self->_set_supports_document_validation(1);
357 0         0 $self->_set_supports_explain_command(1);
358 0         0 $self->_set_supports_query_commands(1);
359 0         0 $self->_set_supports_find_modify_write_concern(1);
360 0         0 $self->_set_supports_fsync_command(1);
361 0         0 $self->_set_supports_read_concern(1);
362             }
363 1 50       3 if ( $self->accepts_wire_version(5) ) {
364 0         0 $self->_set_supports_collation(1);
365 0         0 $self->_set_supports_helper_write_concern(1);
366 0         0 $self->_set_supports_x509_user_from_cert(1);
367             }
368 1 50       3 if ( $self->accepts_wire_version(6) ) {
369 0         0 $self->_set_supports_arrayFilters(1);
370 0         0 $self->_set_supports_clusterTime(1);
371 0         0 $self->_set_supports_db_aggregation(1);
372 0 0 0     0 $self->_set_supports_retryWrites(
373             defined( $server->logical_session_timeout_minutes )
374             && ( $server->type ne 'Standalone' )
375             ? 1
376             : 0
377             );
378 0         0 $self->_set_supports_op_msg(1);
379 0         0 $self->_set_supports_retryReads(1);
380             }
381 1 50       3 if ( $self->accepts_wire_version(7) ) {
382 0         0 $self->_set_supports_4_0_changestreams(1);
383             }
384 1 50       3 if ( $self->accepts_wire_version(8) ) {
385 0         0 $self->_set_supports_aggregate_out_read_concern(1);
386             }
387              
388 1         4 return;
389             }
390              
391             sub accepts_wire_version {
392 7     7 0 9 my ( $self, $version ) = @_;
393 7   50     22 my $min = $self->min_wire_version || 0;
394 7   50     17 my $max = $self->max_wire_version || 0;
395 7   33     26 return $version >= $min && $version <= $max;
396             }
397              
398             sub start_ssl {
399 0     0 0 0 my ( $self, $host ) = @_;
400              
401 0         0 my $ssl_args = $self->_ssl_args($host);
402             IO::Socket::SSL->start_SSL(
403             $self->fh,
404             %$ssl_args,
405             SSL_create_ctx_callback => sub {
406 0     0   0 my $ctx = shift;
407 0         0 Net::SSLeay::CTX_set_mode( $ctx, Net::SSLeay::MODE_AUTO_RETRY() );
408             },
409 0         0 );
410              
411 0 0       0 unless ( ref( $self->fh ) eq 'IO::Socket::SSL' ) {
412 0         0 my $ssl_err = IO::Socket::SSL->errstr;
413 0         0 $self->_close;
414 0         0 MongoDB::HandshakeError->throw(qq/SSL connection failed for $host: $ssl_err\n/);
415             }
416             }
417              
418             sub client_certificate_subject {
419 0     0 0 0 my ($self) = @_;
420 0 0 0     0 return "" unless $self->fh && $self->fh->isa("IO::Socket::SSL");
421              
422 0 0       0 my $client_cert = $self->fh->sock_certificate()
423             or return "";
424              
425 0 0       0 my $subject_raw = Net::SSLeay::X509_get_subject_name($client_cert)
426             or return "";
427              
428 0         0 my $subject =
429             Net::SSLeay::X509_NAME_print_ex( $subject_raw, Net::SSLeay::XN_FLAG_RFC2253() );
430              
431 0         0 return $subject;
432             }
433              
434             sub close {
435 0     0 0 0 my ($self) = @_;
436 0 0       0 $self->_close
437             or MongoDB::NetworkError->throw(qq/Error closing socket: '$!'\n/);
438             }
439              
440             # this is a quiet close so preexisting network errors can be thrown
441             sub _close {
442 0     0   0 my ($self) = @_;
443 0         0 $self->_clear_connected;
444 0         0 my $ok = 1;
445 0 0       0 if ( $self->fh ) {
446 0         0 $ok = CORE::close( $self->fh );
447 0         0 $self->_clear_fh;
448             }
449 0         0 return $ok;
450             }
451              
452             sub is_connected {
453 0     0 0 0 my ($self) = @_;
454 0   0     0 return $self->connected && $self->fh;
455             }
456              
457             sub write {
458 1     1 0 11800 my ( $self, $buf, $write_opt ) = @_;
459 1   50     13 $write_opt ||= {};
460              
461 1 50 33     66 if (
      33        
462             !$write_opt->{disable_compression}
463             && $self->server
464             && $self->server->compressor
465             ) {
466 0         0 $buf = MongoDB::_Protocol::compress(
467             $buf,
468             $self->server->compressor,
469             );
470             }
471              
472 1         4 my ( $len, $off, $pending, $nfound, $r ) = ( length($buf), 0 );
473              
474             MongoDB::ProtocolError->throw(
475             qq/Message of size $len exceeds maximum of / . $self->{max_message_size_bytes} )
476 1 50       38 if $len > $self->max_message_size_bytes;
477              
478 0           local $SIG{PIPE} = 'IGNORE';
479              
480 0           while () {
481              
482             # do timeout
483 0           ( $pending, $nfound ) = ( $self->socket_timeout, 0 );
484 0           TIMEOUT: while () {
485 0 0         if ( -1 == ( $nfound = select( undef, $self->fdset, undef, $pending ) ) ) {
486 0 0         unless ( $! == EINTR ) {
487 0           $self->_close;
488 0           MongoDB::NetworkError->throw(qq/select(2): '$!'\n/);
489             }
490             # to avoid overhead tracking monotonic clock times; assume
491             # interrupts occur on average halfway through the timeout period
492             # and restart with half the original time
493 0           $pending = int( $pending / 2 );
494 0           redo TIMEOUT;
495             }
496 0           last TIMEOUT;
497             }
498 0 0         unless ($nfound) {
499 0           $self->_close;
500 0           MongoDB::NetworkTimeout->throw(
501             qq/Timed out while waiting for socket to become ready for writing\n/);
502             }
503              
504             # do write
505 0 0         if ( defined( $r = syswrite( $self->fh, $buf, $len, $off ) ) ) {
    0          
    0          
506 0           ( $len -= $r ), ( $off += $r );
507 0 0         last unless $len > 0;
508             }
509             elsif ( $! == EPIPE ) {
510 0           $self->_close;
511 0           MongoDB::NetworkError->throw(qq/Socket closed by remote server: $!\n/);
512             }
513             elsif ( $! != EINTR ) {
514 0 0         if ( $self->fh->can('errstr') ) {
515 0           my $err = $self->fh->errstr();
516 0           $self->_close;
517 0           MongoDB::NetworkError->throw(qq/Could not write to SSL socket: '$err'\n /);
518             }
519             else {
520 0           $self->_close;
521 0           MongoDB::NetworkError->throw(qq/Could not write to socket: '$!'\n/);
522             }
523              
524             }
525             }
526              
527 0           $self->_set_last_used(time);
528              
529 0           return;
530             }
531              
532             sub read {
533 0     0 0   my ($self) = @_;
534              
535             # len of undef triggers first pass through loop
536 0           my ( $msg, $len, $pending, $nfound, $r ) = ( '', undef );
537              
538 0           while () {
539              
540             # do timeout
541 0           ( $pending, $nfound ) = ( $self->socket_timeout, 0 );
542 0           TIMEOUT: while () {
543             # no need to select if SSL and has pending data from a frame
544 0 0         if ( $self->with_ssl ) {
545 0 0         ( $nfound = 1 ), last TIMEOUT
546             if $self->fh->pending;
547             }
548              
549 0 0         if ( -1 == ( $nfound = select( $self->fdset, undef, undef, $pending ) ) ) {
550 0 0         unless ( $! == EINTR ) {
551 0           $self->_close;
552 0           MongoDB::NetworkError->throw(qq/select(2): '$!'\n/);
553             }
554             # to avoid overhead tracking monotonic clock times; assume
555             # interrupts occur on average halfway through the timeout period
556             # and restart with half the original time
557 0           $pending = int( $pending / 2 );
558 0           redo TIMEOUT;
559             }
560 0           last TIMEOUT;
561             }
562 0 0         unless ($nfound) {
563 0           $self->_close;
564 0           MongoDB::NetworkTimeout->throw(
565             q/Timed out while waiting for socket to become ready for reading/ . "\n" );
566             }
567              
568             # read up to SO_RCVBUF if we can
569 0 0         if ( defined( $r = sysread( $self->fh, $msg, $self->rcvbuf, length $msg ) ) ) {
    0          
570             # because select said we're ready to read, if we read 0 then
571             # we got EOF before the full message
572 0 0         if ( !$r ) {
573 0           $self->_close;
574 0           MongoDB::NetworkError->throw(qq/Unexpected end of stream\n/);
575             }
576             }
577             elsif ( $! != EINTR ) {
578 0 0         if ( $self->fh->can('errstr') ) {
579 0           my $err = $self->fh->errstr();
580 0           $self->_close;
581 0           MongoDB::NetworkError->throw(qq/Could not read from SSL socket: '$err'\n /);
582             }
583             else {
584 0           $self->_close;
585 0           MongoDB::NetworkError->throw(qq/Could not read from socket: '$!'\n/);
586             }
587             }
588              
589 0 0         if ( !defined $len ) {
590 0 0         next if length($msg) < 4;
591 0           $len = unpack( P_INT32, $msg );
592             MongoDB::ProtocolError->throw(
593             qq/Server reply of size $len exceeds maximum of / . $self->{max_message_size_bytes} )
594 0 0         if $len > $self->max_message_size_bytes;
595             }
596 0 0         last unless length($msg) < $len;
597             }
598              
599 0           $self->_set_last_used(time);
600              
601 0           return $msg;
602             }
603              
604             sub _assert_ssl {
605             # Need IO::Socket::SSL 1.42 for SSL_create_ctx_callback
606             MongoDB::UsageError->throw(qq/IO::Socket::SSL 1.42 must be installed for SSL support\n/)
607 0 0   0     unless eval { require IO::Socket::SSL; IO::Socket::SSL->VERSION(1.42) };
  0            
  0            
608             # Need Net::SSLeay 1.49 for MODE_AUTO_RETRY
609             MongoDB::UsageError->throw(qq/Net::SSLeay 1.49 must be installed for SSL support\n/)
610 0 0         unless eval { require Net::SSLeay; Net::SSLeay->VERSION(1.49) };
  0            
  0            
611             }
612              
613             # Try to find a CA bundle to validate the SSL cert,
614             # prefer Mozilla::CA or fallback to a system file
615             sub _find_CA_file {
616 0     0     my $self = shift();
617              
618             return $self->SSL_options->{SSL_ca_file}
619 0 0 0       if $self->SSL_options->{SSL_ca_file} and -e $self->SSL_options->{SSL_ca_file};
620              
621             return Mozilla::CA::SSL_ca_file()
622 0 0         if eval { require Mozilla::CA };
  0            
623              
624             # cert list copied from golang src/crypto/x509/root_unix.go
625 0           foreach my $ca_bundle (
626             "/etc/ssl/certs/ca-certificates.crt", # Debian/Ubuntu/Gentoo etc.
627             "/etc/pki/tls/certs/ca-bundle.crt", # Fedora/RHEL
628             "/etc/ssl/ca-bundle.pem", # OpenSUSE
629             "/etc/openssl/certs/ca-certificates.crt", # NetBSD
630             "/etc/ssl/cert.pem", # OpenBSD
631             "/usr/local/share/certs/ca-root-nss.crt", # FreeBSD/DragonFly
632             "/etc/pki/tls/cacert.pem", # OpenELEC
633             "/etc/certs/ca-certificates.crt", # Solaris 11.2+
634             ) {
635 0 0         return $ca_bundle if -e $ca_bundle;
636             }
637              
638             MongoDB::UsageError->throw(
639 0           qq/Couldn't find a CA bundle with which to verify the SSL certificate.\n/
640             . qq/Try installing Mozilla::CA from CPAN\n/);
641             }
642              
643             sub _ssl_args {
644 0     0     my ( $self, $host ) = @_;
645              
646 0           my %ssl_args;
647              
648             # This test reimplements IO::Socket::SSL::can_client_sni(), which wasn't
649             # added until IO::Socket::SSL 1.84
650 0 0         if ( Net::SSLeay::OPENSSL_VERSION_NUMBER() >= 0x10000000 ) {
651 0           $ssl_args{SSL_hostname} = $host, # Sane SNI support
652             }
653              
654 0 0         if ( Net::SSLeay::OPENSSL_VERSION_NUMBER() >= 0x10100000 ) {
655 0           $ssl_args{SSL_OP_NO_RENEGOTIATION} = Net::SSLeay::OP_NO_RENEGOTIATION();
656             }
657              
658 0           $ssl_args{SSL_verifycn_scheme} = 'http'; # enable CN validation
659 0           $ssl_args{SSL_verifycn_name} = $host; # set validation hostname
660 0           $ssl_args{SSL_verify_mode} = 0x01; # enable cert validation
661 0           $ssl_args{SSL_ca_file} = $self->_find_CA_file;
662              
663             # user options override default settings
664 0           for my $k ( keys %{ $self->SSL_options } ) {
  0            
665 0 0         $ssl_args{$k} = $self->SSL_options->{$k} if $k =~ m/^SSL_/;
666             }
667              
668 0           return \%ssl_args;
669             }
670              
671             1;
672              
673             # vim: ts=4 sts=4 sw=4 et: