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 { |
774d564b |
13 | if (-d "lib" && -f "TEST") { |
45c0de28 |
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 |
24 | if ($reason) { |
25 | print "1..0 # Skip: $reason\n"; |
7a4c00b4 |
26 | exit 0; |
27 | } |
61f2b451 |
28 | } |
29 | } |
30 | |
fcdfa64f |
31 | my $has_perlio = find PerlIO::Layer 'perlio'; |
32 | |
61f2b451 |
33 | $| = 1; |
0c28a436 |
34 | print "1..26\n"; |
61f2b451 |
35 | |
560d348b |
36 | eval { |
37 | $SIG{ALRM} = sub { die; }; |
38 | alarm 120; |
39 | }; |
40 | |
61f2b451 |
41 | use IO::Socket; |
42 | |
7a4c00b4 |
43 | $listen = IO::Socket::INET->new(Listen => 2, |
44 | Proto => 'tcp', |
862b0ad8 |
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 |
50 | print "ok 1\n"; |
61f2b451 |
51 | |
a245ea2d |
52 | # Check if can fork with dynamic extensions (bug in CRT): |
53 | if ($^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 |
61 | if($pid = fork()) { |
61f2b451 |
62 | |
e197ebb9 |
63 | $sock = $listen->accept() or die "accept failed: $!"; |
61f2b451 |
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 |
78 | |
79 | $sock = IO::Socket::INET->new(PeerPort => $port, |
80 | Proto => 'tcp', |
81 | PeerAddr => 'localhost' |
9b599b2a |
82 | ) |
6e806fe3 |
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 |
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 |
97 | exit; |
98 | } else { |
99 | die; |
100 | } |
101 | |
cf7fe8a2 |
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 |
107 | if($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 |
121 | $sock = IO::Socket::INET->new("localhost:$port") |
122 | || IO::Socket::INET->new("127.0.0.1:$port"); |
cf7fe8a2 |
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 |
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 |
159 | PeerAddr => "localhost:$port") |
160 | || IO::Socket->new(Domain => AF_INET, |
161 | PeerAddr => "127.0.0.1:$port"); |
cf7fe8a2 |
162 | if ($sock) { |
163 | $sock->print("ok 11\n"); |
164 | $sock->print("quit\n"); |
9d44748a |
165 | } else { |
166 | print "not ok 11\n"; |
cf7fe8a2 |
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 |
178 | LocalAddr => 'localhost') |
179 | || IO::Socket->new(Domain => AF_INET, |
180 | Proto => 'udp', |
181 | LocalAddr => '127.0.0.1'); |
cf7fe8a2 |
182 | $port = $server->sockport; |
183 | |
0994c4d0 |
184 | if ($^O eq 'mpeix') { |
185 | print("ok 12 # skipped\n") |
cf7fe8a2 |
186 | } else { |
0994c4d0 |
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', |
6e806fe3 |
194 | PeerAddr => "localhost:$port") |
195 | || IO::Socket::INET->new(Proto => 'udp', |
196 | PeerAddr => "127.0.0.1:$port"); |
0994c4d0 |
197 | $sock->send("ok 12\n"); |
198 | sleep(1); |
199 | $sock->send("ok 12\n"); # send another one to be sure |
200 | exit; |
201 | } else { |
202 | die; |
203 | } |
cf7fe8a2 |
204 | } |
61f2b451 |
205 | |
cf7fe8a2 |
206 | print "not " unless $server->blocking; |
207 | print "ok 13\n"; |
61f2b451 |
208 | |
39990a16 |
209 | if ( $^O eq 'qnx' ) { |
6dea6691 |
210 | # QNX4 library bug: Can set non-blocking on socket, but |
39990a16 |
211 | # cannot return that status. |
6dea6691 |
212 | print "ok 14 # skipped on QNX4\n"; |
39990a16 |
213 | } else { |
214 | $server->blocking(0); |
215 | print "not " if $server->blocking; |
216 | print "ok 14\n"; |
217 | } |
cf829ab0 |
218 | |
219 | ### TEST 15 |
220 | ### Set up some data to be transfered between the server and |
221 | ### the client. We'll use own source code ... |
222 | # |
223 | local @data; |
224 | if( !open( SRC, "< $0")) { |
3c83a670 |
225 | print "not ok 15 - $!\n"; |
cf829ab0 |
226 | } else { |
227 | @data = <SRC>; |
fcdfa64f |
228 | close(SRC); |
3c83a670 |
229 | print "ok 15\n"; |
cf829ab0 |
230 | } |
cf829ab0 |
231 | |
232 | ### TEST 16 |
233 | ### Start the server |
234 | # |
235 | my $listen = IO::Socket::INET->new( Listen => 2, Proto => 'tcp', Timeout => 15) || |
236 | print "not "; |
237 | print "ok 16\n"; |
238 | die if( !defined( $listen)); |
239 | my $serverport = $listen->sockport; |
cf829ab0 |
240 | my $server_pid = fork(); |
241 | if( $server_pid) { |
242 | |
243 | ### TEST 17 Client/Server establishment |
244 | # |
245 | print "ok 17\n"; |
246 | |
247 | ### TEST 18 |
248 | ### Get data from the server using a single stream |
249 | # |
250 | $sock = IO::Socket::INET->new("localhost:$serverport") |
251 | || IO::Socket::INET->new("127.0.0.1:$serverport"); |
252 | |
253 | if ($sock) { |
254 | $sock->print("send\n"); |
255 | |
256 | my @array = (); |
257 | while( <$sock>) { |
258 | push( @array, $_); |
259 | } |
260 | |
261 | $sock->print("done\n"); |
262 | $sock->close; |
263 | |
264 | print "not " if( @array != @data); |
265 | } else { |
266 | print "not "; |
267 | } |
268 | print "ok 18\n"; |
269 | |
ce4f4a1c |
270 | ### TEST 21 |
cf829ab0 |
271 | ### Get data from the server using a stream, which is |
272 | ### interrupted by eof calls. |
273 | ### On perl-5.7.0@7673 this failed in a SOCKS environment, because eof |
274 | ### did an getc followed by an ungetc in order to check for the streams |
275 | ### end. getc(3) got replaced by the SOCKS funktion, which ended up in |
276 | ### a recv(2) call on the socket, while ungetc(3) put back a character |
277 | ### to an IO buffer, which never again was read. |
278 | # |
0c28a436 |
279 | ### TESTS 19,20,21,22 |
280 | ### Try to ping-pong some Unicode. |
fcdfa64f |
281 | # |
b62e3068 |
282 | if ($^O eq 'mpeix') { |
283 | print "ok 19 # skipped: broken on MPE/iX\n"; |
284 | } else { |
cf829ab0 |
285 | $sock = IO::Socket::INET->new("localhost:$serverport") |
286 | || IO::Socket::INET->new("127.0.0.1:$serverport"); |
287 | |
ce4f4a1c |
288 | if ($has_perlio) { |
289 | print binmode($sock, ":utf8") ? "ok 19\n" : "not ok 19\n"; |
290 | } else { |
291 | print "ok 19 - Skip: no perlio\n"; |
292 | } |
fcdfa64f |
293 | |
cf829ab0 |
294 | if ($sock) { |
fcdfa64f |
295 | |
296 | if ($has_perlio) { |
297 | $sock->print("ping \x{100}\n"); |
298 | chomp(my $pong = scalar <$sock>); |
299 | print $pong =~ /^pong (.+)$/ && $1 eq "\x{100}" ? |
ce4f4a1c |
300 | "ok 20\n" : "not ok 20\n"; |
0c28a436 |
301 | |
302 | $sock->print("ord \x{100}\n"); |
303 | chomp(my $ord = scalar <$sock>); |
304 | print $ord == 0x100 ? |
305 | "ok 21\n" : "not ok 21\n"; |
306 | |
307 | $sock->print("chr 0x100\n"); |
308 | chomp(my $chr = scalar <$sock>); |
309 | print $chr eq "\x{100}" ? |
310 | "ok 22\n" : "not ok 22\n"; |
fcdfa64f |
311 | } else { |
0c28a436 |
312 | print "ok $_ - Skip: no perlio\n" for 20..22; |
fcdfa64f |
313 | } |
314 | |
cf829ab0 |
315 | $sock->print("send\n"); |
316 | |
317 | my @array = (); |
318 | while( !eof( $sock ) ){ |
319 | while( <$sock>) { |
320 | push( @array, $_); |
321 | last; |
322 | } |
323 | } |
324 | |
325 | $sock->print("done\n"); |
326 | $sock->close; |
327 | |
328 | print "not " if( @array != @data); |
329 | } else { |
330 | print "not "; |
331 | } |
0c28a436 |
332 | print "ok 23\n"; |
b62e3068 |
333 | } |
cf829ab0 |
334 | |
0c28a436 |
335 | ### TEST 24 |
cf829ab0 |
336 | ### Stop the server |
337 | # |
338 | $sock = IO::Socket::INET->new("localhost:$serverport") |
339 | || IO::Socket::INET->new("127.0.0.1:$serverport"); |
340 | |
341 | if ($sock) { |
342 | $sock->print("done\n"); |
343 | $sock->close; |
344 | |
345 | print "not " if( 1 != kill 0, $server_pid); |
346 | } else { |
347 | print "not "; |
348 | } |
0c28a436 |
349 | print "ok 24\n"; |
cf829ab0 |
350 | |
fcdfa64f |
351 | } elsif (defined($server_pid)) { |
cf829ab0 |
352 | |
353 | ### Child |
354 | # |
355 | SERVER_LOOP: while (1) { |
356 | last SERVER_LOOP unless $sock = $listen->accept; |
0c28a436 |
357 | # Do not print ok/not ok for this binmode() since there's |
358 | # a race condition with our client, just die if we fail. |
29929b39 |
359 | if ($has_perlio) { binmode($sock, ":utf8") or die } |
cf829ab0 |
360 | while (<$sock>) { |
361 | last SERVER_LOOP if /^quit/; |
362 | last if /^done/; |
fcdfa64f |
363 | if (/^ping (.+)/) { |
364 | print $sock "pong $1\n"; |
365 | next; |
366 | } |
0c28a436 |
367 | if (/^ord (.+)/) { |
368 | print $sock ord($1), "\n"; |
369 | next; |
370 | } |
371 | if (/^chr (.+)/) { |
372 | print $sock chr(hex($1)), "\n"; |
373 | next; |
374 | } |
fcdfa64f |
375 | if (/^send/) { |
cf829ab0 |
376 | print $sock @data; |
377 | last; |
378 | } |
379 | print; |
380 | } |
381 | $sock = undef; |
382 | } |
383 | $listen->close; |
3c83a670 |
384 | exit 0; |
cf829ab0 |
385 | |
386 | } else { |
387 | |
388 | ### Fork failed |
389 | # |
390 | print "not ok 17\n"; |
391 | die; |
392 | } |
393 | |
3c83a670 |
394 | # test Blocking option in constructor |
395 | |
396 | $sock = IO::Socket::INET->new(Blocking => 0) |
397 | or print "not "; |
0c28a436 |
398 | print "ok 25\n"; |
3c83a670 |
399 | |
6dea6691 |
400 | if ( $^O eq 'qnx' ) { |
0c28a436 |
401 | print "ok 26 # skipped on QNX4\n"; |
6dea6691 |
402 | # QNX4 library bug: Can set non-blocking on socket, but |
403 | # cannot return that status. |
404 | } else { |
405 | my $status = $sock->blocking; |
406 | print "not " unless defined $status && !$status; |
0c28a436 |
407 | print "ok 26\n"; |
6dea6691 |
408 | } |