File Coverage

blib/lib/Net/Server/Proto.pm

Criterion	Covered	Total	%
statement	83	138	60.1
branch	57	128	44.5
condition	24	66	36.3
subroutine	7	9	77.7
pod	1	4	25.0
total	172	345	49.8

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

my $requires_ipv6 = 0;

sub parse_info {
    my ($class, $port, $host, $proto, $ipv, $server) = @_;

    my $info;
    if (ref($port) eq 'HASH') {
        die "Missing port in hashref passed in port argument.\n" 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/udb 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 =~ /[*]/) {
        my @rows = eval { $class->get_addr_info(@$info{qw(host port proto)}) };
        $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) : ()};
            $requires_ipv6++ if $ipv ne '4' && $proto ne 'ssl'; # we need to know if Proto::TCP needs to reparent as a child of IO::Socket::INET6
        }
        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'};
        $requires_ipv6++ if $proto ne 'ssl'; # IO::Socket::SSL does its own determination
        push @_info, {%$info, ipv => '4'} if $ipv =~ /4/ && $info->{'host'} !~ /:/;
    } else {
        push @_info, {%$info, ipv => '4'};
    }

    return @_info;
}

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

    my @info;
    if ($host =~ /^\d+(?:\.\d+){3}$/) {
        my $addr = Socket::inet_aton($host) or die "Unresolveable host [$host]:$port: invalid ip\n";
        push @info, [Socket::inet_ntoa($addr), $port, 4]
    } elsif (!$ENV{'NO_IPV6'} && eval { require Socket6; require IO::Socket::INET6 }) {
        my $proto_id = getprotobyname(lc($proto) eq 'udp' ? 'udp' : 'tcp');
        my $socktype = lc($proto) eq 'udp' ? Socket::SOCK_DGRAM() : Socket::SOCK_STREAM();
        my @res = Socket6::getaddrinfo($host eq '*' ? '' : $host, $port, Socket::AF_UNSPEC(), $socktype, $proto_id, Socket6::AI_PASSIVE());
        die "Unresolveable [$host]:$port: $res[0]\n" if @res < 5;
        while (@res >= 5) {
            my ($afam, $socktype, $proto, $saddr, $canonname) = splice @res, 0, 5;
            my @res2 = Socket6::getnameinfo($saddr, Socket6::NI_NUMERICHOST() | Socket6::NI_NUMERICSERV());
            die "getnameinfo failed on [$host]:$port: $res2[0]\n" if @res2 < 2;
            my ($ip, $port) = @res2;
            my $ipv = ($afam == Socket6::AF_INET6()) ? 6 : ($afam == Socket::AF_INET()) ? 4 : '*';
            push @info, [$ip, $port, $ipv];
        }
        my %ipv6mapped = map {$_->[0] eq '::' ? ('0.0.0.0' => $_) : $_->[0] =~ /^::ffff:(\d+(?:\.\d+){3})$/ ? ($1 => $_) : ()} @info;
        if ((scalar(keys %ipv6mapped)
             && grep {$ipv6mapped{$_->[0]}} @info)
            && not my $only = $class->_bindv6only) {
            for my $i4 (@info) {
                my $i6 = $ipv6mapped{$i4->[0]} || next;
                if ($host eq '*' && $i6->[0] eq '::' && !length($only)
                    && !eval{IO::Socket::INET6->new->configure({LocalAddr => '', LocalPort => 0, Listen => 1, ReuseAddr => 1, Domain => Socket6::AF_INET6()}) or die $!}) {
                    $i4->[3] = "Host [*] resolved to IPv6 address [::] but IO::Socket::INET6->new fails: $@";
                    $i6->[0] = '';
                } else {
                    $i6->[3] = "Not including resolved host [$i4->[0]] IPv4 because it ".(length($only) ? 'will' : 'should')." be handled by [$i6->[0]] IPv6";
                    $i4->[0] = '';
                }
            }
            @info = grep {length $_->[0]} @info;
        }
    } elsif ($host =~ /:/) {
        die "Unresolveable host [$host]:$port - could not load IO::Socket::INET6: $@";
    } else {
        my @addr;
        if ($host eq '*') {
            push @addr, Socket::INADDR_ANY();
        } else {
            (undef, undef, undef, undef, @addr) = gethostbyname($host);
            die "Unresolveable host [$host]:$port via IPv4 gethostbyname\n" if !@addr;
        }
        push @info, [Socket::inet_ntoa($_), $port, 4] for @addr
    }

    return @info;
}

sub _bindv6only {
    my $class = shift;
    my $val = $class->_sysctl('net.ipv6.bindv6only'); # linux
    $val = $class->_sysctl('net.inet6.ip6.v6only') if ! length($val); # bsd
    return $val;
}

sub _sysctl {
    my ($class, $key) = @_;
    (my $file = "/proc/sys/$key") =~ y|.|/|;
    if (-e $file) {
        open my $fh, "<", $file or return '';
        my $val = <$fh> || return '';
        chomp $val;
        return $val;
    } elsif (-x "/sbin/sysctl") {
        my $val = (split /\s+/, `/sbin/sysctl -n $key 2>/dev/null`)[0];
        return defined($val) ? $val : '';
    }
    return '';
}

sub object {
    my ($class, $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 };
    return $proto_class->object($info, $server);
}

sub requires_ipv6 {
    my ($class, $server) = @_;
    return if ! $requires_ipv6;

    if (! $INC{'IO/Socket/INET6.pm'}) {
        eval {
            require Socket6;
            require IO::Socket::INET6;
        } or $server->fatal("Port configuration using IPv6 could not be started becauses of Socket6 library issues: $@");
    }
    return 1;
}

1;

__END__