t/lib/io_sock.t

   1 #!./perl
   2
   3 BEGIN {
   4     unless(grep /blib/, @INC) {
   5         chdir 't' if -d 't';
   6         unshift @INC, '../lib' if -d '../lib';
   7     }
   8 }
   9
  10 use Config;
  11
  12 BEGIN {
  13     if (-d "lib" && -f "TEST") {
  14         if (!$Config{'d_fork'} ||
  15             (($Config{'extensions'} !~ /\bSocket\b/ ||
  16               $Config{'extensions'} !~ /\bIO\b/) &&
  17              !(($^O eq 'VMS') && $Config{d_socket}))) {
  18             print "1..0\n";
  19             exit 0;
  20         }
  21     }
  22 }
  23
  24 $| = 1;
  25 print "1..14\n";
  26
  27 use IO::Socket;
  28
  29 $listen = IO::Socket::INET->new(Listen => 2,
  30                                 Proto => 'tcp',
  31                                 # some systems seem to need as much as 10,
  32                                 # so be generous with the timeout
  33                                 Timeout => 15,
  34                                ) or die "$!";
  35
  36 print "ok 1\n";
  37
  38 # Check if can fork with dynamic extensions (bug in CRT):
  39 if ($^O eq 'os2' and
  40     system "$^X -I../lib -MOpcode -e 'defined fork or die'  > /dev/null 2>&1") {
  41     print "ok $_ # skipped: broken fork\n" for 2..5;
  42     exit 0;
  43 }
  44
  45 $port = $listen->sockport;
  46
  47 if($pid = fork()) {
  48
  49     $sock = $listen->accept() or die "accept failed: $!";
  50     print "ok 2\n";
  51
  52     $sock->autoflush(1);
  53     print $sock->getline();
  54
  55     print $sock "ok 4\n";
  56
  57     $sock->close;
  58
  59     waitpid($pid,0);
  60
  61     print "ok 5\n";
  62
  63 } elsif(defined $pid) {
  64
  65     # This can fail if localhost is undefined or the
  66     # special 'loopback' address 127.0.0.1 is not configured
  67     # on your system. (/etc/rc.config.d/netconfig on HP-UX.)
  68     # As a shortcut (not recommended) you could change 'localhost'
  69     # here to be the name of this machine eg 'myhost.mycompany.com'.
  70
  71     $sock = IO::Socket::INET->new(PeerPort => $port,
  72                                   Proto => 'tcp',
  73                                   PeerAddr => 'localhost'
  74                                  )
  75         or die "$! (maybe your system does not have the 'localhost' address defined)";
  76
  77     $sock->autoflush(1);
  78
  79     print $sock "ok 3\n";
  80
  81     print $sock->getline();
  82
  83     $sock->close;
  84
  85     exit;
  86 } else {
  87  die;
  88 }
  89
  90 # Test various other ways to create INET sockets that should
  91 # also work.
  92 $listen = IO::Socket::INET->new(Listen => '', Timeout => 15) or die "$!";
  93 $port = $listen->sockport;
  94
  95 if($pid = fork()) {
  96   SERVER_LOOP:
  97     while (1) {
  98        last SERVER_LOOP unless $sock = $listen->accept;
  99        while (<$sock>) {
 100            last SERVER_LOOP if /^quit/;
 101            last if /^done/;
 102            print;
 103        }
 104        $sock = undef;
 105     }
 106     $listen->close;
 107 } elsif (defined $pid) {
 108     # child, try various ways to connect
 109     $sock = IO::Socket::INET->new("localhost:$port");
 110     if ($sock) {
 111         print "not " unless $sock->connected;
 112         print "ok 6\n";
 113        $sock->print("ok 7\n");
 114        sleep(1);
 115        print "ok 8\n";
 116        $sock->print("ok 9\n");
 117        $sock->print("done\n");
 118        $sock->close;
 119     }
 120     else {
 121         print "# $@\n";
 122         print "not ok 6\n";
 123         print "not ok 7\n";
 124         print "not ok 8\n";
 125         print "not ok 9\n";
 126     }
 127
 128     # some machines seem to suffer from a race condition here
 129     sleep(1);
 130
 131     $sock = IO::Socket::INET->new("127.0.0.1:$port");
 132     if ($sock) {
 133        $sock->print("ok 10\n");
 134        $sock->print("done\n");
 135        $sock->close;
 136     }
 137     else {
 138         print "# $@\n";
 139         print "not ok 10\n";
 140     }
 141
 142     # some machines seem to suffer from a race condition here
 143 #    sleep(1);
 144
 145     $sock = IO::Socket->new(Domain => AF_INET,
 146                             PeerAddr => "localhost:$port");
 147     if ($sock) {
 148        $sock->print("ok 11\n");
 149        $sock->print("quit\n");
 150     }
 151     $sock = undef;
 152     sleep(1);
 153     exit;
 154 } else {
 155     die;
 156 }
 157
 158 # Then test UDP sockets
 159 $server = IO::Socket->new(Domain => AF_INET,
 160                           Proto  => 'udp',
 161                           LocalAddr => 'localhost');
 162 $port = $server->sockport;
 163
 164 if ($pid = fork()) {
 165     my $buf;
 166     $server->recv($buf, 100);
 167     print $buf;
 168 } elsif (defined($pid)) {
 169     #child
 170     $sock = IO::Socket::INET->new(Proto => 'udp',
 171                                   PeerAddr => "localhost:$port");
 172     $sock->send("ok 12\n");
 173     sleep(1);
 174     $sock->send("ok 12\n");  # send another one to be sure
 175     exit;
 176 } else {
 177     die;
 178 }
 179
 180 print "not " unless $server->blocking;
 181 print "ok 13\n";
 182
 183 $server->blocking(0);
 184 print "not " if $server->blocking;
 185 print "ok 14\n";