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