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