view release on metacpan or  search on metacpan

t/io_multihomed6.t  view on Meta::CPAN

}

# check that localhost resolves to 127.0.0.1 and ::1
# otherwise the test will not work

use Socket (qw(
    AF_INET6 PF_INET6 SOCK_RAW SOCK_STREAM INADDR_ANY SOCK_DGRAM
    AF_INET SO_REUSEADDR SO_REUSEPORT AF_UNSPEC SO_BROADCAST
    sockaddr_in unpack_sockaddr_in
    )
);

# IO::Socket and Socket already import stuff here - possibly AF_INET6
# and PF_INET6 so selectively import things from Socket6.
use Socket6 (
    qw(AI_PASSIVE getaddrinfo
    sockaddr_in6 unpack_sockaddr_in6 pack_sockaddr_in6_all in6addr_any
    inet_ntop
    )
);

{
    my %resolved_addresses;

    my @r = getaddrinfo('localhost',1);

    if (@r < 5) {
        print "1..0 # SKIP getaddrinfo('localhost',1) failed: $r[0]\n";
        exit 0;
    }

    while (@r) {
        my @values = splice(@r,0,5);
        my ($fam,$addr) = @values[0,3];
        $addr =
        (
              ($fam == AF_INET)
            ? ( (unpack_sockaddr_in($addr))[1]  )
            : ( (unpack_sockaddr_in6($addr))[1] )
        );
        $resolved_addresses{inet_ntop($fam,$addr)}++;
    }
    if (! $resolved_addresses{'127.0.0.1'} || ! $resolved_addresses{'::1'}) {
        print "1..0 # SKIP localhost does not resolve to both 127.0.0.1 and ::1\n";
        exit 0;
    }
}

# IO::Socket has an import method that is inherited by IO::Socket::INET6 ,
# and so we should instruct it not to import anything.
use IO::Socket::INET6 ();

$| = 1;
print "1..8\n";

eval {
    $SIG{ALRM} = sub { die; };
    alarm 60;
};

# find out if the host prefers inet or inet6 by offering
# both and checking where it connects
my ($port,@srv);
for my $addr ( '127.0.0.1','::1' ) {
    push @srv,
        IO::Socket::INET6->new(
            Listen => 2,
            LocalAddr => $addr,
            LocalPort => $port,
        ) or die "listen on $addr port $port: $!";
    $port ||= $srv[-1]->sockport;
}

print "ok 1\n";

if (my $pid = fork()) {
    my $vec = '';
    vec($vec,fileno($_),1) = 1 for(@srv);
    select($vec,undef,undef,5) or die $!;

    # connected to first, not second
    my ($first,$second) = vec($vec,fileno($srv[0]),1) ? @srv[0,1]:@srv[1,0];
    my $cl = $first->accept or die $!;

    # listener should not work for next connect
    # so it needs to try second
    close($first);

    # make sure established connection works
    my $fam0 = ( $cl->sockdomain == AF_INET ) ? 'inet':'inet6';
    print {$cl} "ok 2 # $fam0\n";
    print $cl->getline(); # ok 3
    # So we'll be sure ok 3 has already been printed.
    print {$cl} "Move on, will ya!\n";
    close($cl);

    # ... ok 4 comes when client fails to connect to first

    # wait for connect on second and make sure it works
    $vec = '';
    vec($vec,fileno($second),1) = 1;
    if ( select($vec,undef,undef,5)) {
        my $cl2 = $second->accept or die $!;
        my $fam1 = ( $cl2->sockdomain == AF_INET ) ? 'inet':'inet6';
        print {$cl2} "ok 5 # $fam1\n";
        print $cl2->getline(); # ok 6
        close($cl2);

        # should be different families
        print "not " if $fam0 eq $fam1;
        print "ok 7\n";
    }

    waitpid($pid,0);
    print "ok 8\n";

} elsif (defined $pid) {
    close($_) for (@srv);
    # should work because server is listening on inet and inet6
    my $cl = IO::Socket::INET6->new(
        PeerPort => $port,
        PeerAddr => 'localhost',
        Timeout => 5,
    ) or die "$@";

    print $cl->getline(); # ok 2
    print {$cl} "ok 3\n";
    # So we'll be sure ok 3 has already been printed.
    $cl->getline();
    close($cl);

    # this should not work because listener is closed
    if ( $cl = IO::Socket::INET6->new(
            PeerPort => $port,
        PeerAddr => 'localhost',
        Timeout => 5,
    )) {
        print "not ok 4\n";
        exit;
    }
    print "ok 4\n";

    # but same thing with multihoming should work because server
    # is still listening on the other family
    $cl = IO::Socket::INET6->new(
        PeerPort => $port,
        PeerAddr => 'localhost',
        Timeout => 5,
        MultiHomed => 1,
    ) or do {
        print "not ok 5\n";
        exit;
    };
    print $cl->getline(); # ok 5
    print {$cl} "ok 6\n";
    exit;

} else {
    die $!; # fork failed
}