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     my $can_fork = $Config{d_fork} ||
  14                     (($^O eq 'MSWin32' || $^O eq 'NetWare') and
  15                      $Config{useithreads} and
  16                      $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/
  17                     );
  18     my $reason;
  19     if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bSocket\b/) {
  20         $reason = 'Socket extension unavailable';
  21     }
  22     elsif ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bIO\b/) {
  23         $reason = 'IO extension unavailable';
  24     }
  25     elsif (!$can_fork) {
  26         $reason = 'no fork';
  27     }
  28     if ($reason) {
  29         print "1..0 # Skip: $reason\n";
  30         exit 0;
  31     }
  32 }
  33
  34 my $has_perlio = $] >= 5.008 && find PerlIO::Layer 'perlio';
  35
  36 $| = 1;
  37 print "1..26\n";
  38
  39 eval {
  40     $SIG{ALRM} = sub { die; };
  41     alarm 120;
  42 };
  43
  44 use IO::Socket;
  45
  46 $listen = IO::Socket::INET->new(Listen => 2,
  47                                 Proto => 'tcp',
  48                                 # some systems seem to need as much as 10,
  49                                 # so be generous with the timeout
  50                                 Timeout => 15,
  51                                ) or die "$!";
  52
  53 print "ok 1\n";
  54
  55 # Check if can fork with dynamic extensions (bug in CRT):
  56 if ($^O eq 'os2' and
  57     system "$^X -I../lib -MOpcode -e 'defined fork or die'  > /dev/null 2>&1") {
  58     print "ok $_ # skipped: broken fork\n" for 2..5;
  59     exit 0;
  60 }
  61
  62 $port = $listen->sockport;
  63
  64 if($pid = fork()) {
  65
  66     $sock = $listen->accept() or die "accept failed: $!";
  67     print "ok 2\n";
  68
  69     $sock->autoflush(1);
  70     print $sock->getline();
  71
  72     print $sock "ok 4\n";
  73
  74     $sock->close;
  75
  76     waitpid($pid,0);
  77
  78     print "ok 5\n";
  79
  80 } elsif(defined $pid) {
  81
  82     $sock = IO::Socket::INET->new(PeerPort => $port,
  83                                   Proto => 'tcp',
  84                                   PeerAddr => 'localhost'
  85                                  )
  86          || IO::Socket::INET->new(PeerPort => $port,
  87                                   Proto => 'tcp',
  88                                   PeerAddr => '127.0.0.1'
  89                                  )
  90         or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)";
  91
  92     $sock->autoflush(1);
  93
  94     print $sock "ok 3\n";
  95
  96     print $sock->getline();
  97
  98     $sock->close;
  99
 100     exit;
 101 } else {
 102  die;
 103 }
 104
 105 # Test various other ways to create INET sockets that should
 106 # also work.
 107 $listen = IO::Socket::INET->new(Listen => '', Timeout => 15) or die "$!";
 108 $port = $listen->sockport;
 109
 110 if($pid = fork()) {
 111   SERVER_LOOP:
 112     while (1) {
 113        last SERVER_LOOP unless $sock = $listen->accept;
 114        while (<$sock>) {
 115            last SERVER_LOOP if /^quit/;
 116            last if /^done/;
 117            print;
 118        }
 119        $sock = undef;
 120     }
 121     $listen->close;
 122 } elsif (defined $pid) {
 123     # child, try various ways to connect
 124     $sock = IO::Socket::INET->new("localhost:$port")
 125          || IO::Socket::INET->new("127.0.0.1:$port");
 126     if ($sock) {
 127         print "not " unless $sock->connected;
 128         print "ok 6\n";
 129        $sock->print("ok 7\n");
 130        sleep(1);
 131        print "ok 8\n";
 132        $sock->print("ok 9\n");
 133        $sock->print("done\n");
 134        $sock->close;
 135     }
 136     else {
 137         print "# $@\n";
 138         print "not ok 6\n";
 139         print "not ok 7\n";
 140         print "not ok 8\n";
 141         print "not ok 9\n";
 142     }
 143
 144     # some machines seem to suffer from a race condition here
 145     sleep(2);
 146
 147     $sock = IO::Socket::INET->new("127.0.0.1:$port");
 148     if ($sock) {
 149        $sock->print("ok 10\n");
 150        $sock->print("done\n");
 151        $sock->close;
 152     }
 153     else {
 154         print "# $@\n";
 155         print "not ok 10\n";
 156     }
 157
 158     # some machines seem to suffer from a race condition here
 159     sleep(1);
 160
 161     $sock = IO::Socket->new(Domain => AF_INET,
 162                             PeerAddr => "localhost:$port")
 163          || IO::Socket->new(Domain => AF_INET,
 164                             PeerAddr => "127.0.0.1:$port");
 165     if ($sock) {
 166        $sock->print("ok 11\n");
 167        $sock->print("quit\n");
 168     } else {
 169        print "not ok 11\n";
 170     }
 171     $sock = undef;
 172     sleep(1);
 173     exit;
 174 } else {
 175     die;
 176 }
 177
 178 # Then test UDP sockets
 179 $server = IO::Socket->new(Domain => AF_INET,
 180                           Proto  => 'udp',
 181                           LocalAddr => 'localhost')
 182        || IO::Socket->new(Domain => AF_INET,
 183                           Proto  => 'udp',
 184                           LocalAddr => '127.0.0.1');
 185 $port = $server->sockport;
 186
 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 print "not " unless $server->blocking;
 206 print "ok 13\n";
 207
 208 if ( $^O eq 'qnx' ) {
 209   # QNX4 library bug: Can set non-blocking on socket, but
 210   # cannot return that status.
 211   print "ok 14 # skipped on QNX4\n";
 212 } else {
 213   $server->blocking(0);
 214   print "not " if $server->blocking;
 215   print "ok 14\n";
 216 }
 217
 218 ### TEST 15
 219 ### Set up some data to be transfered between the server and
 220 ### the client. We'll use own source code ...
 221 #
 222 local @data;
 223 if( !open( SRC, "< $0")) {
 224     print "not ok 15 - $!\n";
 225 } else {
 226     @data = <SRC>;
 227     close(SRC);
 228     print "ok 15\n";
 229 }
 230
 231 ### TEST 16
 232 ### Start the server
 233 #
 234 my $listen = IO::Socket::INET->new( Listen => 2, Proto => 'tcp', Timeout => 15) ||
 235     print "not ";
 236 print "ok 16\n";
 237 die if( !defined( $listen));
 238 my $serverport = $listen->sockport;
 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 21
 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     ### TESTS 19,20,21,22
 279     ### Try to ping-pong some Unicode.
 280     #
 281     $sock = IO::Socket::INET->new("localhost:$serverport")
 282          || IO::Socket::INET->new("127.0.0.1:$serverport");
 283
 284     if ($has_perlio) {
 285         print binmode($sock, ":utf8") ? "ok 19\n" : "not ok 19\n";
 286     } else {
 287         print "ok 19 - Skip: no perlio\n";
 288     }
 289
 290     if ($sock) {
 291
 292         if ($has_perlio) {
 293             $sock->print("ping \x{100}\n");
 294             chomp(my $pong = scalar <$sock>);
 295             print $pong =~ /^pong (.+)$/ && $1 eq "\x{100}" ?
 296                 "ok 20\n" : "not ok 20\n";
 297
 298             $sock->print("ord \x{100}\n");
 299             chomp(my $ord = scalar <$sock>);
 300             print $ord == 0x100 ?
 301                 "ok 21\n" : "not ok 21\n";
 302
 303             $sock->print("chr 0x100\n");
 304             chomp(my $chr = scalar <$sock>);
 305             print $chr eq "\x{100}" ?
 306                 "ok 22\n" : "not ok 22\n";
 307         } else {
 308             print "ok $_ - Skip: no perlio\n" for 20..22;
 309         }
 310
 311         $sock->print("send\n");
 312
 313         my @array = ();
 314         while( !eof( $sock ) ){
 315             while( <$sock>) {
 316                 push( @array, $_);
 317                 last;
 318             }
 319         }
 320
 321         $sock->print("done\n");
 322         $sock->close;
 323
 324         print "not " if( @array != @data);
 325     } else {
 326         print "not ";
 327     }
 328     print "ok 23\n";
 329
 330     ### TEST 24
 331     ### Stop the server
 332     #
 333     $sock = IO::Socket::INET->new("localhost:$serverport")
 334          || IO::Socket::INET->new("127.0.0.1:$serverport");
 335
 336     if ($sock) {
 337         $sock->print("done\n");
 338         $sock->close;
 339
 340         print "not " if( 1 != kill 0, $server_pid);
 341     } else {
 342         print "not ";
 343     }
 344     print "ok 24\n";
 345
 346 } elsif (defined($server_pid)) {
 347
 348     ### Child
 349     #
 350     SERVER_LOOP: while (1) {
 351         last SERVER_LOOP unless $sock = $listen->accept;
 352         # Do not print ok/not ok for this binmode() since there's
 353         # a race condition with our client, just die if we fail.
 354         if ($has_perlio) { binmode($sock, ":utf8") or die }
 355         while (<$sock>) {
 356             last SERVER_LOOP if /^quit/;
 357             last if /^done/;
 358             if (/^ping (.+)/) {
 359                 print $sock "pong $1\n";
 360                 next;
 361             }
 362             if (/^ord (.+)/) {
 363                 print $sock ord($1), "\n";
 364                 next;
 365             }
 366             if (/^chr (.+)/) {
 367                 print $sock chr(hex($1)), "\n";
 368                 next;
 369             }
 370             if (/^send/) {
 371                 print $sock @data;
 372                 last;
 373             }
 374             print;
 375         }
 376         $sock = undef;
 377     }
 378     $listen->close;
 379     exit 0;
 380
 381 } else {
 382
 383     ### Fork failed
 384     #
 385     print "not ok 17\n";
 386     die;
 387 }
 388
 389 # test Blocking option in constructor
 390
 391 $sock = IO::Socket::INET->new(Blocking => 0)
 392     or print "not ";
 393 print "ok 25\n";
 394
 395 if ( $^O eq 'qnx' ) {
 396   print "ok 26 # skipped on QNX4\n";
 397   # QNX4 library bug: Can set non-blocking on socket, but
 398   # cannot return that status.
 399 } else {
 400   my $status = $sock->blocking;
 401   print "not " unless defined $status && !$status;
 402   print "ok 26\n";
 403 }