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 = $] >= 5.008 && 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 ($pid = fork()) {
 185     my $buf;
 186     $server->recv($buf, 100);
 187     print $buf;
 188 } elsif (defined($pid)) {
 189     #child
 190     $sock = IO::Socket::INET->new(Proto => 'udp',
 191                                   PeerAddr => "localhost:$port")
 192          || IO::Socket::INET->new(Proto => 'udp',
 193                                   PeerAddr => "127.0.0.1:$port");
 194     $sock->send("ok 12\n");
 195     sleep(1);
 196     $sock->send("ok 12\n");  # send another one to be sure
 197     exit;
 198 } else {
 199     die;
 200 }
 201
 202 print "not " unless $server->blocking;
 203 print "ok 13\n";
 204
 205 if ( $^O eq 'qnx' ) {
 206   # QNX4 library bug: Can set non-blocking on socket, but
 207   # cannot return that status.
 208   print "ok 14 # skipped on QNX4\n";
 209 } else {
 210   $server->blocking(0);
 211   print "not " if $server->blocking;
 212   print "ok 14\n";
 213 }
 214
 215 ### TEST 15
 216 ### Set up some data to be transfered between the server and
 217 ### the client. We'll use own source code ...
 218 #
 219 local @data;
 220 if( !open( SRC, "< $0")) {
 221     print "not ok 15 - $!\n";
 222 } else {
 223     @data = <SRC>;
 224     close(SRC);
 225     print "ok 15\n";
 226 }
 227
 228 ### TEST 16
 229 ### Start the server
 230 #
 231 my $listen = IO::Socket::INET->new( Listen => 2, Proto => 'tcp', Timeout => 15) ||
 232     print "not ";
 233 print "ok 16\n";
 234 die if( !defined( $listen));
 235 my $serverport = $listen->sockport;
 236 my $server_pid = fork();
 237 if( $server_pid) {
 238
 239     ### TEST 17 Client/Server establishment
 240     #
 241     print "ok 17\n";
 242
 243     ### TEST 18
 244     ### Get data from the server using a single stream
 245     #
 246     $sock = IO::Socket::INET->new("localhost:$serverport")
 247          || IO::Socket::INET->new("127.0.0.1:$serverport");
 248
 249     if ($sock) {
 250         $sock->print("send\n");
 251
 252         my @array = ();
 253         while( <$sock>) {
 254             push( @array, $_);
 255         }
 256
 257         $sock->print("done\n");
 258         $sock->close;
 259
 260         print "not " if( @array != @data);
 261     } else {
 262         print "not ";
 263     }
 264     print "ok 18\n";
 265
 266     ### TEST 21
 267     ### Get data from the server using a stream, which is
 268     ### interrupted by eof calls.
 269     ### On perl-5.7.0@7673 this failed in a SOCKS environment, because eof
 270     ### did an getc followed by an ungetc in order to check for the streams
 271     ### end. getc(3) got replaced by the SOCKS funktion, which ended up in
 272     ### a recv(2) call on the socket, while ungetc(3) put back a character
 273     ### to an IO buffer, which never again was read.
 274     #
 275     ### TESTS 19,20,21,22
 276     ### Try to ping-pong some Unicode.
 277     #
 278     $sock = IO::Socket::INET->new("localhost:$serverport")
 279          || IO::Socket::INET->new("127.0.0.1:$serverport");
 280
 281     if ($has_perlio) {
 282         print binmode($sock, ":utf8") ? "ok 19\n" : "not ok 19\n";
 283     } else {
 284         print "ok 19 - Skip: no perlio\n";
 285     }
 286
 287     if ($sock) {
 288
 289         if ($has_perlio) {
 290             $sock->print("ping \x{100}\n");
 291             chomp(my $pong = scalar <$sock>);
 292             print $pong =~ /^pong (.+)$/ && $1 eq "\x{100}" ?
 293                 "ok 20\n" : "not ok 20\n";
 294
 295             $sock->print("ord \x{100}\n");
 296             chomp(my $ord = scalar <$sock>);
 297             print $ord == 0x100 ?
 298                 "ok 21\n" : "not ok 21\n";
 299
 300             $sock->print("chr 0x100\n");
 301             chomp(my $chr = scalar <$sock>);
 302             print $chr eq "\x{100}" ?
 303                 "ok 22\n" : "not ok 22\n";
 304         } else {
 305             print "ok $_ - Skip: no perlio\n" for 20..22;
 306         }
 307
 308         $sock->print("send\n");
 309
 310         my @array = ();
 311         while( !eof( $sock ) ){
 312             while( <$sock>) {
 313                 push( @array, $_);
 314                 last;
 315             }
 316         }
 317
 318         $sock->print("done\n");
 319         $sock->close;
 320
 321         print "not " if( @array != @data);
 322     } else {
 323         print "not ";
 324     }
 325     print "ok 23\n";
 326
 327     ### TEST 24
 328     ### Stop the server
 329     #
 330     $sock = IO::Socket::INET->new("localhost:$serverport")
 331          || IO::Socket::INET->new("127.0.0.1:$serverport");
 332
 333     if ($sock) {
 334         $sock->print("done\n");
 335         $sock->close;
 336
 337         print "not " if( 1 != kill 0, $server_pid);
 338     } else {
 339         print "not ";
 340     }
 341     print "ok 24\n";
 342
 343 } elsif (defined($server_pid)) {
 344
 345     ### Child
 346     #
 347     SERVER_LOOP: while (1) {
 348         last SERVER_LOOP unless $sock = $listen->accept;
 349         # Do not print ok/not ok for this binmode() since there's
 350         # a race condition with our client, just die if we fail.
 351         if ($has_perlio) { binmode($sock, ":utf8") or die }
 352         while (<$sock>) {
 353             last SERVER_LOOP if /^quit/;
 354             last if /^done/;
 355             if (/^ping (.+)/) {
 356                 print $sock "pong $1\n";
 357                 next;
 358             }
 359             if (/^ord (.+)/) {
 360                 print $sock ord($1), "\n";
 361                 next;
 362             }
 363             if (/^chr (.+)/) {
 364                 print $sock chr(hex($1)), "\n";
 365                 next;
 366             }
 367             if (/^send/) {
 368                 print $sock @data;
 369                 last;
 370             }
 371             print;
 372         }
 373         $sock = undef;
 374     }
 375     $listen->close;
 376     exit 0;
 377
 378 } else {
 379
 380     ### Fork failed
 381     #
 382     print "not ok 17\n";
 383     die;
 384 }
 385
 386 # test Blocking option in constructor
 387
 388 $sock = IO::Socket::INET->new(Blocking => 0)
 389     or print "not ";
 390 print "ok 25\n";
 391
 392 if ( $^O eq 'qnx' ) {
 393   print "ok 26 # skipped on QNX4\n";
 394   # QNX4 library bug: Can set non-blocking on socket, but
 395   # cannot return that status.
 396 } else {
 397   my $status = $sock->blocking;
 398   print "not " unless defined $status && !$status;
 399   print "ok 26\n";
 400 }