r21739 - in /trunk/libio-socket-ssl-perl: Changes MANIFEST Makefile.PL SSL.pm debian/changelog t/acceptSSL-timeout.t t/cert_no_file.t t/connectSSL-timeout.t t/nonblock.t t/sessions.t t/start-stopssl.t t/testlib.pl
gregoa at users.alioth.debian.org
gregoa at users.alioth.debian.org
Mon Jun 16 18:08:59 UTC 2008
Author: gregoa
Date: Mon Jun 16 18:08:59 2008
New Revision: 21739
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=21739
Log:
New upstream release (closes: #474631).
Added:
trunk/libio-socket-ssl-perl/t/acceptSSL-timeout.t
- copied unchanged from r21738, branches/upstream/libio-socket-ssl-perl/current/t/acceptSSL-timeout.t
trunk/libio-socket-ssl-perl/t/connectSSL-timeout.t
- copied unchanged from r21738, branches/upstream/libio-socket-ssl-perl/current/t/connectSSL-timeout.t
trunk/libio-socket-ssl-perl/t/start-stopssl.t
- copied unchanged from r21738, branches/upstream/libio-socket-ssl-perl/current/t/start-stopssl.t
trunk/libio-socket-ssl-perl/t/testlib.pl
- copied unchanged from r21738, branches/upstream/libio-socket-ssl-perl/current/t/testlib.pl
Modified:
trunk/libio-socket-ssl-perl/Changes
trunk/libio-socket-ssl-perl/MANIFEST
trunk/libio-socket-ssl-perl/Makefile.PL
trunk/libio-socket-ssl-perl/SSL.pm
trunk/libio-socket-ssl-perl/debian/changelog
trunk/libio-socket-ssl-perl/t/cert_no_file.t
trunk/libio-socket-ssl-perl/t/nonblock.t
trunk/libio-socket-ssl-perl/t/sessions.t
Modified: trunk/libio-socket-ssl-perl/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libio-socket-ssl-perl/Changes?rev=21739&op=diff
==============================================================================
--- trunk/libio-socket-ssl-perl/Changes (original)
+++ trunk/libio-socket-ssl-perl/Changes Mon Jun 16 18:08:59 2008
@@ -1,3 +1,56 @@
+v1.13
+ - removed CLONE_SKIP which was added in 1.03 because this breaks
+ windows forking. Handled threads/windows forking better by making
+ sure that CTX from Net::SSLeay gets not freed multiple times from
+ different threads after cloning/forking
+ - removed setting LocalPort to 0 in tests, instead leave it undef
+ if a random port should be allocated. This should fix build problems
+ with 5.6.1. Thanks to <andrew[DOT]benham[AT]thus[DOT]net>
+v1.12
+ - treat timeouts of 0 for accept_SSL and connect_SSL like no timeout,
+ like IO::Socket does.
+v1.11
+ - fixed errors in accept_SSL which would work when called from start_SSL
+ but not from accept
+v1.10
+ - start_SSL, accept_SSL and connect_SSL have argument for Timeout
+ so that the SSL handshake will not block forever. Only used if the
+ socket is blocking. If not set the Timeout value from the underlying
+ IO::Socket is used
+v1.09
+ - new method stop_SSL as opposite of start_SSL based on a idea
+ of Bron Gondwana <brong[AT]fastmail[DOT]fm>
+ To support this method the SSL_shutdown handling had to be
+ fixed, e.g. in close a proper unidirectional shutdown
+ should be done while in stop_SSL a bidirectional shutdown
+ - try to make it clearer that thread support is buggy
+v1.08
+ - make sure that Scalar::Util has support for dualvar
+ (Makefile.PL,SSL.pm) because the perl-only version has
+ has no dualvar
+v1.07
+ - fix t/nonblock.t on systems which have by default a larger
+ socket buffer. Set SO_SNDBUF explicitly with setsockopt
+ to force smaller writes on the socket
+v1.06
+ - instead of setting undef args to '' in configure_SSL drop
+ them. This makes Net::SMTP::SSL working again because it
+ does not give LocalPort of '' to IO::Socket::INET any more
+v1.05
+ - make session cache working even if the IO::Socket::SSL object
+ was not created with IO::Socket::SSL->new but with
+ IO::Socket::SSL->start_SSL on an established socket
+v1.04
+ - added way to create SSL object with predefined session
+ cache, thus making it possible to share the cache between
+ objects even if the rest of the context is not shared
+ key SSL_session_cache
+ Note that the arguments of IO::Socket::SSL::SessionCache::new
+ changed (but you should never have used this class directly
+ because it's internal to IO::Socket::SSL)
+v1.03
+ - add CLONE_SKIP as proposed by
+ Jarrod Johnson jbjohnso at us dot ibm dot com
v1.02
- added some info to BUGS and to BUGS section of pod
- added TELL and BINMODE to IO::Socket::SSL::SSL_HANDLE, even
Modified: trunk/libio-socket-ssl-perl/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libio-socket-ssl-perl/MANIFEST?rev=21739&op=diff
==============================================================================
--- trunk/libio-socket-ssl-perl/MANIFEST (original)
+++ trunk/libio-socket-ssl-perl/MANIFEST Mon Jun 16 18:08:59 2008
@@ -30,5 +30,9 @@
t/cert_no_file.t
t/dhe.t
t/readline.t
+t/start-stopssl.t
+t/acceptSSL-timeout.t
+t/connectSSL-timeout.t
+t/testlib.pl
util/export_certs.pl
META.yml
Modified: trunk/libio-socket-ssl-perl/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libio-socket-ssl-perl/Makefile.PL?rev=21739&op=diff
==============================================================================
--- trunk/libio-socket-ssl-perl/Makefile.PL (original)
+++ trunk/libio-socket-ssl-perl/Makefile.PL Mon Jun 16 18:08:59 2008
@@ -29,6 +29,7 @@
print "Net::SSLeay could not find a random number generator on\n";
print "your system. This will likely cause most of the tests\n";
print "to fail. Please see the README file for more information.\n";
+ print "the message from Net::SSLeay was: $warning\n";
# Taken from ExtUtils::MakeMaker 6.16 (Michael Schwern) so that
# the prompt() function can be emulated for older versions of ExtUtils::MakeMaker.
@@ -50,11 +51,20 @@
}
}
+{
+ # make sure that we have dualvar from the XS Version of Scalar::Util
+ if ( eval { require Scalar::Util } ) {
+ eval { Scalar::Util::dualvar( 0,'' ) };
+ die "You need the XS Version of Scalar::Util for dualvar() support"
+ if $@
+ }
+}
+
# See lib/ExtUtils/MakeMaker.pm for details of how to influence
# the contents of the Makefile that is written.
WriteMakefile(
'NAME' => 'IO::Socket::SSL',
- 'AUTHOR' => 'Peter Behroozi & Marko Asplund',
+ 'AUTHOR' => 'Steffen Ullrich & Peter Behroozi & Marko Asplund',
'ABSTRACT' => 'Nearly transparent SSL encapsulation for IO::Socket::INET.',
'VERSION_FROM' => 'SSL.pm',
'DISTNAME' => 'IO-Socket-SSL',
Modified: trunk/libio-socket-ssl-perl/SSL.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libio-socket-ssl-perl/SSL.pm?rev=21739&op=diff
==============================================================================
--- trunk/libio-socket-ssl-perl/SSL.pm (original)
+++ trunk/libio-socket-ssl-perl/SSL.pm Mon Jun 16 18:08:59 2008
@@ -4,7 +4,8 @@
# a drop-in replacement for IO::Socket::INET that encapsulates
# data passed over a network with SSL.
#
-# Current Code Shepherd: Peter Behroozi, <behrooz at fas.harvard.edu>
+# Current Code Shepherd: Steffen Ullrich <steffen at genua.de>
+# Code Shepherd before: Peter Behroozi, <behrooz at fas.harvard.edu>
#
# The original version of this module was written by
# Marko Asplund, <marko.asplund at kronodoc.fi>, who drew from
@@ -16,10 +17,21 @@
use IO::Socket;
use Net::SSLeay 1.21;
use Exporter ();
-use Scalar::Util 'dualvar';
-use Errno 'EAGAIN';
+use Errno qw( EAGAIN ETIMEDOUT );
use Carp;
use strict;
+
+# from openssl/ssl.h, should be better in Net::SSLeay
+use constant SSL_SENT_SHUTDOWN => 1;
+use constant SSL_RECEIVED_SHUTDOWN => 2;
+
+# non-XS Versions of Scalar::Util will fail
+BEGIN{
+ eval { use Scalar::Util 'dualvar'; dualvar(0,'') };
+ die "You need the XS Version of Scalar::Util for dualvar() support"
+ if $@;
+}
+
use vars qw(@ISA $VERSION $DEBUG $SSL_ERROR $GLOBAL_CONTEXT_ARGS @EXPORT );
@@ -40,7 +52,7 @@
BEGIN {
# Declare @ISA, $VERSION, $GLOBAL_CONTEXT_ARGS
@ISA = qw(IO::Socket::INET);
- $VERSION = '1.02';
+ $VERSION = '1.13';
$GLOBAL_CONTEXT_ARGS = {};
#Make $DEBUG another name for $Net::SSLeay::trace
@@ -55,6 +67,15 @@
Net::SSLeay::randomize();
}
+
+sub DEBUG {
+ $DEBUG or return;
+ my (undef,$file,$line) = caller;
+ my $msg = shift;
+ $msg = sprintf $msg, at _ if @_;
+ print STDERR "DEBUG: $file:$line: $msg\n";
+}
+
# Export some stuff
# inet4|inet6|debug will be handeled by myself, everything
@@ -136,7 +157,7 @@
%$arg_hash = ( %default_args, %$GLOBAL_CONTEXT_ARGS, %$arg_hash );
#Avoid passing undef arguments to Net::SSLeay
- !defined($arg_hash->{$_}) and ($arg_hash->{$_} = '') foreach (keys %$arg_hash);
+ defined($arg_hash->{$_}) or delete($arg_hash->{$_}) foreach (keys %$arg_hash);
#Handle CA paths properly if no CA file is specified
if ($arg_hash->{'SSL_ca_path'} ne '' and !(-f $arg_hash->{'SSL_ca_file'})) {
@@ -186,6 +207,7 @@
sub connect_SSL {
my $self = shift;
+ my $args = @_>1 ? {@_}: $_[0]||{};
my ($ssl,$ctx);
if ( ! ${*$self}{'_SSL_opening'} ) {
@@ -209,6 +231,7 @@
|| return $self->error("Failed to set SSL cipher list");
}
+ $arg_hash->{PeerAddr} || $self->_update_peer;
my $session = $ctx->session_cache( $arg_hash->{PeerAddr}, $arg_hash->{PeerPort} );
Net::SSLeay::set_session($ssl, $session) if ($session);
}
@@ -216,33 +239,87 @@
$ssl ||= ${*$self}{'_SSL_object'};
$SSL_ERROR = undef;
- #DEBUG( 'calling ssleay::connect' );
- my $rv = Net::SSLeay::connect($ssl);
- #DEBUG( "rv=$rv" );
- if ( $rv < 0 ) {
- unless ( $self->_set_rw_error( $ssl,$rv )) {
- $self->error("SSL connect attempt failed with unknown error");
+ my $timeout = exists $args->{Timeout}
+ ? $args->{Timeout}
+ : ${*$self}{io_socket_timeout}; # from IO::Socket
+ if ( defined($timeout) && $timeout>0 && $self->blocking(0) ) {
+ #DEBUG( "set socket to non-blocking to enforce timeout=$timeout" );
+ # timeout was given and socket was blocking
+ # enforce timeout with now non-blocking socket
+ } else {
+ # timeout does not apply because invalid or socket non-blocking
+ $timeout = undef;
+ }
+
+ my $start = defined($timeout) && time();
+ for my $dummy (1) {
+ #DEBUG( 'calling ssleay::connect' );
+ my $rv = Net::SSLeay::connect($ssl);
+ #DEBUG( "connect -> rv=$rv" );
+ if ( $rv < 0 ) {
+ unless ( $self->_set_rw_error( $ssl,$rv )) {
+ $self->error("SSL connect attempt failed with unknown error");
+ delete ${*$self}{'_SSL_opening'};
+ ${*$self}{'_SSL_opened'} = 1;
+ #DEBUG( "fatal SSL error: $SSL_ERROR" );
+ return $self->fatal_ssl_error();
+ }
+
+ #DEBUG( 'ssl handshake in progress' );
+ # connect failed because handshake needs to be completed
+ # if socket was non-blocking or no timeout was given return with this error
+ return if ! defined($timeout);
+
+ # wait until socket is readable or writable
+ my $rv;
+ if ( $timeout>0 ) {
+ my $vec = '';
+ vec($vec,$self->fileno,1) = 1;
+ #DEBUG( "waiting for fd to become ready: $SSL_ERROR" );
+ $rv =
+ $SSL_ERROR == SSL_WANT_READ ? select( $vec,undef,undef,$timeout) :
+ $SSL_ERROR == SSL_WANT_WRITE ? select( undef,$vec,undef,$timeout) :
+ undef;
+ } else {
+ #DEBUG( "handshake failed because no more time" );
+ $! = ETIMEDOUT
+ }
+ if ( ! $rv ) {
+ #DEBUG( "handshake failed because socket did not became ready" );
+ # failed because of timeout, return
+ $! ||= ETIMEDOUT;
+ delete ${*$self}{'_SSL_opening'};
+ ${*$self}{'_SSL_opened'} = 1;
+ $self->blocking(1); # was blocking before
+ return
+ }
+
+ # socket is ready, try non-blocking connect again after recomputing timeout
+ #DEBUG( "socket ready, retrying connect" );
+ my $now = time();
+ $timeout -= $now - $start;
+ $start = $now;
+ redo;
+
+ } elsif ( $rv == 0 ) {
delete ${*$self}{'_SSL_opening'};
+ #DEBUG( "connection failed - connect returned 0" );
+ $self->error("SSL connect attempt failed because of handshake problems" );
${*$self}{'_SSL_opened'} = 1;
return $self->fatal_ssl_error();
}
- #DEBUG( 'ssl handshake in progress' );
- return;
- } elsif ( $rv == 0 ) {
- delete ${*$self}{'_SSL_opening'};
- $self->error("SSL connect attempt failed because of handshake problems" );
- ${*$self}{'_SSL_opened'} = 1;
- return $self->fatal_ssl_error();
}
#DEBUG( 'ssl handshake done' );
# ssl connect successful
delete ${*$self}{'_SSL_opening'};
${*$self}{'_SSL_opened'}=1;
+ $self->blocking(1) if defined($timeout); # was blocking before
$ctx ||= ${*$self}{'_SSL_ctx'};
if ( $ctx->has_session_cache ) {
my $arg_hash = ${*$self}{'_SSL_arguments'};
+ $arg_hash->{PeerAddr} || $self->_update_peer;
my ($addr,$port) = ( $arg_hash->{PeerAddr}, $arg_hash->{PeerPort} );
my $session = $ctx->session_cache( $addr,$port );
$ctx->session_cache( $addr,$port, Net::SSLeay::get1_session($ssl) ) if !$session;
@@ -253,6 +330,18 @@
return $self;
}
+# called if PeerAddr is not set in ${*$self}{'_SSL_arguments'}
+# this can be the case if start_SSL is called with a normal IO::Socket::INET
+# so that PeerAddr|PeerPort are not set from args
+sub _update_peer {
+ my $self = shift;
+ my $arg_hash = ${*$self}{'_SSL_arguments'};
+ eval {
+ my ($port,$addr) = sockaddr_in( getpeername( $self ));
+ $arg_hash->{PeerAddr} = inet_ntoa( $addr );
+ $arg_hash->{PeerPort} = $port;
+ }
+}
#Call to accept occurs when a new client connects to a server using
#IO::Socket::SSL
@@ -275,8 +364,9 @@
}
sub accept_SSL {
- my ($self,$socket) = @_;
- $socket ||= $self;
+ my $self = shift;
+ my $socket = ( @_ && UNIVERSAL::isa( $_[0], 'IO::Handle' )) ? shift : $self;
+ my $args = @_>1 ? {@_}: $_[0]||{};
my $ssl;
if ( ! ${*$self}{'_SSL_opening'} ) {
@@ -305,27 +395,74 @@
$SSL_ERROR = undef;
#DEBUG( 'calling ssleay::accept' );
- my $rv = Net::SSLeay::accept($ssl);
- #DEBUG( 'called ssleay::accept rv='.$rv );
- if ( $rv < 0 ) {
- unless ( $socket->_set_rw_error( $ssl,$rv )) {
- $socket->error("SSL accept attempt failed with unknown error");
+
+ my $timeout = exists $args->{Timeout}
+ ? $args->{Timeout}
+ : ${*$self}{io_socket_timeout}; # from IO::Socket
+ if ( defined($timeout) && $timeout>0 && $socket->blocking(0) ) {
+ # timeout was given and socket was blocking
+ # enforce timeout with now non-blocking socket
+ } else {
+ # timeout does not apply because invalid or socket non-blocking
+ $timeout = undef;
+ }
+
+ my $start = defined($timeout) && time();
+ for my $dummy (1) {
+ my $rv = Net::SSLeay::accept($ssl);
+ #DEBUG( 'called ssleay::accept rv='.$rv );
+ if ( $rv < 0 ) {
+ unless ( $socket->_set_rw_error( $ssl,$rv )) {
+ $socket->error("SSL accept attempt failed with unknown error");
+ delete ${*$self}{'_SSL_opening'};
+ ${*$socket}{'_SSL_opened'} = 1;
+ return $socket->fatal_ssl_error();
+ }
+
+ # accept failed because handshake needs to be completed
+ # if socket was non-blocking or no timeout was given return with this error
+ return if ! defined($timeout);
+
+ # wait until socket is readable or writable
+ my $rv;
+ if ( $timeout>0 ) {
+ my $vec = '';
+ vec($vec,$socket->fileno,1) = 1;
+ $rv =
+ $SSL_ERROR == SSL_WANT_READ ? select( $vec,undef,undef,$timeout) :
+ $SSL_ERROR == SSL_WANT_WRITE ? select( undef,$vec,undef,$timeout) :
+ undef;
+ } else {
+ $! = ETIMEDOUT
+ }
+ if ( ! $rv ) {
+ # failed because of timeout, return
+ $! ||= ETIMEDOUT;
+ delete ${*$self}{'_SSL_opening'};
+ ${*$socket}{'_SSL_opened'} = 1;
+ $socket->blocking(1); # was blocking before
+ return
+ }
+
+ # socket is ready, try non-blocking accept again after recomputing timeout
+ my $now = time();
+ $timeout -= $now - $start;
+ $start = $now;
+ redo;
+
+ } elsif ( $rv == 0 ) {
+ $socket->error("SSL connect accept failed because of handshake problems" );
delete ${*$self}{'_SSL_opening'};
- ${*$socket}{'_SSL_opened'} = 1;
+ ${*$socket}{'_SSL_opened'} = 1;
return $socket->fatal_ssl_error();
}
- return;
- } elsif ( $rv == 0 ) {
- $socket->error("SSL connect accept failed because of handshake problems" );
- delete ${*$self}{'_SSL_opening'};
- ${*$socket}{'_SSL_opened'} = 1;
- return $socket->fatal_ssl_error();
}
#DEBUG( 'handshake done, socket ready' );
# socket opened
delete ${*$self}{'_SSL_opening'};
${*$socket}{'_SSL_opened'} = 1;
+ $socket->blocking(1) if defined($timeout); # was blocking before
tie *{$socket}, "IO::Socket::SSL::SSL_HANDLE", $socket;
@@ -520,32 +657,93 @@
sub close {
my $self = shift || return _invalid_object();
my $close_args = (ref($_[0]) eq 'HASH') ? $_[0] : {@_};
+
+ return if ! $self->stop_SSL(
+ SSL_fast_shutdown => 1,
+ %$close_args,
+ _SSL_ioclass_downgrade => 0,
+ );
+
+ if ( ! $close_args->{_SSL_in_DESTROY} ) {
+ untie( *$self );
+ return $self->SUPER::close;
+ }
+ return 1;
+}
+
+sub stop_SSL {
+ my $self = shift || return _invalid_object();
+ my $stop_args = (ref($_[0]) eq 'HASH') ? $_[0] : {@_};
return $self->error("SSL object already closed") unless (${*$self}{'_SSL_opened'});
if (my $ssl = ${*$self}{'_SSL_object'}) {
- local $SIG{PIPE} = sub{};
- $close_args->{'SSL_no_shutdown'} or Net::SSLeay::shutdown($ssl);
+ my $shutdown_done;
+ if ( $stop_args->{SSL_no_shutdown} ) {
+ $shutdown_done = 1;
+ } else {
+ my $fast = $stop_args->{SSL_fast_shutdown};
+ my $status = Net::SSLeay::get_shutdown($ssl);
+ if ( $status == SSL_RECEIVED_SHUTDOWN
+ || ( $status != 0 && $fast )) {
+ # shutdown done
+ $shutdown_done = 1;
+ } else {
+ # need to initiate/continue shutdown
+ local $SIG{PIPE} = sub{};
+ for my $try (1,2 ) {
+ my $rv = Net::SSLeay::shutdown($ssl);
+ if ( $rv < 0 ) {
+ # non-blocking socket?
+ $self->_set_rw_error( $ssl,$rv );
+ # need to try again
+ return;
+ } elsif ( $rv
+ || ( $rv == 0 && $fast )) {
+ # shutdown finished
+ $shutdown_done = 1;
+ last;
+ } else {
+ # shutdown partly finished (e.g. one direction)
+ # call again
+ }
+ }
+ }
+ }
+
+ return if ! $shutdown_done;
Net::SSLeay::free($ssl);
- delete ${*$self}{'_SSL_object'};
- }
-
- if ($close_args->{'SSL_ctx_free'}) {
- my $ctx = ${*$self}{'_SSL_ctx'};
- delete ${*$self}{'_SSL_ctx'};
- $ctx->DESTROY();
- }
-
- if (${*$self}{'_SSL_certificate'}) {
- Net::SSLeay::X509_free(${*$self}{'_SSL_certificate'});
+ delete ${*$self}{_SSL_object};
+ }
+
+ if ($stop_args->{'SSL_ctx_free'}) {
+ my $ctx = delete ${*$self}{'_SSL_ctx'};
+ $ctx && $ctx->DESTROY();
+ }
+
+ if (my $cert = delete ${*$self}{'_SSL_certificate'}) {
+ Net::SSLeay::X509_free($cert);
}
${*$self}{'_SSL_opened'} = 0;
- my $arg_hash = ${*$self}{'_SSL_arguments'};
- untie(*$self) unless ($arg_hash->{'SSL_server'}
- or $close_args->{_SSL_in_DESTROY});
-
- $self->SUPER::close unless ($close_args->{_SSL_in_DESTROY});
-}
+
+ if ( ! $stop_args->{_SSL_in_DESTROY} ) {
+
+ my $downgrade = $stop_args->{_SSL_ioclass_downgrade};
+ if ( $downgrade || ! defined $downgrade ) {
+ # rebless to original class from start_SSL
+ if ( my $orig_class = delete ${*$self}{'_SSL_ioclass_upgraded'} ) {
+ bless $self,$orig_class;
+ untie(*$self);
+ # FIXME: if original class was tied too we need to restore the tie
+ }
+ # remove all _SSL related from *$self
+ my @sslkeys = grep { m{^_?SSL_} } keys %{*$self};
+ delete @{*$self}{@sslkeys} if @sslkeys;
+ }
+ }
+ return 1;
+}
+
sub kill_socket {
my $self = shift;
@@ -586,6 +784,7 @@
my ($class,$socket) = (shift,shift);
return $class->error("Not a socket") unless(ref($socket));
my $arg_hash = (ref($_[0]) eq 'HASH') ? $_[0] : {@_};
+ my %to = exists $arg_hash->{Timeout} ? ( Timeout => delete $arg_hash->{Timeout} ) :();
my $original_class = ref($socket);
my $original_fileno = (UNIVERSAL::can($socket, "fileno"))
? $socket->fileno : CORE::fileno($socket);
@@ -595,6 +794,7 @@
$socket->configure_SSL($arg_hash) or bless($socket, $original_class) && return;
${*$socket}{'_SSL_fileno'} = $original_fileno;
+ ${*$socket}{'_SSL_ioclass_upgraded'} = $original_class;
my $start_handshake = $arg_hash->{SSL_startHandshake};
if ( ! defined($start_handshake) || $start_handshake ) {
@@ -602,8 +802,8 @@
#DEBUG( "start handshake" );
my $blocking = $socket->blocking(1);
my $result = ${*$socket}{'_SSL_arguments'}{SSL_server}
- ? $socket->accept_SSL
- : $socket->connect_SSL;
+ ? $socket->accept_SSL(%to)
+ : $socket->connect_SSL(%to);
$socket->blocking(0) if !$blocking;
return $result ? $socket : (bless($socket, $original_class) && ());
} else {
@@ -667,6 +867,7 @@
sub fatal_ssl_error {
my $self = shift;
my $error_trap = ${*$self}{'_SSL_arguments'}->{'SSL_error_trap'};
+ $@ = $self->errstr;
if (defined $error_trap and ref($error_trap) eq 'CODE') {
$error_trap->($self, $self->errstr()."\n".$self->get_ssleay_error());
} else { $self->kill_socket; }
@@ -713,6 +914,10 @@
$GLOBAL_CONTEXT_ARGS->{'SSL_reuse_ctx'} = shift;
}
+sub set_default_session_cache {
+ $GLOBAL_CONTEXT_ARGS->{SSL_session_cache} = shift;
+}
+
sub opened {
my $self = shift;
@@ -759,6 +964,7 @@
$HAVE_WEAKREF = $@ ? 0 : 1;
}
+
sub TIEHANDLE {
my ($class, $handle) = @_;
weaken($handle) if $HAVE_WEAKREF;
@@ -788,15 +994,20 @@
package IO::Socket::SSL::SSL_Context;
use strict;
+my %CTX_CREATED_IN_THIS_THREAD;
+*DEBUG = *IO::Socket::SSL::DEBUG;
+
# should be better taken from Net::SSLeay, but they are not (yet) defined there
use constant SSL_MODE_ENABLE_PARTIAL_WRITE => 1;
use constant SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER => 2;
+
# Note that the final object will actually be a reference to the scalar
# (C-style pointer) returned by Net::SSLeay::CTX_*_new() so that
# it can be blessed.
sub new {
my $class = shift;
+ DEBUG( "$class @_" );
my $arg_hash = (ref($_[0]) eq 'HASH') ? $_[0] : {@_};
my $ctx_object = $arg_hash->{'SSL_reuse_ctx'};
@@ -914,13 +1125,16 @@
Net::SSLeay::CTX_set_verify($ctx, $verify_mode, $verify_callback);
$ctx_object = { context => $ctx };
- if ($arg_hash->{'SSL_session_cache_size'}) {
- if ($Net::SSLeay::VERSION < 1.26) {
- return IO::Socket::SSL->error("Session caches not supported for Net::SSLeay < v1.26");
- } else {
- $ctx_object->{'session_cache'} =
- IO::Socket::SSL::Session_Cache->new($arg_hash) || undef;
- }
+ DEBUG( "new ctx $ctx" );
+ $CTX_CREATED_IN_THIS_THREAD{$ctx} = 1;
+
+ if ( my $cache = $arg_hash->{SSL_session_cache} ) {
+ # use predefined cache
+ $ctx_object->{session_cache} = $cache
+ } elsif ( my $size = $arg_hash->{SSL_session_cache_size}) {
+ return IO::Socket::SSL->error("Session caches not supported for Net::SSLeay < v1.26")
+ if $Net::SSLeay::VERSION < 1.26;
+ $ctx_object->{session_cache} = IO::Socket::SSL::Session_Cache->new( $size );
}
return bless $ctx_object, $class;
@@ -929,37 +1143,40 @@
sub session_cache {
my $ctx = shift;
- my $cache = $ctx->{'session_cache'};
- return unless defined $cache;
- my ($addr, $port) = (shift, shift);
+ my $cache = $ctx->{'session_cache'} || return;
+ my ($addr,$port,$session) = @_;
my $key = "$addr:$port";
- my $session = shift;
-
- return (defined($session) ? $cache->add_session($key, $session)
- : $cache->get_session($key));
+ return defined($session)
+ ? $cache->add_session($key, $session)
+ : $cache->get_session($key);
}
sub has_session_cache {
- my $ctx = shift;
- return (defined $ctx->{'session_cache'});
-}
-
-
+ return defined shift->{session_cache};
+}
+
+
+sub CLONE { %CTX_CREATED_IN_THIS_THREAD = (); DEBUG( "clone!" ) }
sub DESTROY {
my $self = shift;
- $self->{context} and Net::SSLeay::CTX_free($self->{context});
+ if ( my $ctx = $self->{context} ) {
+ DEBUG( "free ctx $ctx open=".join( " ",keys %CTX_CREATED_IN_THIS_THREAD ));
+ if ( %CTX_CREATED_IN_THIS_THREAD and
+ delete $CTX_CREATED_IN_THIS_THREAD{$ctx} ) {
+ DEBUG( "OK free ctx $ctx" );
+ Net::SSLeay::CTX_free($ctx);
+ }
+ }
delete(@{$self}{'context','session_cache'});
}
-
package IO::Socket::SSL::Session_Cache;
use strict;
sub new {
- my ($class, $arg_hash) = @_;
- my $cache = { _maxsize => $arg_hash->{'SSL_session_cache_size'}};
- return unless ($cache->{_maxsize} > 0);
- return bless $cache, $class;
+ my ($class, $size) = @_;
+ $size>0 or return;
+ return bless { _maxsize => $size }, $class;
}
@@ -978,12 +1195,11 @@
sub add_session {
my ($self, $key, $val) = @_;
-
return if ($key eq '_maxsize' or $key eq '_head');
if ((keys %$self) > $self->{'_maxsize'} + 1) {
my $last = $self->{'_head'}->{prev};
- &Net::SSLeay::SESSION_free($last->{session});
+ Net::SSLeay::SESSION_free($last->{session});
delete($self->{$last->{key}});
$self->{'_head'}->{prev} = $self->{'_head'}->{prev}->{prev};
delete($self->{'_head'}) if ($self->{'_maxsize'} == 1);
@@ -1053,6 +1269,8 @@
If you are using non-blocking sockets read on, as version 0.98 added better
support for non-blocking.
+
+If you are trying to use it with threads see the BUGS section.
=head1 METHODS
@@ -1201,6 +1419,18 @@
The session cache size refers to the number of unique host/port pairs that can be
stored at one time; the oldest sessions in the cache will be removed if new ones are
added.
+
+=item SSL_session_cache
+
+Specifies session cache object which should be used instead of creating a new.
+Overrules SSL_session_cache_size.
+This option is useful if you wan't to reuse the cache, but not the rest of
+the context.
+
+A session cache object can be created using
+C<< IO::Socket::SSL::Session_Cache->new( cachesize ) >>.
+
+Use set_default_session_cache() to set a global cache object.
=item SSL_error_trap
@@ -1234,6 +1464,13 @@
on the socket in question so that the close operation can complete without problems
if you have used shutdown() or are working on a copy of a socket.
+=item SSL_fast_shutdown
+
+If set to true only a unidirectional shutdown will be done, e.g. only the
+close_notify (see SSL_shutdown(3)) will be called. Otherwise a bidrectional
+shutdown will be done. If used within close() it defaults to true, if used
+within stop_SSL() it defaults to false.
+
=item SSL_ctx_free
If you want to make sure that the SSL context of the socket is destroyed when
@@ -1300,6 +1537,21 @@
just upgrade the socket set B<SSL_startHandshake> explicitly to 0. If you call start_SSL
w/o this parameter it will revert to blocking behavior for accept_SSL and connect_SSL.
+If given the parameter "Timeout" it will stop if after the timeout no SSL connection
+was established. This parameter is only used for blocking sockets, if it is not given the
+default Timeout from the underlying IO::Socket will be used.
+
+=item B<stop_SSL(...)>
+
+This is the opposite of start_SSL(), e.g. it will shutdown the SSL connection
+and return to the class before start_SSL(). It gets the same arguments as close(),
+in fact close() calls stop_SSL() (but without downgrading the class).
+
+Will return true if it suceeded and undef if failed. This might be the case for
+non-blocking sockets. In this case $! is set to EAGAIN and the ssl error to
+SSL_WANT_READ or SSL_WANT_WRITE. In this case the call should be retried again with
+the same arguments once the socket is ready is until it succeeds.
+
=item B<< IO::Socket::SSL->new_from_fd($fd, ...) >>
This will convert a socket identified via a file descriptor into an SSL socket.
@@ -1315,6 +1567,16 @@
be either an IO::Socket::SSL object or an IO::Socket::SSL::SSL_Context object. See
the SSL_reuse_ctx option of new() for more details. Note that this sets the default
context globally, so use with caution (esp. in mod_perl scripts).
+
+=item B<IO::Socket::SSL::set_default_session_cache(...)>
+
+You may use this to make IO::Socket::SSL automatically re-use a given session cache
+(unless specifically overridden in a call to new()). It accepts one argument, which should
+be an IO::Socket::SSL::Session_Cache object or similar (e.g something which implements
+get_session and add_session like IO::Socket::SSL::Session_Cache does).
+See the SSL_session_cache option of new() for more details. Note that this sets the default
+cache globally, so use with caution.
+
=back
@@ -1415,6 +1677,8 @@
This is because IO::Socket::SSL is based on Net::SSLeay which
uses a global object to access some of the API of openssl
and is therefore not threadsafe.
+It might probably work if you don't use SSL_verify_cb and
+SSL_password_cb.
IO::Socket::SSL does not work together with Storable::fd_retrieve/fd_store.
See BUGS file for more information and how to work around the problem.
Modified: trunk/libio-socket-ssl-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libio-socket-ssl-perl/debian/changelog?rev=21739&op=diff
==============================================================================
--- trunk/libio-socket-ssl-perl/debian/changelog (original)
+++ trunk/libio-socket-ssl-perl/debian/changelog Mon Jun 16 18:08:59 2008
@@ -1,4 +1,4 @@
-libio-socket-ssl-perl (1.02-2) UNRELEASED; urgency=low
+libio-socket-ssl-perl (1.13-1) UNRELEASED; urgency=low
* Take over for the Debian Perl Group with maintainer's permission
(http://lists.debian.org/debian-perl/2008/06/msg00039.html)
@@ -9,6 +9,8 @@
<rafl at debian.org>); Florian Ragwitz <rafl at debian.org> moved to
Uploaders.
* Add debian/watch.
+
+ * New upstream release (closes: #474631).
-- gregor herrmann <gregoa at debian.org> Sun, 15 Jun 2008 16:14:29 +0200
Modified: trunk/libio-socket-ssl-perl/t/cert_no_file.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libio-socket-ssl-perl/t/cert_no_file.t?rev=21739&op=diff
==============================================================================
--- trunk/libio-socket-ssl-perl/t/cert_no_file.t (original)
+++ trunk/libio-socket-ssl-perl/t/cert_no_file.t Mon Jun 16 18:08:59 2008
@@ -29,7 +29,6 @@
my $ID = 'server';
my %server_args = (
- LocalPort => 0, # take random port
LocalAddr => $SSL_SERVER_ADDR,
Listen => 2,
ReuseAddr => 1,
Modified: trunk/libio-socket-ssl-perl/t/nonblock.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libio-socket-ssl-perl/t/nonblock.t?rev=21739&op=diff
==============================================================================
--- trunk/libio-socket-ssl-perl/t/nonblock.t (original)
+++ trunk/libio-socket-ssl-perl/t/nonblock.t Mon Jun 16 18:08:59 2008
@@ -91,12 +91,12 @@
while (1) {
$to_server->connect( $server_addr ) && last;
if ( $! == EINPROGRESS ) {
- #DEBUG( 'connect in progress' );
+ diag( 'connect in progress' );
IO::Select->new( $to_server )->can_read(30) && next;
print "not ";
last;
}
- #DEBUG( 'connect failed: '.$! );
+ diag( 'connect failed: '.$! );
print "not ";
last;
}
@@ -117,10 +117,10 @@
SSL_cipher_list => 'HIGH',
%extra_options
)) {
- #DEBUG( 'start_SSL return undef' );
+ diag( 'start_SSL return undef' );
print "not ";
} elsif ( !UNIVERSAL::isa( $to_server,'IO::Socket::SSL' ) ) {
- #DEBUG( 'failed to upgrade socket' );
+ diag( 'failed to upgrade socket' );
print "not ";
}
ok( "upgrade client to IO::Socket::SSL" );
@@ -131,14 +131,14 @@
my $attempts = 0;
while ( 1 ) {
$to_server->connect_SSL && last;
- #DEBUG( $SSL_ERROR );
+ diag( $SSL_ERROR );
if ( $SSL_ERROR == SSL_WANT_READ ) {
$attempts++;
IO::Select->new($to_server)->can_read(30) && next; # retry if can read
} elsif ( $SSL_ERROR == SSL_WANT_WRITE ) {
IO::Select->new($to_server)->can_write(30) && next; # retry if can write
}
- #DEBUG( "failed to connect: ".$to_server->errstr );
+ diag( "failed to connect: ".$to_server->errstr );
print "not ";
last;
}
@@ -159,25 +159,38 @@
my $msg = "1234567890";
$attempts = 0;
my $bytes_send = 0;
+
+ # set send buffer to 8192 so it will definitly fail writing all 100000 bytes in it
+ # linux allocates twice as much (see tcp(7)) but it's small enough anyway
+ eval q{
+ setsockopt( $to_server, SOL_SOCKET, SO_SNDBUF, pack( "I",8192 ));
+ diag( "sndbuf=".unpack( "I",getsockopt( $to_server, SOL_SOCKET, SO_SNDBUF )));
+ };
+ my $test_might_fail;
+ if ( $@ ) {
+ # the next test might fail because setsockopt(... SO_SNDBUF...) failed
+ $test_might_fail = 1;
+ }
+
WRITE:
for( my $i=0;$i<10000;$i++ ) {
my $offset = 0;
while (1) {
my $n = syswrite( $to_server,$msg,length($msg)-$offset,$offset );
if ( !defined($n) ) {
- #DEBUG( "\$!=$! \$SSL_ERROR=$SSL_ERROR send=$bytes_send" );
+ diag( "\$!=$! \$SSL_ERROR=$SSL_ERROR send=$bytes_send" );
if ( $! == EAGAIN ) {
if ( $SSL_ERROR == SSL_WANT_WRITE ) {
- #DEBUG( 'wait for write' );
+ diag( 'wait for write' );
$attempts++;
IO::Select->new($to_server)->can_write(30);
- #DEBUG( "can write again" );
+ diag( "can write again" );
} elsif ( $SSL_ERROR == SSL_WANT_READ ) {
- #DEBUG( 'wait for read' );
+ diag( 'wait for read' );
IO::Select->new($to_server)->can_read(30);
}
} elsif ( ( $! == EPIPE || $! == ECONNRESET ) && $bytes_send > 30000 ) {
- #DEBUG( "connection closed hard" );
+ diag( "connection closed hard" );
last WRITE;
} else {
print "not ";
@@ -185,10 +198,10 @@
}
next;
} elsif ( $n == 0 ) {
- #DEBUG( "connection closed" );
+ diag( "connection closed" );
last WRITE;
} elsif ( $n<0 ) {
- #DEBUG( "syswrite returned $n!" );
+ diag( "syswrite returned $n!" );
print "not ";
last WRITE;
}
@@ -198,14 +211,21 @@
last
} else {
$offset += $n;
- #DEBUG( "partial write of $n new offset=$offset" );
+ diag( "partial write of $n new offset=$offset" );
}
}
}
ok( "syswrite" );
- print "not " if !$attempts;
- ok( "multiple write attempts" );
+ if ( ! $attempts ) {
+ if ( $test_might_fail ) {
+ ok( " write attempts failed, but OK nevertheless because setsockopt failed" );
+ } else {
+ print "not " if !$attempts;
+ }
+ } else {
+ ok( "multiple write attempts" );
+ }
print "not " if $bytes_send < 30000;
ok( "30000 bytes send" );
@@ -229,7 +249,7 @@
my $from_client = $server->accept or print "not ";
ok( "tcp accept" );
$from_client || do {
- #DEBUG( "failed to accept: $!" );
+ diag( "failed to accept: $!" );
next;
};
@@ -259,10 +279,10 @@
SSL_cipher_list => 'HIGH',
%extra_options
)) {
- #DEBUG( 'start_SSL return undef' );
+ diag( 'start_SSL return undef' );
print "not ";
} elsif ( !UNIVERSAL::isa( $from_client,'IO::Socket::SSL' ) ) {
- #DEBUG( 'failed to upgrade socket' );
+ diag( 'failed to upgrade socket' );
print "not ";
}
ok( "upgrade to_client to IO::Socket::SSL" );
@@ -275,7 +295,7 @@
my $attempts = 0;
while ( 1 ) {
$from_client->accept_SSL && last;
- #DEBUG( $SSL_ERROR );
+ diag( $SSL_ERROR );
if ( $SSL_ERROR == SSL_WANT_READ ) {
$attempts++;
IO::Select->new($from_client)->can_read(30) && next; # retry if can read
@@ -283,7 +303,7 @@
$attempts++;
IO::Select->new($from_client)->can_write(30) && next; # retry if can write
}
- #DEBUG( "failed to accept: ".$from_client->errstr );
+ diag( "failed to accept: ".$from_client->errstr );
print "not ";
last;
}
@@ -300,7 +320,7 @@
IO::Select->new( $from_client )->can_read(30);
( sysread( $from_client, $buf,10 ) == 10 ) || print "not ";
- #DEBUG($buf);
+ diag($buf);
ok( "received client message" );
sleep(5);
@@ -311,7 +331,7 @@
while ( ( my $diff = 30000 - $bytes_received ) > 0 ) {
my $n = sysread( $from_client,my $buf,$diff );
if ( !defined($n) ) {
- #DEBUG( "\$!=$! \$SSL_ERROR=$SSL_ERROR" );
+ diag( "\$!=$! \$SSL_ERROR=$SSL_ERROR" );
if ( $! == EAGAIN ) {
if ( $SSL_ERROR == SSL_WANT_READ ) {
$attempts++;
@@ -326,19 +346,19 @@
}
next;
} elsif ( $n == 0 ) {
- #DEBUG( "connection closed" );
+ diag( "connection closed" );
last READ;
} elsif ( $n<0 ) {
- #DEBUG( "sysread returned $n!" );
+ diag( "sysread returned $n!" );
print "not ";
last READ;
}
$bytes_received += $n;
- #DEBUG( "read of $n bytes" );
- }
-
- #DEBUG( "read $bytes_received" );
+ diag( "read of $n bytes" );
+ }
+
+ diag( "read $bytes_received" );
close($from_client);
}
@@ -351,3 +371,4 @@
sub ok { print "ok # [$ID] @_\n"; }
+sub diag { print "# @_\n" }
Modified: trunk/libio-socket-ssl-perl/t/sessions.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libio-socket-ssl-perl/t/sessions.t?rev=21739&op=diff
==============================================================================
--- trunk/libio-socket-ssl-perl/t/sessions.t (original)
+++ trunk/libio-socket-ssl-perl/t/sessions.t Mon Jun 16 18:08:59 2008
@@ -120,10 +120,15 @@
IO::Socket::SSL::set_default_context($ctx);
- my @clients = (new IO::Socket::SSL(PeerAddr => $SSL_SERVER_ADDR, PeerPort => $SSL_SERVER_PORT),
- new IO::Socket::SSL(PeerAddr => $SSL_SERVER_ADDR, PeerPort => $SSL_SERVER_PORT2),
- new IO::Socket::SSL(PeerAddr => $SSL_SERVER_ADDR, PeerPort => $SSL_SERVER_PORT3));
-
+ my $sock3 = IO::Socket::INET->new(
+ PeerAddr => $SSL_SERVER_ADDR,
+ PeerPort => $SSL_SERVER_PORT3
+ );
+ my @clients = (
+ IO::Socket::SSL->new(PeerAddr => $SSL_SERVER_ADDR, PeerPort => $SSL_SERVER_PORT),
+ IO::Socket::SSL->new(PeerAddr => $SSL_SERVER_ADDR, PeerPort => $SSL_SERVER_PORT2),
+ IO::Socket::SSL->start_SSL( $sock3 ),
+ );
if (!$clients[0] or !$clients[1] or !$clients[2]) {
print "not ok \# Client init\n";
More information about the Pkg-perl-cvs-commits
mailing list