This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
dist/IO: Always bind to localhost in tests.
[perl5.git] / dist / IO / t / io_sock.t
CommitLineData
ce4f4a1c 1#!./perl -w
61f2b451 2
7a4c00b4 3use Config;
4
5BEGIN {
ec64f737
SH
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 );
90b9a713
GB
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 }
ec64f737
SH
18 elsif (!$can_fork) {
19 $reason = 'no fork';
90b9a713
GB
20 }
21 if ($reason) {
22 print "1..0 # Skip: $reason\n";
23 exit 0;
61f2b451 24 }
25}
26
16fa8939 27my $has_perlio = $] >= 5.008 && find PerlIO::Layer 'perlio';
fcdfa64f 28
61f2b451 29$| = 1;
0c28a436 30print "1..26\n";
61f2b451 31
560d348b
JH
32eval {
33 $SIG{ALRM} = sub { die; };
34 alarm 120;
35};
36
61f2b451 37use IO::Socket;
38
04093f69
AP
39$listen = IO::Socket::INET->new(LocalAddr => 'localhost',
40 Listen => 2,
7a4c00b4 41 Proto => 'tcp',
862b0ad8
GS
42 # some systems seem to need as much as 10,
43 # so be generous with the timeout
44 Timeout => 15,
7a4c00b4 45 ) or die "$!";
61f2b451 46
7a4c00b4 47print "ok 1\n";
61f2b451 48
a245ea2d
IZ
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
7a4c00b4 56$port = $listen->sockport;
61f2b451 57
7a4c00b4 58if($pid = fork()) {
61f2b451 59
e197ebb9 60 $sock = $listen->accept() or die "accept failed: $!";
61f2b451 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";
61f2b451 73
7a4c00b4 74} elsif(defined $pid) {
61f2b451 75
76 $sock = IO::Socket::INET->new(PeerPort => $port,
77 Proto => 'tcp',
78 PeerAddr => 'localhost'
9b599b2a 79 )
6e806fe3
CT
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)";
61f2b451 85
86 $sock->autoflush(1);
7a4c00b4 87
61f2b451 88 print $sock "ok 3\n";
7a4c00b4 89
61f2b451 90 print $sock->getline();
7a4c00b4 91
61f2b451 92 $sock->close;
7a4c00b4 93
61f2b451 94 exit;
95} else {
96 die;
97}
98
cf7fe8a2
GS
99# Test various other ways to create INET sockets that should
100# also work.
04093f69 101$listen = IO::Socket::INET->new(LocalAddr => 'localhost', Listen => '', Timeout => 15) or die "$!";
cf7fe8a2 102$port = $listen->sockport;
61f2b451 103
cf7fe8a2
GS
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
6e806fe3
CT
118 $sock = IO::Socket::INET->new("localhost:$port")
119 || IO::Socket::INET->new("127.0.0.1:$port");
cf7fe8a2
GS
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
d6a255e6 139 sleep(2);
cf7fe8a2
GS
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 }
61f2b451 151
cf7fe8a2 152 # some machines seem to suffer from a race condition here
e3e876cf 153 sleep(1);
61f2b451 154
cf7fe8a2 155 $sock = IO::Socket->new(Domain => AF_INET,
6e806fe3
CT
156 PeerAddr => "localhost:$port")
157 || IO::Socket->new(Domain => AF_INET,
158 PeerAddr => "127.0.0.1:$port");
cf7fe8a2
GS
159 if ($sock) {
160 $sock->print("ok 11\n");
161 $sock->print("quit\n");
9d44748a
JH
162 } else {
163 print "not ok 11\n";
cf7fe8a2
GS
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',
6e806fe3
CT
175 LocalAddr => 'localhost')
176 || IO::Socket->new(Domain => AF_INET,
177 Proto => 'udp',
178 LocalAddr => '127.0.0.1');
cf7fe8a2
GS
179$port = $server->sockport;
180
b606c525
JH
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;
cf7fe8a2 195} else {
b606c525 196 die;
cf7fe8a2 197}
61f2b451 198
cf7fe8a2
GS
199print "not " unless $server->blocking;
200print "ok 13\n";
61f2b451 201
39990a16 202if ( $^O eq 'qnx' ) {
6dea6691 203 # QNX4 library bug: Can set non-blocking on socket, but
39990a16 204 # cannot return that status.
6dea6691 205 print "ok 14 # skipped on QNX4\n";
39990a16
NA
206} else {
207 $server->blocking(0);
208 print "not " if $server->blocking;
209 print "ok 14\n";
210}
cf829ab0
JH
211
212### TEST 15
213### Set up some data to be transfered between the server and
214### the client. We'll use own source code ...
215#
216local @data;
217if( !open( SRC, "< $0")) {
3c83a670 218 print "not ok 15 - $!\n";
cf829ab0
JH
219} else {
220 @data = <SRC>;
fcdfa64f 221 close(SRC);
3c83a670 222 print "ok 15\n";
cf829ab0 223}
cf829ab0
JH
224
225### TEST 16
226### Start the server
227#
04093f69 228my $listen = IO::Socket::INET->new(LocalAddr => 'localhost', Listen => 2, Proto => 'tcp', Timeout => 15) ||
cf829ab0
JH
229 print "not ";
230print "ok 16\n";
231die if( !defined( $listen));
232my $serverport = $listen->sockport;
cf829ab0
JH
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
ce4f4a1c 263 ### TEST 21
cf829ab0
JH
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 funktion, 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 #
0c28a436
JH
272 ### TESTS 19,20,21,22
273 ### Try to ping-pong some Unicode.
fcdfa64f 274 #
cf829ab0
JH
275 $sock = IO::Socket::INET->new("localhost:$serverport")
276 || IO::Socket::INET->new("127.0.0.1:$serverport");
277
ce4f4a1c
JH
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 }
fcdfa64f 283
cf829ab0 284 if ($sock) {
fcdfa64f
JH
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}" ?
ce4f4a1c 290 "ok 20\n" : "not ok 20\n";
0c28a436
JH
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";
fcdfa64f 301 } else {
0c28a436 302 print "ok $_ - Skip: no perlio\n" for 20..22;
fcdfa64f
JH
303 }
304
cf829ab0
JH
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 }
0c28a436 322 print "ok 23\n";
cf829ab0 323
0c28a436 324 ### TEST 24
cf829ab0
JH
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 }
0c28a436 338 print "ok 24\n";
cf829ab0 339
fcdfa64f 340} elsif (defined($server_pid)) {
cf829ab0
JH
341
342 ### Child
343 #
344 SERVER_LOOP: while (1) {
345 last SERVER_LOOP unless $sock = $listen->accept;
0c28a436
JH
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.
29929b39 348 if ($has_perlio) { binmode($sock, ":utf8") or die }
cf829ab0
JH
349 while (<$sock>) {
350 last SERVER_LOOP if /^quit/;
351 last if /^done/;
fcdfa64f
JH
352 if (/^ping (.+)/) {
353 print $sock "pong $1\n";
354 next;
355 }
0c28a436
JH
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 }
fcdfa64f 364 if (/^send/) {
cf829ab0
JH
365 print $sock @data;
366 last;
367 }
368 print;
369 }
370 $sock = undef;
371 }
372 $listen->close;
3c83a670 373 exit 0;
cf829ab0
JH
374
375} else {
376
377 ### Fork failed
378 #
379 print "not ok 17\n";
380 die;
381}
382
3c83a670
DM
383# test Blocking option in constructor
384
385$sock = IO::Socket::INET->new(Blocking => 0)
386 or print "not ";
0c28a436 387print "ok 25\n";
3c83a670 388
6dea6691 389if ( $^O eq 'qnx' ) {
0c28a436 390 print "ok 26 # skipped on QNX4\n";
6dea6691
NA
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;
0c28a436 396 print "ok 26\n";
6dea6691 397}