Commit | Line | Data |
61f2b451 |
1 | #!./perl |
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; |
fcdfa64f |
34 | print "1..23\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 | |
270 | ### TEST 19 |
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 | # |
fcdfa64f |
279 | ### TEST 20 |
280 | ### Try to ping-pong a Unicode character. |
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 | |
fcdfa64f |
288 | binmode($sock, ":utf8") if $has_perlio; |
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}" ? |
296 | "ok 19\n" : "not ok 19\n"; |
297 | } else { |
298 | print "ok 19 - Skip: no perlio\n"; |
299 | } |
300 | |
cf829ab0 |
301 | $sock->print("send\n"); |
302 | |
303 | my @array = (); |
304 | while( !eof( $sock ) ){ |
305 | while( <$sock>) { |
306 | push( @array, $_); |
307 | last; |
308 | } |
309 | } |
310 | |
311 | $sock->print("done\n"); |
312 | $sock->close; |
313 | |
314 | print "not " if( @array != @data); |
315 | } else { |
316 | print "not "; |
317 | } |
fcdfa64f |
318 | print "ok 20\n"; |
b62e3068 |
319 | } |
cf829ab0 |
320 | |
fcdfa64f |
321 | ### TEST 21 |
cf829ab0 |
322 | ### Stop the server |
323 | # |
324 | $sock = IO::Socket::INET->new("localhost:$serverport") |
325 | || IO::Socket::INET->new("127.0.0.1:$serverport"); |
326 | |
327 | if ($sock) { |
328 | $sock->print("done\n"); |
329 | $sock->close; |
330 | |
331 | print "not " if( 1 != kill 0, $server_pid); |
332 | } else { |
333 | print "not "; |
334 | } |
fcdfa64f |
335 | print "ok 21\n"; |
cf829ab0 |
336 | |
fcdfa64f |
337 | } elsif (defined($server_pid)) { |
cf829ab0 |
338 | |
339 | ### Child |
340 | # |
341 | SERVER_LOOP: while (1) { |
342 | last SERVER_LOOP unless $sock = $listen->accept; |
343 | while (<$sock>) { |
344 | last SERVER_LOOP if /^quit/; |
345 | last if /^done/; |
fcdfa64f |
346 | if (/^ping (.+)/) { |
347 | print $sock "pong $1\n"; |
348 | next; |
349 | } |
350 | if (/^send/) { |
cf829ab0 |
351 | print $sock @data; |
352 | last; |
353 | } |
354 | print; |
355 | } |
356 | $sock = undef; |
357 | } |
358 | $listen->close; |
3c83a670 |
359 | exit 0; |
cf829ab0 |
360 | |
361 | } else { |
362 | |
363 | ### Fork failed |
364 | # |
365 | print "not ok 17\n"; |
366 | die; |
367 | } |
368 | |
3c83a670 |
369 | # test Blocking option in constructor |
370 | |
371 | $sock = IO::Socket::INET->new(Blocking => 0) |
372 | or print "not "; |
fcdfa64f |
373 | print "ok 22\n"; |
3c83a670 |
374 | |
6dea6691 |
375 | if ( $^O eq 'qnx' ) { |
fcdfa64f |
376 | print "ok 23 # skipped on QNX4\n"; |
6dea6691 |
377 | # QNX4 library bug: Can set non-blocking on socket, but |
378 | # cannot return that status. |
379 | } else { |
380 | my $status = $sock->blocking; |
381 | print "not " unless defined $status && !$status; |
fcdfa64f |
382 | print "ok 23\n"; |
6dea6691 |
383 | } |