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