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 }