File Coverage

blib/lib/Net/Server/IP.pm

Criterion	Covered	Total	%
statement	56	69	81.1
branch	31	50	62.0
condition	19	39	48.7
subroutine	8	8	100.0
pod	1	2	50.0
total	115	168	68.4

# -*- perl -*-
#
#  Net::Server::IP - IPv4 / IPv6 compatibility module
#
#  Copyright (C) 2025-2026
#
#    Rob Brown
#
#  This package may be distributed under the terms of either the
#  GNU General Public License
#    or the
#  Perl Artistic License
#
#  All rights reserved.
#
################################################################

package Net::Server::IP;

use strict;
use warnings;
use Net::Server::Proto qw(AF_INET AF_INET6 AF_UNSPEC IPPROTO_IPV6 IPV6_V6ONLY);
use IO::Socket::INET ();
use Exporter qw(import);

our @ISA = qw(IO::Socket::INET); # we may dynamically change this to an IPv6-compatible class based upon our configuration
our $ipv6_package = undef;
our @preferred = qw(IO::Socket::IP IO::Socket::INET6);
our $fake_danger = undef; # Detect if fake interface is spoofed by kernel (e.g. OpenVZ venet) instead of a real public network interface.

sub configure {
    my ($self, $arg) = @_;
    die "configure: no arg" if !$arg or !%$arg;
    my $family = delete $arg->{'Family'};
    if (defined (my $family2 = delete $arg->{'Domain'}) and !defined $family) { $family = $family2 };
    if (!defined $family and my $addr = $arg->{'LocalHost'} || $arg->{'PeerHost'} || $arg->{'LocalAddr'} || $arg->{'PeerAddr'}) {
        # Use Addr arg to hint which Family to use.
        if ($addr =~ /^(\d+\.\d+\.\d+\.\d+)(|:\w+|\w+\(\d+\))$/) {
            $family = AF_INET; # Surely IPv4
        } elsif ($addr =~ /^\[[a-fA-F\d:]+\](|:\w+|\w+\(\d+\))$/ or $addr =~ /^(?:[a-fA-F\d]*:){2,7}([a-fA-F\d]*|\d+\.\d+\.\d+\.\d+)$/) {
            $family = AF_INET6; # Surely IPv6
        } else {
            $family = AF_UNSPEC; # Some other Host, maybe a DNS word, so can't tell if it's IPv4 or IPv6 yet.
        }
    }
    if ($ISA[0] eq "IO::Socket::INET" and defined $family and $family ne AF_INET) {
        # Look for IPv6-compatible module
        my @try = ($ipv6_package?($ipv6_package):(), @preferred);
        my $pm = sub { (my $f="$_[0].pm") =~ s|::|/|g; $f};
        my ($pkg) = grep { $INC{$pm->($_)} && !$_->isa(__PACKAGE__) } @try;
        my $err = '';
        for (@try) { last if $pkg; eval{local $^W=0;require $pm->($_);die "Circular ISA" if $_->isa(__PACKAGE__);$pkg=$_} or $err .= $@=~/^(.*)/ && "\n[$_] ($!) $1"; }
        if ($pkg) {
            my $args = { Listen=>1 };
            if (not $pkg->new(LocalAddr=>"[::]", Listen=>1) or not $pkg->new(LocalAddr=>"127.0.0.1", Listen=>1)) { # Simple ephemeral sanity pre-check didn't even work
                if ($pkg->new(LocalAddr=>"[::]", Listen=>1, GetAddrInfoFlags => 0) or $pkg->new(LocalAddr=>"127.0.0.1", Listen=>1, GetAddrInfoFlags => 0)) { # Yet DOES work without doing that getaddrinfo AI_ADDRCONFIG AF_NETLINK SOCK_RAW sendto RTM_GETADDR recvmsg interferfaces pre-check boogie dance?
                    $fake_danger = 1; $@ = ""; # Flag to remember this special network configuration. Pretend like there is no error.
                } else {
                    $@ = "bind: $pkg failed: $! $@"; $pkg = undef; # This $pkg is of no use. Set error $@ with good excuse.
                }
            } else {
                $fake_danger = 0; # Works fine without monkeying anything.
            }
            $ISA[0] = $ipv6_package = $pkg if $pkg;
        } else {
            return if $@ = "Preferred ipv6_package (@try) could not be loaded:$err" and $family;
            $family = undef;
        }
    }
    if (defined $family) { # Set the corresponding 'Family' arg:
        $arg->{'Family'} = $family if $self->isa("IO::Socket::IP");
        $arg->{'Domain'} = $family if $self->isa("IO::Socket::INET6");
        $arg->{'GetAddrInfoFlags'} = 0 if !defined $arg->{'GetAddrInfoFlags'} and $fake_danger; # Special delicate network
        if (defined $arg->{'V6Only'} and $self->isa("IO::Socket::INET6")) {
            ${ *$self }{'NS_v6only'} = delete $arg->{'V6Only'};
            delete ${ *$self }{'NS_v6only'} if $family eq AF_INET;
        }
    }
    return $self->SUPER::configure($arg);
}

sub socket {
    my $self = shift;
    my $ret  = $self->SUPER::socket(@_);
    if (defined (my $opt = ${ *$self }{'NS_v6only'})) {
        eval { $self->setsockopt( IPPROTO_IPV6, IPV6_V6ONLY, $opt?1:0 ) } or warn "setsockopt(IPV6_V6ONLY) failed: ($!) ($@)";
    }
    return $ret;
}

1;

__END__