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