#!perl -w
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl t/sysread_write.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_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(
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");
my ($SSL_SERVER_PORT) = unpack_sockaddr_in( $server->sockname );
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" );
# TODO does not work on Win32!!!
print "ok # TODO(win32): " if $^O=~m{mswin32}i;
# 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 ($n)" );
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"; }