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