1#!/usr/bin/perl -w 2# 3# IO::Socket::SSL: 4# a drop-in replacement for IO::Socket::INET that encapsulates 5# data passed over a network with SSL. 6# 7# Current Code Shepherd: Steffen Ullrich <steffen at genua.de> 8# Code Shepherd before: Peter Behroozi, <behrooz at fas.harvard.edu> 9# 10# The original version of this module was written by 11# Marko Asplund, <marko.asplund at kronodoc.fi>, who drew from 12# Crypt::SSLeay (Net::SSL) by Gisle Aas. 13# 14 15package IO::Socket::SSL; 16 17use IO::Socket; 18use Net::SSLeay 1.21; 19use Exporter (); 20use Errno qw( EAGAIN ETIMEDOUT ); 21use Carp; 22use strict; 23 24use constant SSL_VERIFY_NONE => Net::SSLeay::VERIFY_NONE(); 25use constant SSL_VERIFY_PEER => Net::SSLeay::VERIFY_PEER(); 26use constant SSL_VERIFY_FAIL_IF_NO_PEER_CERT => Net::SSLeay::VERIFY_FAIL_IF_NO_PEER_CERT(); 27use constant SSL_VERIFY_CLIENT_ONCE => Net::SSLeay::VERIFY_CLIENT_ONCE(); 28 29# from openssl/ssl.h; should be better in Net::SSLeay 30use constant SSL_SENT_SHUTDOWN => 1; 31use constant SSL_RECEIVED_SHUTDOWN => 2; 32 33use constant DEFAULT_CIPHER_LIST => 'ALL:!LOW'; 34use constant DEFAULT_VERSION => 'SSLv23:!SSLv2'; 35 36# non-XS Versions of Scalar::Util will fail 37BEGIN{ 38 eval { use Scalar::Util 'dualvar'; dualvar(0,'') }; 39 die "You need the XS Version of Scalar::Util for dualvar() support" 40 if $@; 41} 42 43use vars qw(@ISA $VERSION $DEBUG $SSL_ERROR $GLOBAL_CONTEXT_ARGS @EXPORT ); 44 45{ 46 # These constants will be used in $! at return from SSL_connect, 47 # SSL_accept, generic_read and write, thus notifying the caller 48 # the usual way of problems. Like with EAGAIN, EINPROGRESS.. 49 # these are especially important for non-blocking sockets 50 51 my $x = Net::SSLeay::ERROR_WANT_READ(); 52 use constant SSL_WANT_READ => dualvar( \$x, 'SSL wants a read first' ); 53 my $y = Net::SSLeay::ERROR_WANT_WRITE(); 54 use constant SSL_WANT_WRITE => dualvar( \$y, 'SSL wants a write first' ); 55 56 @EXPORT = qw( 57 SSL_WANT_READ SSL_WANT_WRITE SSL_VERIFY_NONE SSL_VERIFY_PEER 58 SSL_VERIFY_FAIL_IF_NO_PEER_CERT SSL_VERIFY_CLIENT_ONCE 59 $SSL_ERROR GEN_DNS GEN_IPADD 60 ); 61} 62 63my @caller_force_inet4; # in case inet4 gets forced we store here who forced it 64 65BEGIN { 66 # Declare @ISA, $VERSION, $GLOBAL_CONTEXT_ARGS 67 68 # try to load inet_pton from Socket or Socket6 69 my $ip6 = eval { 70 require Socket; 71 Socket->VERSION(1.95); 72 Socket->import( 'inet_pton' ); 73 1; 74 } || eval { 75 require Socket6; 76 Socket6->import( 'inet_pton' ); 77 1; 78 }; 79 80 # try IO::Socket::IP or IO::Socket::INET6 for IPv6 support 81 if ( $ip6 ) { 82 83 # if we have IO::Socket::IP >= 0.11 we will use this in preference 84 # because it can handle both IPv4 and IPv6 85 if ( eval { require IO::Socket::IP; IO::Socket::IP->VERSION(0.11); } ) { 86 @ISA = qw(IO::Socket::IP); 87 constant->import( CAN_IPV6 => "IO::Socket::IP" ); 88 89 # if we have IO::Socket::INET6 we will use this not IO::Socket::INET 90 # because it can handle both IPv4 and IPv6 91 } elsif( eval { require IO::Socket::INET6; } ) { 92 @ISA = qw(IO::Socket::INET6); 93 constant->import( CAN_IPV6 => "IO::Socket::INET6" ); 94 } else { 95 $ip6 = 0; 96 } 97 } 98 99 # fall back to IO::Socket::INET for IPv4 only 100 if ( ! $ip6 ) { 101 @ISA = qw(IO::Socket::INET); 102 constant->import( CAN_IPV6 => '' ); 103 } 104 105 $VERSION = '1.76'; 106 $GLOBAL_CONTEXT_ARGS = {}; 107 108 #Make $DEBUG another name for $Net::SSLeay::trace 109 *DEBUG = \$Net::SSLeay::trace; 110 111 #Compability 112 *ERROR = \$SSL_ERROR; 113 114 # Do Net::SSLeay initialization 115 Net::SSLeay::load_error_strings(); 116 Net::SSLeay::SSLeay_add_ssl_algorithms(); 117 Net::SSLeay::randomize(); 118} 119 120sub DEBUG { 121 $DEBUG>=shift or return; # check against debug level 122 my (undef,$file,$line) = caller; 123 my $msg = shift; 124 $file = '...'.substr( $file,-17 ) if length($file)>20; 125 $msg = sprintf $msg,@_ if @_; 126 print STDERR "DEBUG: $file:$line: $msg\n"; 127} 128 129BEGIN { 130 # import some constants from Net::SSLeay or use hard-coded defaults 131 # if Net::SSLeay isn't recent enough to provide the constants 132 my %const = ( 133 NID_CommonName => 13, 134 GEN_DNS => 2, 135 GEN_IPADD => 7, 136 ); 137 while ( my ($name,$value) = each %const ) { 138 no strict 'refs'; 139 *{$name} = UNIVERSAL::can( 'Net::SSLeay', $name ) || sub { $value }; 140 } 141 142 # check if we have something to handle IDN 143 local $SIG{__DIE__}; local $SIG{__WARN__}; # be silent 144 if ( eval { require Net::IDN::Encode }) { 145 *{idn_to_ascii} = \&Net::IDN::Encode::domain_to_ascii; 146 } elsif ( eval { require Net::LibIDN }) { 147 *{idn_to_ascii} = \&Net::LibIDN::idn_to_ascii; 148 } elsif ( eval { require URI; URI->VERSION(1.50) }) { 149 *{idn_to_ascii} = sub { URI->new("http://" . shift)->host } 150 } else { 151 # default: croak if we really got an unencoded international domain 152 *{idn_to_ascii} = sub { 153 my $domain = shift; 154 return $domain if $domain =~m{^[a-zA-Z0-9-_\.]+$}; 155 croak "cannot handle international domains, please install Net::LibIDN, Net::IDN::Encode or URI" 156 } 157 } 158} 159 160# Export some stuff 161# inet4|inet6|debug will be handeled by myself, everything 162# else will be handeld the Exporter way 163sub import { 164 my $class = shift; 165 166 my @export; 167 foreach (@_) { 168 if ( /^inet4$/i ) { 169 # explicitly fall back to inet4 170 @ISA = 'IO::Socket::INET'; 171 @caller_force_inet4 = caller(); # save for warnings for 'inet6' case 172 } elsif ( /^inet6$/i ) { 173 # check if we have already ipv6 as base 174 if ( ! UNIVERSAL::isa( $class, 'IO::Socket::INET6' )) { 175 # either we don't support it or we disabled it by explicitly 176 # loading it with 'inet4'. In this case re-enable but warn 177 # because this is probably an error 178 if ( CAN_IPV6 ) { 179 @ISA = ( CAN_IPV6 ); 180 warn "IPv6 support re-enabled in __PACKAGE__, got disabled in file $caller_force_inet4[1] line $caller_force_inet4[2]"; 181 } else { 182 die "INET6 is not supported, install IO::Socket::INET6"; 183 } 184 } 185 } elsif ( /^:?debug(\d+)/ ) { 186 $DEBUG=$1; 187 } else { 188 push @export,$_ 189 } 190 } 191 192 @_ = ( $class,@export ); 193 goto &Exporter::import; 194} 195 196my %CREATED_IN_THIS_THREAD; 197sub CLONE { %CREATED_IN_THIS_THREAD = (); } 198 199# You might be expecting to find a new() subroutine here, but that is 200# not how IO::Socket::INET works. All configuration gets performed in 201# the calls to configure() and either connect() or accept(). 202 203#Call to configure occurs when a new socket is made using 204#IO::Socket::INET. Returns false (empty list) on failure. 205sub configure { 206 my ($self, $arg_hash) = @_; 207 return _invalid_object() unless($self); 208 209 # work around Bug in IO::Socket::INET6 where it doesn't use the 210 # right family for the socket on BSD systems: 211 # http://rt.cpan.org/Ticket/Display.html?id=39550 212 if ( CAN_IPV6 eq "IO::Socket::INET6" && ! $arg_hash->{Domain} && 213 ! ( $arg_hash->{LocalAddr} || $arg_hash->{LocalHost} ) && 214 (my $peer = $arg_hash->{PeerAddr} || $arg_hash->{PeerHost})) { 215 # set Domain to AF_INET/AF_INET6 if there is only one choice 216 ($peer, my $port) = IO::Socket::INET6::_sock_info( $peer,$arg_hash->{PeerPort},6 ); 217 my @res = Socket6::getaddrinfo( $peer,$port,AF_UNSPEC,SOCK_STREAM ); 218 if (@res == 5) { 219 $arg_hash->{Domain} = $res[0]; 220 DEBUG(2,'set domain to '.$res[0] ); 221 } 222 } 223 224 # force initial blocking 225 # otherwise IO::Socket::SSL->new might return undef if the 226 # socket is nonblocking and it fails to connect immediatly 227 # for real nonblocking behavior one should create a nonblocking 228 # socket and later call connect explicitly 229 my $blocking = delete $arg_hash->{Blocking}; 230 231 # because Net::HTTPS simple redefines blocking() to {} (e.g 232 # return undef) and IO::Socket::INET does not like this we 233 234 # set Blocking only explicitly if it was set 235 $arg_hash->{Blocking} = 1 if defined ($blocking); 236 237 $self->configure_SSL($arg_hash) || return; 238 239 $self->SUPER::configure($arg_hash) 240 || return $self->error("@ISA configuration failed"); 241 242 $self->blocking(0) if defined $blocking && !$blocking; 243 return $self; 244} 245 246sub configure_SSL { 247 my ($self, $arg_hash) = @_; 248 249 my $is_server = $arg_hash->{'SSL_server'} || $arg_hash->{'Listen'} || 0; 250 251 my %default_args = ( 252 Proto => 'tcp', 253 SSL_server => $is_server, 254 SSL_use_cert => $is_server, 255 SSL_check_crl => 0, 256 SSL_version => DEFAULT_VERSION, 257 SSL_verify_mode => SSL_VERIFY_NONE, 258 SSL_verify_callback => undef, 259 SSL_verifycn_scheme => undef, # don't verify cn 260 SSL_verifycn_name => undef, # use from PeerAddr/PeerHost 261 SSL_npn_protocols => undef, # meaning depends whether on server or client side 262 SSL_honor_cipher_order => 0, # client order gets preference 263 ); 264 265 # common problem forgetting SSL_use_cert 266 # if client cert is given but SSL_use_cert undef assume that it 267 # should be set 268 if ( ! $is_server && ! defined $arg_hash->{SSL_use_cert} 269 && ( grep { $arg_hash->{$_} } qw(SSL_cert SSL_cert_file)) 270 && ( grep { $arg_hash->{$_} } qw(SSL_key SSL_key_file)) ) { 271 $arg_hash->{SSL_use_cert} = 1 272 } 273 274 # SSL_key_file and SSL_cert_file will only be set in defaults if 275 # SSL_key|SSL_key_file resp SSL_cert|SSL_cert_file are not set in 276 # $args_hash 277 foreach my $k (qw( key cert )) { 278 next if exists $arg_hash->{ "SSL_${k}" }; 279 next if exists $arg_hash->{ "SSL_${k}_file" }; 280 $default_args{ "SSL_${k}_file" } = $is_server 281 ? "certs/server-${k}.pem" 282 : "certs/client-${k}.pem"; 283 } 284 285 # add only SSL_ca_* if not in args 286 if ( ! exists $arg_hash->{SSL_ca_file} && ! exists $arg_hash->{SSL_ca_path} ) { 287 if ( -f 'certs/my-ca.pem' ) { 288 $default_args{SSL_ca_file} = 'certs/my-ca.pem' 289 } elsif ( -d 'ca/' ) { 290 $default_args{SSL_ca_path} = 'ca/' 291 } 292 } 293 294 #Replace nonexistent entries with defaults 295 %$arg_hash = ( %default_args, %$GLOBAL_CONTEXT_ARGS, %$arg_hash ); 296 297 #Avoid passing undef arguments to Net::SSLeay 298 defined($arg_hash->{$_}) or delete($arg_hash->{$_}) foreach (keys %$arg_hash); 299 300 my $vcn_scheme = delete $arg_hash->{SSL_verifycn_scheme}; 301 if ( $vcn_scheme && $vcn_scheme ne 'none' ) { 302 # don't access ${*self} inside callback - this seems to create 303 # circular references from the ssl object to the context and back 304 305 # use SSL_verifycn_name or determine from PeerAddr 306 my $host = $arg_hash->{SSL_verifycn_name}; 307 if (not defined($host)) { 308 if ( $host = $arg_hash->{PeerAddr} || $arg_hash->{PeerHost} ) { 309 $host =~s{:[a-zA-Z0-9_\-]+$}{}; 310 } 311 } 312 $host ||= ref($vcn_scheme) && $vcn_scheme->{callback} && 'unknown'; 313 $host or return $self->error( "Cannot determine peer hostname for verification" ); 314 315 my $vcb = $arg_hash->{SSL_verify_callback}; 316 $arg_hash->{SSL_verify_callback} = sub { 317 my ($ok,$ctx_store,$certname,$error,$cert) = @_; 318 $ok = $vcb->($ok,$ctx_store,$certname,$error,$cert) if $vcb; 319 $ok or return 0; 320 my $depth = Net::SSLeay::X509_STORE_CTX_get_error_depth($ctx_store); 321 return $ok if $depth != 0; 322 323 # verify name 324 my $rv = verify_hostname_of_cert( $host,$cert,$vcn_scheme ); 325 # just do some code here against optimization because x509 has no 326 # increased reference and CRYPTO_add is not available from Net::SSLeay 327 return $rv; 328 }; 329 } 330 331 ${*$self}{'_SSL_arguments'} = $arg_hash; 332 ${*$self}{'_SSL_ctx'} = IO::Socket::SSL::SSL_Context->new($arg_hash) || return; 333 ${*$self}{'_SSL_opened'} = 1 if $is_server; 334 335 return $self; 336} 337 338 339sub _set_rw_error { 340 my ($self,$ssl,$rv) = @_; 341 my $err = Net::SSLeay::get_error($ssl,$rv); 342 $SSL_ERROR = 343 $err == Net::SSLeay::ERROR_WANT_READ() ? SSL_WANT_READ : 344 $err == Net::SSLeay::ERROR_WANT_WRITE() ? SSL_WANT_WRITE : 345 return; 346 $! ||= EAGAIN; 347 ${*$self}{'_SSL_last_err'} = $SSL_ERROR if ref($self); 348 return 1; 349} 350 351 352#Call to connect occurs when a new client socket is made using 353#IO::Socket::INET 354sub connect { 355 my $self = shift || return _invalid_object(); 356 return $self if ${*$self}{'_SSL_opened'}; # already connected 357 358 if ( ! ${*$self}{'_SSL_opening'} ) { 359 # call SUPER::connect if the underlying socket is not connected 360 # if this fails this might not be an error (e.g. if $! = EINPROGRESS 361 # and socket is nonblocking this is normal), so keep any error 362 # handling to the client 363 DEBUG(2, 'socket not yet connected' ); 364 $self->SUPER::connect(@_) || return; 365 DEBUG(2,'socket connected' ); 366 367 # IO::Socket works around systems, which return EISCONN or similar 368 # on non-blocking re-connect by returning true, even if $! is set 369 # but it does not clear $!, so do it here 370 $! = undef; 371 } 372 return $self->connect_SSL; 373} 374 375 376sub connect_SSL { 377 my $self = shift; 378 my $args = @_>1 ? {@_}: $_[0]||{}; 379 380 my ($ssl,$ctx); 381 if ( ! ${*$self}{'_SSL_opening'} ) { 382 # start ssl connection 383 DEBUG(2,'ssl handshake not started' ); 384 ${*$self}{'_SSL_opening'} = 1; 385 my $arg_hash = ${*$self}{'_SSL_arguments'}; 386 387 my $fileno = ${*$self}{'_SSL_fileno'} = fileno($self); 388 return $self->error("Socket has no fileno") unless (defined $fileno); 389 390 $ctx = ${*$self}{'_SSL_ctx'}; # Reference to real context 391 $ssl = ${*$self}{'_SSL_object'} = Net::SSLeay::new($ctx->{context}) 392 || return $self->error("SSL structure creation failed"); 393 $CREATED_IN_THIS_THREAD{$ssl} = 1; 394 395 Net::SSLeay::set_fd($ssl, $fileno) 396 || return $self->error("SSL filehandle association failed"); 397 398 if ( my $cl = exists $arg_hash->{SSL_cipher_list} 399 ? $arg_hash->{SSL_cipher_list} 400 : DEFAULT_CIPHER_LIST ) { 401 Net::SSLeay::set_cipher_list($ssl, $cl ) 402 || return $self->error("Failed to set SSL cipher list"); 403 } 404 405 if (Net::SSLeay::OPENSSL_VERSION_NUMBER() >= 0x009080ef) { 406 my $host; 407 if ( exists $arg_hash->{SSL_hostname} ) { 408 # explicitly given 409 # can be set to undef/'' to not use extension 410 $host = $arg_hash->{SSL_hostname} 411 } elsif ( $host = $arg_hash->{PeerAddr} || $arg_hash->{PeerHost} ) { 412 # implicitly given 413 $host =~s{:[a-zA-Z0-9_\-]+$}{}; 414 # should be hostname, not IPv4/6 415 $host = undef if $host !~m{[a-z_]} or $host =~m{:}; 416 } 417 # define SSL_CTRL_SET_TLSEXT_HOSTNAME 55 418 # define TLSEXT_NAMETYPE_host_name 0 419 Net::SSLeay::ctrl($ssl,55,0,$host) if $host; 420 } 421 422 $arg_hash->{PeerAddr} || $self->_update_peer; 423 my $session = $ctx->session_cache( $arg_hash->{PeerAddr}, $arg_hash->{PeerPort} ); 424 Net::SSLeay::set_session($ssl, $session) if ($session); 425 } 426 427 $ssl ||= ${*$self}{'_SSL_object'}; 428 429 $SSL_ERROR = undef; 430 my $timeout = exists $args->{Timeout} 431 ? $args->{Timeout} 432 : ${*$self}{io_socket_timeout}; # from IO::Socket 433 if ( defined($timeout) && $timeout>0 && $self->blocking(0) ) { 434 DEBUG(2, "set socket to non-blocking to enforce timeout=$timeout" ); 435 # timeout was given and socket was blocking 436 # enforce timeout with now non-blocking socket 437 } else { 438 # timeout does not apply because invalid or socket non-blocking 439 $timeout = undef; 440 } 441 442 my $start = defined($timeout) && time(); 443 for my $dummy (1) { 444 #DEBUG( 'calling ssleay::connect' ); 445 my $rv = Net::SSLeay::connect($ssl); 446 DEBUG( 3,"Net::SSLeay::connect -> $rv" ); 447 if ( $rv < 0 ) { 448 unless ( $self->_set_rw_error( $ssl,$rv )) { 449 $self->error("SSL connect attempt failed with unknown error"); 450 delete ${*$self}{'_SSL_opening'}; 451 ${*$self}{'_SSL_opened'} = -1; 452 DEBUG(1, "fatal SSL error: $SSL_ERROR" ); 453 return $self->fatal_ssl_error(); 454 } 455 456 DEBUG(2,'ssl handshake in progress' ); 457 # connect failed because handshake needs to be completed 458 # if socket was non-blocking or no timeout was given return with this error 459 return if ! defined($timeout); 460 461 # wait until socket is readable or writable 462 my $rv; 463 if ( $timeout>0 ) { 464 my $vec = ''; 465 vec($vec,$self->fileno,1) = 1; 466 DEBUG(2, "waiting for fd to become ready: $SSL_ERROR" ); 467 $rv = 468 $SSL_ERROR == SSL_WANT_READ ? select( $vec,undef,undef,$timeout) : 469 $SSL_ERROR == SSL_WANT_WRITE ? select( undef,$vec,undef,$timeout) : 470 undef; 471 } else { 472 DEBUG(2,"handshake failed because no more time" ); 473 $! = ETIMEDOUT 474 } 475 if ( ! $rv ) { 476 DEBUG(2,"handshake failed because socket did not became ready" ); 477 # failed because of timeout, return 478 $! ||= ETIMEDOUT; 479 delete ${*$self}{'_SSL_opening'}; 480 ${*$self}{'_SSL_opened'} = -1; 481 $self->blocking(1); # was blocking before 482 return 483 } 484 485 # socket is ready, try non-blocking connect again after recomputing timeout 486 DEBUG(2,"socket ready, retrying connect" ); 487 my $now = time(); 488 $timeout -= $now - $start; 489 $start = $now; 490 redo; 491 492 } elsif ( $rv == 0 ) { 493 delete ${*$self}{'_SSL_opening'}; 494 DEBUG(2,"connection failed - connect returned 0" ); 495 $self->error("SSL connect attempt failed because of handshake problems" ); 496 ${*$self}{'_SSL_opened'} = -1; 497 return $self->fatal_ssl_error(); 498 } 499 } 500 501 DEBUG(2,'ssl handshake done' ); 502 # ssl connect successful 503 delete ${*$self}{'_SSL_opening'}; 504 ${*$self}{'_SSL_opened'}=1; 505 $self->blocking(1) if defined($timeout); # was blocking before 506 507 $ctx ||= ${*$self}{'_SSL_ctx'}; 508 if ( $ctx->has_session_cache ) { 509 my $arg_hash = ${*$self}{'_SSL_arguments'}; 510 $arg_hash->{PeerAddr} || $self->_update_peer; 511 my ($addr,$port) = ( $arg_hash->{PeerAddr}, $arg_hash->{PeerPort} ); 512 my $session = $ctx->session_cache( $addr,$port ); 513 $ctx->session_cache( $addr,$port, Net::SSLeay::get1_session($ssl) ) if !$session; 514 } 515 516 tie *{$self}, "IO::Socket::SSL::SSL_HANDLE", $self; 517 518 return $self; 519} 520 521# called if PeerAddr is not set in ${*$self}{'_SSL_arguments'} 522# this can be the case if start_SSL is called with a normal IO::Socket::INET 523# so that PeerAddr|PeerPort are not set from args 524sub _update_peer { 525 my $self = shift; 526 my $arg_hash = ${*$self}{'_SSL_arguments'}; 527 eval { 528 my ($port,$addr) = sockaddr_in( getpeername( $self )); 529 $arg_hash->{PeerAddr} = inet_ntoa( $addr ); 530 $arg_hash->{PeerPort} = $port; 531 } 532} 533 534#Call to accept occurs when a new client connects to a server using 535#IO::Socket::SSL 536sub accept { 537 my $self = shift || return _invalid_object(); 538 my $class = shift || 'IO::Socket::SSL'; 539 540 my $socket = ${*$self}{'_SSL_opening'}; 541 if ( ! $socket ) { 542 # underlying socket not done 543 DEBUG(2,'no socket yet' ); 544 $socket = $self->SUPER::accept($class) || return; 545 DEBUG(2,'accept created normal socket '.$socket ); 546 } 547 548 $self->accept_SSL($socket) || return; 549 DEBUG(2,'accept_SSL ok' ); 550 551 return wantarray ? ($socket, getpeername($socket) ) : $socket; 552} 553 554sub accept_SSL { 555 my $self = shift; 556 my $socket = ( @_ && UNIVERSAL::isa( $_[0], 'IO::Handle' )) ? shift : $self; 557 my $args = @_>1 ? {@_}: $_[0]||{}; 558 559 my $ssl; 560 if ( ! ${*$self}{'_SSL_opening'} ) { 561 DEBUG(2,'starting sslifying' ); 562 ${*$self}{'_SSL_opening'} = $socket; 563 my $arg_hash = ${*$self}{'_SSL_arguments'}; 564 ${*$socket}{'_SSL_arguments'} = { %$arg_hash, SSL_server => 0 }; 565 my $ctx = ${*$socket}{'_SSL_ctx'} = ${*$self}{'_SSL_ctx'}; 566 567 my $fileno = ${*$socket}{'_SSL_fileno'} = fileno($socket); 568 return $socket->error("Socket has no fileno") unless (defined $fileno); 569 570 $ssl = ${*$socket}{'_SSL_object'} = Net::SSLeay::new($ctx->{context}) 571 || return $socket->error("SSL structure creation failed"); 572 $CREATED_IN_THIS_THREAD{$ssl} = 1; 573 574 Net::SSLeay::set_fd($ssl, $fileno) 575 || return $socket->error("SSL filehandle association failed"); 576 577 if ( my $cl = exists $arg_hash->{SSL_cipher_list} 578 ? $arg_hash->{SSL_cipher_list} 579 : DEFAULT_CIPHER_LIST) { 580 Net::SSLeay::set_cipher_list($ssl, $cl ) 581 || return $socket->error("Failed to set SSL cipher list"); 582 } 583 } 584 585 $ssl ||= ${*$socket}{'_SSL_object'}; 586 587 $SSL_ERROR = undef; 588 #DEBUG(2,'calling ssleay::accept' ); 589 590 my $timeout = exists $args->{Timeout} 591 ? $args->{Timeout} 592 : ${*$self}{io_socket_timeout}; # from IO::Socket 593 if ( defined($timeout) && $timeout>0 && $socket->blocking(0) ) { 594 # timeout was given and socket was blocking 595 # enforce timeout with now non-blocking socket 596 } else { 597 # timeout does not apply because invalid or socket non-blocking 598 $timeout = undef; 599 } 600 601 my $start = defined($timeout) && time(); 602 for my $dummy (1) { 603 my $rv = Net::SSLeay::accept($ssl); 604 DEBUG(3, "Net::SSLeay::accept -> $rv" ); 605 if ( $rv < 0 ) { 606 unless ( $socket->_set_rw_error( $ssl,$rv )) { 607 $socket->error("SSL accept attempt failed with unknown error"); 608 delete ${*$self}{'_SSL_opening'}; 609 ${*$socket}{'_SSL_opened'} = -1; 610 return $socket->fatal_ssl_error(); 611 } 612 613 # accept failed because handshake needs to be completed 614 # if socket was non-blocking or no timeout was given return with this error 615 return if ! defined($timeout); 616 617 # wait until socket is readable or writable 618 my $rv; 619 if ( $timeout>0 ) { 620 my $vec = ''; 621 vec($vec,$socket->fileno,1) = 1; 622 $rv = 623 $SSL_ERROR == SSL_WANT_READ ? select( $vec,undef,undef,$timeout) : 624 $SSL_ERROR == SSL_WANT_WRITE ? select( undef,$vec,undef,$timeout) : 625 undef; 626 } else { 627 $! = ETIMEDOUT 628 } 629 if ( ! $rv ) { 630 # failed because of timeout, return 631 $! ||= ETIMEDOUT; 632 delete ${*$self}{'_SSL_opening'}; 633 ${*$socket}{'_SSL_opened'} = -1; 634 $socket->blocking(1); # was blocking before 635 return 636 } 637 638 # socket is ready, try non-blocking accept again after recomputing timeout 639 my $now = time(); 640 $timeout -= $now - $start; 641 $start = $now; 642 redo; 643 644 } elsif ( $rv == 0 ) { 645 $socket->error("SSL connect accept failed because of handshake problems" ); 646 delete ${*$self}{'_SSL_opening'}; 647 ${*$socket}{'_SSL_opened'} = -1; 648 return $socket->fatal_ssl_error(); 649 } 650 } 651 652 DEBUG(2,'handshake done, socket ready' ); 653 # socket opened 654 delete ${*$self}{'_SSL_opening'}; 655 ${*$socket}{'_SSL_opened'} = 1; 656 $socket->blocking(1) if defined($timeout); # was blocking before 657 658 tie *{$socket}, "IO::Socket::SSL::SSL_HANDLE", $socket; 659 660 return $socket; 661} 662 663 664####### I/O subroutines ######################## 665 666sub generic_read { 667 my ($self, $read_func, undef, $length, $offset) = @_; 668 my $ssl = $self->_get_ssl_object || return; 669 my $buffer=\$_[2]; 670 671 $SSL_ERROR = undef; 672 my $data = $read_func->($ssl, $length); 673 if ( !defined($data)) { 674 $self->_set_rw_error( $ssl,-1 ) || $self->error("SSL read error"); 675 return; 676 } 677 678 $length = length($data); 679 $$buffer = '' if !defined $$buffer; 680 $offset ||= 0; 681 if ($offset>length($$buffer)) { 682 $$buffer.="\0" x ($offset-length($$buffer)); #mimic behavior of read 683 } 684 685 substr($$buffer, $offset, length($$buffer), $data); 686 return $length; 687} 688 689sub read { 690 my $self = shift; 691 return $self->generic_read( 692 $self->blocking ? \&Net::SSLeay::ssl_read_all : \&Net::SSLeay::read, 693 @_ 694 ); 695} 696 697# contrary to the behavior of read sysread can read partial data 698sub sysread { 699 my $self = shift; 700 return $self->generic_read( \&Net::SSLeay::read, @_ ); 701} 702 703sub peek { 704 my $self = shift; 705 if (Net::SSLeay::OPENSSL_VERSION_NUMBER() >= 0x0090601f) { 706 return $self->generic_read(\&Net::SSLeay::peek, @_); 707 } else { 708 return $self->error("SSL_peek not supported for OpenSSL < v0.9.6a"); 709 } 710} 711 712 713sub generic_write { 714 my ($self, $write_all, undef, $length, $offset) = @_; 715 716 my $ssl = $self->_get_ssl_object || return; 717 my $buffer = \$_[2]; 718 719 my $buf_len = length($$buffer); 720 $length ||= $buf_len; 721 $offset ||= 0; 722 return $self->error("Invalid offset for SSL write") if ($offset>$buf_len); 723 return 0 if ($offset == $buf_len); 724 725 $SSL_ERROR = undef; 726 my $written; 727 if ( $write_all ) { 728 my $data = $length < $buf_len-$offset ? substr($$buffer, $offset, $length) : $$buffer; 729 ($written, my $errs) = Net::SSLeay::ssl_write_all($ssl, $data); 730 # ssl_write_all returns number of bytes written 731 $written = undef if ! $written && $errs; 732 } else { 733 $written = Net::SSLeay::write_partial( $ssl,$offset,$length,$$buffer ); 734 # write_partial does SSL_write which returns -1 on error 735 $written = undef if $written < 0; 736 } 737 if ( !defined($written) ) { 738 $self->_set_rw_error( $ssl,-1 ) 739 || $self->error("SSL write error"); 740 return; 741 } 742 743 return $written; 744} 745 746# if socket is blocking write() should return only on error or 747# if all data are written 748sub write { 749 my $self = shift; 750 return $self->generic_write( scalar($self->blocking),@_ ); 751} 752 753# contrary to write syswrite() returns already if only 754# a part of the data is written 755sub syswrite { 756 my $self = shift; 757 return $self->generic_write( 0,@_ ); 758} 759 760sub print { 761 my $self = shift; 762 my $string = join(($, or ''), @_, ($\ or '')); 763 return $self->write( $string ); 764} 765 766sub printf { 767 my ($self,$format) = (shift,shift); 768 return $self->write(sprintf($format, @_)); 769} 770 771sub getc { 772 my ($self, $buffer) = (shift, undef); 773 return $buffer if $self->read($buffer, 1, 0); 774} 775 776sub readline { 777 my $self = shift; 778 779 if ( not defined $/ or wantarray) { 780 # read all and split 781 782 my $buf = ''; 783 while (1) { 784 my $rv = $self->sysread($buf,2**16,length($buf)); 785 if ( ! defined $rv ) { 786 next if $!{EINTR}; 787 return; 788 } elsif ( ! $rv ) { 789 last 790 } 791 } 792 793 if ( ! defined $/ ) { 794 return $buf 795 } elsif ( ref($/)) { 796 my $size = ${$/}; 797 die "bad value in ref \$/: $size" unless $size>0; 798 return $buf=~m{\G(.{1,$size})}g; 799 } elsif ( $/ eq '' ) { 800 return $buf =~m{\G(.*\n\n+|.+)}g; 801 } else { 802 return $buf =~m{\G(.*$/|.+)}g; 803 } 804 } 805 806 # read only one line 807 if ( ref($/) ) { 808 my $size = ${$/}; 809 # read record of $size bytes 810 die "bad value in ref \$/: $size" unless $size>0; 811 my $buf = ''; 812 while ( $size>length($buf)) { 813 my $rv = $self->sysread($buf,$size-length($buf),length($buf)); 814 if ( ! defined $rv ) { 815 next if $!{EINTR}; 816 return; 817 } elsif ( ! $rv ) { 818 last 819 } 820 } 821 return $buf; 822 } 823 824 my ($delim0,$delim1) = $/ eq '' ? ("\n\n","\n"):($/,''); 825 826 if ( Net::SSLeay::OPENSSL_VERSION_NUMBER() < 0x0090601f ) { 827 # no usable peek - need to read byte after byte 828 die "empty \$/ is not supported if I don't have peek" if $delim1 ne ''; 829 my $buf = ''; 830 while (1) { 831 my $rv = $self->sysread($buf,1,length($buf)); 832 if ( ! defined $rv ) { 833 next if $!{EINTR}; 834 return; 835 } elsif ( ! $rv ) { 836 last 837 } 838 index($buf,$delim0) >= 0 and last; 839 } 840 return $buf; 841 } 842 843 844 # find first occurence of $delim0 followed by as much as possible $delim1 845 my $buf = ''; 846 my $eod = 0; # pointer into $buf after $delim0 $delim1* 847 my $ssl = $self->_get_ssl_object or return; 848 while (1) { 849 850 # block until we have more data or eof 851 my $poke = Net::SSLeay::peek($ssl,1); 852 if ( ! defined $poke or $poke eq '' ) { 853 next if $!{EINTR}; 854 } 855 856 my $skip = 0; 857 858 # peek into available data w/o reading 859 my $pending = Net::SSLeay::pending($ssl); 860 if ( $pending and 861 ( my $pb = Net::SSLeay::peek( $ssl,$pending )) ne '' ) { 862 $buf .= $pb 863 } else { 864 return $buf eq '' ? ():$buf; 865 }; 866 if ( !$eod ) { 867 my $pos = index( $buf,$delim0 ); 868 if ( $pos<0 ) { 869 $skip = $pending 870 } else { 871 $eod = $pos + length($delim0); # pos after delim0 872 } 873 } 874 875 if ( $eod ) { 876 if ( $delim1 ne '' ) { 877 # delim0 found, check for as much delim1 as possible 878 while ( index( $buf,$delim1,$eod ) == $eod ) { 879 $eod+= length($delim1); 880 } 881 } 882 $skip = $pending - ( length($buf) - $eod ); 883 } 884 885 # remove data from $self which I already have in buf 886 while ( $skip>0 ) { 887 if ($self->sysread(my $p,$skip,0)) { 888 $skip -= length($p); 889 next; 890 } 891 $!{EINTR} or last; 892 } 893 894 if ( $eod and ( $delim1 eq '' or $eod < length($buf))) { 895 # delim0 found and there can be no more delim1 pending 896 last 897 } 898 } 899 return substr($buf,0,$eod); 900} 901 902sub close { 903 my $self = shift || return _invalid_object(); 904 my $close_args = (ref($_[0]) eq 'HASH') ? $_[0] : {@_}; 905 906 return if ! $self->stop_SSL( 907 SSL_fast_shutdown => 1, 908 %$close_args, 909 _SSL_ioclass_downgrade => 0, 910 ); 911 912 if ( ! $close_args->{_SSL_in_DESTROY} ) { 913 untie( *$self ); 914 undef ${*$self}{_SSL_fileno}; 915 return $self->SUPER::close; 916 } 917 return 1; 918} 919 920sub stop_SSL { 921 my $self = shift || return _invalid_object(); 922 my $stop_args = (ref($_[0]) eq 'HASH') ? $_[0] : {@_}; 923 $stop_args->{SSL_no_shutdown} = 1 if ! ${*$self}{_SSL_opened}; 924 925 if (my $ssl = ${*$self}{'_SSL_object'}) { 926 my $shutdown_done; 927 if ( $stop_args->{SSL_no_shutdown} ) { 928 $shutdown_done = 1; 929 } else { 930 my $fast = $stop_args->{SSL_fast_shutdown}; 931 my $status = Net::SSLeay::get_shutdown($ssl); 932 if ( $fast && $status != 0) { 933 # shutdown done, either status has 934 # SSL_SENT_SHUTDOWN or SSL_RECEIVED_SHUTDOWN or both, 935 # so the handshake is at least in process 936 $shutdown_done = 1; 937 } elsif ( ( $status & SSL_SENT_SHUTDOWN ) == 0 ) { 938 # need to initiate/continue shutdown 939 local $SIG{PIPE} = 'IGNORE'; 940 for my $try (1,2 ) { 941 my $rv = Net::SSLeay::shutdown($ssl); 942 if ( $rv < 0 ) { 943 # non-blocking socket? 944 $self->_set_rw_error( $ssl,$rv ); 945 # need to try again 946 return; 947 } elsif ( $rv 948 || ( $rv == 0 && $fast )) { 949 # shutdown finished 950 $shutdown_done = 1; 951 last; 952 } else { 953 # shutdown partly initiated (e.g. one direction) 954 # call again 955 } 956 } 957 } elsif ( $status & SSL_RECEIVED_SHUTDOWN ) { 958 # SSL_SENT_SHUTDOWN is done already (previous if-case) 959 # and because SSL_RECEIVED_SHUTDOWN is done also we 960 # consider the shutdown done 961 $shutdown_done = 1; 962 } 963 } 964 965 return if ! $shutdown_done; 966 Net::SSLeay::free($ssl); 967 delete ${*$self}{_SSL_object}; 968 } 969 970 if ($stop_args->{'SSL_ctx_free'}) { 971 my $ctx = delete ${*$self}{'_SSL_ctx'}; 972 $ctx && $ctx->DESTROY(); 973 } 974 975 if (my $cert = delete ${*$self}{'_SSL_certificate'}) { 976 Net::SSLeay::X509_free($cert); 977 } 978 979 ${*$self}{'_SSL_opened'} = 0; 980 981 if ( ! $stop_args->{_SSL_in_DESTROY} ) { 982 983 my $downgrade = $stop_args->{_SSL_ioclass_downgrade}; 984 if ( $downgrade || ! defined $downgrade ) { 985 # rebless to original class from start_SSL 986 if ( my $orig_class = delete ${*$self}{'_SSL_ioclass_upgraded'} ) { 987 bless $self,$orig_class; 988 untie(*$self); 989 # FIXME: if original class was tied too we need to restore the tie 990 } 991 # remove all _SSL related from *$self 992 my @sslkeys = grep { m{^_?SSL_} } keys %{*$self}; 993 delete @{*$self}{@sslkeys} if @sslkeys; 994 } 995 } 996 return 1; 997} 998 999 1000sub fileno { 1001 my $self = shift; 1002 my $fn = ${*$self}{'_SSL_fileno'}; 1003 return defined($fn) ? $fn : $self->SUPER::fileno(); 1004} 1005 1006 1007####### IO::Socket::SSL specific functions ####### 1008# _get_ssl_object is for internal use ONLY! 1009sub _get_ssl_object { 1010 my $self = shift; 1011 my $ssl = ${*$self}{'_SSL_object'}; 1012 return IO::Socket::SSL->error("Undefined SSL object") unless($ssl); 1013 return $ssl; 1014} 1015 1016# _get_ctx_object is for internal use ONLY! 1017sub _get_ctx_object { 1018 my $self = shift; 1019 my $ctx_object = ${*$self}{_SSL_ctx}; 1020 return $ctx_object && $ctx_object->{context}; 1021} 1022 1023# default error for undefined arguments 1024sub _invalid_object { 1025 return IO::Socket::SSL->error("Undefined IO::Socket::SSL object"); 1026} 1027 1028 1029sub pending { 1030 my $ssl = shift()->_get_ssl_object || return; 1031 return Net::SSLeay::pending($ssl); 1032} 1033 1034sub start_SSL { 1035 my ($class,$socket) = (shift,shift); 1036 return $class->error("Not a socket") unless(ref($socket)); 1037 my $arg_hash = (ref($_[0]) eq 'HASH') ? $_[0] : {@_}; 1038 my %to = exists $arg_hash->{Timeout} ? ( Timeout => delete $arg_hash->{Timeout} ) :(); 1039 my $original_class = ref($socket); 1040 my $original_fileno = (UNIVERSAL::can($socket, "fileno")) 1041 ? $socket->fileno : CORE::fileno($socket); 1042 return $class->error("Socket has no fileno") unless defined $original_fileno; 1043 1044 bless $socket, $class; 1045 $socket->configure_SSL($arg_hash) or bless($socket, $original_class) && return; 1046 1047 ${*$socket}{'_SSL_fileno'} = $original_fileno; 1048 ${*$socket}{'_SSL_ioclass_upgraded'} = $original_class; 1049 1050 my $start_handshake = $arg_hash->{SSL_startHandshake}; 1051 if ( ! defined($start_handshake) || $start_handshake ) { 1052 # if we have no callback force blocking mode 1053 DEBUG(2, "start handshake" ); 1054 my $blocking = $socket->blocking(1); 1055 my $result = ${*$socket}{'_SSL_arguments'}{SSL_server} 1056 ? $socket->accept_SSL(%to) 1057 : $socket->connect_SSL(%to); 1058 $socket->blocking(0) if !$blocking; 1059 return $result ? $socket : (bless($socket, $original_class) && ()); 1060 } else { 1061 DEBUG(2, "dont start handshake: $socket" ); 1062 return $socket; # just return upgraded socket 1063 } 1064 1065} 1066 1067sub new_from_fd { 1068 my ($class, $fd) = (shift,shift); 1069 # Check for accidental inclusion of MODE in the argument list 1070 if (length($_[0]) < 4) { 1071 (my $mode = $_[0]) =~ tr/+<>//d; 1072 shift unless length($mode); 1073 } 1074 my $handle = $ISA[0]->new_from_fd($fd, '+<') 1075 || return($class->error("Could not create socket from file descriptor.")); 1076 1077 # Annoying workaround for Perl 5.6.1 and below: 1078 $handle = $ISA[0]->new_from_fd($handle, '+<'); 1079 1080 return $class->start_SSL($handle, @_); 1081} 1082 1083 1084sub dump_peer_certificate { 1085 my $ssl = shift()->_get_ssl_object || return; 1086 return Net::SSLeay::dump_peer_certificate($ssl); 1087} 1088 1089{ 1090 my %dispatcher = ( 1091 issuer => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_issuer_name( shift )) }, 1092 subject => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_subject_name( shift )) }, 1093 ); 1094 if ( $Net::SSLeay::VERSION >= 1.30 ) { 1095 # I think X509_NAME_get_text_by_NID got added in 1.30 1096 $dispatcher{commonName} = sub { 1097 my $cn = Net::SSLeay::X509_NAME_get_text_by_NID( 1098 Net::SSLeay::X509_get_subject_name( shift ), NID_CommonName); 1099 $cn =~s{\0$}{}; # work around Bug in Net::SSLeay <1.33 1100 $cn; 1101 } 1102 } else { 1103 $dispatcher{commonName} = sub { 1104 croak "you need at least Net::SSLeay version 1.30 for getting commonName" 1105 } 1106 } 1107 1108 if ( $Net::SSLeay::VERSION >= 1.33 ) { 1109 # X509_get_subjectAltNames did not really work before 1110 $dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) }; 1111 } else { 1112 $dispatcher{subjectAltNames} = sub { 1113 croak "you need at least Net::SSLeay version 1.33 for getting subjectAltNames" 1114 }; 1115 } 1116 1117 # alternative names 1118 $dispatcher{authority} = $dispatcher{issuer}; 1119 $dispatcher{owner} = $dispatcher{subject}; 1120 $dispatcher{cn} = $dispatcher{commonName}; 1121 1122 sub peer_certificate { 1123 my ($self, $field) = @_; 1124 my $ssl = $self->_get_ssl_object or return; 1125 1126 my $cert = ${*$self}{_SSL_certificate} 1127 ||= Net::SSLeay::get_peer_certificate($ssl) 1128 or return $self->error("Could not retrieve peer certificate"); 1129 1130 if ($field) { 1131 my $sub = $dispatcher{$field} or croak 1132 "invalid argument for peer_certificate, valid are: ".join( " ",keys %dispatcher ). 1133 "\nMaybe you need to upgrade your Net::SSLeay"; 1134 return $sub->($cert); 1135 } else { 1136 return $cert 1137 } 1138 } 1139 1140 # known schemes, possible attributes are: 1141 # - wildcards_in_alt (0, 'leftmost', 'anywhere') 1142 # - wildcards_in_cn (0, 'leftmost', 'anywhere') 1143 # - check_cn (0, 'always', 'when_only') 1144 1145 my %scheme = ( 1146 # rfc 4513 1147 ldap => { 1148 wildcards_in_cn => 0, 1149 wildcards_in_alt => 'leftmost', 1150 check_cn => 'always', 1151 }, 1152 # rfc 2818 1153 http => { 1154 wildcards_in_cn => 'anywhere', 1155 wildcards_in_alt => 'anywhere', 1156 check_cn => 'when_only', 1157 }, 1158 # rfc 3207 1159 # This is just a dumb guess 1160 # RFC3207 itself just says, that the client should expect the 1161 # domain name of the server in the certificate. It doesn't say 1162 # anything about wildcards, so I forbid them. It doesn't say 1163 # anything about alt names, but other documents show, that alt 1164 # names should be possible. The check_cn value again is a guess. 1165 # Fix the spec! 1166 smtp => { 1167 wildcards_in_cn => 0, 1168 wildcards_in_alt => 0, 1169 check_cn => 'always' 1170 }, 1171 none => {}, # do not check 1172 ); 1173 1174 $scheme{www} = $scheme{http}; # alias 1175 $scheme{xmpp} = $scheme{http}; # rfc 3920 1176 $scheme{pop3} = $scheme{ldap}; # rfc 2595 1177 $scheme{imap} = $scheme{ldap}; # rfc 2595 1178 $scheme{acap} = $scheme{ldap}; # rfc 2595 1179 $scheme{nntp} = $scheme{ldap}; # rfc 4642 1180 $scheme{ftp} = $scheme{http}; # rfc 4217 1181 1182 # function to verify the hostname 1183 # 1184 # as every application protocol has its own rules to do this 1185 # we provide some default rules as well as a user-defined 1186 # callback 1187 1188 sub verify_hostname_of_cert { 1189 my $identity = shift; 1190 my $cert = shift; 1191 my $scheme = shift || 'none'; 1192 if ( ! ref($scheme) ) { 1193 DEBUG(3, "scheme=$scheme cert=$cert" ); 1194 $scheme = $scheme{$scheme} or croak "scheme $scheme not defined"; 1195 } 1196 1197 return 1 if ! %$scheme; # 'none' 1198 1199 # get data from certificate 1200 my $commonName = $dispatcher{cn}->($cert); 1201 my @altNames = $dispatcher{subjectAltNames}->($cert); 1202 DEBUG(3,"identity=$identity cn=$commonName alt=@altNames" ); 1203 1204 if ( my $sub = $scheme->{callback} ) { 1205 # use custom callback 1206 return $sub->($identity,$commonName,@altNames); 1207 } 1208 1209 # is the given hostname an IP address? Then we have to convert to network byte order [RFC791][RFC2460] 1210 1211 my $ipn; 1212 if ( CAN_IPV6 and $identity =~m{:} ) { 1213 # no IPv4 or hostname have ':' in it, try IPv6. 1214 $ipn = inet_pton(AF_INET6,$identity) 1215 or croak "'$identity' is not IPv6, but neither IPv4 nor hostname"; 1216 } elsif ( $identity =~m{^\d+\.\d+\.\d+\.\d+$} ) { 1217 # definitly no hostname, try IPv4 1218 $ipn = inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname"; 1219 } else { 1220 # assume hostname, check for umlauts etc 1221 if ( $identity =~m{[^a-zA-Z0-9_.\-]} ) { 1222 $identity =~m{\0} and croak("name '$identity' has \\0 byte"); 1223 $identity = idn_to_ascii($identity) or 1224 croak "Warning: Given name '$identity' could not be converted to IDNA!"; 1225 } 1226 } 1227 1228 # do the actual verification 1229 my $check_name = sub { 1230 my ($name,$identity,$wtyp) = @_; 1231 $wtyp ||= ''; 1232 my $pattern; 1233 ### IMPORTANT! 1234 # we accept only a single wildcard and only for a single part of the FQDN 1235 # e.g *.example.org does match www.example.org but not bla.www.example.org 1236 # The RFCs are in this regard unspecific but we don't want to have to 1237 # deal with certificates like *.com, *.co.uk or even * 1238 # see also http://nils.toedtmann.net/pub/subjectAltName.txt 1239 if ( $wtyp eq 'anywhere' and $name =~m{^([a-zA-Z0-9_\-]*)\*(.+)} ) { 1240 $pattern = qr{^\Q$1\E[a-zA-Z0-9_\-]*\Q$2\E$}i; 1241 } elsif ( $wtyp eq 'leftmost' and $name =~m{^\*(\..+)$} ) { 1242 $pattern = qr{^[a-zA-Z0-9_\-]*\Q$1\E$}i; 1243 } else { 1244 $pattern = qr{^\Q$name\E$}i; 1245 } 1246 return $identity =~ $pattern; 1247 }; 1248 1249 my $alt_dnsNames = 0; 1250 while (@altNames) { 1251 my ($type, $name) = splice (@altNames, 0, 2); 1252 if ( $ipn and $type == GEN_IPADD ) { 1253 # exakt match needed for IP 1254 # $name is already packed format (inet_xton) 1255 return 1 if $ipn eq $name; 1256 1257 } elsif ( ! $ipn and $type == GEN_DNS ) { 1258 $name =~s/\s+$//; $name =~s/^\s+//; 1259 $alt_dnsNames++; 1260 $check_name->($name,$identity,$scheme->{wildcards_in_alt}) 1261 and return 1; 1262 } 1263 } 1264 1265 if ( ! $ipn and ( 1266 $scheme->{check_cn} eq 'always' or 1267 $scheme->{check_cn} eq 'when_only' and !$alt_dnsNames)) { 1268 $check_name->($commonName,$identity,$scheme->{wildcards_in_cn}) 1269 and return 1; 1270 } 1271 1272 return 0; # no match 1273 } 1274} 1275 1276sub verify_hostname { 1277 my $self = shift; 1278 my $host = shift; 1279 my $cert = $self->peer_certificate; 1280 return verify_hostname_of_cert( $host,$cert,@_ ); 1281} 1282 1283 1284sub get_cipher { 1285 my $ssl = shift()->_get_ssl_object || return; 1286 return Net::SSLeay::get_cipher($ssl); 1287} 1288 1289sub errstr { 1290 my $self = shift; 1291 return ((ref($self) ? ${*$self}{'_SSL_last_err'} : $SSL_ERROR) or ''); 1292} 1293 1294sub fatal_ssl_error { 1295 my $self = shift; 1296 my $error_trap = ${*$self}{'_SSL_arguments'}->{'SSL_error_trap'}; 1297 $@ = $self->errstr; 1298 if (defined $error_trap and ref($error_trap) eq 'CODE') { 1299 $error_trap->($self, $self->errstr()."\n".$self->get_ssleay_error()); 1300 } elsif ( ${*$self}{'_SSL_ioclass_upgraded'} ) { 1301 # downgrade only 1302 $self->stop_SSL; 1303 } else { 1304 # kill socket 1305 $self->close 1306 } 1307 return; 1308} 1309 1310sub get_ssleay_error { 1311 #Net::SSLeay will print out the errors itself unless we explicitly 1312 #undefine $Net::SSLeay::trace while running print_errs() 1313 local $Net::SSLeay::trace; 1314 return Net::SSLeay::print_errs('SSL error: ') || ''; 1315} 1316 1317sub error { 1318 my ($self, $error, $destroy_socket) = @_; 1319 $error .= ' '.Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error()); 1320 DEBUG(2, $error."\n".$self->get_ssleay_error()); 1321 $SSL_ERROR = dualvar( -1, $error ); 1322 ${*$self}{'_SSL_last_err'} = $SSL_ERROR if (ref($self)); 1323 return; 1324} 1325 1326 1327sub DESTROY { 1328 my $self = shift or return; 1329 my $ssl = ${*$self}{_SSL_object} or return; 1330 if ($CREATED_IN_THIS_THREAD{$ssl}) { 1331 $self->close(_SSL_in_DESTROY => 1, SSL_no_shutdown => 1) 1332 if ${*$self}{'_SSL_opened'}; 1333 delete(${*$self}{'_SSL_ctx'}); 1334 } 1335} 1336 1337 1338#######Extra Backwards Compatibility Functionality####### 1339sub socket_to_SSL { IO::Socket::SSL->start_SSL(@_); } 1340sub socketToSSL { IO::Socket::SSL->start_SSL(@_); } 1341sub kill_socket { shift->close } 1342 1343sub issuer_name { return(shift()->peer_certificate("issuer")) } 1344sub subject_name { return(shift()->peer_certificate("subject")) } 1345sub get_peer_certificate { return shift() } 1346 1347sub context_init { 1348 return($GLOBAL_CONTEXT_ARGS = (ref($_[0]) eq 'HASH') ? $_[0] : {@_}); 1349} 1350 1351sub set_default_context { 1352 $GLOBAL_CONTEXT_ARGS->{'SSL_reuse_ctx'} = shift; 1353} 1354 1355sub set_default_session_cache { 1356 $GLOBAL_CONTEXT_ARGS->{SSL_session_cache} = shift; 1357} 1358 1359sub set_ctx_defaults { 1360 my %args = @_; 1361 while ( my ($k,$v) = each %args ) { 1362 $k =~s{^(SSL_)?}{SSL_}; 1363 $GLOBAL_CONTEXT_ARGS->{$k} = $v; 1364 } 1365} 1366 1367sub next_proto_negotiated { 1368 my $self = shift; 1369 return $self->error("NPN not supported in Net::SSLeay") 1370 if ! exists &Net::SSLeay::P_next_proto_negotiated; 1371 my $ssl = $self->_get_ssl_object || return; 1372 return Net::SSLeay::P_next_proto_negotiated($ssl); 1373} 1374 1375sub opened { 1376 my $self = shift; 1377 return IO::Handle::opened($self) && ${*$self}{'_SSL_opened'}; 1378} 1379 1380sub opening { 1381 my $self = shift; 1382 return ${*$self}{'_SSL_opening'}; 1383} 1384 1385sub want_read { shift->errstr == SSL_WANT_READ } 1386sub want_write { shift->errstr == SSL_WANT_WRITE } 1387 1388 1389#Redundant IO::Handle functionality 1390sub getline { return(scalar shift->readline()) } 1391sub getlines { 1392 return(shift->readline()) if wantarray(); 1393 croak("Use of getlines() not allowed in scalar context"); 1394} 1395 1396#Useless IO::Handle functionality 1397sub truncate { croak("Use of truncate() not allowed with SSL") } 1398sub stat { croak("Use of stat() not allowed with SSL" ) } 1399sub setbuf { croak("Use of setbuf() not allowed with SSL" ) } 1400sub setvbuf { croak("Use of setvbuf() not allowed with SSL" ) } 1401sub fdopen { croak("Use of fdopen() not allowed with SSL" ) } 1402 1403#Unsupported socket functionality 1404sub ungetc { croak("Use of ungetc() not implemented in IO::Socket::SSL") } 1405sub send { croak("Use of send() not implemented in IO::Socket::SSL; use print/printf/syswrite instead") } 1406sub recv { croak("Use of recv() not implemented in IO::Socket::SSL; use read/sysread instead") } 1407 1408package IO::Socket::SSL::SSL_HANDLE; 1409use strict; 1410use vars qw($HAVE_WEAKREF); 1411use Errno 'EBADF'; 1412 1413BEGIN { 1414 local ($@, $SIG{__DIE__}); 1415 1416 #Use Scalar::Util or WeakRef if possible: 1417 eval "use Scalar::Util qw(weaken isweak); 1" or 1418 eval "use WeakRef"; 1419 $HAVE_WEAKREF = $@ ? 0 : 1; 1420} 1421 1422 1423sub TIEHANDLE { 1424 my ($class, $handle) = @_; 1425 weaken($handle) if $HAVE_WEAKREF; 1426 bless \$handle, $class; 1427} 1428 1429sub READ { ${shift()}->sysread(@_) } 1430sub READLINE { ${shift()}->readline(@_) } 1431sub GETC { ${shift()}->getc(@_) } 1432 1433sub PRINT { ${shift()}->print(@_) } 1434sub PRINTF { ${shift()}->printf(@_) } 1435sub WRITE { ${shift()}->syswrite(@_) } 1436 1437sub FILENO { ${shift()}->fileno(@_) } 1438 1439sub TELL { $! = EBADF; return -1 } 1440sub BINMODE { return 0 } # not perfect, but better than not implementing the method 1441 1442sub CLOSE { #<---- Do not change this function! 1443 my $ssl = ${$_[0]}; 1444 local @_; 1445 $ssl->close(); 1446} 1447 1448 1449package IO::Socket::SSL::SSL_Context; 1450use Carp; 1451use strict; 1452 1453my %CTX_CREATED_IN_THIS_THREAD; 1454*DEBUG = *IO::Socket::SSL::DEBUG; 1455 1456# should be better taken from Net::SSLeay, but they are not (yet) defined there 1457use constant SSL_MODE_ENABLE_PARTIAL_WRITE => 1; 1458use constant SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER => 2; 1459 1460 1461# Note that the final object will actually be a reference to the scalar 1462# (C-style pointer) returned by Net::SSLeay::CTX_*_new() so that 1463# it can be blessed. 1464sub new { 1465 my $class = shift; 1466 #DEBUG( "$class @_" ); 1467 my $arg_hash = (ref($_[0]) eq 'HASH') ? $_[0] : {@_}; 1468 1469 my $ctx_object = $arg_hash->{'SSL_reuse_ctx'}; 1470 if ($ctx_object) { 1471 return $ctx_object if ($ctx_object->isa('IO::Socket::SSL::SSL_Context') and 1472 $ctx_object->{context}); 1473 1474 # The following "double entendre" applies only if someone passed 1475 # in an IO::Socket::SSL object instead of an actual context. 1476 return $ctx_object if ($ctx_object = ${*$ctx_object}{'_SSL_ctx'}); 1477 } 1478 1479 my $ver; 1480 my $disable_ver = 0; 1481 for (split(/\s*:\s*/,$arg_hash->{SSL_version})) { 1482 m{^(!?)(?:(SSL(?:v2|v3|v23|v2/3))|(TLSv1[12]?))$}i 1483 or croak("invalid SSL_version specified"); 1484 my $not = $1; 1485 ( my $v = lc($2||$3) ) =~s{^(...)}{\U$1}; 1486 $v =~s{/}{}; # interpret SSLv2/3 as SSLv23 1487 if ( $not ) { 1488 $disable_ver |= 1489 $v eq 'SSLv2' ? 0x01000000 : # SSL_OP_NO_SSLv2 1490 $v eq 'SSLv3' ? 0x02000000 : # SSL_OP_NO_SSLv3 1491 $v eq 'TLSv1' ? 0x04000000 : # SSL_OP_NO_TLSv1 1492 $v eq 'TLSv11' ? 0x00000400 : # SSL_OP_NO_TLSv1_1 1493 $v eq 'TLSv12' ? 0x08000000 : # SSL_OP_NO_TLSv1_2 1494 croak("cannot disable version $_"); 1495 } else { 1496 croak("cannot set multiple SSL protocols in SSL_version") 1497 if $ver && $v ne $ver; 1498 $ver = $v; 1499 } 1500 } 1501 1502 my $sub = UNIVERSAL::can( 'Net::SSLeay', 1503 $ver eq 'SSLv2' ? 'CTX_v2_new' : 1504 $ver eq 'SSLv3' ? 'CTX_v3_new' : 1505 $ver eq 'TLSv1' ? 'CTX_tlsv1_new' : 1506 'CTX_new' 1507 ) or return IO::Socket::SSL->error("SSL Version $ver not supported"); 1508 my $ctx = $sub->() or return 1509 IO::Socket::SSL->error("SSL Context init failed"); 1510 1511 Net::SSLeay::CTX_set_options($ctx, Net::SSLeay::OP_ALL() | $disable_ver ); 1512 if ( $arg_hash->{SSL_honor_cipher_order} ) { 1513 Net::SSLeay::CTX_set_options($ctx, 0x00400000); 1514 } 1515 1516 # if we don't set session_id_context if client certicate is expected 1517 # client session caching will fail 1518 # if user does not provide explicit id just use the stringification 1519 # of the context 1520 if ( my $id = $arg_hash->{SSL_session_id_context} 1521 || ( $arg_hash->{SSL_verify_mode} & 0x01 ) && "$ctx" ) { 1522 Net::SSLeay::CTX_set_session_id_context($ctx,$id,length($id)); 1523 } 1524 1525 # SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER makes syswrite return if at least one 1526 # buffer was written and not block for the rest 1527 # SSL_MODE_ENABLE_PARTIAL_WRITE can be necessary for non-blocking because we 1528 # cannot guarantee, that the location of the buffer stays constant 1529 Net::SSLeay::CTX_set_mode( $ctx, 1530 SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER|SSL_MODE_ENABLE_PARTIAL_WRITE); 1531 1532 if ( my $proto_list = $arg_hash->{SSL_npn_protocols} ) { 1533 return IO::Socket::SSL->error("NPN not supported in Net::SSLeay") 1534 if ! exists &Net::SSLeay::P_next_proto_negotiated; 1535 if($arg_hash->{SSL_server}) { 1536 # on server side SSL_npn_protocols means a list of advertised protocols 1537 Net::SSLeay::CTX_set_next_protos_advertised_cb($ctx, $proto_list); 1538 } else { 1539 # on client side SSL_npn_protocols means a list of prefered protocols 1540 # negotiation algorithm used is "as-openssl-implements-it" 1541 Net::SSLeay::CTX_set_next_proto_select_cb($ctx, $proto_list); 1542 } 1543 } 1544 1545 my $verify_mode = $arg_hash->{SSL_verify_mode}; 1546 if ( $verify_mode != Net::SSLeay::VERIFY_NONE() and 1547 ( defined $arg_hash->{SSL_ca_file} || defined $arg_hash->{SSL_ca_path}) and 1548 ! Net::SSLeay::CTX_load_verify_locations( 1549 $ctx, $arg_hash->{SSL_ca_file} || '',$arg_hash->{SSL_ca_path} || '') ) { 1550 return IO::Socket::SSL->error("Invalid certificate authority locations"); 1551 } 1552 1553 if ($arg_hash->{'SSL_check_crl'}) { 1554 if (Net::SSLeay::OPENSSL_VERSION_NUMBER() >= 0x0090702f) { 1555 Net::SSLeay::X509_STORE_set_flags( 1556 Net::SSLeay::CTX_get_cert_store($ctx), 1557 Net::SSLeay::X509_V_FLAG_CRL_CHECK() 1558 ); 1559 if ($arg_hash->{'SSL_crl_file'}) { 1560 my $bio = Net::SSLeay::BIO_new_file($arg_hash->{'SSL_crl_file'}, 'r'); 1561 my $crl = Net::SSLeay::PEM_read_bio_X509_CRL($bio); 1562 if ( $crl ) { 1563 Net::SSLeay::X509_STORE_add_crl(Net::SSLeay::CTX_get_cert_store($ctx), $crl); 1564 } else { 1565 return IO::Socket::SSL->error("Invalid certificate revocation list"); 1566 } 1567 } 1568 } else { 1569 return IO::Socket::SSL->error("CRL not supported for OpenSSL < v0.9.7b"); 1570 } 1571 } 1572 1573 if ($arg_hash->{'SSL_server'} || $arg_hash->{'SSL_use_cert'}) { 1574 my $filetype = Net::SSLeay::FILETYPE_PEM(); 1575 1576 if ($arg_hash->{'SSL_passwd_cb'}) { 1577 Net::SSLeay::CTX_set_default_passwd_cb($ctx, $arg_hash->{'SSL_passwd_cb'}); 1578 } 1579 1580 if ( my $pkey= $arg_hash->{SSL_key} ) { 1581 # binary, e.g. EVP_PKEY* 1582 Net::SSLeay::CTX_use_PrivateKey($ctx, $pkey) 1583 || return IO::Socket::SSL->error("Failed to use Private Key"); 1584 } elsif ( my $f = $arg_hash->{SSL_key_file} ) { 1585 Net::SSLeay::CTX_use_PrivateKey_file($ctx, $f, $filetype) 1586 || return IO::Socket::SSL->error("Failed to open Private Key"); 1587 } 1588 1589 if ( my $x509 = $arg_hash->{SSL_cert} ) { 1590 # binary, e.g. X509* 1591 # we habe either a single certificate or a list with 1592 # a chain of certificates 1593 my @x509 = ref($x509) eq 'ARRAY' ? @$x509: ($x509); 1594 my $cert = shift @x509; 1595 Net::SSLeay::CTX_use_certificate( $ctx,$cert ) 1596 || return IO::Socket::SSL->error("Failed to use Certificate"); 1597 foreach my $ca (@x509) { 1598 Net::SSLeay::CTX_add_extra_chain_cert( $ctx,$ca ) 1599 || return IO::Socket::SSL->error("Failed to use Certificate"); 1600 } 1601 } elsif ( my $f = $arg_hash->{SSL_cert_file} ) { 1602 Net::SSLeay::CTX_use_certificate_chain_file($ctx, $f) 1603 || return IO::Socket::SSL->error("Failed to open Certificate"); 1604 } 1605 1606 if ( my $dh = $arg_hash->{SSL_dh} ) { 1607 # binary, e.g. DH* 1608 Net::SSLeay::CTX_set_tmp_dh( $ctx,$dh ) 1609 || return IO::Socket::SSL->error( "Failed to set DH from SSL_dh" ); 1610 } elsif ( my $f = $arg_hash->{SSL_dh_file} ) { 1611 my $bio = Net::SSLeay::BIO_new_file( $f,'r' ) 1612 || return IO::Socket::SSL->error( "Failed to open DH file $f" ); 1613 my $dh = Net::SSLeay::PEM_read_bio_DHparams($bio); 1614 Net::SSLeay::BIO_free($bio); 1615 $dh || return IO::Socket::SSL->error( "Failed to read PEM for DH from $f - wrong format?" ); 1616 my $rv = Net::SSLeay::CTX_set_tmp_dh( $ctx,$dh ); 1617 Net::SSLeay::DH_free( $dh ); 1618 $rv || return IO::Socket::SSL->error( "Failed to set DH from $f" ); 1619 } 1620 } 1621 1622 my $verify_cb = $arg_hash->{SSL_verify_callback}; 1623 my $verify_callback = $verify_cb && sub { 1624 my ($ok, $ctx_store) = @_; 1625 my ($certname,$cert,$error); 1626 if ($ctx_store) { 1627 $cert = Net::SSLeay::X509_STORE_CTX_get_current_cert($ctx_store); 1628 $error = Net::SSLeay::X509_STORE_CTX_get_error($ctx_store); 1629 $certname = Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_issuer_name($cert)). 1630 Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_subject_name($cert)); 1631 $error &&= Net::SSLeay::ERR_error_string($error); 1632 } 1633 DEBUG(3, "ok=$ok cert=$cert" ); 1634 return $verify_cb->($ok,$ctx_store,$certname,$error,$cert); 1635 }; 1636 1637 Net::SSLeay::CTX_set_verify($ctx, $verify_mode, $verify_callback); 1638 1639 if ( my $cb = $arg_hash->{SSL_create_ctx_callback} ) { 1640 $cb->($ctx); 1641 } 1642 1643 $ctx_object = { context => $ctx }; 1644 $ctx_object->{has_verifycb} = 1 if $verify_callback; 1645 DEBUG(3, "new ctx $ctx" ); 1646 $CTX_CREATED_IN_THIS_THREAD{$ctx} = 1; 1647 1648 if ( my $cache = $arg_hash->{SSL_session_cache} ) { 1649 # use predefined cache 1650 $ctx_object->{session_cache} = $cache 1651 } elsif ( my $size = $arg_hash->{SSL_session_cache_size}) { 1652 return IO::Socket::SSL->error("Session caches not supported for Net::SSLeay < v1.26") 1653 if $Net::SSLeay::VERSION < 1.26; 1654 $ctx_object->{session_cache} = IO::Socket::SSL::Session_Cache->new( $size ); 1655 } 1656 1657 1658 return bless $ctx_object, $class; 1659} 1660 1661 1662sub session_cache { 1663 my $ctx = shift; 1664 my $cache = $ctx->{'session_cache'} || return; 1665 my ($addr,$port,$session) = @_; 1666 $port ||= $addr =~s{:(\w+)$}{} && $1; # host:port 1667 my $key = "$addr:$port"; 1668 return defined($session) 1669 ? $cache->add_session($key, $session) 1670 : $cache->get_session($key); 1671} 1672 1673sub has_session_cache { 1674 return defined shift->{session_cache}; 1675} 1676 1677 1678sub CLONE { %CTX_CREATED_IN_THIS_THREAD = (); } 1679sub DESTROY { 1680 my $self = shift; 1681 if ( my $ctx = $self->{context} ) { 1682 DEBUG( 3,"free ctx $ctx open=".join( " ",keys %CTX_CREATED_IN_THIS_THREAD )); 1683 if ( %CTX_CREATED_IN_THIS_THREAD and 1684 delete $CTX_CREATED_IN_THIS_THREAD{$ctx} ) { 1685 # remove any verify callback for this context 1686 if ( $self->{has_verifycb}) { 1687 DEBUG( 3,"free ctx $ctx callback" ); 1688 Net::SSLeay::CTX_set_verify($ctx, 0,undef); 1689 } 1690 DEBUG( 3,"OK free ctx $ctx" ); 1691 Net::SSLeay::CTX_free($ctx); 1692 } 1693 } 1694 delete(@{$self}{'context','session_cache'}); 1695} 1696 1697package IO::Socket::SSL::Session_Cache; 1698use strict; 1699 1700sub new { 1701 my ($class, $size) = @_; 1702 $size>0 or return; 1703 return bless { _maxsize => $size }, $class; 1704} 1705 1706 1707sub get_session { 1708 my ($self, $key) = @_; 1709 my $session = $self->{$key} || return; 1710 return $session->{session} if ($self->{'_head'} eq $session); 1711 $session->{prev}->{next} = $session->{next}; 1712 $session->{next}->{prev} = $session->{prev}; 1713 $session->{next} = $self->{'_head'}; 1714 $session->{prev} = $self->{'_head'}->{prev}; 1715 $self->{'_head'}->{prev} = $self->{'_head'}->{prev}->{next} = $session; 1716 $self->{'_head'} = $session; 1717 return $session->{session}; 1718} 1719 1720sub add_session { 1721 my ($self, $key, $val) = @_; 1722 return if ($key eq '_maxsize' or $key eq '_head'); 1723 1724 if ((keys %$self) > $self->{'_maxsize'} + 1) { 1725 my $last = $self->{'_head'}->{prev}; 1726 Net::SSLeay::SESSION_free($last->{session}); 1727 delete($self->{$last->{key}}); 1728 $self->{'_head'}->{prev} = $self->{'_head'}->{prev}->{prev}; 1729 delete($self->{'_head'}) if ($self->{'_maxsize'} == 1); 1730 } 1731 1732 my $session = $self->{$key} = { session => $val, key => $key }; 1733 1734 if ($self->{'_head'}) { 1735 $session->{next} = $self->{'_head'}; 1736 $session->{prev} = $self->{'_head'}->{prev}; 1737 $self->{'_head'}->{prev}->{next} = $session; 1738 $self->{'_head'}->{prev} = $session; 1739 } else { 1740 $session->{next} = $session->{prev} = $session; 1741 } 1742 $self->{'_head'} = $session; 1743 return $session; 1744} 1745 1746sub DESTROY { 1747 my $self = shift; 1748 delete(@{$self}{'_head','_maxsize'}); 1749 foreach my $key (keys %$self) { 1750 Net::SSLeay::SESSION_free($self->{$key}->{session}); 1751 } 1752} 1753 1754 17551; 1756 1757 1758=head1 NAME 1759 1760IO::Socket::SSL -- Nearly transparent SSL encapsulation for IO::Socket::INET. 1761 1762=head1 SYNOPSIS 1763 1764 use strict; 1765 use IO::Socket::SSL; 1766 1767 my $client = IO::Socket::SSL->new("www.example.com:https") 1768 || warn "I encountered a problem: ".IO::Socket::SSL::errstr(); 1769 $client->verify_hostname( 'www.example.com','http' ) 1770 || die "hostname verification failed"; 1771 1772 print $client "GET / HTTP/1.0\r\n\r\n"; 1773 print <$client>; 1774 1775 1776=head1 DESCRIPTION 1777 1778This module is a true drop-in replacement for IO::Socket::INET that uses 1779SSL to encrypt data before it is transferred to a remote server or 1780client. IO::Socket::SSL supports all the extra features that one needs 1781to write a full-featured SSL client or server application: multiple SSL contexts, 1782cipher selection, certificate verification, and SSL version selection. As an 1783extra bonus, it works perfectly with mod_perl. 1784 1785If you have never used SSL before, you should read the appendix labelled 'Using SSL' 1786before attempting to use this module. 1787 1788If you have used this module before, read on, as versions 0.93 and above 1789have several changes from the previous IO::Socket::SSL versions (especially 1790see the note about return values). 1791 1792If you are using non-blocking sockets read on, as version 0.98 added better 1793support for non-blocking. 1794 1795If you are trying to use it with threads see the BUGS section. 1796 1797=head1 METHODS 1798 1799IO::Socket::SSL inherits its methods from IO::Socket::INET, overriding them 1800as necessary. If there is an SSL error, the method or operation will return an 1801empty list (false in all contexts). The methods that have changed from the 1802perspective of the user are re-documented here: 1803 1804=over 4 1805 1806=item B<new(...)> 1807 1808Creates a new IO::Socket::SSL object. You may use all the friendly options 1809that came bundled with IO::Socket::INET, plus (optionally) the ones that follow: 1810 1811=over 2 1812 1813=item SSL_hostname 1814 1815This can be given to specifiy the hostname used for SNI, which is needed if you 1816have multiple SSL hostnames on the same IP address. If not given it will try to 1817determine hostname from PeerAddr, which will fail if only IP was given or if 1818this argument is used within start_SSL. 1819 1820If you want to disable SNI set this argument to ''. 1821 1822Currently only supported for the client side and will be ignored for the server 1823side. 1824 1825=item SSL_version 1826 1827Sets the version of the SSL protocol used to transmit data. 'SSLv23' auto-negotiates 1828between SSLv2 and SSLv3, while 'SSLv2', 'SSLv3' or 'TLSv1' restrict the protocol 1829to the specified version. All values are case-insensitive. 1830 1831You can limit to set of supported protocols by adding !version separated by ':'. 1832 1833The default SSL_version is 'SSLv23:!SSLv2' which means, that SSLv2, SSLv3 and TLSv1 1834are supported for initial protocol handshakes, but SSLv2 will not be accepted, leaving 1835only SSLv3 and TLSv1. You can also use !TLSv11 and !TLSv12 to disable TLS versions 18361.1 and 1.2 while allowing TLS version 1.0. 1837 1838Setting the version instead to 'TLSv1' will probably break interaction with lots of 1839clients which start with SSLv2 and then upgrade to TLSv1. On the other side some 1840clients just close the connection when they receive a TLS version 1.1 request. In this 1841case setting the version to 'SSLv23:!SSLv2:!TLSv11:!TLSv12' might help. 1842 1843=item SSL_cipher_list 1844 1845If this option is set the cipher list for the connection will be set to the 1846given value, e.g. something like 'ALL:!LOW:!EXP:!ADH'. Look into the OpenSSL 1847documentation (L<http://www.openssl.org/docs/apps/ciphers.html#CIPHER_STRINGS>) 1848for more details. 1849 1850If this option is not set 'ALL:!LOW' will be used. 1851To use OpenSSL builtin default (whatever this is) set it to ''. 1852 1853=item SSL_honor_cipher_order 1854 1855If this option is true the cipher order the server specified is used instead 1856of the order proposed by the client. To mitigate BEAST attack you might use 1857something like 1858 1859 SSL_honor_cipher_order => 1, 1860 SSL_cipher_list => 'RC4-SHA:ALL:!ADH:!LOW', 1861 1862=item SSL_use_cert 1863 1864If this is set, it forces IO::Socket::SSL to use a certificate and key, even if 1865you are setting up an SSL client. If this is set to 0 (the default), then you will 1866only need a certificate and key if you are setting up a server. 1867 1868SSL_use_cert will implicitly be set if SSL_server is set. 1869For convinience it is also set if it was not given but a cert was given for use 1870(SSL_cert_file or similar). 1871 1872=item SSL_server 1873 1874Use this, if the socket should be used as a server. 1875If this is not explicitly set it is assumed, if Listen with given when creating 1876the socket. 1877 1878=item SSL_key_file 1879 1880If your RSA private key is not in default place (F<certs/server-key.pem> for servers, 1881F<certs/client-key.pem> for clients), then this is the option that you would use to 1882specify a different location. Keys should be PEM formatted, and if they are 1883encrypted, you will be prompted to enter a password before the socket is formed 1884(unless you specified the SSL_passwd_cb option). 1885 1886=item SSL_key 1887 1888This is an EVP_PKEY* and can be used instead of SSL_key_file. 1889Useful if you don't have your key in a file but create it dynamically or get it from 1890a string (see openssl PEM_read_bio_PrivateKey etc for getting a EVP_PKEY* from 1891a string). 1892 1893=item SSL_cert_file 1894 1895If your SSL certificate is not in the default place (F<certs/server-cert.pem> for servers, 1896F<certs/client-cert.pem> for clients), then you should use this option to specify the 1897location of your certificate. Note that a key and certificate are only required for an 1898SSL server, so you do not need to bother with these trifling options should you be 1899setting up an unauthenticated client. 1900 1901=item SSL_cert 1902 1903This is an X509* or an array of X509*. 1904The first X509* is the internal representation of the certificate while the following 1905ones are extra certificates. Useful if you create your certificate dynamically (like 1906in a SSL intercepting proxy) or get it from a string (see openssl PEM_read_bio_X509 etc 1907for getting a X509* from a string). 1908 1909=item SSL_dh_file 1910 1911If you want Diffie-Hellman key exchange you need to supply a suitable file here 1912or use the SSL_dh parameter. See dhparam command in openssl for more information. 1913 1914=item SSL_dh 1915 1916Like SSL_dh_file, but instead of giving a file you use a preloaded or generated DH*. 1917 1918=item SSL_passwd_cb 1919 1920If your private key is encrypted, you might not want the default password prompt from 1921Net::SSLeay. This option takes a reference to a subroutine that should return the 1922password required to decrypt your private key. 1923 1924=item SSL_ca_file 1925 1926If you want to verify that the peer certificate has been signed by a reputable 1927certificate authority, then you should use this option to locate the file 1928containing the certificateZ<>(s) of the reputable certificate authorities if it is 1929not already in the file F<certs/my-ca.pem>. 1930If you definitly want no SSL_ca_file used you should set it to undef. 1931 1932=item SSL_ca_path 1933 1934If you are unusually friendly with the OpenSSL documentation, you might have set 1935yourself up a directory containing several trusted certificates as separate files 1936as well as an index of the certificates. If you want to use that directory for 1937validation purposes, and that directory is not F<ca/>, then use this option to 1938point IO::Socket::SSL to the right place to look. 1939If you definitly want no SSL_ca_path used you should set it to undef. 1940 1941=item SSL_verify_mode 1942 1943This option sets the verification mode for the peer certificate. The default 1944(0x00) does no authentication. You may combine 0x01 (verify peer), 0x02 (fail 1945verification if no peer certificate exists; ignored for clients), and 0x04 1946(verify client once) to change the default. 1947 1948See OpenSSL man page for SSL_CTX_set_verify for more information. 1949 1950=item SSL_verify_callback 1951 1952If you want to verify certificates yourself, you can pass a sub reference along 1953with this parameter to do so. When the callback is called, it will be passed: 1954 1955=over 4 1956 1957=item 1. 1958a true/false value that indicates what OpenSSL thinks of the certificate, 1959 1960=item 2. 1961a C-style memory address of the certificate store, 1962 1963=item 3. 1964a string containing the certificate's issuer attributes and owner attributes, and 1965 1966=item 4. 1967a string containing any errors encountered (0 if no errors). 1968 1969=item 5. 1970a C-style memory address of the peer's own certificate (convertible to 1971PEM form with Net::SSLeay::PEM_get_string_X509()). 1972 1973=back 1974 1975The function should return 1 or 0, depending on whether it thinks the certificate 1976is valid or invalid. The default is to let OpenSSL do all of the busy work. 1977 1978The callback will be called for each element in the certificate chain. 1979 1980See the OpenSSL documentation for SSL_CTX_set_verify for more information. 1981 1982=item SSL_verifycn_scheme 1983 1984Set the scheme used to automatically verify the hostname of the peer. 1985See the information about the verification schemes in B<verify_hostname>. 1986 1987The default is undef, e.g. to not automatically verify the hostname. 1988If no verification is done the other B<SSL_verifycn_*> options have 1989no effect, but you might still do manual verification by calling 1990B<verify_hostname>. 1991 1992=item SSL_verifycn_name 1993 1994Set the name which is used in verification of hostname. If SSL_verifycn_scheme 1995is set and no SSL_verifycn_name is given it will try to use the PeerHost and 1996PeerAddr settings and fail if no name can be determined. 1997 1998Using PeerHost or PeerAddr works only if you create the connection directly 1999with C<< IO::Socket::SSL->new >>, if an IO::Socket::INET object is upgraded 2000with B<start_SSL> the name has to be given in B<SSL_verifycn_name>. 2001 2002=item SSL_check_crl 2003 2004If you want to verify that the peer certificate has not been revoked 2005by the signing authority, set this value to true. OpenSSL will search 2006for the CRL in your SSL_ca_path, or use the file specified by 2007SSL_crl_file. See the Net::SSLeay documentation for more details. 2008Note that this functionality appears to be broken with OpenSSL < 2009v0.9.7b, so its use with lower versions will result in an error. 2010 2011=item SSL_crl_file 2012 2013If you want to specify the CRL file to be used, set this value to the 2014pathname to be used. This must be used in addition to setting 2015SSL_check_crl. 2016 2017=item SSL_reuse_ctx 2018 2019If you have already set the above options (SSL_version through SSL_check_crl; 2020this does not include SSL_cipher_list yet) for a previous instance of 2021IO::Socket::SSL, then you can reuse the SSL context of that instance by passing 2022it as the value for the SSL_reuse_ctx parameter. You may also create a 2023new instance of the IO::Socket::SSL::SSL_Context class, using any context options 2024that you desire without specifying connection options, and pass that here instead. 2025 2026If you use this option, all other context-related options that you pass 2027in the same call to new() will be ignored unless the context supplied was invalid. 2028Note that, contrary to versions of IO::Socket::SSL below v0.90, a global SSL context 2029will not be implicitly used unless you use the set_default_context() function. 2030 2031=item SSL_create_ctx_callback 2032 2033With this callback you can make individual settings to the context after it 2034got created and the default setup was done. 2035The callback will be called with the CTX object from Net::SSLeay as the single 2036argument. 2037 2038Example for limiting the server session cache size: 2039 2040 SSL_create_ctx_callback => sub { 2041 my $ctx = shift; 2042 Net::SSLeay::CTX_sess_set_cache_size($ctx,128); 2043 } 2044 2045=item SSL_session_cache_size 2046 2047If you make repeated connections to the same host/port and the SSL renegotiation time 2048is an issue, you can turn on client-side session caching with this option by specifying a 2049positive cache size. For successive connections, pass the SSL_reuse_ctx option to 2050the new() calls (or use set_default_context()) to make use of the cached sessions. 2051The session cache size refers to the number of unique host/port pairs that can be 2052stored at one time; the oldest sessions in the cache will be removed if new ones are 2053added. 2054 2055This option does not effect the session cache a server has for it's clients, e.g. it 2056does not affect SSL objects with SSL_server set. 2057 2058=item SSL_session_cache 2059 2060Specifies session cache object which should be used instead of creating a new. 2061Overrules SSL_session_cache_size. 2062This option is useful if you want to reuse the cache, but not the rest of 2063the context. 2064 2065A session cache object can be created using 2066C<< IO::Socket::SSL::Session_Cache->new( cachesize ) >>. 2067 2068Use set_default_session_cache() to set a global cache object. 2069 2070=item SSL_session_id_context 2071 2072This gives an id for the servers session cache. It's necessary if you want 2073clients to connect with a client certificate. If not given but SSL_verify_mode 2074specifies the need for client certificate a context unique id will be picked. 2075 2076=item SSL_error_trap 2077 2078When using the accept() or connect() methods, it may be the case that the 2079actual socket connection works but the SSL negotiation fails, as in the case of 2080an HTTP client connecting to an HTTPS server. Passing a subroutine ref attached 2081to this parameter allows you to gain control of the orphaned socket instead of having it 2082be closed forcibly. The subroutine, if called, will be passed two parameters: 2083a reference to the socket on which the SSL negotiation failed and and the full 2084text of the error message. 2085 2086=item SSL_npn_protocols 2087 2088If used on the server side it specifies list of protocols advertised by SSL 2089server as an array ref, e.g. ['spdy/2','http1.1']. 2090On the client side it specifies the protocols offered by the client for NPN 2091as an array ref. 2092See also method L<next_proto_negotiated>. 2093 2094Next Protocol Negotioation (NPN) is available with Net::SSLeay 1.46+ and openssl-1.0.1+. 2095 2096=back 2097 2098=item B<close(...)> 2099 2100There are a number of nasty traps that lie in wait if you are not careful about using 2101close(). The first of these will bite you if you have been using shutdown() on your 2102sockets. Since the SSL protocol mandates that a SSL "close notify" message be 2103sent before the socket is closed, a shutdown() that closes the socket's write channel 2104will cause the close() call to hang. For a similar reason, if you try to close a 2105copy of a socket (as in a forking server) you will affect the original socket as well. 2106To get around these problems, call close with an object-oriented syntax 2107(e.g. $socket->close(SSL_no_shutdown => 1)) 2108and one or more of the following parameters: 2109 2110=over 2 2111 2112=item SSL_no_shutdown 2113 2114If set to a true value, this option will make close() not use the SSL_shutdown() call 2115on the socket in question so that the close operation can complete without problems 2116if you have used shutdown() or are working on a copy of a socket. 2117 2118=item SSL_fast_shutdown 2119 2120If set to true only a unidirectional shutdown will be done, e.g. only the 2121close_notify (see SSL_shutdown(3)) will be called. Otherwise a bidrectional 2122shutdown will be done. If used within close() it defaults to true, if used 2123within stop_SSL() it defaults to false. 2124 2125=item SSL_ctx_free 2126 2127If you want to make sure that the SSL context of the socket is destroyed when 2128you close it, set this option to a true value. 2129 2130=back 2131 2132=item B<peek(...)> 2133 2134This function has exactly the same syntax as sysread(), and performs nearly the same 2135task (reading data from the socket) but will not advance the read position so 2136that successive calls to peek() with the same arguments will return the same results. 2137This function requires OpenSSL 0.9.6a or later to work. 2138 2139 2140=item B<pending()> 2141 2142This function will let you know how many bytes of data are immediately ready for reading 2143from the socket. This is especially handy if you are doing reads on a blocking socket 2144or just want to know if new data has been sent over the socket. 2145 2146 2147=item B<get_cipher()> 2148 2149Returns the string form of the cipher that the IO::Socket::SSL object is using. 2150 2151=item B<dump_peer_certificate()> 2152 2153Returns a parsable string with select fields from the peer SSL certificate. This 2154method directly returns the result of the dump_peer_certificate() method of Net::SSLeay. 2155 2156=item B<peer_certificate($field)> 2157 2158If a peer certificate exists, this function can retrieve values from it. 2159If no field is given the internal representation of certificate from Net::SSLeay is 2160returned. 2161The following fields can be queried: 2162 2163=over 8 2164 2165=item authority (alias issuer) 2166 2167The certificate authority which signed the certificate. 2168 2169=item owner (alias subject) 2170 2171The owner of the certificate. 2172 2173=item commonName (alias cn) - only for Net::SSLeay version >=1.30 2174 2175The common name, usually the server name for SSL certificates. 2176 2177=item subjectAltNames - only for Net::SSLeay version >=1.33 2178 2179Alternative names for the subject, usually different names for the same 2180server, like example.org, example.com, *.example.com. 2181 2182It returns a list of (typ,value) with typ GEN_DNS, GEN_IPADD etc (these 2183constants are exported from IO::Socket::SSL). 2184See Net::SSLeay::X509_get_subjectAltNames. 2185 2186=back 2187 2188=item B<verify_hostname($hostname,$scheme)> 2189 2190This verifies the given hostname against the peer certificate using the 2191given scheme. Hostname is usually what you specify within the PeerAddr. 2192 2193Verification of hostname against a certificate is different between various 2194applications and RFCs. Some scheme allow wildcards for hostnames, some only 2195in subjectAltNames, and even their different wildcard schemes are possible. 2196 2197To ease the verification the following schemes are predefined: 2198 2199=over 8 2200 2201=item ldap (rfc4513), pop3,imap,acap (rfc2995), nntp (rfc4642) 2202 2203Simple wildcards in subjectAltNames are possible, e.g. *.example.org matches 2204www.example.org but not lala.www.example.org. If nothing from subjectAltNames 2205match it checks against the common name, but there are no wildcards allowed. 2206 2207=item http (rfc2818), alias is www 2208 2209Extended wildcards in subjectAltNames and common name are possible, e.g. 2210*.example.org or even www*.example.org. The common 2211name will be only checked if no names are given in subjectAltNames. 2212 2213=item smtp (rfc3207) 2214 2215This RFC doesn't say much useful about the verification so it just assumes 2216that subjectAltNames are possible, but no wildcards are possible anywhere. 2217 2218=item none 2219 2220No verification will be done. 2221Actually is does not make any sense to call verify_hostname in this case. 2222 2223=back 2224 2225The scheme can be given either by specifying the name for one of the above predefined 2226schemes, or by using a hash which can have the following keys and values: 2227 2228=over 8 2229 2230=item check_cn: 0|'always'|'when_only' 2231 2232Determines if the common name gets checked. If 'always' it will always be checked 2233(like in ldap), if 'when_only' it will only be checked if no names are given in 2234subjectAltNames (like in http), for any other values the common name will not be checked. 2235 2236=item wildcards_in_alt: 0|'leftmost'|'anywhere' 2237 2238Determines if and where wildcards in subjectAltNames are possible. If 'leftmost' 2239only cases like *.example.org will be possible (like in ldap), for 'anywhere' 2240www*.example.org is possible too (like http), dangerous things like but www.*.org 2241or even '*' will not be allowed. 2242 2243=item wildcards_in_cn: 0|'leftmost'|'anywhere' 2244 2245Similar to wildcards_in_alt, but checks the common name. There is no predefined 2246scheme which allows wildcards in common names. 2247 2248=item callback: \&coderef 2249 2250If you give a subroutine for verification it will be called with the arguments 2251($hostname,$commonName,@subjectAltNames), where hostname is the name given for 2252verification, commonName is the result from peer_certificate('cn') and 2253subjectAltNames is the result from peer_certificate('subjectAltNames'). 2254 2255All other arguments for the verification scheme will be ignored in this case. 2256 2257=back 2258 2259=item B<next_proto_negotiated()> 2260 2261This method returns the name of negotiated protocol - e.g. 'http/1.1'. It works 2262for both client and server side of SSL connection. 2263 2264NPN support is available with Net::SSLeay 1.46+ and openssl-1.0.1+. 2265 2266=item B<errstr()> 2267 2268Returns the last error (in string form) that occurred. If you do not have a real 2269object to perform this method on, call IO::Socket::SSL::errstr() instead. 2270 2271For read and write errors on non-blocking sockets, this method may include the string 2272C<SSL wants a read first!> or C<SSL wants a write first!> meaning that the other side 2273is expecting to read from or write to the socket and wants to be satisfied before you 2274get to do anything. But with version 0.98 you are better comparing the global exported 2275variable $SSL_ERROR against the exported symbols SSL_WANT_READ and SSL_WANT_WRITE. 2276 2277=item B<opened()> 2278 2279This returns false if the socket could not be opened, 1 if the socket could be opened 2280and the SSL handshake was successful done and -1 if the underlying IO::Handle is open, 2281but the SSL handshake failed. 2282 2283=item B<< IO::Socket::SSL->start_SSL($socket, ... ) >> 2284 2285This will convert a glob reference or a socket that you provide to an IO::Socket::SSL 2286object. You may also pass parameters to specify context or connection options as with 2287a call to new(). If you are using this function on an accept()ed socket, you must 2288set the parameter "SSL_server" to 1, i.e. IO::Socket::SSL->start_SSL($socket, SSL_server => 1). 2289If you have a class that inherits from IO::Socket::SSL and you want the $socket to be blessed 2290into your own class instead, use MyClass->start_SSL($socket) to achieve the desired effect. 2291 2292Note that if start_SSL() fails in SSL negotiation, $socket will remain blessed in its 2293original class. For non-blocking sockets you better just upgrade the socket to 2294IO::Socket::SSL and call accept_SSL or connect_SSL and the upgraded object. To 2295just upgrade the socket set B<SSL_startHandshake> explicitly to 0. If you call start_SSL 2296w/o this parameter it will revert to blocking behavior for accept_SSL and connect_SSL. 2297 2298If given the parameter "Timeout" it will stop if after the timeout no SSL connection 2299was established. This parameter is only used for blocking sockets, if it is not given the 2300default Timeout from the underlying IO::Socket will be used. 2301 2302=item B<stop_SSL(...)> 2303 2304This is the opposite of start_SSL(), e.g. it will shutdown the SSL connection 2305and return to the class before start_SSL(). It gets the same arguments as close(), 2306in fact close() calls stop_SSL() (but without downgrading the class). 2307 2308Will return true if it suceeded and undef if failed. This might be the case for 2309non-blocking sockets. In this case $! is set to EAGAIN and the ssl error to 2310SSL_WANT_READ or SSL_WANT_WRITE. In this case the call should be retried again with 2311the same arguments once the socket is ready is until it succeeds. 2312 2313=item B<< IO::Socket::SSL->new_from_fd($fd, ...) >> 2314 2315This will convert a socket identified via a file descriptor into an SSL socket. 2316Note that the argument list does not include a "MODE" argument; if you supply one, 2317it will be thoughtfully ignored (for compatibility with IO::Socket::INET). Instead, 2318a mode of '+<' is assumed, and the file descriptor passed must be able to handle such 2319I/O because the initial SSL handshake requires bidirectional communication. 2320 2321=item B<IO::Socket::SSL::set_default_context(...)> 2322 2323You may use this to make IO::Socket::SSL automatically re-use a given context (unless 2324specifically overridden in a call to new()). It accepts one argument, which should 2325be either an IO::Socket::SSL object or an IO::Socket::SSL::SSL_Context object. See 2326the SSL_reuse_ctx option of new() for more details. Note that this sets the default 2327context globally, so use with caution (esp. in mod_perl scripts). 2328 2329=item B<IO::Socket::SSL::set_default_session_cache(...)> 2330 2331You may use this to make IO::Socket::SSL automatically re-use a given session cache 2332(unless specifically overridden in a call to new()). It accepts one argument, which should 2333be an IO::Socket::SSL::Session_Cache object or similar (e.g something which implements 2334get_session and add_session like IO::Socket::SSL::Session_Cache does). 2335See the SSL_session_cache option of new() for more details. Note that this sets the default 2336cache globally, so use with caution. 2337 2338=item B<IO::Socket::SSL::set_ctx_defaults(%args)> 2339 2340With this function one can set defaults for all SSL_* parameter used for creation of 2341the context, like the SSL_verify* parameter. 2342 2343=over 8 2344 2345=item mode - set default SSL_verify_mode 2346 2347=item callback - set default SSL_verify_callback 2348 2349=item scheme - set default SSL_verifycn_scheme 2350 2351=item name - set default SSL_verifycn_name 2352 2353If not given and scheme is hash reference with key callback it will be set to 'unknown' 2354 2355=back 2356 2357=back 2358 2359The following methods are unsupported (not to mention futile!) and IO::Socket::SSL 2360will emit a large CROAK() if you are silly enough to use them: 2361 2362=over 4 2363 2364=item truncate 2365 2366=item stat 2367 2368=item ungetc 2369 2370=item setbuf 2371 2372=item setvbuf 2373 2374=item fdopen 2375 2376=item send/recv 2377 2378Note that send() and recv() cannot be reliably trapped by a tied filehandle (such as 2379that used by IO::Socket::SSL) and so may send unencrypted data over the socket. Object-oriented 2380calls to these functions will fail, telling you to use the print/printf/syswrite 2381and read/sysread families instead. 2382 2383=back 2384 2385=head1 IPv6 2386 2387Support for IPv6 with IO::Socket::SSL is expected to work and basic testing is done. 2388If IO::Socket::INET6 is available it will automatically use it instead of 2389IO::Socket::INET4. 2390 2391Please be aware of the associated problems: If you give a name as a host and the 2392host resolves to both IPv6 and IPv4 it will try IPv6 first and if there is no IPv6 2393connectivity it will fail. 2394 2395To avoid these problems you can either force IPv4 by specifying and AF_INET as the 2396Domain (this is per socket) or load IO::Socket::SSL with the option 'inet4' 2397(This is a global setting, e.g. affects all IO::Socket::SSL objects in the program). 2398 2399=head1 RETURN VALUES 2400 2401A few changes have gone into IO::Socket::SSL v0.93 and later with respect to 2402return values. The behavior on success remains unchanged, but for I<all> functions, 2403the return value on error is now an empty list. Therefore, the return value will be 2404false in all contexts, but those who have been using the return values as arguments 2405to subroutines (like C<mysub(IO::Socket::SSL(...)->new, ...)>) may run into problems. 2406The moral of the story: I<always> check the return values of these functions before 2407using them in any way that you consider meaningful. 2408 2409 2410=head1 DEBUGGING 2411 2412If you are having problems using IO::Socket::SSL despite the fact that can recite backwards 2413the section of this documentation labelled 'Using SSL', you should try enabling debugging. To 2414specify the debug level, pass 'debug#' (where # is a number from 0 to 3) to IO::Socket::SSL 2415when calling it. 2416The debug level will also be propagated to Net::SSLeay::trace, see also L<Net::SSLeay>: 2417 2418=over 4 2419 2420=item use IO::Socket::SSL qw(debug0); 2421 2422No debugging (default). 2423 2424=item use IO::Socket::SSL qw(debug1); 2425 2426Print out errors from IO::Socket::SSL and ciphers from Net::SSLeay. 2427 2428=item use IO::Socket::SSL qw(debug2); 2429 2430Print also information about call flow from IO::Socket::SSL and progress 2431information from Net::SSLeay. 2432 2433=item use IO::Socket::SSL qw(debug3); 2434 2435Print also some data dumps from IO::Socket::SSL and from Net::SSLeay. 2436 2437=back 2438 2439=head1 EXAMPLES 2440 2441See the 'example' directory. 2442 2443=head1 BUGS 2444 2445IO::Socket::SSL depends on Net::SSLeay. Up to version 1.43 of Net::SSLeay 2446it was not thread safe, although it did probably work if you did not use 2447SSL_verify_callback and SSL_password_cb. 2448 2449Creating an IO::Socket::SSL object in one thread and closing it in another 2450thread will not work. 2451 2452IO::Socket::SSL does not work together with Storable::fd_retrieve/fd_store. 2453See BUGS file for more information and how to work around the problem. 2454 2455Non-blocking and timeouts (which are based on non-blocking) are not 2456supported on Win32, because the underlying IO::Socket::INET does not support 2457non-blocking on this platform. 2458 2459If you have a server and it looks like you have a memory leak you might 2460check the size of your session cache. Default for Net::SSLeay seems to be 246120480, see the example for SSL_create_ctx_callback for how to limit it. 2462 2463=head1 LIMITATIONS 2464 2465IO::Socket::SSL uses Net::SSLeay as the shiny interface to OpenSSL, which is 2466the shiny interface to the ugliness of SSL. As a result, you will need both Net::SSLeay 2467and OpenSSL on your computer before using this module. 2468 2469If you have Scalar::Util (standard with Perl 5.8.0 and above) or WeakRef, IO::Socket::SSL 2470sockets will auto-close when they go out of scope, just like IO::Socket::INET sockets. If 2471you do not have one of these modules, then IO::Socket::SSL sockets will stay open until the 2472program ends or you explicitly close them. This is due to the fact that a circular reference 2473is required to make IO::Socket::SSL sockets act simultaneously like objects and glob references. 2474 2475=head1 DEPRECATIONS 2476 2477The following functions are deprecated and are only retained for compatibility: 2478 2479=over 2 2480 2481=item context_init() 2482 2483use the SSL_reuse_ctx option if you want to re-use a context 2484 2485 2486=item socketToSSL() and socket_to_SSL() 2487 2488use IO::Socket::SSL->start_SSL() instead 2489 2490=item kill_socket() 2491 2492use close() instead 2493 2494=item get_peer_certificate() 2495 2496use the peer_certificate() function instead. 2497Used to return X509_Certificate with methods subject_name and issuer_name. 2498Now simply returns $self which has these methods (although depreceated). 2499 2500=item issuer_name() 2501 2502use peer_certificate( 'issuer' ) instead 2503 2504=item subject_name() 2505 2506use peer_certificate( 'subject' ) instead 2507 2508=back 2509 2510The following classes have been removed: 2511 2512=over 2 2513 2514=item SSL_SSL 2515 2516(not that you should have been directly accessing this anyway): 2517 2518=item X509_Certificate 2519 2520(but get_peer_certificate() will still Do The Right Thing) 2521 2522=back 2523 2524=head1 SEE ALSO 2525 2526IO::Socket::INET, IO::Socket::INET6, Net::SSLeay. 2527 2528=head1 AUTHORS 2529 2530Steffen Ullrich, <steffen at genua.de> is the current maintainer. 2531 2532Peter Behroozi, <behrooz at fas.harvard.edu> (Note the lack of an "i" at the end of "behrooz") 2533 2534Marko Asplund, <marko.asplund at kronodoc.fi>, was the original author of IO::Socket::SSL. 2535 2536Patches incorporated from various people, see file Changes. 2537 2538=head1 COPYRIGHT 2539 2540Working support for non-blocking was added by Steffen Ullrich. 2541 2542The rewrite of this module is Copyright (C) 2002-2005 Peter Behroozi. 2543 2544The original versions of this module are Copyright (C) 1999-2002 Marko Asplund. 2545 2546This module is free software; you can redistribute it and/or 2547modify it under the same terms as Perl itself. 2548 2549 2550=head1 Appendix: Using SSL 2551 2552If you are unfamiliar with the way OpenSSL works, good references may be found in 2553both the book "Network Security with OpenSSL" (Oreilly & Assoc.) and the web site 2554L<http://www.tldp.org/HOWTO/SSL-Certificates-HOWTO/>. Read on for a quick overview. 2555 2556=head2 The Long of It (Detail) 2557 2558The usual reason for using SSL is to keep your data safe. This means that not only 2559do you have to encrypt the data while it is being transported over a network, but 2560you also have to make sure that the right person gets the data. To accomplish this 2561with SSL, you have to use certificates. A certificate closely resembles a 2562Government-issued ID (at least in places where you can trust them). The ID contains some sort of 2563identifying information such as a name and address, and is usually stamped with a seal 2564of Government Approval. Theoretically, this means that you may trust the information on 2565the card and do business with the owner of the card. The same ideas apply to SSL certificates, 2566which have some identifying information and are "stamped" [most people refer to this as 2567I<signing> instead] by someone (a Certificate Authority) who you trust will adequately 2568verify the identifying information. In this case, because of some clever number theory, 2569it is extremely difficult to falsify the stamping process. Another useful consequence 2570of number theory is that the certificate is linked to the encryption process, so you may 2571encrypt data (using information on the certificate) that only the certificate owner can 2572decrypt. 2573 2574What does this mean for you? It means that at least one person in the party has to 2575have an ID to get drinks :-). Seriously, it means that one of the people communicating 2576has to have a certificate to ensure that your data is safe. For client/server 2577interactions, the server must B<always> have a certificate. If the server wants to 2578verify that the client is safe, then the client must also have a personal certificate. 2579To verify that a certificate is safe, one compares the stamped "seal" [commonly called 2580an I<encrypted digest/hash/signature>] on the certificate with the official "seal" of 2581the Certificate Authority to make sure that they are the same. To do this, you will 2582need the [unfortunately named] certificate of the Certificate Authority. With all these 2583in hand, you can set up a SSL connection and be reasonably confident that no-one is 2584reading your data. 2585 2586=head2 The Short of It (Summary) 2587 2588For servers, you will need to generate a cryptographic private key and a certificate 2589request. You will need to send the certificate request to a Certificate Authority to 2590get a real certificate back, after which you can start serving people. For clients, 2591you will not need anything unless the server wants validation, in which case you will 2592also need a private key and a real certificate. For more information about how to 2593get these, see L<http://www.modssl.org/docs/2.8/ssl_faq.html#ToC24>. 2594 2595=cut 2596