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