File Coverage

blib/lib/Net/Server/Proto.pm

Criterion	Covered	Total	%
statement	224	272	82.3
branch	122	194	62.8
condition	63	145	43.4
subroutine	25	27	92.5
pod	1	8	12.5
total	435	646	67.3

# -*- perl -*-
#
#  Net::Server::Proto - Net::Server Protocol compatibility layer
#
#  Copyright (C) 2001-2026
#
#    Paul Seamons
#
#    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::Proto;

use strict;
use warnings;
use Carp qw(croak);
use Socket ();
use Exporter ();
use constant NIx_NOHOST => 1; # The getNameInfo Xtended flags are too difficult to obtain on some older systems,
use constant NIx_NOSERV => 2; # So just hard-code the constant numbers.

my $ipv6_package;
my $can_disable_v6only;
my $exported = {};
my $have6;
my $stub_wrapper;

our @EXPORT;
our @EXPORT_OK; # Allow any routine defined in this module to be exported, except block these static methods:
our @EXPORT_DENIED = qw[
    import
];
sub IPV6_V6ONLY();

sub import {
    my $class = shift;
    my $callpkg = caller;
    foreach my $func (@_) {
        if (!grep {$_ eq $func} @EXPORT_OK) { # Trying to import something not in my list
            croak "$func: Can't import underbar routine" if $func =~ /^_/;
            if (!exists &$func) { # Symbol doesn't exist here yet
                grep {$_ eq $func} @Socket::EXPORT,@Socket::EXPORT_OK # Is exportable by Socket
                or ($have6 || !defined $have6 && eval{($have6=0)=require Socket6}) && # Or else if Socket6 is available, AND
                grep {$_ eq $func} @Socket6::EXPORT,@Socket6::EXPORT_OK # Is exportable by Socket6
                or croak "$func is not a valid Socket macro nor defined by ".__PACKAGE__." and could not be imported";
                no strict 'refs'; *$func = sub { $stub_wrapper->($func,@_) };
            }
            croak "$func is a static method invoked via ".__PACKAGE__."->$func so it cannot be imported" if grep {$_ eq $func} @EXPORT_DENIED;
            push @EXPORT_OK, $func; # Verified routine or stub exists, so it's safe to append to my exportable list
        }
    }
    # Keep track of who imports any fake stub wrappers
    $exported->{$_}->{$callpkg}=1 foreach @_;
    return Exporter::export($class, $callpkg, @_);
}

BEGIN {
    # If the underlying constant or routine really isn't available in Socket nor Socket6,
    # then it will not die until run-time instead of crashing at compile-time.
    # It can still be caught with eval.
    @EXPORT_OK = qw[
        AF_INET
        AF_INET6
        AF_UNIX
        AF_UNSPEC
        AI_PASSIVE
        INADDR_ANY
        NI_NUMERICHOST
        NI_NUMERICSERV
        NIx_NOHOST
        NIx_NOSERV
        SOCK_DGRAM
        SOCK_STREAM
        SOMAXCONN
        SOL_SOCKET
        SO_TYPE
        IPPROTO_IPV6
        IPV6_V6ONLY
        sockaddr_in
        sockaddr_in6
        sockaddr_family
        inet_ntop
        inet_ntoa
        inet_aton
        getaddrinfo
        getnameinfo
    ];

    # Load just in time once explicitly invoked.
    my $sub = {};
    $stub_wrapper = sub {
        my @c = caller 1;
        my $fullname = __PACKAGE__."::".(my $basename = shift);
        # Manually run routine if import failed to brick over symbol in local namespace during the last attempt.
        $sub->{$fullname} ? (return $sub->{$fullname}->(@_)) : (die "$fullname: Unable to replace symbol") if exists $sub->{$fullname};
        # Socket < 2.xxx and Socket6 can conjure constant routine on-the-fly via AUTOLOAD upon invocation, so "can" may not work until the second time.
        no strict 'refs'; # Avoid Crash: Can't use string as a subroutine ref while "strict refs"
        $sub->{$fullname}  = Socket ->can($basename) || eval { &{"Socket ::$basename"};0} || Socket ->can($basename); # Always try Socket.pm first, then Socket6.pm
        $sub->{$fullname}||= Socket6->can($basename) || eval { &{"Socket6::$basename"};0} || Socket6->can($basename)
            if $have6 or !defined $have6 && eval { ($have6||=0)||=do{require Socket6;1} }; # Only try to load Socket6 the first time Socket couldn't find something.
        if (my $code = $sub->{$fullname}) {
            no warnings qw(redefine prototype); # Don't spew when redefining the stub in the packages that imported it (as well as mine) with the REAL routine
            eval { *{"$_\::$basename"}=$code foreach keys %{$exported->{$basename}}; *$fullname=$code } or warn "$fullname: On-The-Fly replacement failed: $@";
            my @res = (); # Run REAL routine preserving the same wantarray-ness context as caller
            eval { @res = $c[5] ? $code->(@_) : scalar $code->(@_); 1 } or do { (my $why=$@) =~ s/\s*at .* line \d.*//s; die "$why at $c[1] line $c[2]\n"; };
            return $c[5] ? @res : $res[0];
        }
        die "$basename is not a valid Socket macro and could not be imported at $c[1] line $c[2]\n";
    };
    foreach my $func (@EXPORT_OK) { eval { no strict 'refs'; *$func = sub { $stub_wrapper->($func,@_) }; } if !exists &$func; }
}

# ($err, $hostname, $servicename) = safe_name_info($sockaddr, [$flags, [$xflags]])
# Compatibility routine to always act like Socket::getnameinfo even if it doesn't exist or if IO::Socket::IP is not available.
# XXX: Why are there two different versions of getnameinfo?
# The old Socket6 only allows for a single option $flags after the $sockaddr input and an error might be the first element. ($host,$sevice)=Socket6::getnameinfo($sockaddr, [$flags])
# The new Socket also allows for an optional $xflags input and always returns its $err as the first element, even on success.
sub safe_name_info {
    my ($sockaddr, $flags, $xflags) = @_; $sockaddr ||= sockaddr_in 0, inet_aton "0.0.0.0"; $flags ||= 0; $xflags ||= 0;
    my @res;
    eval { @res = getnameinfo $sockaddr, $flags, $xflags; 1 } or do { # Force 3-arg input to ensure old version will die: "Usage: Socket6::getnameinfo"
        @res = getnameinfo $sockaddr, $flags; # Probably old Socket6 version, so hide NIx_* $xflags in $_[2]
        @res<2 ? ($res[0]||="EAI_NONAME") : do {
            @res = @res[-3,-2,-1]; $res[0] ||= ""; # Create first $err output element, if doesn't exist.
            $res[NIx_NOHOST] = undef if $xflags & NIx_NOHOST; # Emulate $xflags
            $res[NIx_NOSERV] = undef if $xflags & NIx_NOSERV; # so output matches
        };
    };
    return @res;
}

# ($err, @result) = safe_addr_info($host, $service, [$hints])
# Compatibility routine to always act like Socket::getaddrinfo even if IO::Socket::IP is not available.
# XXX: Why are there two different versions of getaddrinfo?
# The old Socket6 accepts a list of optional hints and returns either an $err or a multiple of 5 output. (@fiver_chunks)=Socket6::getaddrinfo($node,$port,[$family,$socktype,$proto,$flags])
# The new Socket accepts an optional HASHREF of hints and returns an $err followed by a list of HASHREFs.
sub safe_addr_info {
    my ($host, $port, $hints) = @_; $host ||= ""; $port ||= 0;
    $hints ||= {};
    my @res;
    return @res = ('EAI_BADFLAGS: Usage: safe_addr_info($hostname, $servicename, \%hints)') if "HASH" ne ref $hints or @_ < 2 or @_ > 3;
    eval { @res = getaddrinfo( $host, $port, $hints ); die ($res[0] || "EAI_NONAME") if @res < 2; 1 } # Nice new Socket "HASH" method
    or eval { # Convert Socket6 Old Array "C" method to "HASH" method
        @res = (''); # Pretend like no error so far
        my @results = getaddrinfo( $host, $port, map {$hints->{$_}||0} qw[family socktype protocol flags] );
        while (@results > 4) {
            my $r = {};
            (@$r{qw[family socktype protocol addr canonname]}, @results) = @results;
            push @res, $r;
        }
        $res[0] ||= "EAI_NONAME" if @res < 2;
        1;
    }
    or $res[0] = ($@ || "getaddrinfo: failed $!");
    return @res;
}

# Capability test function (stolen from IO::Socket::IP in case only IO::Socket::INET6 is available)
sub CAN_DISABLE_V6ONLY {
    return $can_disable_v6only if defined $can_disable_v6only;
    socket my $testsock, AF_INET6, SOCK_STREAM, 0 or die "Cannot socket(PF_INET6) - $!";
    setsockopt $testsock, IPPROTO_IPV6, IPV6_V6ONLY, 0 and return $can_disable_v6only = 1;
    $!{EINVAL} || $!{EOPNOTSUPP} and return $can_disable_v6only = 0; # OpenBSD, WindowsXP, etc
    die "Cannot setsockopt(IPV6_V6ONLY) - $!";
}

sub parse_info {
    my $class = $_[0] eq __PACKAGE__ ? shift : __PACKAGE__;
    my ($port, $host, $proto, $ipv, $server) = @_;

    my $info;
    if (ref($port) eq 'HASH') {
        croak "Missing port in hashref passed in port argument" if ! $port->{'port'};
        $info = $port;
    } else {
        $info = {};
        $info->{'unix_type'} = $1
                    if $port =~ s{ (?<=[\w*\]]) [,|\s:/]+ (sock_stream|sock_dgram) \b }{}x; # legacy /some/path|sock_dgram
        $ipv   = $1 if $port =~ s{ (?<=[\w*\]]) [,|\s:/]+ IPv([*\d]+) }{}xi; # allow for 80|IPv*
        $ipv  .= $1 if $port =~ s{ (?<=[\w*\]]) [,|\s:/]+ IPv([*\d]+) }{}xi; # allow for 80|IPv4|IPv6 stacked
        $proto = $1 if $port =~ s{ (?<=[\w*\]]) [,|\s:/]+ (tcp|udp|ssl|ssleay|unix|unixdgram|\w+(?: ::\w+)+) $ }{}xi # allow for 80/tcp or 200/udp or 90/Net::Server::Proto::TCP
                    || $port =~ s{ / (\w+) $ }{}x; # legacy 80/MyTcp support
        $host  = $1 if $port =~ s{ ^ (.*?)      [,|\s:]+  (?= \w+ $) }{}x; # allow localhost:80
        $info->{'port'} = $port;
    }
    $info->{'port'} ||= 0;


    $info->{'host'} ||= (defined($host) && length($host)) ? $host : '*';
    $ipv  = $1 if $info->{'host'} =~ s{ (?<=[\w*\]]) [,|\s:/]+ IPv([*\d]+) }{}xi; # allow for 80|IPv*
    $ipv .= $1 if $info->{'host'} =~ s{ (?<=[\w*\]]) [,|\s:/]+ IPv([*\d]+) }{}xi; # allow for 80|IPv4|IPv6 stacked
    if (     $info->{'host'} =~ m{^ \[ ([\w/.\-:]+ | \*?) \] $ }x) { # allow for [::1] or [host.example.com]
        $info->{'host'} = length($1) ? $1 : '*';
    } elsif ($info->{'host'} =~ m{^    ([\w/.\-:]+ | \*?)    $ }x) {
        $info->{'host'} = $1; # untaint
    } else {
        $server->fatal("Could not determine host from \"$info->{'host'}\"");
    }


    $info->{'proto'} ||= $proto || 'tcp';
    $ipv  = $1 if $info->{'proto'} =~ s{ (?<=[\w*\]]) [,|\s:/]+ IPv([*\d]+) }{}xi; # allow for 80|IPv*
    $ipv .= $1 if $info->{'proto'} =~ s{ (?<=[\w*\]]) [,|\s:/]+ IPv([*\d]+) }{}xi; # allow for 80|IPv4|IPv6 stacked
    if ($info->{'proto'} =~ /^(\w+ (?:::\w+)*)$/x) {
        $info->{'proto'} = $1;
    } else {
        $server->fatal("Could not determine proto from \"$proto\"");
    }
    $proto = lc $info->{'proto'};

    if ($info->{'proto'} =~ /^UNIX/i) {
        return ({%$info, ipv => '*'});
    }
    $ipv = $info->{'ipv'} || $ipv || $ENV{'IPV'} || '';
    $ipv = join '', @$ipv if ref($ipv) eq 'ARRAY';
    $server->fatal("Invalid ipv parameter - must contain 4, 6, or *") if $ipv && $ipv !~ /[46*]/;
    my @_info;
    if (!$ipv || $ipv =~ /[*]/ and eval {CAN_DISABLE_V6ONLY}) {
        my @rows = eval { $class->get_addr_info(@$info{qw(host port proto)}, $server) };
        $server->fatal($@ || "Could not find valid addresses for [$info->{'host'}]:$info->{'port'} with ipv set to '*'") if ! @rows;
        foreach my $row (@rows) {
            my ($host, $port, $ipv, $warn) = @$row;
            push @_info, {host => $host, port => $port, ipv => $ipv, proto => $info->{'proto'}, $warn ? (warn => $warn) : ()};
        }
        if (@rows > 1 && $rows[0]->[1] == 0) {
            $server->log(2, "Determining auto-assigned port (0) for host $info->{'host'} (prebind)");
            my $sock = $class->object($_info[-1], $server);
            $sock->connect($server);
            @$_{qw(port orig_port)} = ($sock->NS_port, 0) for @_info;
        }
        foreach my $_info (@_info) {
            $server->log(2, "Resolved [$info->{'host'}]:$info->{'port'} to [$_info->{'host'}]:$_info->{'port'}, IPv$_info->{'ipv'}")
                if $_info->{'host'} ne $info->{'host'} || $_info->{'port'} ne $info->{'port'};
            $server->log(2, delete $_info->{'warn'}) if $_info->{'warn'};
        }
    } elsif ($ipv =~ /6/ || $info->{'host'} =~ /:/) {
        push @_info, {%$info, ipv => '6'};
        push @_info, {%$info, ipv => '4'} if $ipv =~ /4/ && $info->{'host'} !~ /:/;
    } else {
        push @_info, {%$info, ipv => '4'};
    }

    return @_info;
}

sub get_addr_info {
    my $class = $_[0] eq __PACKAGE__ ? shift : __PACKAGE__;
    my ($host, $port, $proto, $server) = @_;
    $host  = '*'   if ! defined $host;
    $port  = 0     if ! defined $port;
    $proto = 'tcp' if ! defined $proto;
    $server = {}   if ! defined $server;
    return ([$host, $port, '*']) if $proto =~ /UNIX/i;
    $port = (getservbyname($port, $proto))[2] or croak "Could not determine port number from host [$host]:$_[1]" if $port =~ /\D/;

    my @info;
    if ($host =~ /^\d+(?:\.\d+){3}$/) {
        my $addr = inet_aton($host) or croak "Unresolveable host [$host]:$port: invalid ip";
        push @info, [inet_ntoa($addr), $port, 4];
    } elsif (eval { AI_PASSIVE }) { # PreTest to ensure AddressInfo AI_* operations can even try on this platform.
        my $proto_id = getprotobyname(lc($proto) eq 'udp' ? 'udp' : 'tcp');
        my $socktype = lc($proto) eq 'udp' ? SOCK_DGRAM : SOCK_STREAM;
        my @res = safe_addr_info($host eq '*' ? '' : $host, $port, { family=>AF_UNSPEC, socktype=>$socktype, protocol=>$proto_id, flags=>AI_PASSIVE });
        my $err = shift @res; croak "Unresolveable [$host]:$port: $err" if $err or (@res < 1 and $err = "getaddrname: $host: FAILURE!");
        while (my $r = shift @res) {
            my ($err, $ip) = safe_name_info($r->{addr}, NI_NUMERICHOST | NI_NUMERICSERV);
            croak "safe_name_info failed on [$host]:$port [$err]" if $err || !$ip;
            my $ipv = ($r->{family} == AF_INET) ? 4 : ($r->{family} == AF_INET6) ? 6 : '*';
            push @info, [$ip, $port, $ipv];
        }
        my %ipv6mapped = map {$_->[0] eq '::' ? ('0.0.0.0' => $_) : $_->[0] =~ /^::ffff:(\d+(?:\.\d+){3})$/i ? ($1 => $_) : ()} @info;
        if (keys %ipv6mapped and grep {$ipv6mapped{$_->[0]}} @info) {
            for my $i4 (@info) {
                my $i6 = $ipv6mapped{$i4->[0]} or next;
                if (!eval{ipv6_package($server)->new(LocalAddr=>$i6->[0],Type=>$socktype)}) {
                    $i4->[3] = "Host [$host] resolved to IPv6 address [$i6->[0]] but ipv6_package->new fails: $@";
                    $i6->[0] = '';
                } elsif ($i6->[2] eq '6' and eval {CAN_DISABLE_V6ONLY}) { # If IPv* can bind to both, upgrade '6' to '*', and disable the corresponding '4' entry
                    $i6->[3] = "Not including resolved host [$i4->[0]] IPv4 because it will be handled by [$i6->[0]] IPv6";
                    $i6->[2] = '*';
                    $i4->[0] = '';
                }
            }
            @info = grep {length $_->[0]} @info;
        }
    } elsif ($host =~ /:/) {
        croak "Unresolveable host [$host]:$port - could not load IPv6: $@";
    } else {
        my @addr;
        if ($host eq '*') {
            push @addr, INADDR_ANY;
        } else {
            (undef, undef, undef, undef, @addr) = gethostbyname($host);
            croak "Unresolveable host [$host]:$port via IPv4 gethostbyname" if !@addr;
        }
        push @info, [inet_ntoa($_), $port, 4] for @addr
    }

    return @info;
}

sub object {
    my $class = $_[0] eq __PACKAGE__ ? shift : __PACKAGE__;
    my ($info, $server) = @_;
    my $proto_class = $info->{'proto'};
    if ($proto_class !~ /::/) {
        $server->fatal("Invalid proto class \"$proto_class\"") if $proto_class !~ /^\w+$/;
        $proto_class = "Net::Server::Proto::" .uc($proto_class);
    }
    (my $file = "${proto_class}.pm") =~ s|::|/|g;
    $server->fatal("Unable to load module for proto \"$proto_class\": $@") if ! eval { require $file;1 };
    ipv6_package($server) if $server->{'server'}->{'ipv6_package'};
    return $proto_class->object($info, $server);
}

sub ipv6_package {
    return $ipv6_package if $ipv6_package;
    return undef if $ENV{'NO_IPV6'};
    my $class = @_ && $_[0] eq __PACKAGE__ ? shift : __PACKAGE__;
    my $server = shift || {};
    eval {require Net::Server::IP;1} or !warn "ipv6_package: Failure! [$!] [$@]" or die "ipv6_package: Failure! [$!] [$@]";
    if (!$Net::Server::IP::ipv6_package and my $pkg = $server->{'server'} && $server->{'server'}->{'ipv6_package'}) {
        $Net::Server::IP::ipv6_package = $pkg;
    }
    return $ipv6_package = "Net::Server::IP";
}

our $IPV6_V6ONLY;
sub IPV6_V6ONLY () {
    return $IPV6_V6ONLY if $IPV6_V6ONLY;
    $IPV6_V6ONLY = eval { Socket::IPV6_V6ONLY() }; # First try the actual platform value
    my $why = $@; # XXX: Do we need to hard-code magic numbers based on OS for old Perl < 5.14 / Socket < 1.94?
    $IPV6_V6ONLY ||= $^O eq 'linux' ? 26 : # XXX: Why is Linux different?
        $^O =~ /^(?:darwin|freebsd|openbsd|netbsd|dragonfly|MSWin32|solaris|svr4)$/ ? 27 : undef; # XXX: "27" everywhere else?
    if (!$IPV6_V6ONLY) { # XXX: Do we need to scrape it from kernel header files? Last ditch effort super ugly string-eval hack!
        my $d = "/tmp/IP6Cache"; !eval{$IPV6_V6ONLY=do"$d.pl"} and $IPV6_V6ONLY=do{mkdir $d;`h2ph -d $d -a netinet/in.h 2>/dev/null`;eval `echo "package _h2ph_shush_ipv6only;";grep -rl "sub IPV6_V6ONLY" $d|xargs cat|grep "sub IPV6_V6ONLY";echo "IPV6_V6ONLY()"`} and `rm -rvf $d 1>&2;echo $IPV6_V6ONLY|tee $d.pl`;
    }
    if ($IPV6_V6ONLY) {
        my $bricker=sub(){$IPV6_V6ONLY}; (my $me=(caller 0)[3])=~s/.*:://;
        no strict 'refs';no warnings qw(redefine);*{"$_\::$me"}=$bricker foreach keys %{$exported->{$me}},__PACKAGE__;
        return $IPV6_V6ONLY;
    }
    croak "$why\n$@\n[Socket $Socket::VERSION] Could not determine IPV6_V6ONLY on Unknown Platform [$^O]";
}

1;

__END__