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