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