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..20\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 - $!";
 224 } else {
 225     @data = <SRC>;
 226     close( SRC);
 227 }
 228 print "ok 15\n";
 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
 340 } else {
 341
 342     ### Fork failed
 343     #
 344     print "not ok 17\n";
 345     die;
 346 }
 347