1#!perl -w
2# Before `make install' is performed this script should be runnable with
3# `make test'. After `make install' it should work as `perl t/sysread_write.t'
4
5# This tests that sysread/syswrite behave different to read/write, e.g.
6# that the latter ones are blocking until they read/write everything while
7# the sys* function also can read/write partial data.
8
9use Net::SSLeay;
10use Socket;
11use IO::Socket::SSL;
12use strict;
13
14use vars qw( $SSL_SERVER_ADDR );
15do "t/ssl_settings.req" || do "ssl_settings.req";
16
17if ( grep { $^O =~m{$_} } qw( MacOS VOS vmesa riscos amigaos ) ) {
18    print "1..0 # Skipped: fork not implemented on this platform\n";
19    exit
20}
21
22$|=1;
23print "1..9\n";
24
25#################################################################
26# create Server socket before forking client, so that it is
27# guaranteed to be listening
28#################################################################
29
30# first create simple ssl-server
31my $ID = 'server';
32my $server = IO::Socket::SSL->new(
33    LocalAddr => $SSL_SERVER_ADDR,
34    Listen => 2,
35    ReuseAddr => 1,
36    SSL_server => 1,
37    SSL_verify_mode => 0x00,
38    SSL_ca_file => "certs/test-ca.pem",
39    SSL_cert_file => "certs/client-cert.pem",
40    SSL_key_file => "certs/client-key.pem",
41);
42
43print "not ok: $!\n", exit if !$server; # Address in use?
44ok("Server Initialization");
45
46my ($SSL_SERVER_PORT) = unpack_sockaddr_in( $server->sockname );
47
48defined( my $pid = fork() ) || die $!;
49if ( $pid == 0 ) {
50
51    ############################################################
52    # CLIENT == child process
53    ############################################################
54
55    close($server);
56    $ID = 'client';
57
58    my $to_server = IO::Socket::SSL->new( 
59	PeerAddr => $SSL_SERVER_ADDR,
60	PeerPort => $SSL_SERVER_PORT,
61	SSL_verify_mode => 0x00,
62    ) || do {
63    	print "not ok: connect failed: $!\n";
64	exit
65    };
66
67    ok( "client connected" );
68
69    # write 512 byte, server reads it in 66 byte chunks which
70    # should cause at least the last read to be less then 66 bytes
71    # (and not block).
72    alarm(10);
73    $SIG{ALRM} = sub {
74    	print "not ok: timed out\n";
75	exit;
76    };
77    #DEBUG( "send 2x512 byte" );
78    unless ( syswrite( $to_server, 'x' x 512 ) == 512 
79    	and syswrite( $to_server, 'x' x 512 ) == 512 ) {
80    	print "not ok: write to small: $!\n";
81	exit;
82    }
83
84    sysread( $to_server,my $ack,1 ) || print "not ";
85    ok( "received ack" );
86
87    alarm(0);
88    ok( "send in time" );
89
90    # make a syswrite with a buffer length greater than the
91    # ssl message block size (16k for sslv3). It should send
92    # only a partial packet of 16k
93    my $n = syswrite( $to_server, 'x' x 18000 );
94    #DEBUG( "send $n bytes" );
95    print "not " if $n != 16384;
96    ok( "partial write in syswrite" );
97
98    # TODO does not work on Win32!!!
99    print "ok # TODO(win32): " if $^O=~m{mswin32}i;
100    # but write should send everything because it does ssl_write_all
101    $n = $to_server->write( 'x' x 18000 );
102    #DEBUG( "send $n bytes" );
103    print "not " if $n != 18000;
104    ok( "full write in write ($n)" );
105
106    exit;
107
108} else {
109
110    ############################################################
111    # SERVER == parent process
112    ############################################################
113
114    my $to_client = $server->accept || do {
115    	print "not ok: accept failed: $!\n";
116	kill(9,$pid);
117	exit;
118    };
119    ok( "Server accepted" );
120
121    my $total = 1024;
122    my $partial;
123    while ( $total > 0 ) {
124	#DEBUG( "reading 66 of $total bytes pending=".$to_client->pending() );
125    	my $n = sysread( $to_client, my $buf,66 );
126	#DEBUG( "read $n bytes" );
127	if ( !$n ) {
128	    print "not ok: read failed: $!\n";
129	    kill(9,$pid);
130	    exit;
131	} elsif ( $n != 66 ) {
132	    $partial++;
133	}
134	$total -= $n;
135    }
136    print "not " if !$partial;
137    ok( "partial read in sysread" );
138
139    # send ack back
140    print "not " if !syswrite( $to_client, 'x' );
141    ok( "send ack back" );
142
143    # just read so that the writes will not block
144    $to_client->read( my $buf,18000 ); 
145    $to_client->read( $buf,18000 ); 
146	
147
148    # wait until client exits
149    wait;
150}
151
152exit;
153
154
155sub ok { print "ok # [$ID] @_\n"; }
156