git.maemo.org Git - dh-make-perl/blob - dev/i386/libio-socket-ssl-perl/libio-socket-ssl-perl-1.16/SSL.pm

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