1#!./perl -w
2
3use Config;
4
5BEGIN {
6    my $can_fork = $Config{d_fork} ||
7		    (($^O eq 'MSWin32' || $^O eq 'NetWare') and
8		     $Config{useithreads} and
9		     $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/
10		    );
11    my $reason;
12    if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bSocket\b/) {
13	$reason = 'Socket extension unavailable';
14    }
15    elsif ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bIO\b/) {
16	$reason = 'IO extension unavailable';
17    }
18    elsif (!$can_fork) {
19        $reason = 'no fork';
20    }
21    $reason = q[Test out of sequence on windows] if $^O eq 'MSWin32' && $ENV{CONTINUOUS_INTEGRATION};
22    if ($reason) {
23	print "1..0 # Skip: $reason\n";
24	exit 0;
25    }
26}
27
28my $has_perlio = find PerlIO::Layer 'perlio';
29
30$| = 1;
31print "1..26\n";
32
33eval {
34    $SIG{ALRM} = sub { die; };
35    alarm 120;
36};
37
38use IO::Socket;
39
40$listen = IO::Socket::INET->new(LocalAddr => 'localhost',
41				Listen => 2,
42				Proto => 'tcp',
43				# some systems seem to need as much as 10,
44				# so be generous with the timeout
45				Timeout => 15,
46			       ) or die "$!";
47
48print "ok 1\n";
49
50# Check if can fork with dynamic extensions (bug in CRT):
51if ($^O eq 'os2' and
52    system "$^X -I../lib -MOpcode -e 'defined fork or die'  > /dev/null 2>&1") {
53    print "ok $_ # skipped: broken fork\n" for 2..5;
54    exit 0;
55}
56
57$port = $listen->sockport;
58
59if($pid = fork()) {
60
61    $sock = $listen->accept() or die "accept failed: $!";
62    print "ok 2\n";
63
64    $sock->autoflush(1);
65    print $sock->getline();
66
67    print $sock "ok 4\n";
68
69    $sock->close;
70
71    waitpid($pid,0);
72
73    print "ok 5\n";
74
75} elsif(defined $pid) {
76
77    $sock = IO::Socket::INET->new(PeerPort => $port,
78				  Proto => 'tcp',
79				  PeerAddr => 'localhost'
80				 )
81         || IO::Socket::INET->new(PeerPort => $port,
82				  Proto => 'tcp',
83				  PeerAddr => '127.0.0.1'
84				 )
85	or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)";
86
87    $sock->autoflush(1);
88
89    print $sock "ok 3\n";
90
91    print $sock->getline();
92
93    $sock->close;
94
95    exit;
96} else {
97 die;
98}
99
100# Test various other ways to create INET sockets that should
101# also work.
102$listen = IO::Socket::INET->new(LocalAddr => 'localhost', Listen => '', Timeout => 15) or die "$!";
103$port = $listen->sockport;
104
105if($pid = fork()) {
106  SERVER_LOOP:
107    while (1) {
108       last SERVER_LOOP unless $sock = $listen->accept;
109       while (<$sock>) {
110           last SERVER_LOOP if /^quit/;
111           last if /^done/;
112           print;
113       }
114       $sock = undef;
115    }
116    $listen->close;
117} elsif (defined $pid) {
118    # child, try various ways to connect
119    $sock = IO::Socket::INET->new("localhost:$port")
120         || IO::Socket::INET->new("127.0.0.1:$port");
121    if ($sock) {
122	print "not " unless $sock->connected;
123	print "ok 6\n";
124       $sock->print("ok 7\n");
125       sleep(1);
126       print "ok 8\n";
127       $sock->print("ok 9\n");
128       $sock->print("done\n");
129       $sock->close;
130    }
131    else {
132	print "# $@\n";
133	print "not ok 6\n";
134	print "not ok 7\n";
135	print "not ok 8\n";
136	print "not ok 9\n";
137    }
138
139    # some machines seem to suffer from a race condition here
140    sleep(2);
141
142    $sock = IO::Socket::INET->new("127.0.0.1:$port");
143    if ($sock) {
144       $sock->print("ok 10\n");
145       $sock->print("done\n");
146       $sock->close;
147    }
148    else {
149	print "# $@\n";
150	print "not ok 10\n";
151    }
152
153    # some machines seem to suffer from a race condition here
154    sleep(1);
155
156    $sock = IO::Socket->new(Domain => AF_INET,
157                            PeerAddr => "localhost:$port")
158         || IO::Socket->new(Domain => AF_INET,
159                            PeerAddr => "127.0.0.1:$port");
160    if ($sock) {
161       $sock->print("ok 11\n");
162       $sock->print("quit\n");
163    } else {
164       print "not ok 11\n";
165    }
166    $sock = undef;
167    sleep(1);
168    exit;
169} else {
170    die;
171}
172
173# Then test UDP sockets
174$server = IO::Socket->new(Domain => AF_INET,
175                          Proto  => 'udp',
176                          LocalAddr => 'localhost')
177       || IO::Socket->new(Domain => AF_INET,
178                          Proto  => 'udp',
179                          LocalAddr => '127.0.0.1');
180$port = $server->sockport;
181
182if ($pid = fork()) {
183    my $buf;
184    $server->recv($buf, 100);
185    print $buf;
186} elsif (defined($pid)) {
187    #child
188    $sock = IO::Socket::INET->new(Proto => 'udp',
189                                  PeerAddr => "localhost:$port")
190         || IO::Socket::INET->new(Proto => 'udp',
191                                  PeerAddr => "127.0.0.1:$port");
192    $sock->send("ok 12\n");
193    sleep(1);
194    $sock->send("ok 12\n");  # send another one to be sure
195    exit;
196} else {
197    die;
198}
199
200print "not " unless $server->blocking;
201print "ok 13\n";
202
203if ( $^O eq 'qnx' ) {
204  # QNX4 library bug: Can set non-blocking on socket, but
205  # cannot return that status.
206  print "ok 14 # skipped on QNX4\n";
207} else {
208  $server->blocking(0);
209  print "not " if $server->blocking;
210  print "ok 14\n";
211}
212
213### TEST 15
214### Set up some data to be transferred between the server and
215### the client. We'll use own source code ...
216#
217local @data;
218if( !open( SRC, '<', $0)) {
219    print "not ok 15 - $!\n";
220} else {
221    @data = <SRC>;
222    close(SRC);
223    print "ok 15\n";
224}
225
226### TEST 16
227### Start the server
228#
229my $listen = IO::Socket::INET->new(LocalAddr => 'localhost', Listen => 2, Proto => 'tcp', Timeout => 15) ||
230    print "not ";
231print "ok 16\n";
232die if( !defined( $listen));
233my $serverport = $listen->sockport;
234my $server_pid = fork();
235if( $server_pid) {
236
237    ### TEST 17 Client/Server establishment
238    #
239    print "ok 17\n";
240
241    ### TEST 18
242    ### Get data from the server using a single stream
243    #
244    $sock = IO::Socket::INET->new("localhost:$serverport")
245         || IO::Socket::INET->new("127.0.0.1:$serverport");
246
247    if ($sock) {
248	$sock->print("send\n");
249
250	my @array = ();
251	while( <$sock>) {
252	    push( @array, $_);
253	}
254
255	$sock->print("done\n");
256	$sock->close;
257
258	print "not " if( @array != @data);
259    } else {
260	print "not ";
261    }
262    print "ok 18\n";
263
264    ### TEST 21
265    ### Get data from the server using a stream, which is
266    ### interrupted by eof calls.
267    ### On perl-5.7.0@7673 this failed in a SOCKS environment, because eof
268    ### did an getc followed by an ungetc in order to check for the streams
269    ### end. getc(3) got replaced by the SOCKS function, which ended up in
270    ### a recv(2) call on the socket, while ungetc(3) put back a character
271    ### to an IO buffer, which never again was read.
272    #
273    ### TESTS 19,20,21,22
274    ### Try to ping-pong some Unicode.
275    #
276    $sock = IO::Socket::INET->new("localhost:$serverport")
277         || IO::Socket::INET->new("127.0.0.1:$serverport");
278
279    if ($has_perlio) {
280	print binmode($sock, ":utf8") ? "ok 19\n" : "not ok 19\n";
281    } else {
282	print "ok 19 - Skip: no perlio\n";
283    }
284
285    if ($sock) {
286
287	if ($has_perlio) {
288	    $sock->print("ping \x{100}\n");
289	    chomp(my $pong = scalar <$sock>);
290	    print $pong =~ /^pong (.+)$/ && $1 eq "\x{100}" ?
291		"ok 20\n" : "not ok 20\n";
292
293	    $sock->print("ord \x{100}\n");
294	    chomp(my $ord = scalar <$sock>);
295	    print $ord == 0x100 ?
296		"ok 21\n" : "not ok 21\n";
297
298	    $sock->print("chr 0x100\n");
299	    chomp(my $chr = scalar <$sock>);
300	    print $chr eq "\x{100}" ?
301		"ok 22\n" : "not ok 22\n";
302	} else {
303	    print "ok $_ - Skip: no perlio\n" for 20..22;
304	}
305
306	$sock->print("send\n");
307
308	my @array = ();
309	while( !eof( $sock ) ){
310	    while( <$sock>) {
311		push( @array, $_);
312		last;
313	    }
314	}
315
316	$sock->print("done\n");
317	$sock->close;
318
319	print "not " if( @array != @data);
320    } else {
321	print "not ";
322    }
323    print "ok 23\n";
324
325    ### TEST 24
326    ### Stop the server
327    #
328    $sock = IO::Socket::INET->new("localhost:$serverport")
329         || IO::Socket::INET->new("127.0.0.1:$serverport");
330
331    if ($sock) {
332	$sock->print("done\n");
333	$sock->close;
334
335	print "not " if( 1 != kill 0, $server_pid);
336    } else {
337	print "not ";
338    }
339    print "ok 24\n";
340
341} elsif (defined($server_pid)) {
342
343    ### Child
344    #
345    SERVER_LOOP: while (1) {
346	last SERVER_LOOP unless $sock = $listen->accept;
347	# Do not print ok/not ok for this binmode() since there's
348	# a race condition with our client, just die if we fail.
349	if ($has_perlio) { binmode($sock, ":utf8") or die }
350	while (<$sock>) {
351	    last SERVER_LOOP if /^quit/;
352	    last if /^done/;
353	    if (/^ping (.+)/) {
354		print $sock "pong $1\n";
355		next;
356	    }
357	    if (/^ord (.+)/) {
358		print $sock ord($1), "\n";
359		next;
360	    }
361	    if (/^chr (.+)/) {
362		print $sock chr(hex($1)), "\n";
363		next;
364	    }
365	    if (/^send/) {
366		print $sock @data;
367		last;
368	    }
369	    print;
370	}
371	$sock = undef;
372    }
373    $listen->close;
374    exit 0;
375
376} else {
377
378    ### Fork failed
379    #
380    print "not ok 17\n";
381    die;
382}
383
384# test Blocking option in constructor
385
386$sock = IO::Socket::INET->new(Blocking => 0)
387    or print "not ";
388print "ok 25\n";
389
390if ( $^O eq 'qnx' ) {
391  print "ok 26 # skipped on QNX4\n";
392  # QNX4 library bug: Can set non-blocking on socket, but
393  # cannot return that status.
394} else {
395  my $status = $sock->blocking;
396  print "not " unless defined $status && !$status;
397  print "ok 26\n";
398}
399