This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Move the ext/IO tests to a more standard location so that
[perl5.git] / ext / IO / t / io_sock.t
1 #!./perl -w
2
3 BEGIN {
4     unless(grep /blib/, @INC) {
5         chdir 't' if -d 't';
6         @INC = '../lib';
7     }
8 }
9
10 use Config;
11
12 BEGIN {
13     if (-d "lib" && -f "TEST") {
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         }
24         if ($reason) {
25             print "1..0 # Skip: $reason\n";
26             exit 0;
27         }
28     }
29 }
30
31 my $has_perlio = find PerlIO::Layer 'perlio';
32
33 $| = 1;
34 print "1..26\n";
35
36 eval {
37     $SIG{ALRM} = sub { die; };
38     alarm 120;
39 };
40
41 use IO::Socket;
42
43 $listen = IO::Socket::INET->new(Listen => 2,
44                                 Proto => 'tcp',
45                                 # some systems seem to need as much as 10,
46                                 # so be generous with the timeout
47                                 Timeout => 15,
48                                ) or die "$!";
49
50 print "ok 1\n";
51
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
59 $port = $listen->sockport;
60
61 if($pid = fork()) {
62
63     $sock = $listen->accept() or die "accept failed: $!";
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";
76
77 } elsif(defined $pid) {
78
79     $sock = IO::Socket::INET->new(PeerPort => $port,
80                                   Proto => 'tcp',
81                                   PeerAddr => 'localhost'
82                                  )
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)";
88
89     $sock->autoflush(1);
90
91     print $sock "ok 3\n";
92
93     print $sock->getline();
94
95     $sock->close;
96
97     exit;
98 } else {
99  die;
100 }
101
102 # Test various other ways to create INET sockets that should
103 # also work.
104 $listen = IO::Socket::INET->new(Listen => '', Timeout => 15) or die "$!";
105 $port = $listen->sockport;
106
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
121     $sock = IO::Socket::INET->new("localhost:$port")
122          || IO::Socket::INET->new("127.0.0.1:$port");
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
142     sleep(2);
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     }
154
155     # some machines seem to suffer from a race condition here
156     sleep(1);
157
158     $sock = IO::Socket->new(Domain => AF_INET,
159                             PeerAddr => "localhost:$port")
160          || IO::Socket->new(Domain => AF_INET,
161                             PeerAddr => "127.0.0.1:$port");
162     if ($sock) {
163        $sock->print("ok 11\n");
164        $sock->print("quit\n");
165     } else {
166        print "not ok 11\n";
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',
178                           LocalAddr => 'localhost')
179        || IO::Socket->new(Domain => AF_INET,
180                           Proto  => 'udp',
181                           LocalAddr => '127.0.0.1');
182 $port = $server->sockport;
183
184 if ($^O eq 'mpeix') {
185     print("ok 12 # skipped\n")
186 } else {
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;
201     } else {
202         die;
203     }
204 }
205
206 print "not " unless $server->blocking;
207 print "ok 13\n";
208
209 if ( $^O eq 'qnx' ) {
210   # QNX4 library bug: Can set non-blocking on socket, but
211   # cannot return that status.
212   print "ok 14 # skipped on QNX4\n";
213 } else {
214   $server->blocking(0);
215   print "not " if $server->blocking;
216   print "ok 14\n";
217 }
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")) {
225     print "not ok 15 - $!\n";
226 } else {
227     @data = <SRC>;
228     close(SRC);
229     print "ok 15\n";
230 }
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;
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 21
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     #
279     ### TESTS 19,20,21,22
280     ### Try to ping-pong some Unicode.
281     #
282     if ($^O eq 'mpeix') {
283         print "ok 19 # skipped: broken on MPE/iX\n";
284     } else {
285     $sock = IO::Socket::INET->new("localhost:$serverport")
286          || IO::Socket::INET->new("127.0.0.1:$serverport");
287
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     }
293
294     if ($sock) {
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}" ?
300                 "ok 20\n" : "not ok 20\n";
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";
311         } else {
312             print "ok $_ - Skip: no perlio\n" for 20..22;
313         }
314
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     }
332     print "ok 23\n";
333     }
334
335     ### TEST 24
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     }
349     print "ok 24\n";
350
351 } elsif (defined($server_pid)) {
352    
353     ### Child
354     #
355     SERVER_LOOP: while (1) {
356         last SERVER_LOOP unless $sock = $listen->accept;
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.
359         if ($has_perlio) { binmode($sock, ":utf8") or die }
360         while (<$sock>) {
361             last SERVER_LOOP if /^quit/;
362             last if /^done/;
363             if (/^ping (.+)/) {
364                 print $sock "pong $1\n";
365                 next;
366             }
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             }
375             if (/^send/) {
376                 print $sock @data;
377                 last;
378             }
379             print;
380         }
381         $sock = undef;
382     }
383     $listen->close;
384     exit 0;
385
386 } else {
387
388     ### Fork failed
389     #
390     print "not ok 17\n";
391     die;
392 }
393
394 # test Blocking option in constructor
395
396 $sock = IO::Socket::INET->new(Blocking => 0)
397     or print "not ";
398 print "ok 25\n";
399
400 if ( $^O eq 'qnx' ) {
401   print "ok 26 # skipped on QNX4\n";
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;
407   print "ok 26\n";
408 }