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