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