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