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


line stmt bran cond sub pod time code
1             # -*- perl -*-
2             #
3             # Net::Server::Proto - Net::Server Protocol compatibility layer
4             #
5             # Copyright (C) 2001-2017
6             #
7             # Paul Seamons
8             #
9             # This package may be distributed under the terms of either the
10             # GNU General Public License
11             # or the
12             # Perl Artistic License
13             #
14             # All rights reserved.
15             #
16             ################################################################
17              
18             package Net::Server::Proto;
19              
20 42     42   27175 use strict;
  42         89  
  42         1415  
21 42     42   223 use warnings;
  42         78  
  42         1172  
22 42     42   203 use Socket ();
  42         71  
  42         133151  
23              
24             my $requires_ipv6 = 0;
25              
26             sub parse_info {
27 100     100 0 377 my ($class, $port, $host, $proto, $ipv, $server) = @_;
28              
29 100         191 my $info;
30 100 100       265 if (ref($port) eq 'HASH') {
31 9 50       26 die "Missing port in hashref passed in port argument.\n" if ! $port->{'port'};
32 9         14 $info = $port;
33             } else {
34 91         188 $info = {};
35 91 100       369 $info->{'unix_type'} = $1
36             if $port =~ s{ (?<=[\w*\]]) [,|\s:/]+ (sock_stream|sock_dgram) \b }{}x; # legacy /some/path|sock_dgram
37 91 100       518 $ipv = $1 if $port =~ s{ (?<=[\w*\]]) [,|\s:/]+ IPv([*\d]+) }{}xi; # allow for 80|IPv*
38 91 50       316 $ipv .= $1 if $port =~ s{ (?<=[\w*\]]) [,|\s:/]+ IPv([*\d]+) }{}xi; # allow for 80|IPv4|IPv6 stacked
39 91 100 66     746 $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
40             || $port =~ s{ / (\w+) $ }{}x; # legacy 80/MyTcp support
41 91 100       618 $host = $1 if $port =~ s{ ^ (.*?) [,|\s:]+ (?= \w+ $) }{}x; # allow localhost:80
42 91         290 $info->{'port'} = $port;
43             }
44 100   50     248 $info->{'port'} ||= 0;
45              
46              
47 100 100 66     845 $info->{'host'} ||= (defined($host) && length($host)) ? $host : '*';
      66        
48 100 50       349 $ipv = $1 if $info->{'host'} =~ s{ (?<=[\w*\]]) [,|\s:/]+ IPv([*\d]+) }{}xi; # allow for 80|IPv*
49 100 50       262 $ipv .= $1 if $info->{'host'} =~ s{ (?<=[\w*\]]) [,|\s:/]+ IPv([*\d]+) }{}xi; # allow for 80|IPv4|IPv6 stacked
50 100 100       779 if ( $info->{'host'} =~ m{^ \[ ([\w/.\-:]+ | \*?) \] $ }x) { # allow for [::1] or [host.example.com]
    50          
51 1 50       6 $info->{'host'} = length($1) ? $1 : '*';
52             } elsif ($info->{'host'} =~ m{^ ([\w/.\-:]+ | \*?) $ }x) {
53 99         319 $info->{'host'} = $1; # untaint
54             } else {
55 0         0 $server->fatal("Could not determine host from \"$info->{'host'}\"");
56             }
57              
58              
59 100   100     792 $info->{'proto'} ||= $proto || 'tcp';
      66        
60 100 50       261 $ipv = $1 if $info->{'proto'} =~ s{ (?<=[\w*\]]) [,|\s:/]+ IPv([*\d]+) }{}xi; # allow for 80|IPv*
61 100 50       240 $ipv .= $1 if $info->{'proto'} =~ s{ (?<=[\w*\]]) [,|\s:/]+ IPv([*\d]+) }{}xi; # allow for 80|IPv4|IPv6 stacked
62 100 50       512 if ($info->{'proto'} =~ /^(\w+ (?:::\w+)*)$/x) {
63 100         278 $info->{'proto'} = $1;
64             } else {
65 0         0 $server->fatal("Could not determine proto from \"$proto\"");
66             }
67 100         247 $proto = lc $info->{'proto'};
68              
69 100 100       288 if ($info->{'proto'} =~ /^UNIX/i) {
70 8         72 return ({%$info, ipv => '*'});
71             }
72 92   100     627 $ipv = $info->{'ipv'} || $ipv || $ENV{'IPV'} || '';
73 92 50       242 $ipv = join '', @$ipv if ref($ipv) eq 'ARRAY';
74 92 50 66     405 $server->fatal("Invalid ipv parameter - must contain 4, 6, or *") if $ipv && $ipv !~ /[46*]/;
75 92         147 my @_info;
76 92 100 100     614 if (!$ipv || $ipv =~ /[*]/) {
    50 33        
77 41         70 my @rows = eval { $class->get_addr_info(@$info{qw(host port proto)}) };
  41         120  
78 41 50 0     101 $server->fatal($@ || "Could not find valid addresses for [$info->{'host'}]:$info->{'port'} with ipv set to '*'") if ! @rows;
79 41         74 foreach my $row (@rows) {
80 41         104 my ($host, $port, $ipv, $warn) = @$row;
81 41 50       218 push @_info, {host => $host, port => $port, ipv => $ipv, proto => $info->{'proto'}, $warn ? (warn => $warn) : ()};
82 41 50 33     123 $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
83             }
84 41 50 33     112 if (@rows > 1 && $rows[0]->[1] == 0) {
85 0         0 $server->log(2, "Determining auto-assigned port (0) for host $info->{'host'} (prebind)");
86 0         0 my $sock = $class->object($_info[-1], $server);
87 0         0 $sock->connect($server);
88 0         0 @$_{qw(port orig_port)} = ($sock->NS_port, 0) for @_info;
89             }
90 41         64 foreach my $_info (@_info) {
91             $server->log(2, "Resolved [$info->{'host'}]:$info->{'port'} to [$_info->{'host'}]:$_info->{'port'}, IPv$_info->{'ipv'}")
92 41 100 66     286 if $_info->{'host'} ne $info->{'host'} || $_info->{'port'} ne $info->{'port'};
93 41 50       179 $server->log(2, delete $_info->{'warn'}) if $_info->{'warn'};
94             }
95             } elsif ($ipv =~ /6/ || $info->{'host'} =~ /:/) {
96 0         0 push @_info, {%$info, ipv => '6'};
97 0 0       0 $requires_ipv6++ if $proto ne 'ssl'; # IO::Socket::SSL does its own determination
98 0 0 0     0 push @_info, {%$info, ipv => '4'} if $ipv =~ /4/ && $info->{'host'} !~ /:/;
99             } else {
100 51         355 push @_info, {%$info, ipv => '4'};
101             }
102              
103 92         514 return @_info;
104             }
105              
106             sub get_addr_info {
107 80     80 0 857 my ($class, $host, $port, $proto) = @_;
108 80 50       264 $host = '*' if ! defined $host;
109 80 100       213 $port = 0 if ! defined $port;
110 80 100       226 $proto = 'tcp' if ! defined $proto;
111 80 50       215 return ([$host, $port, '*']) if $proto =~ /UNIX/i;
112 80 50 0     328 $port = (getservbyname($port, $proto))[2] or die "Could not determine port number from host [$host]:$_[2]\n" if $port =~ /\D/;
113              
114 80         157 my @info;
115 80 100 33     453 if ($host =~ /^\d+(?:\.\d+){3}$/) {
    50          
    50          
116 1 50       35 my $addr = Socket::inet_aton($host) or die "Unresolveable host [$host]:$port: invalid ip\n";
117 1         13 push @info, [Socket::inet_ntoa($addr), $port, 4]
118 79         13356 } elsif (!$ENV{'NO_IPV6'} && eval { require Socket6; require IO::Socket::INET6 }) {
  0         0  
119 0 0       0 my $proto_id = getprotobyname(lc($proto) eq 'udp' ? 'udp' : 'tcp');
120 0 0       0 my $socktype = lc($proto) eq 'udp' ? Socket::SOCK_DGRAM() : Socket::SOCK_STREAM();
121 0 0       0 my @res = Socket6::getaddrinfo($host eq '*' ? '' : $host, $port, Socket::AF_UNSPEC(), $socktype, $proto_id, Socket6::AI_PASSIVE());
122 0 0       0 die "Unresolveable [$host]:$port: $res[0]\n" if @res < 5;
123 0         0 while (@res >= 5) {
124 0         0 my ($afam, $socktype, $proto, $saddr, $canonname) = splice @res, 0, 5;
125 0         0 my @res2 = Socket6::getnameinfo($saddr, Socket6::NI_NUMERICHOST() | Socket6::NI_NUMERICSERV());
126 0 0       0 die "getnameinfo failed on [$host]:$port: $res2[0]\n" if @res2 < 2;
127 0         0 my ($ip, $port) = @res2;
128 0 0       0 my $ipv = ($afam == Socket6::AF_INET6()) ? 6 : ($afam == Socket::AF_INET()) ? 4 : '*';
    0          
129 0         0 push @info, [$ip, $port, $ipv];
130             }
131 0 0       0 my %ipv6mapped = map {$_->[0] eq '::' ? ('0.0.0.0' => $_) : $_->[0] =~ /^::ffff:(\d+(?:\.\d+){3})$/ ? ($1 => $_) : ()} @info;
  0 0       0  
132 0 0 0     0 if ((scalar(keys %ipv6mapped)
      0        
133 0         0 && grep {$ipv6mapped{$_->[0]}} @info)
134             && not my $only = $class->_bindv6only) {
135 0         0 for my $i4 (@info) {
136 0   0     0 my $i6 = $ipv6mapped{$i4->[0]} || next;
137 0 0 0     0 if ($host eq '*' && $i6->[0] eq '::' && !length($only)
      0        
      0        
138 0 0       0 && !eval{IO::Socket::INET6->new->configure({LocalAddr => '', LocalPort => 0, Listen => 1, ReuseAddr => 1, Domain => Socket6::AF_INET6()}) or die $!}) {
139 0         0 $i4->[3] = "Host [*] resolved to IPv6 address [::] but IO::Socket::INET6->new fails: $@";
140 0         0 $i6->[0] = '';
141             } else {
142 0 0       0 $i6->[3] = "Not including resolved host [$i4->[0]] IPv4 because it ".(length($only) ? 'will' : 'should')." be handled by [$i6->[0]] IPv6";
143 0         0 $i4->[0] = '';
144             }
145             }
146 0         0 @info = grep {length $_->[0]} @info;
  0         0  
147             }
148             } elsif ($host =~ /:/) {
149 0         0 die "Unresolveable host [$host]:$port - could not load IO::Socket::INET6: $@";
150             } else {
151 79         252 my @addr;
152 79 100       211 if ($host eq '*') {
153 40         92 push @addr, Socket::INADDR_ANY();
154             } else {
155 39         19144 (undef, undef, undef, undef, @addr) = gethostbyname($host);
156 39 50       360 die "Unresolveable host [$host]:$port via IPv4 gethostbyname\n" if !@addr;
157             }
158 79         932 push @info, [Socket::inet_ntoa($_), $port, 4] for @addr
159             }
160              
161 80         469 return @info;
162             }
163              
164             sub _bindv6only {
165 0     0   0 my $class = shift;
166 0         0 my $val = $class->_sysctl('net.ipv6.bindv6only'); # linux
167 0 0       0 $val = $class->_sysctl('net.inet6.ip6.v6only') if ! length($val); # bsd
168 0         0 return $val;
169             }
170              
171             sub _sysctl {
172 0     0   0 my ($class, $key) = @_;
173 0         0 (my $file = "/proc/sys/$key") =~ y|.|/|;
174 0 0       0 if (-e $file) {
    0          
175 0 0       0 open my $fh, "<", $file or return '';
176 0   0     0 my $val = <$fh> || return '';
177 0         0 chomp $val;
178 0         0 return $val;
179             } elsif (-x "/sbin/sysctl") {
180 0         0 my $val = (split /\s+/, `/sbin/sysctl -n $key 2>/dev/null`)[0];
181 0 0       0 return defined($val) ? $val : '';
182             }
183 0         0 return '';
184             }
185              
186             sub object {
187 100     100 1 276 my ($class, $info, $server) = @_;
188 100         193 my $proto_class = $info->{'proto'};
189 100 100       397 if ($proto_class !~ /::/) {
190 99 50       595 $server->fatal("Invalid proto class \"$proto_class\"") if $proto_class !~ /^\w+$/;
191 99         329 $proto_class = "Net::Server::Proto::" .uc($proto_class);
192             }
193 100         544 (my $file = "${proto_class}.pm") =~ s|::|/|g;
194 100 50       220 $server->fatal("Unable to load module for proto \"$proto_class\": $@") if ! eval { require $file };
  100         23785  
195 100         701 return $proto_class->object($info, $server);
196             }
197              
198             sub requires_ipv6 {
199 90     90 0 193 my ($class, $server) = @_;
200 90 50       440 return if ! $requires_ipv6;
201              
202 0 0         if (! $INC{'IO/Socket/INET6.pm'}) {
203 0 0         eval {
204 0           require Socket6;
205 0           require IO::Socket::INET6;
206             } or $server->fatal("Port configuration using IPv6 could not be started becauses of Socket6 library issues: $@");
207             }
208 0           return 1;
209             }
210              
211             1;
212              
213             __END__