ext/IO/t/io_multihomed.t

   1 #!./perl
   2
   3 BEGIN {
   4     unless(grep /blib/, @INC) {
   5         chdir 't' if -d 't';
   6         @INC = '../lib';
   7     }
   8
   9     require($ENV{PERL_CORE} ? './test.pl' : './t/test.pl');
  10
  11     use Config;
  12     my $can_fork = $Config{d_fork} ||
  13                     (($^O eq 'MSWin32' || $^O eq 'NetWare') and
  14                      $Config{useithreads} and
  15                      $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/
  16                     );
  17     my $reason;
  18     if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bSocket\b/) {
  19         $reason = 'Socket extension unavailable';
  20     }
  21     elsif ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bIO\b/) {
  22         $reason = 'IO extension unavailable';
  23     }
  24     elsif (!$can_fork) {
  25         $reason = 'no fork';
  26     }
  27     skip_all($reason) if $reason;
  28 }
  29
  30 $| = 1;
  31
  32 print "1..8\n";
  33 watchdog(15);
  34
  35 package Multi;
  36 require IO::Socket::INET;
  37 @ISA=qw(IO::Socket::INET);
  38
  39 use Socket qw(inet_aton inet_ntoa unpack_sockaddr_in);
  40
  41 sub _get_addr
  42 {
  43     my($sock,$addr_str, $multi) = @_;
  44     #print "_get_addr($sock, $addr_str, $multi)\n";
  45
  46     print "not " unless $multi;
  47     print "ok 2\n";
  48
  49     (
  50      # private IP-addresses which I hope does not work anywhere :-)
  51      inet_aton("10.250.230.10"),
  52      inet_aton("10.250.230.12"),
  53      inet_aton("127.0.0.1")        # loopback
  54     )
  55 }
  56
  57 sub connect
  58 {
  59     my $self = shift;
  60     if (@_ == 1) {
  61         my($port, $addr) = unpack_sockaddr_in($_[0]);
  62         $addr = inet_ntoa($addr);
  63         #print "connect($self, $port, $addr)\n";
  64         if($addr eq "10.250.230.10") {
  65             print "ok 3\n";
  66             return 0;
  67         }
  68         if($addr eq "10.250.230.12") {
  69             print "ok 4\n";
  70             return 0;
  71         }
  72     }
  73     $self->SUPER::connect(@_);
  74 }
  75
  76
  77
  78 package main;
  79
  80 use IO::Socket;
  81
  82 $listen = IO::Socket::INET->new(Listen => 2,
  83                                 Proto => 'tcp',
  84                                 Timeout => 5,
  85                                ) or die "$!";
  86
  87 print "ok 1\n";
  88
  89 $port = $listen->sockport;
  90
  91 if($pid = fork()) {
  92
  93     $sock = $listen->accept() or die "$!";
  94     print "ok 5\n";
  95
  96     print $sock->getline();
  97     print $sock "ok 7\n";
  98
  99     waitpid($pid,0);
 100
 101     $sock->close;
 102
 103     print "ok 8\n";
 104
 105 } elsif(defined $pid) {
 106
 107     $sock = Multi->new(PeerPort => $port,
 108                        Proto => 'tcp',
 109                        PeerAddr => 'localhost',
 110                        MultiHomed => 1,
 111                        Timeout => 1,
 112                       ) or die "$!";
 113
 114     print $sock "ok 6\n";
 115     sleep(1); # race condition
 116     print $sock->getline();
 117
 118     $sock->close;
 119
 120     exit;
 121 } else {
 122     die;
 123 }