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