@@ -1,3 +1,21 @@
+v0.994
+ - hide DEBUG statements and remove test to load Debug.pm
+ because packets like Spamassisin cannot cope with it
+ (at least the OpenBSD port)
+v0.993
+ - added SSL_cert and SSL_key parameter which do not take
+ a file name like SSL_cert_file and SSL_key_file but
+ an internal X509* resp. EVP_PKEY* value. Useful for
+ dynamically created certificates and keys.
+ - added test for sysread/syswrite behavior (which was changed
+ in v0.991)
+v0.992
+ - _set_rw_error does $!||=EAGAIN only if error is one of
+ SSL_WANT_READ|SSL_WANT_WRITE (patch from Mike Smith
+ <mike at mailchannels dot com>)
+ - Fix Makefile.PL to allow detectection of failures in PREREQ_PM
+ (http://rt.cpan.org/Public/Bug/Display.html?id=20563, patch
+ by alexchorny at gmail dot com)
v0.991
- sysread and syswrite ar no longer the same as read and write,
but can return already if only parts of the data are read
@@ -25,5 +25,7 @@ t/nonblock.t
t/sessions.t
t/ssl_settings.req
t/startssl.t
+t/sysread_write.t
+t/cert_no_file.t
util/export_certs.pl
META.yml
@@ -18,31 +18,36 @@ unless (defined $ENV{EGD_PATH}) {
$| = 1;
-$SIG{__WARN__} = sub {
- undef $SIG{__WARN__};
- my $warning = shift;
- return unless $warning =~ /random/i;
- 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";
-
- # Taken from ExtUtils::MakeMaker 6.16 (Michael Schwern) so that
- # the prompt() function can be emulated for older versions of ExtUtils::MakeMaker.
- my $isa_tty = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT));
-
- if ($isa_tty) {
- print "Do you REALLY want to continue? [Default: no] ";
- die "User cancelled install!\n" if (<STDIN> !~ /^y(?:es)?$/);
+{
+ # issue warning, if Net::SSLeay cannot find random generator
+ # redefine __WARN__ only locally to allow detection of failures
+ # in PREREQ_PM
+ local $SIG{__WARN__} = sub {
+ undef $SIG{__WARN__};
+ my $warning = shift;
+ return unless $warning =~ /random/i;
+ 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";
+
+ # Taken from ExtUtils::MakeMaker 6.16 (Michael Schwern) so that
+ # the prompt() function can be emulated for older versions of ExtUtils::MakeMaker.
+ my $isa_tty = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT));
+
+ if ($isa_tty) {
+ print "Do you REALLY want to continue? [Default: no] ";
+ die "User cancelled install!\n" if (<STDIN> !~ /^y(?:es)?$/);
+ } else {
+ die "Install cancelled.\n";
+ }
+ };
+
+ if (! defined $ENV{SKIP_RNG_TEST}) {
+ eval { require Net::SSLeay; $Net::SSLeay::trace=1; Net::SSLeay::randomize(); };
+ die $@ if $@ =~ /cancelled/;
} else {
- die "Install cancelled.\n";
+ print "Random Number Generator test skipped.\n";
}
-};
-
-if (! defined $ENV{SKIP_RNG_TEST}) {
- eval { require Net::SSLeay; $Net::SSLeay::trace=1; Net::SSLeay::randomize(); };
- die $@ if $@ =~ /cancelled/;
-} else {
- print "Random Number Generator test skipped.\n";
}
# See lib/ExtUtils/MakeMaker.pm for details of how to influence
@@ -23,9 +23,6 @@ use strict;
use vars qw(@ISA $VERSION $DEBUG $SSL_ERROR $GLOBAL_CONTEXT_ARGS @EXPORT );
-eval 'require Debug; Debug->import';
-*{DEBUG} = sub { warn "DEBUG: @_\n" if $DEBUG>=2 } if !defined(&DEBUG);
-
{
# These constants will be used in $! at return from SSL_connect,
# SSL_accept, generic_read and write, thus notifying the caller
@@ -43,7 +40,7 @@ eval 'require Debug; Debug->import';
BEGIN {
# Declare @ISA, $VERSION, $GLOBAL_CONTEXT_ARGS
@ISA = qw(IO::Socket::INET);
- $VERSION = '0.991';
+ $VERSION = '0.994';
$GLOBAL_CONTEXT_ARGS = {};
#Make $DEBUG another name for $Net::SSLeay::trace
@@ -111,8 +108,6 @@ sub configure_SSL {
my %default_args =
('Proto' => 'tcp',
'SSL_server' => $is_server,
- 'SSL_key_file' => $is_server ? 'certs/server-key.pem' : 'certs/client-key.pem',
- 'SSL_cert_file' => $is_server ? 'certs/server-cert.pem' : 'certs/client-cert.pem',
'SSL_ca_file' => 'certs/my-ca.pem',
'SSL_ca_path' => 'ca/',
'SSL_use_cert' => $is_server,
@@ -121,7 +116,17 @@ sub configure_SSL {
'SSL_verify_mode' => Net::SSLeay::VERIFY_NONE(),
'SSL_verify_callback' => 0,
'SSL_cipher_list' => 'ALL:!LOW:!EXP');
-
+
+ # SSL_key_file and SSL_cert_file will only be set in defaults if
+ # SSL_key|SSL_key_file resp SSL_cert|SSL_cert_file are not set in
+ # $args_hash
+ foreach my $k (qw( key cert )) {
+ next if exists $arg_hash->{ "SSL_${k}" };
+ next if exists $arg_hash->{ "SSL_${k}_file" };
+ $default_args{ "SSL_${k}_file" } = $is_server
+ ? "certs/server-${k}.pem"
+ : "certs/client-${k}.pem";
+ }
#Replace nonexistent entries with defaults
%$arg_hash = ( %default_args, %$GLOBAL_CONTEXT_ARGS, %$arg_hash );
@@ -136,7 +141,7 @@ sub configure_SSL {
}
${*$self}{'_SSL_arguments'} = $arg_hash;
- ${*$self}{'_SSL_ctx'} = new IO::Socket::SSL::SSL_Context($arg_hash) || return;
+ ${*$self}{'_SSL_ctx'} = IO::Socket::SSL::SSL_Context->new($arg_hash) || return;
${*$self}{'_SSL_opened'} = 1 if ($is_server);
return $self;
@@ -146,11 +151,11 @@ sub configure_SSL {
sub _set_rw_error {
my ($self,$ssl,$rv) = @_;
my $err = Net::SSLeay::get_error($ssl,$rv);
- $! ||= EAGAIN;
$SSL_ERROR =
$err == Net::SSLeay::ERROR_WANT_READ() ? SSL_WANT_READ :
$err == Net::SSLeay::ERROR_WANT_WRITE() ? SSL_WANT_WRITE :
return;
+ $! ||= EAGAIN;
${*$self}{'_SSL_last_err'} = $SSL_ERROR if (ref($self));
return 1;
}
@@ -167,9 +172,9 @@ sub connect {
# if this fails this might not be an error (e.g. if $! = EINPROGRESS
# and socket is nonblocking this is normal), so keep any error
# handling to the client
- DEBUG( 'socket not yet connected' );
+ #DEBUG( 'socket not yet connected' );
$self->SUPER::connect(@_) || return;
- DEBUG( 'socket connected' );
+ #DEBUG( 'socket connected' );
}
return $self->connect_SSL;
}
@@ -181,7 +186,7 @@ sub connect_SSL {
my ($ssl,$ctx);
if ( ! ${*$self}{'_SSL_opening'} ) {
# start ssl connection
- DEBUG( 'ssl handshake not started' );
+ #DEBUG( 'ssl handshake not started' );
${*$self}{'_SSL_opening'} = 1;
my $arg_hash = ${*$self}{'_SSL_arguments'};
@@ -205,16 +210,16 @@ sub connect_SSL {
$ssl ||= ${*$self}{'_SSL_object'};
$SSL_ERROR = undef;
- DEBUG( 'calling ssleay::connect' );
+ #DEBUG( 'calling ssleay::connect' );
my $rv = Net::SSLeay::connect($ssl);
- DEBUG( "rv=$rv" );
+ #DEBUG( "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'};
return $self->fatal_ssl_error();
}
- DEBUG( 'ssl handshake in progress' );
+ #DEBUG( 'ssl handshake in progress' );
return;
} elsif ( $rv == 0 ) {
delete ${*$self}{'_SSL_opening'};
@@ -222,7 +227,7 @@ sub connect_SSL {
return $self->fatal_ssl_error();
}
- DEBUG( 'ssl handshake done' );
+ #DEBUG( 'ssl handshake done' );
# ssl connect successful
delete ${*$self}{'_SSL_opening'};
${*$self}{'_SSL_opened'}=1;
@@ -250,13 +255,13 @@ sub accept {
my $socket = ${*$self}{'_SSL_opening'};
if ( ! $socket ) {
# underlying socket not done
- DEBUG( 'no socket yet' );
+ #DEBUG( 'no socket yet' );
$socket = $self->SUPER::accept($class) || return;
- DEBUG( 'accept created normal socket '.$socket );
+ #DEBUG( 'accept created normal socket '.$socket );
}
$self->accept_SSL($socket) || return;
- DEBUG( 'accept_SSL ok' );
+ #DEBUG( 'accept_SSL ok' );
return wantarray ? ($socket, getpeername($socket) ) : $socket;
}
@@ -267,7 +272,7 @@ sub accept_SSL {
my $ssl;
if ( ! ${*$self}{'_SSL_opening'} ) {
- DEBUG( 'starting sslifying' );
+ #DEBUG( 'starting sslifying' );
${*$self}{'_SSL_opening'} = $socket;
my $arg_hash = ${*$self}{'_SSL_arguments'};
${*$socket}{'_SSL_arguments'} = { %$arg_hash, SSL_server => 0 };
@@ -289,9 +294,9 @@ sub accept_SSL {
$ssl ||= ${*$socket}{'_SSL_object'};
$SSL_ERROR = undef;
- DEBUG( 'calling ssleay::accept' );
+ #DEBUG( 'calling ssleay::accept' );
my $rv = Net::SSLeay::accept($ssl);
- DEBUG( 'called ssleay::accept rv='.$rv );
+ #DEBUG( 'called ssleay::accept rv='.$rv );
if ( $rv < 0 ) {
unless ( $self->_set_rw_error( $ssl,$rv )) {
$self->error("SSL accept attempt failed with unknown error");
@@ -305,7 +310,7 @@ sub accept_SSL {
return $socket->fatal_ssl_error();
}
- DEBUG( 'handshake done, socket ready' );
+ #DEBUG( 'handshake done, socket ready' );
# socket opened
delete ${*$self}{'_SSL_opening'};
${*$socket}{'_SSL_opened'} = 1;
@@ -518,7 +523,7 @@ sub start_SSL {
my $start_handshake = $arg_hash->{SSL_startHandshake};
if ( ! defined($start_handshake) || $start_handshake ) {
# if we have no callback force blocking mode
- DEBUG( "start handshake" );
+ #DEBUG( "start handshake" );
my $blocking = $socket->blocking(1);
my $result = ${*$socket}{'_SSL_arguments'}{SSL_server}
? $socket->accept_SSL
@@ -526,7 +531,7 @@ sub start_SSL {
$socket->blocking(0) if !$blocking;
return $result ? $socket : (bless($socket, $original_class) && ());
} else {
- DEBUG( "dont start handshake: $socket" );
+ #DEBUG( "dont start handshake: $socket" );
return $socket; # just return upgraded socket
}
@@ -710,8 +715,7 @@ 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
-{
+sub new {
my $class = shift;
my $arg_hash = (ref($_[0]) eq 'HASH') ? $_[0] : {@_};
@@ -771,13 +775,31 @@ sub new
Net::SSLeay::CTX_set_default_passwd_cb($ctx, $arg_hash->{'SSL_passwd_cb'});
}
- Net::SSLeay::CTX_use_PrivateKey_file
- ($ctx, $arg_hash->{'SSL_key_file'}, $filetype)
- || return IO::Socket::SSL->error("Failed to open Private Key");
+ if ( my $pkey= $arg_hash->{SSL_key} ) {
+ # binary, e.g. EVP_PKEY*
+ Net::SSLeay::CTX_use_PrivateKey($ctx, $pkey)
+ || return IO::Socket::SSL->error("Failed to use Private Key");
+ } elsif ( my $f = $arg_hash->{SSL_key_file} ) {
+ Net::SSLeay::CTX_use_PrivateKey_file($ctx, $f, $filetype)
+ || return IO::Socket::SSL->error("Failed to open Private Key");
+ }
- Net::SSLeay::CTX_use_certificate_chain_file
- ($ctx, $arg_hash->{'SSL_cert_file'})
- || return IO::Socket::SSL->error("Failed to open Certificate");
+ if ( my $x509 = $arg_hash->{SSL_cert} ) {
+ # binary, e.g. X509*
+ # we habe either a single certificate or a list with
+ # a chain of certificates
+ my @x509 = ref($x509) eq 'ARRAY' ? @$x509: ($x509);
+ my $cert = shift @x509;
+ Net::SSLeay::CTX_use_certificate( $ctx,$cert )
+ || return IO::Socket::SSL->error("Failed to use Certificate");
+ foreach my $ca (@x509) {
+ Net::SSLeay::CTX_add_extra_chain_cert( $ctx,$ca )
+ || return IO::Socket::SSL->error("Failed to use Certificate");
+ }
+ } elsif ( my $f = $arg_hash->{SSL_cert_file} ) {
+ Net::SSLeay::CTX_use_certificate_chain_file($ctx, $f)
+ || return IO::Socket::SSL->error("Failed to open Certificate");
+ }
}
my $verify_callback = $verify_cb &&
@@ -802,7 +824,7 @@ sub new
return IO::Socket::SSL->error("Session caches not supported for Net::SSLeay < v1.26");
} else {
$ctx_object->{'session_cache'} =
- new IO::Socket::SSL::Session_Cache($arg_hash) || undef;
+ IO::Socket::SSL::Session_Cache->new($arg_hash) || undef;
}
}
@@ -979,6 +1001,13 @@ specify a different location. Keys should be PEM formatted, and if they are
encrypted, you will be prompted to enter a password before the socket is formed
(unless you specified the SSL_passwd_cb option).
+=item SSL_key
+
+This is an EVP_PKEY* and can be used instead of SSL_key_file.
+Useful if you don't have your key in a file but create it dynamically or get it from
+a string (see openssl PEM_read_bio_PrivateKey etc for getting a EVP_PKEY* from
+a string).
+
=item SSL_cert_file
If your SSL certificate is not in the default place (F<certs/server-cert.pem> for servers,
@@ -987,6 +1016,14 @@ location of your certificate. Note that a key and certificate are only required
SSL server, so you do not need to bother with these trifling options should you be
setting up an unauthenticated client.
+=item SSL_cert
+
+This is an X509* or an array of X509*.
+The first X509* is the internal representation of the certificate while the following
+ones are extra certificates. Useful if you create your certificate dynamically (like
+in a SSL intercepting proxy) or get it from a string (see openssl PEM_read_bio_X509 etc
+for getting a X509* from a string).
+
=item SSL_passwd_cb
If your private key is encrypted, you might not want the default password prompt from
@@ -1211,7 +1248,7 @@ A few changes have gone into IO::Socket::SSL v0.93 and later with respect to
return values. The behavior on success remains unchanged, but for I<all> functions,
the return value on error is now an empty list. Therefore, the return value will be
false in all contexts, but those who have been using the return values as arguments
-to subroutines (like C<mysub(new IO::Socket::SSL(...), ...)>) may run into problems.
+to subroutines (like C<mysub(IO::Socket::SSL(...)->new, ...)>) may run into problems.
The moral of the story: I<always> check the return values of these functions before
using them in any way that you consider meaningful.
@@ -1339,10 +1376,14 @@ IO::Socket::INET, IO::Socket::INET6, Net::SSLeay.
=head1 AUTHORS
+Steffen Ullrich, <steffen at genua.de> is the current maintainer.
+
Peter Behroozi, <behrooz at fas.harvard.edu> (Note the lack of an "i" at the end of "behrooz")
Marko Asplund, <marko.asplund at kronodoc.fi>, was the original author of IO::Socket::SSL.
+Patches incorporated from various people, see file Changes.
+
=head1 COPYRIGHT
The rewrite of this module is Copyright (C) 2002-2005 Peter Behroozi.
@@ -0,0 +1,118 @@
+#!perl -w
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl t/nonblock.t'
+
+# Tests the use if SSL_cert instead of SSL_cert_file
+# because Net::SSLeay does not implement the necessary functions
+# to create a X509 from file/string (PEM_read_bio_X509) I just
+# create a server with SSL_cert_file and get the X509 from it using
+# Net::SSLeay::get_certificate.
+# Test should also test if SSL_cert is an array of X509*
+# and if SSL_key is an EVP_PKEY* but with the current function in
+# Net::SSLeay I don't see a way to test it
+
+use Net::SSLeay;
+use Socket;
+use IO::Socket::SSL;
+use strict;
+
+use vars qw( $SSL_SERVER_PORT $SSL_SERVER_ADDR );
+do "t/ssl_settings.req" || do "ssl_settings.req";
+
+if ( grep { $^O =~m{$_} } qw( MacOS VOS vmesa riscos amigaos ) ) {
+ print "1..0 # Skipped: fork not implemented on this platform\n";
+ exit
+}
+
+$|=1;
+print "1..9\n";
+
+my $ID = 'server';
+my %server_args = (
+ LocalPort => 0, # take random port
+ LocalAddr => $SSL_SERVER_ADDR,
+ Listen => 2,
+ ReuseAddr => 1,
+ SSL_server => 1,
+ SSL_verify_mode => 0x00,
+ SSL_ca_file => "certs/test-ca.pem",
+ SSL_key_file => "certs/client-key.pem",
+);
+
+my ($x509,@server);
+foreach my $test ( 1,2,3 ) {
+ my %args = %server_args;
+ my $spec;
+ if ( $test == 1 ) {
+ # 1st test: create server with SSL_cert_file
+ $args{SSL_cert_file} = "certs/client-cert.pem";
+ $spec = 'Using SSL_cert_file';
+ } elsif ( $test == 2 ) {
+ # 2nd test: use x509 from previous server
+ # with SSL_cert instead of SSL_cert_file
+ $args{SSL_cert} = $x509;
+ $spec = 'Using SSL_cert';
+ } elsif ( $test == 3 ) {
+ # 3rd test: empty SSL_cert, so that default
+ # SSL_cert_file gets not used
+ # server creation should fail
+ $spec = 'Empty SSL_cert';
+ $args{SSL_cert} = undef;
+ }
+
+ # create server
+ my $server = IO::Socket::SSL->new( %args ) || do {
+ notok( "$spec: $!" );
+ next;
+ };
+ my ($port) = unpack_sockaddr_in( getsockname($server) );
+ #DEBUG( "Server listening to $SSL_SERVER_ADDR:$port" );
+ ok("Server Initialization $spec");
+ push @server,$server;
+
+
+ # then connect to it from a child
+ defined( my $pid = fork() ) || die $!;
+ if ( $pid == 0 ) {
+ close($server);
+ $ID = 'client';
+
+ my $to_server = IO::Socket::SSL->new(
+ PeerAddr => $SSL_SERVER_ADDR,
+ PeerPort => $port,
+ SSL_verify_mode => 0x00,
+ );
+ if ( $test == 3 ) {
+ notok( "$spec: connect suceeded" ) if $to_server;
+ ok( "$spec: connect failed" );
+ exit;
+ } elsif ( ! $to_server ) {
+ notok( "connect failed: $!" );
+ exit
+ };
+ ok( "client connected $spec" );
+ <$to_server>; # wait for close from parent
+ exit;
+ }
+
+ my $to_client = $server->accept;
+ if ( $test == 3 ) {
+ notok( "$spec: accept suceeded" ) if $to_client;
+ ok( "$spec: accept failed" );
+ } elsif ( ! $to_client ) {
+ notok( "$spec: accept failed: $!" );
+ kill(9,$pid);
+ } else {
+ ok( "Server accepted $spec" );
+ # save the X509 certificate from the server
+ $x509 ||= Net::SSLeay::get_certificate($to_client->_get_ssl_object);
+ }
+
+ close($to_client) if $to_client;
+ wait;
+}
+
+
+
+sub ok { print "ok # [$ID] @_\n"; }
+sub notok { print "not ok # [$ID] @_\n"; }
@@ -2,8 +2,6 @@
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl t/core.t'
-eval 'use Debug';
-*{DEBUG} = sub {} if !defined(&DEBUG);
use Net::SSLeay;
use Socket;
@@ -354,7 +352,7 @@ if ($GUARANTEED_TO_HAVE_NONBLOCKING_SOCKETS) {
IO::Select->new($server)->can_read(30);
$client = $server->accept;
while ( ! $client ) {
- DEBUG( "$!,$SSL_ERROR" );
+ #DEBUG( "$!,$SSL_ERROR" );
if ( $! == EAGAIN ) {
if ( $SSL_ERROR == SSL_WANT_WRITE ) {
IO::Select->new( $server->opening )->can_write(30);
@@ -2,8 +2,6 @@
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl t/nonblock.t'
-eval 'use Debug';
-*{DEBUG} = sub {} if !defined(&DEBUG);
use Net::SSLeay;
use Socket;
@@ -94,12 +92,12 @@ if ( $pid == 0 ) {
while (1) {
$to_server->connect( $server_addr ) && last;
if ( $! == EINPROGRESS ) {
- DEBUG( 'connect in progress' );
+ #DEBUG( 'connect in progress' );
IO::Select->new( $to_server )->can_read(30) && next;
print "not ";
last;
}
- DEBUG( 'connect failed: '.$! );
+ #DEBUG( 'connect failed: '.$! );
print "not ";
last;
}
@@ -120,10 +118,10 @@ if ( $pid == 0 ) {
SSL_cipher_list => 'HIGH',
%extra_options
)) {
- DEBUG( 'start_SSL return undef' );
+ #DEBUG( 'start_SSL return undef' );
print "not ";
} elsif ( !UNIVERSAL::isa( $to_server,'IO::Socket::SSL' ) ) {
- DEBUG( 'failed to upgrade socket' );
+ #DEBUG( 'failed to upgrade socket' );
print "not ";
}
ok( "upgrade client to IO::Socket::SSL" );
@@ -134,14 +132,14 @@ if ( $pid == 0 ) {
my $attempts = 0;
while ( 1 ) {
$to_server->connect_SSL && last;
- DEBUG( $SSL_ERROR );
+ #DEBUG( $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 );
+ #DEBUG( "failed to connect: ".$to_server->errstr );
print "not ";
last;
}
@@ -168,19 +166,19 @@ if ( $pid == 0 ) {
while (1) {
my $n = syswrite( $to_server,$msg,length($msg)-$offset,$offset );
if ( !defined($n) ) {
- DEBUG( "\$!=$! \$SSL_ERROR=$SSL_ERROR send=$bytes_send" );
+ #DEBUG( "\$!=$! \$SSL_ERROR=$SSL_ERROR send=$bytes_send" );
if ( $! == EAGAIN ) {
if ( $SSL_ERROR == SSL_WANT_WRITE ) {
- DEBUG( 'wait for write' );
+ #DEBUG( 'wait for write' );
$attempts++;
IO::Select->new($to_server)->can_write(30);
- DEBUG( "can write again" );
+ #DEBUG( "can write again" );
} elsif ( $SSL_ERROR == SSL_WANT_READ ) {
- DEBUG( 'wait for read' );
+ #DEBUG( 'wait for read' );
IO::Select->new($to_server)->can_read(30);
}
} elsif ( ( $! == EPIPE || $! == ECONNRESET ) && $bytes_send > 30000 ) {
- DEBUG( "connection closed hard" );
+ #DEBUG( "connection closed hard" );
last WRITE;
} else {
print "not ";
@@ -188,10 +186,10 @@ if ( $pid == 0 ) {
}
next;
} elsif ( $n == 0 ) {
- DEBUG( "connection closed" );
+ #DEBUG( "connection closed" );
last WRITE;
} elsif ( $n<0 ) {
- DEBUG( "syswrite returned $n!" );
+ #DEBUG( "syswrite returned $n!" );
print "not ";
last WRITE;
}
@@ -201,7 +199,7 @@ if ( $pid == 0 ) {
last
} else {
$offset += $n;
- DEBUG( "partial write of $n new offset=$offset" );
+ #DEBUG( "partial write of $n new offset=$offset" );
}
}
}
@@ -232,7 +230,7 @@ if ( $pid == 0 ) {
my $from_client = $server->accept or print "not ";
ok( "tcp accept" );
$from_client || do {
- DEBUG( "failed to accept: $!" );
+ #DEBUG( "failed to accept: $!" );
next;
};
@@ -262,10 +260,10 @@ if ( $pid == 0 ) {
SSL_cipher_list => 'HIGH',
%extra_options
)) {
- DEBUG( 'start_SSL return undef' );
+ #DEBUG( 'start_SSL return undef' );
print "not ";
} elsif ( !UNIVERSAL::isa( $from_client,'IO::Socket::SSL' ) ) {
- DEBUG( 'failed to upgrade socket' );
+ #DEBUG( 'failed to upgrade socket' );
print "not ";
}
ok( "upgrade to_client to IO::Socket::SSL" );
@@ -278,7 +276,7 @@ if ( $pid == 0 ) {
my $attempts = 0;
while ( 1 ) {
$from_client->accept_SSL && last;
- DEBUG( $SSL_ERROR );
+ #DEBUG( $SSL_ERROR );
if ( $SSL_ERROR == SSL_WANT_READ ) {
$attempts++;
IO::Select->new($from_client)->can_read(30) && next; # retry if can read
@@ -286,7 +284,7 @@ if ( $pid == 0 ) {
$attempts++;
IO::Select->new($from_client)->can_write(30) && next; # retry if can write
}
- DEBUG( "failed to accept: ".$from_client->errstr );
+ #DEBUG( "failed to accept: ".$from_client->errstr );
print "not ";
last;
}
@@ -303,7 +301,7 @@ if ( $pid == 0 ) {
IO::Select->new( $from_client )->can_read(30);
( sysread( $from_client, $buf,10 ) == 10 ) || print "not ";
- DEBUG($buf);
+ #DEBUG($buf);
ok( "received client message" );
sleep(5);
@@ -314,7 +312,7 @@ if ( $pid == 0 ) {
while ( ( my $diff = 30000 - $bytes_received ) > 0 ) {
my $n = sysread( $from_client,my $buf,$diff );
if ( !defined($n) ) {
- DEBUG( "\$!=$! \$SSL_ERROR=$SSL_ERROR" );
+ #DEBUG( "\$!=$! \$SSL_ERROR=$SSL_ERROR" );
if ( $! == EAGAIN ) {
if ( $SSL_ERROR == SSL_WANT_READ ) {
$attempts++;
@@ -329,10 +327,10 @@ if ( $pid == 0 ) {
}
next;
} elsif ( $n == 0 ) {
- DEBUG( "connection closed" );
+ #DEBUG( "connection closed" );
last READ;
} elsif ( $n<0 ) {
- DEBUG( "sysread returned $n!" );
+ #DEBUG( "sysread returned $n!" );
print "not ";
last READ;
}
@@ -341,7 +339,7 @@ if ( $pid == 0 ) {
#DEBUG( "read of $n bytes" );
}
- DEBUG( "read $bytes_received" );
+ #DEBUG( "read $bytes_received" );
close($from_client);
}
@@ -2,8 +2,6 @@
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl t/nonblock.t'
-eval 'use Debug';
-*{DEBUG} = sub {} if !defined(&DEBUG);
use Net::SSLeay;
use Socket;
@@ -65,7 +63,7 @@ if ( $pid == 0 ) {
SSL_cipher_list => 'HIGH',
%extra_options
)) {
- DEBUG( $SSL_ERROR );
+ #DEBUG( $SSL_ERROR );
print "not ";
}
ok( "sslify client" );
@@ -99,14 +97,14 @@ IO::Socket::SSL->start_SSL( $csock,
SSL_cipher_list => 'HIGH',
%extra_options
) || print "not ";
-DEBUG( $IO::Socket::SSL::ERROR );
+#DEBUG( $IO::Socket::SSL::ERROR );
ok( 'sslify server' );
UNIVERSAL::isa( $csock,'IO::Socket::SSL' ) || print "not ";
ok( 'server reblessed as IO::Socket::SSL' );
my $l = <$csock>;
-DEBUG($l);
+#DEBUG($l);
print "not " if $l ne "hannibal\n";
ok( "received client message" );
@@ -0,0 +1,153 @@
+#!perl -w
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl t/nonblock.t'
+
+# This tests that sysread/syswrite behave different to read/write, e.g.
+# that the latter ones are blocking until they read/write everything while
+# the sys* function also can read/write partial data.
+
+use Net::SSLeay;
+use Socket;
+use IO::Socket::SSL;
+use strict;
+
+use vars qw( $SSL_SERVER_PORT $SSL_SERVER_ADDR );
+do "t/ssl_settings.req" || do "ssl_settings.req";
+
+if ( grep { $^O =~m{$_} } qw( MacOS VOS vmesa riscos amigaos ) ) {
+ print "1..0 # Skipped: fork not implemented on this platform\n";
+ exit
+}
+
+$|=1;
+print "1..9\n";
+
+#################################################################
+# create Server socket before forking client, so that it is
+# guaranteed to be listening
+#################################################################
+
+# first create simple ssl-server
+my $ID = 'server';
+my $server = IO::Socket::SSL->new(
+ LocalPort => $SSL_SERVER_PORT,
+ LocalAddr => $SSL_SERVER_ADDR,
+ Listen => 2,
+ ReuseAddr => 1,
+ SSL_server => 1,
+ SSL_verify_mode => 0x00,
+ SSL_ca_file => "certs/test-ca.pem",
+ SSL_cert_file => "certs/client-cert.pem",
+ SSL_key_file => "certs/client-key.pem",
+);
+
+print "not ok: $!\n", exit if !$server; # Address in use?
+ok("Server Initialization");
+
+
+defined( my $pid = fork() ) || die $!;
+if ( $pid == 0 ) {
+
+ ############################################################
+ # CLIENT == child process
+ ############################################################
+
+ close($server);
+ $ID = 'client';
+
+ my $to_server = IO::Socket::SSL->new(
+ PeerAddr => $SSL_SERVER_ADDR,
+ PeerPort => $SSL_SERVER_PORT,
+ SSL_verify_mode => 0x00,
+ ) || do {
+ print "not ok: connect failed: $!\n";
+ exit
+ };
+
+ ok( "client connected" );
+
+ # write 512 byte, server reads it in 66 byte chunks which
+ # should cause at least the last read to be less then 66 bytes
+ # (and not block).
+ alarm(10);
+ $SIG{ALRM} = sub {
+ print "not ok: timed out\n";
+ exit;
+ };
+ #DEBUG( "send 2x512 byte" );
+ unless ( syswrite( $to_server, 'x' x 512 ) == 512
+ and syswrite( $to_server, 'x' x 512 ) == 512 ) {
+ print "not ok: write to small: $!\n";
+ exit;
+ }
+
+ sysread( $to_server,my $ack,1 ) || print "not ";
+ ok( "received ack" );
+
+ alarm(0);
+ ok( "send in time" );
+
+ # make a syswrite with a buffer length greater than the
+ # ssl message block size (16k for sslv3). It should send
+ # only a partial packet of 16k
+ my $n = syswrite( $to_server, 'x' x 18000 );
+ #DEBUG( "send $n bytes" );
+ print "not " if $n != 16384;
+ ok( "partial write in syswrite" );
+
+ # but write should send everything because it does ssl_write_all
+ $n = $to_server->write( 'x' x 18000 );
+ #DEBUG( "send $n bytes" );
+ print "not " if $n != 18000;
+ ok( "full write in write" );
+
+ exit;
+
+} else {
+
+ ############################################################
+ # SERVER == parent process
+ ############################################################
+
+ my $to_client = $server->accept || do {
+ print "not ok: accept failed: $!\n";
+ kill(9,$pid);
+ exit;
+ };
+ ok( "Server accepted" );
+
+ my $total = 1024;
+ my $partial;
+ while ( $total > 0 ) {
+ #DEBUG( "reading 66 of $total bytes pending=".$to_client->pending() );
+ my $n = sysread( $to_client, my $buf,66 );
+ #DEBUG( "read $n bytes" );
+ if ( !$n ) {
+ print "not ok: read failed: $!\n";
+ kill(9,$pid);
+ exit;
+ } elsif ( $n != 66 ) {
+ $partial++;
+ }
+ $total -= $n;
+ }
+ print "not " if !$partial;
+ ok( "partial read in sysread" );
+
+ # send ack back
+ print "not " if !syswrite( $to_client, 'x' );
+ ok( "send ack back" );
+
+ # just read so that the writes will not block
+ $to_client->read( my $buf,18000 );
+ $to_client->read( $buf,18000 );
+
+
+ # wait until client exits
+ wait;
+}
+
+exit;
+
+
+sub ok { print "ok # [$ID] @_\n"; }