Commit | Line | Data |
---|---|---|
ce4f4a1c | 1 | #!./perl -w |
61f2b451 | 2 | |
7a4c00b4 | 3 | use Config; |
4 | ||
5 | BEGIN { | |
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 | 27 | my $has_perlio = $] >= 5.008 && find PerlIO::Layer 'perlio'; |
fcdfa64f | 28 | |
61f2b451 | 29 | $| = 1; |
0c28a436 | 30 | print "1..26\n"; |
61f2b451 | 31 | |
560d348b JH |
32 | eval { |
33 | $SIG{ALRM} = sub { die; }; | |
34 | alarm 120; | |
35 | }; | |
36 | ||
61f2b451 | 37 | use 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 | 47 | print "ok 1\n"; |
61f2b451 | 48 | |
a245ea2d IZ |
49 | # Check if can fork with dynamic extensions (bug in CRT): |
50 | if ($^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 | 58 | if($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 |
104 | if($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 |
181 | if ($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 |
199 | print "not " unless $server->blocking; |
200 | print "ok 13\n"; | |
61f2b451 | 201 | |
39990a16 | 202 | if ( $^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 | # | |
216 | local @data; | |
217 | if( !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 | 228 | my $listen = IO::Socket::INET->new(LocalAddr => 'localhost', Listen => 2, Proto => 'tcp', Timeout => 15) || |
cf829ab0 JH |
229 | print "not "; |
230 | print "ok 16\n"; | |
231 | die if( !defined( $listen)); | |
232 | my $serverport = $listen->sockport; | |
cf829ab0 JH |
233 | my $server_pid = fork(); |
234 | if( $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 | 387 | print "ok 25\n"; |
3c83a670 | 388 | |
6dea6691 | 389 | if ( $^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 | } |