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 | |
16fa8939 |
31 | my $has_perlio = $] >= 5.008 && find PerlIO::Layer 'perlio'; |
fcdfa64f |
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 | |
b606c525 |
184 | if ($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 |
202 | print "not " unless $server->blocking; |
203 | print "ok 13\n"; |
61f2b451 |
204 | |
39990a16 |
205 | if ( $^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 |
209 | } else { |
210 | $server->blocking(0); |
211 | print "not " if $server->blocking; |
212 | print "ok 14\n"; |
213 | } |
cf829ab0 |
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 | # |
219 | local @data; |
220 | if( !open( SRC, "< $0")) { |
3c83a670 |
221 | print "not ok 15 - $!\n"; |
cf829ab0 |
222 | } else { |
223 | @data = <SRC>; |
fcdfa64f |
224 | close(SRC); |
3c83a670 |
225 | print "ok 15\n"; |
cf829ab0 |
226 | } |
cf829ab0 |
227 | |
228 | ### TEST 16 |
229 | ### Start the server |
230 | # |
231 | my $listen = IO::Socket::INET->new( Listen => 2, Proto => 'tcp', Timeout => 15) || |
232 | print "not "; |
233 | print "ok 16\n"; |
234 | die if( !defined( $listen)); |
235 | my $serverport = $listen->sockport; |
cf829ab0 |
236 | my $server_pid = fork(); |
237 | if( $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 |
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 |
275 | ### TESTS 19,20,21,22 |
276 | ### Try to ping-pong some Unicode. |
fcdfa64f |
277 | # |
cf829ab0 |
278 | $sock = IO::Socket::INET->new("localhost:$serverport") |
279 | || IO::Socket::INET->new("127.0.0.1:$serverport"); |
280 | |
ce4f4a1c |
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 |
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 |
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 |
306 | } |
307 | |
cf829ab0 |
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 |
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 |
344 | |
345 | ### Child |
346 | # |
347 | SERVER_LOOP: while (1) { |
348 | last SERVER_LOOP unless $sock = $listen->accept; |
0c28a436 |
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 |
352 | while (<$sock>) { |
353 | last SERVER_LOOP if /^quit/; |
354 | last if /^done/; |
fcdfa64f |
355 | if (/^ping (.+)/) { |
356 | print $sock "pong $1\n"; |
357 | next; |
358 | } |
0c28a436 |
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 |
368 | print $sock @data; |
369 | last; |
370 | } |
371 | print; |
372 | } |
373 | $sock = undef; |
374 | } |
375 | $listen->close; |
3c83a670 |
376 | exit 0; |
cf829ab0 |
377 | |
378 | } else { |
379 | |
380 | ### Fork failed |
381 | # |
382 | print "not ok 17\n"; |
383 | die; |
384 | } |
385 | |
3c83a670 |
386 | # test Blocking option in constructor |
387 | |
388 | $sock = IO::Socket::INET->new(Blocking => 0) |
389 | or print "not "; |
0c28a436 |
390 | print "ok 25\n"; |
3c83a670 |
391 | |
6dea6691 |
392 | if ( $^O eq 'qnx' ) { |
0c28a436 |
393 | print "ok 26 # skipped on QNX4\n"; |
6dea6691 |
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 | } |