--- Net-Server-0.99/lib/Net/Server/Proto/UDP.pm 2008-02-08 03:40:33.000000000 +0100 +++ Net-Server-0.99/lib/Net/Server/Proto/UDP.pm 2010-10-05 15:41:16.000000000 +0200 @@ -35,9 +35,4 @@ my $class = ref($type) || $type || __PACKAGE__; - my $sock = $class->SUPER::object( @_ ); - - $sock->NS_proto('UDP'); - - ### set a few more parameters my($default_host,$port,$server) = @_; my $prop = $server->{server}; @@ -62,33 +57,42 @@ && $prop->{udp_broadcast}; - $sock->NS_recv_len( $prop->{udp_recv_len} ); - $sock->NS_recv_flags( $prop->{udp_recv_flags} ); + my @sockets_list = $class->SUPER::object( @_ ); - return $sock; + foreach my $sock ( @sockets_list ){ + $sock->NS_proto('UDP'); + $sock->NS_recv_len( $prop->{udp_recv_len} ); + $sock->NS_recv_flags( $prop->{udp_recv_flags} ); + } + + ### returns any number of sockets, + ### one for each protocol family (PF_INET or PF_INET6) and each bind address + return !wantarray ? $sockets_list[0] : @sockets_list; } -### connect the first time +### bind the first time ### doesn't support the listen or the reuse option sub connect { - my $sock = shift; - my $server = shift; - my $prop = $server->{server}; - - my $host = $sock->NS_host; - my $port = $sock->NS_port; + my $sock = shift; + my $server = shift; + my $prop = $server->{server}; + + my $host = $sock->NS_host; + my $port = $sock->NS_port; + my $pfamily = $sock->NS_family || 0; - my %args = (); + my %args; $args{LocalPort} = $port; # what port to bind on $args{Proto} = 'udp'; # what procol to use $args{LocalAddr} = $host if $host !~ /\*/; # what local address (* is all) + $args{Domain} = $pfamily if $Net::Server::Proto::TCP::have_inet6 && $pfamily; $args{Reuse} = 1; # allow us to rebind the port on a restart $args{Broadcast} = 1 if $prop->{udp_broadcast}; - ### connect to the sock + ### bind to the sock $sock->SUPER::configure(\%args) - or $server->fatal("Can't connect to UDP port $port on $host [$!]"); + or $server->fatal("Can't bind to UDP port $port on $host [$!]"); - $server->fatal("Back sock [$!]!".caller()) + $server->fatal("Bad sock [$!]!".caller()) unless $sock; --- Net-Server-0.99/lib/Net/Server/Proto.pm 2010-05-05 06:13:22.000000000 +0200 +++ Net-Server-0.99/lib/Net/Server/Proto.pm 2010-10-05 17:56:38.000000000 +0200 @@ -69,5 +69,6 @@ - ### return an object of that procol class + ### returns any number of objects (socket), + ### one for each protocol family (PF_INET or PF_INET6) and each bind address return $proto_class->object($default_host,$port,$server); @@ -84,5 +85,5 @@ =head1 SYNOPSIS - # Net::Server::Proto and its accompianying modules are not + # Net::Server::Proto and its accompanying modules are not # intended to be used outside the scope of Net::Server. @@ -103,5 +104,5 @@ ### Net::Server::Proto will attempt to interface with - ### sub modules named simillar to Net::Server::Proto::TCP + ### sub modules named similar to Net::Server::Proto::TCP ### Individual sub modules will be loaded by ### Net::Server::Proto as they are needed. @@ -225,8 +226,22 @@ The port is the most important argument passed to the sub module classes and to Net::Server::Proto itself. For tcp, -udp, and ssl style ports, the form is generally -host:port/protocol, host|port|protocol, host/port, or port. -For unix the form is generally socket_file|type|unix or -socket_file. +udp, and ssl style ports, the form is generally host:port/protocol +or [host]:port/protocol, host|port|protocol, host/port, or port. +If I is a numerical IPv6 address it must be enclosed in square +brackets to avoid ambiguity in parsing a port number, e.g.: "[::1]:80". +For unix sockets the form is generally socket_file|type|unix or socket_file. + +A socket protocol family PF_INET or PF_INET6 is derived from a specified +address family of the binding address. A PF_INET socket can only accept +IPv4 connections. A PF_INET6 socket accepts IPv6 connections, but may also +accept IPv4 connections, depending on OS and its settings. For example, +on FreeBSD systems setting a sysctl net.inet6.ip6.v6only to 0 will allow +IPv4 connections to a PF_INET6 socket. + +The Net::Server::Proto::object method returns a list of objects corresponding +to created sockets. For Unix and INET sockets the list typically contains +just one element, but may return multiple objects when multiple protocol +families are allowed or when a host name resolves to multiple local +binding addresses. You can see what Net::Server::Proto parsed out by looking at --- Net-Server-0.99/lib/Net/Server.pm 2010-07-09 16:55:31.000000000 +0200 +++ Net-Server-0.99/lib/Net/Server.pm 2010-10-05 19:52:16.000000000 +0200 @@ -26,5 +26,5 @@ use strict; use vars qw($VERSION); -use Socket qw(inet_aton inet_ntoa AF_INET AF_UNIX SOCK_DGRAM SOCK_STREAM); +use Socket qw(AF_INET AF_UNIX SOCK_DGRAM SOCK_STREAM); use IO::Socket (); use IO::Select (); @@ -356,6 +356,12 @@ push @{ $prop->{host} }, (($prop->{host}->[-1]) x (@{ $prop->{port} } - @{ $prop->{host}})); # augment hosts with as many as port foreach my $host (@{ $prop->{host} }) { - $host = '*' if ! defined $host || ! length $host;; - $host = ($host =~ /^([\w\.\-\*\/]+)$/) ? $1 : $self->fatal("Unsecure host \"$host\""); + local $1; + if (!defined $host || $host eq '' || $host eq '*') { + $host = '*'; + } elsif ($host =~ /^\[([\w\/.:-]+)\]$/ || $host =~ /^([\w\/.:-]+)$/) { + $host = $1; + } else { + $self->fatal("Unsecure host \"$host\""); + } } @@ -377,10 +383,12 @@ my $host = $prop->{host}->[$i]; my $proto = $prop->{proto}->[$i]; - if ($port ne 0 && $bound{"$host/$port/$proto"}++) { + if ($port ne "0" && $bound{"$host/$port/$proto"}++) { $self->log(2, "Duplicate configuration (".(uc $proto)." port $port on host $host - skipping"); next; } - my $obj = $self->proto_object($host, $port, $proto) || next; - push @{ $prop->{sock} }, $obj; + my @obj_list = $self->proto_object($host, $port, $proto); + for my $obj (@obj_list) { + push @{ $prop->{sock} }, $obj if $obj; + } } if (! @{ $prop->{sock} }) { @@ -397,5 +405,7 @@ } -### method for invoking procol specific bindings +### method for invoking procol specific bindings; +### returns any number of sockets, +### one for each protocol family (PF_INET or PF_INET6) and each bind address sub proto_object { my $self = shift; @@ -440,6 +450,8 @@ } - ### if more than one port we'll need to select on it - if( @{ $prop->{port} } > 1 || $prop->{multi_port} ){ + ### if more than one socket we'll need to select on it; + ### note there may be more than one socket per port, + ### one for each protocol family (PF_INET and PF_INET6) + if( @{ $prop->{sock} } > 1 || $prop->{multi_port} ){ $prop->{multi_port} = 1; $prop->{select} = IO::Select->new(); @@ -748,5 +760,7 @@ return; } elsif ($self->isa('Net::Server::INET')) { - $prop->{sockaddr} = $ENV{'REMOTE_HOST'} || '0.0.0.0'; + # since we do not know a socket protocol family, we are unable + # to choose between '0.0.0.0' and '::' as an unspecified address + $prop->{sockaddr} = $ENV{'REMOTE_HOST'} || '0.0.0.0'; # or is is a '::' ? $prop->{peeraddr} = '0.0.0.0'; $prop->{sockhost} = $prop->{peerhost} = 'inetd.server'; @@ -756,12 +770,12 @@ ### read information about this connection - my $sockname = getsockname( $sock ); + my $sockname = $sock->sockname; if( $sockname ){ - ($prop->{sockport}, $prop->{sockaddr}) - = Socket::unpack_sockaddr_in( $sockname ); - $prop->{sockaddr} = inet_ntoa( $prop->{sockaddr} ); - + $prop->{sockaddr} = $sock->sockhost; + $prop->{sockport} = $sock->sockport; }else{ ### does this only happen from command line? + # since we do not know a socket protocol family, we are unable + # to choose between '0.0.0.0' and '::' as an unspecified address $prop->{sockaddr} = $ENV{'REMOTE_HOST'} || '0.0.0.0'; $prop->{sockhost} = 'inet.test'; @@ -773,16 +787,24 @@ if( $prop->{udp_true} ){ $proto_type = 'UDP'; - ($prop->{peerport} ,$prop->{peeraddr}) - = Socket::sockaddr_in( $prop->{udp_peer} ); - }elsif( $prop->{peername} = getpeername( $sock ) ){ - ($prop->{peerport}, $prop->{peeraddr}) - = Socket::unpack_sockaddr_in( $prop->{peername} ); - } - - if( $prop->{peername} || $prop->{udp_true} ){ - $prop->{peeraddr} = inet_ntoa( $prop->{peeraddr} ); - - if( defined $prop->{reverse_lookups} ){ - $prop->{peerhost} = gethostbyaddr( inet_aton($prop->{peeraddr}), AF_INET ); + if ($sock->sockdomain == AF_INET) { ($prop->{peerport}, $prop->{peeraddrn}) = Socket::sockaddr_in($prop->{udp_peer}); + } else { ($prop->{peerport}, $prop->{peeraddrn}) = Socket6::sockaddr_in6($prop->{udp_peer}); + } + $prop->{peeraddr} = Socket6->UNIVERSAL::can('inet_ntop') + ? Socket6::inet_ntop($sock->sockdomain, $prop->{peeraddrn}) + : Socket::inet_ntoa( $prop->{peeraddrn} ); + }elsif( $prop->{peername} = $sock->peername ){ + $prop->{peeraddrn} = $sock->peeraddr; # binary + $prop->{peeraddr} = $sock->peerhost; # ascii + $prop->{peerport} = $sock->peerport; + } + + if( $prop->{peeraddrn} ){ + if( !defined $prop->{reverse_lookups} ){ + # no reverse DNS resolving + }elsif( Socket6->UNIVERSAL::can('getnameinfo') ){ + my @res = Socket6::getnameinfo( $prop->{peeraddrn}, 0 ); + $prop->{peerhost} = $res[0] if @res > 1; + }else{ + $prop->{peerhost} = gethostbyaddr( $prop->{peeraddrn}, AF_INET ); } $prop->{peerhost} = '' unless defined $prop->{peerhost}; @@ -790,4 +812,6 @@ }else{ ### does this only happen from command line? + # since we do not know a socket protocol family, we are unable + # to choose between '0.0.0.0' and '::' as an unspecified address $prop->{peeraddr} = '0.0.0.0'; $prop->{peerhost} = 'inet.test'; @@ -796,6 +820,6 @@ $self->log(3,$self->log_time - ." CONNECT $proto_type Peer: \"$prop->{peeraddr}:$prop->{peerport}\"" - ." Local: \"$prop->{sockaddr}:$prop->{sockport}\"\n"); + ." CONNECT $proto_type Peer: \"[$prop->{peeraddr}]:$prop->{peerport}\"" + ." Local: \"[$prop->{sockaddr}]:$prop->{sockport}\"\n"); } @@ -1141,9 +1165,11 @@ foreach my $sock ( @{ $prop->{sock} } ){ - ### duplicate the sock + ### duplicate the socket descriptor my $fd = POSIX::dup($sock->fileno) or $self->fatal("Can't dup socket [$!]"); - ### hold on to the socket copy until exec + ### hold on to the socket copy until exec; + ### just temporary: any socket domain will do, + ### forked process will decide to use IO::Socket::INET6 if necessary $prop->{_HUP}->[$i] = IO::Socket::INET->new; $prop->{_HUP}->[$i]->fdopen($fd, 'w') @@ -1153,5 +1179,5 @@ $prop->{_HUP}->[$i]->fcntl( Fcntl::F_SETFD(), my $flags = "" ); - ### save host,port,proto, and file descriptor + ### save file descriptor and host|port|proto|family push @fd, $fd .'|'. $sock->hup_string; --- Net-Server-0.99/lib/Net/Server.pod 2010-07-08 21:22:42.000000000 +0200 +++ Net-Server-0.99/lib/Net/Server.pod 2010-10-05 19:32:28.000000000 +0200 @@ -556,19 +556,46 @@ bound at server startup. May be of the form C, C, C, or C, -where I represents a hostname residing on the local -box, where I represents either the number of the port -(eg. "80") or the service designation (eg. "http"), and -where I represents the protocol to be used. See -L. If you are working with unix sockets, -you may also specify C or -C where type is SOCK_DGRAM or -SOCK_STREAM. If the protocol is not specified, I will +where I represents a hostname residing on the local box, +where I represents either the number of the port (eg. "80") +or the service designation (eg. "http"), and where I +represents the protocol to be used. See L. + +An explicit I given in a port specification overrides +a default binding address (a C setting, see below). +The I part may be enclosed in square brackets, but when it is +a numerical IPv6 address it B be enclosed in square brackets +to avoid ambiguity in parsing a port number, e.g.: "[::1]:80". + +If you are working with unix sockets, you may also specify +C or C where type is SOCK_DGRAM +or SOCK_STREAM. If the protocol is not specified, I will default to the C specified in the arguments. If C is not specified there it will default to "tcp". If I is not specified, I will default to C specified in the -arguments. If C is not specified there it will -default to "*". Default port is 20203. Configuration passed -to new or run may be either a scalar containing a single port -number or an arrayref of ports. +arguments. If C is not specified there it will default to "*". +Default port is 20203. Configuration passed to new or run may be either +a scalar containing a single port number or an arrayref of ports. + +On an IPv6-enabled host where a module IO::Socket::INET6 is installed +the "*" implies two listening sockets, one for each of the protocols +(PF_INET and PF_INET6) and is equivalent to specifying two ports, bound +to an 'unspecified' address of each address family ("0.0.0.0" and "::"). +If listening on an INET6 socket is not desired despite IO::Socket::INET6 +module being available, please supply the 'unspecifed' INET (IPv4) address +'0.0.0.0' as a I, either in the C or in the C argument. + +An INET socket can only accept IPv4 connections. An INET6 socket accepts +IPv6 connections, but may also accept IPv4 connections depending on +OS and its settings. For example, on FreeBSD systems setting a sysctl +net.inet6.ip6.v6only to 0 will allow IPv4 connections to an INET6 socket. +If this is the case, specifying "::" as a binding address instead of a "*" +might be desired to reduce the number of sockets needed. Note that a +textual representation of a peer's IPv4 address as connected to an INET6 +socket will typically be in a form of an IPv4-mapped IPv6 addresses, +e.g. "::FFFF:127.0.0.1" . + +Restricting binding to a loopback interface on systems where an INET6 +socket does not accept IPv4 connections requires creating two sockets, +one bound to address "127.0.0.1" and the other bound to address "::1". On systems that support it, a port value of 0 may be used to ask @@ -583,5 +610,7 @@ Local host or addr upon which to bind port. If a value of '*' is given, the server will bind that port on all available addresses -on the box. See L. See L. Configuration +on the box. The C argument provides a default local host +address if the C argument omits a host specification. +See L. See L. Configuration passed to new or run may be either a scalar containing a single host or an arrayref of hosts - if the hosts array is shorter than --- Net-Server-0.99/lib/Net/Server/Proto/SSLEAY.pm.orig 2010-07-09 09:44:48.000000000 -0700 +++ Net-Server-0.99/lib/Net/Server/Proto/SSLEAY.pm 2011-08-01 11:08:19.183613424 -0700 @@ -22,156 +22,254 @@ package Net::Server::Proto::SSLEAY; use strict; -use vars qw($VERSION $AUTOLOAD @ISA); -use IO::Socket::INET; +use vars qw($VERSION $AUTOLOAD @ISA $have_inet6); use Fcntl (); use Errno (); use Socket (); +use IO::Socket; BEGIN { - eval { require Net::SSLeay }; - $@ && warn "Module Net::SSLeay is required for SSLeay."; - # Net::SSLeay gets mad if we call these multiple times - the question is - who will call them multiple times? - for my $sub (qw(load_error_strings SSLeay_add_ssl_algorithms ENGINE_load_builtin_engines ENGINE_register_all_complete randomize)) { - Net::SSLeay->can($sub)->(); - } + eval { + require Socket6; import Socket6; + require IO::Socket::INET6; + @ISA = qw(IO::Socket::INET6); + $have_inet6 = 1; + } or do { + require IO::Socket::INET; + @ISA = qw(IO::Socket::INET); + }; + eval { require Net::SSLeay }; + $@ && warn "Module Net::SSLeay is required for SSLeay."; + # Net::SSLeay gets mad if we call these multiple times - the question is - who will call them multiple times? + for my $sub (qw(load_error_strings SSLeay_add_ssl_algorithms ENGINE_load_builtin_engines ENGINE_register_all_complete randomize)) { + Net::SSLeay->can($sub)->(); + } } $VERSION = $Net::Server::VERSION; # done until separated -@ISA = qw(IO::Socket::INET); + +# additional protocol specific arguments +my @ssl_args = qw( + SSL_use_cert + SSL_verify_mode + SSL_key_file + SSL_cert_file + SSL_ca_path + SSL_ca_file + SSL_cipher_list + SSL_passwd_cb + SSL_max_getline_length + SSL_error_callback +); sub object { - my $type = shift; - my $class = ref($type) || $type || __PACKAGE__; + my $type = shift; + my $class = ref($type) || $type || __PACKAGE__; - my ($default_host,$port,$server) = @_; - my $prop = $server->{'server'}; - my $host; - - if ($port =~ m/^([\w\.\-\*\/]+):(\w+)$/) { # allow for things like "domain.com:80" - ($host, $port) = ($1, $2); - } - elsif ($port =~ /^(\w+)$/) { # allow for things like "80" - ($host, $port) = ($default_host, $1); - } - else { - $server->fatal("Undeterminate port \"$port\" under ".__PACKAGE__); - } - - # read any additional protocol specific arguments - my @ssl_args = qw( - SSL_server - SSL_use_cert - SSL_verify_mode - SSL_key_file - SSL_cert_file - SSL_ca_path - SSL_ca_file - SSL_cipher_list - SSL_passwd_cb - SSL_error_callback - SSL_max_getline_length - ); - my %args; - $args{$_} = \$prop->{$_} for @ssl_args; - $server->configure(\%args); - - my $sock = $class->new; - $sock->NS_host($host); - $sock->NS_port($port); - $sock->NS_proto('SSLEAY'); + my ($default_host,$port,$server) = @_; + my $host; + my $prop = $server->{'server'}; + + local($1,$2); + ### allow for things like "[::1]:80" or "[host.example.com]:80" + if( $port =~ m/^\[([^\]]*)\]:(\w+)$/ ){ + ($host,$port) = ($1,$2); + + ### allow for things like "host.example.com:80" + }elsif( $port =~ m/^([\w\.\-\*\/]+):(\w+)$/ ){ + ($host,$port) = ($1,$2); + + ### allow for things like "80" or "http" + }elsif( $port =~ /^(\w+)$/ ){ + ($host,$port) = ($default_host,$1); + + ### don't know that style of port + }else{ + $server->fatal("Undeterminate port \"$port\" under ".__PACKAGE__); + } + + ### collect bind addresses along with their address family for all hosts + my @bind_tuples; + if( $host =~ /^\d{1,3}(?:\.\d{1,3}){3}\z/ ){ + push(@bind_tuples, [AF_INET,$host,$port]); + }elsif( $host =~ /:/ ){ + die "No IO::Socket::INET6, cannot bind to [$host]:$port" if !$have_inet6; + push(@bind_tuples, [AF_INET6,$host,$port]); + }elsif( !$have_inet6 ){ + push(@bind_tuples, [AF_INET,$host,$port]); + }elsif( $have_inet6 && $host =~ /\*/ ){ + push(@bind_tuples, [AF_INET6,$host,$port], [AF_INET,$host,$port]); + }else{ # we do have IO::Socket::INET6, it handles inet6 as well as inet + # obtain a list of IP addresses for $host, resolve port name + my @res1 = getaddrinfo($host, $port, AF_UNSPEC, SOCK_STREAM, 0, + AI_PASSIVE|AI_ADDRCONFIG); + die "Unresolvable [$host]:$port: $res1[0]" if @res1 < 5; + while (@res1 >= 5) { + my($afam, $socktype, $proto, $saddr, $canonname); + ($afam, $socktype, $proto, $saddr, $canonname, @res1) = @res1; + my @res2 = getnameinfo($saddr, NI_NUMERICHOST | NI_NUMERICSERV); + die "getnameinfo failed on [$host]:$port: $res2[0]" if @res2 < 2; + my($hostip,$portnum) = @res2; + $server->log(4,"Resolved [$host]:$port -> [$hostip]:$portnum, AF $afam"); + push(@bind_tuples, [$afam,$hostip,$portnum]); + } + } + + my @sockets_list; + ### create a socket for each specified bind address and family + foreach my $tuple ( @bind_tuples ){ + my $afamily; # address family (AF_* constants) + my $pfamily; # socket protocol family (PF_* constants) + ($afamily,$host,$port) = @$tuple; + my $sock; + if( $have_inet6 ){ + # Using IO::Socket::INET6 to handle both the IPv4 and IPv6. + # Constants PF_INET/PF_INET6 (protocol family) usually happen to have + # the same value as AF_INET/AF_INET6 (address family) constants. + # Still, better safe than sorry: + if ( $afamily == AF_INET ) { + $pfamily = PF_INET; + } elsif ( $afamily == AF_INET6 ) { + $pfamily = PF_INET6; + } else { + $pfamily = $afamily; + } + $server->log(3,"Using IO::Socket::INET6 for [$host]:$port, PF $pfamily"); + $sock = IO::Socket::INET6->new(Domain => $pfamily); # inet or inet6 + }else{ + $pfamily = PF_INET; + $server->log(3,"Using IO::Socket::INET for [$host]:$port, PF $pfamily"); + $sock = IO::Socket::INET->new(); # inet socket (IPv4 only) + } + + if ($sock) { + bless $sock, $class; + + $sock->NS_host($host); + $sock->NS_port($port); + $sock->NS_proto('SSLEAY'); + $sock->NS_family($pfamily); # socket protocol family - for my $key (@ssl_args) { + for my $key (@ssl_args) { my $val = defined($prop->{$key}) ? $prop->{$key} : $server->can($key) ? $server->$key($host, $port, 'SSLEAY') : undef; $sock->$key($val); + } + push @sockets_list, $sock; } + } - return $sock; + ### returns any number of sockets, + ### one for each protocol family (PF_INET or PF_INET6) and each bind address + return !wantarray ? $sockets_list[0] : @sockets_list; } sub log_connect { - my $sock = shift; - my $server = shift; - my $host = $sock->NS_host; - my $port = $sock->NS_port; - my $proto = $sock->NS_proto; - $server->log(2,"Binding to $proto port $port on host $host\n"); + my $sock = shift; + my $server = shift; + my $host = $sock->NS_host; + my $port = $sock->NS_port; + my $proto = $sock->NS_proto; + my $pfamily = $sock->NS_family || 0; + $server->log(2,"Binding to $proto port $port on host $host, PF $pfamily\n"); } ###----------------------------------------------------------------### -sub connect { # connect the first time - my $sock = shift; - my $server = shift; - my $prop = $server->{'server'}; - - my $host = $sock->NS_host; - my $port = $sock->NS_port; - - my %args; - $args{'LocalPort'} = $port; - $args{'Proto'} = 'tcp'; - $args{'LocalAddr'} = $host if $host !~ /\*/; # * is all - $args{'Listen'} = $prop->{'listen'}; - $args{'Reuse'} = 1; - - $sock->SUPER::configure(\%args) || $server->fatal("Can't connect to SSL port $port on $host [$!]"); - $server->fatal("Bad sock [$!]!".caller()) if ! $sock; - - if ($port == 0 && ($port = $sock->sockport)) { - $sock->NS_port($port); - $server->log(2,"Bound to auto-assigned port $port"); - } - - $sock->bind_SSL($server); -} - -sub reconnect { # connect on a sig -HUP - my ($sock, $fd, $server) = @_; - my $resp = $sock->fdopen( $fd, 'w' ) || $server->fatal("Error opening to file descriptor ($fd) [$!]"); - $sock->bind_SSL($server); - return $resp; +### bind the first time +sub connect { + my $sock = shift; + my $server = shift; + my $prop = $server->{server}; + + my $host = $sock->NS_host; + my $port = $sock->NS_port; + my $pfamily = $sock->NS_family || 0; + + my %args; + $args{LocalPort} = $port; + $args{Proto} = 'tcp'; + $args{LocalAddr} = $host if $host !~ /\*/; # * is all + $args{Domain} = $pfamily if $have_inet6 && $pfamily; + $args{Listen} = $prop->{listen}; + $args{Reuse} = 1; + + $sock->SUPER::configure(\%args) + or $server->fatal("Can't bind to SSL port $port on $host [$!]"); + $server->fatal("Bad sock [$!]!".caller()) if !$sock; + + my $actual_port = $sock->sockport; + # $port may be a service name, compare as strings + if( $actual_port && (!defined $port || $actual_port ne $port) ){ + $sock->NS_port($actual_port); + if( $port =~ /^0*\z/ ){ + $server->log(2,"Bound to auto-assigned port $actual_port"); + }else{ + $server->log(3,"Bound to service \"$port\", port number $actual_port"); + } + } + + $sock->bind_SSL($server); +} + +### reassociate sockets with inherited file descriptors on a sig -HUP +sub reconnect { + my ($sock, $fd, $server) = @_; + + my $host = $sock->NS_host; + my $port = $sock->NS_port; + my $proto = $sock->NS_proto; + my $pfamily = $sock->NS_family || 0; + + $server->log(3,"Reassociating file descriptor $fd ". + "with socket $proto on [$host]:port, PF $pfamily\n"); + my $resp = $sock->fdopen( $fd, 'w' ) + or $server->fatal("Error opening to file descriptor ($fd) [$!]"); + $sock->bind_SSL($server); + return $resp; } sub bind_SSL { - my ($sock, $server) = @_; - my $ctx = Net::SSLeay::CTX_new(); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_new"); + my ($sock, $server) = @_; + my $ctx = Net::SSLeay::CTX_new(); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_new"); - Net::SSLeay::CTX_set_options($ctx, Net::SSLeay::OP_ALL()); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_set_options"); + Net::SSLeay::CTX_set_options($ctx, Net::SSLeay::OP_ALL()); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_set_options"); - # 0x1: SSL_MODE_ENABLE_PARTIAL_WRITE - # 0x10: SSL_MODE_RELEASE_BUFFERS (ignored before OpenSSL v1.0.0) - Net::SSLeay::CTX_set_mode($ctx, 0x11); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_set_mode"); - - # Load certificate. This will prompt for a password if necessary. - my $file_key = $sock->SSL_key_file || die "SSLeay missing SSL_key_file.\n"; - my $file_cert = $sock->SSL_cert_file || die "SSLeay missing SSL_cert_file.\n"; - Net::SSLeay::CTX_use_RSAPrivateKey_file($ctx, $file_key, Net::SSLeay::FILETYPE_PEM()); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_use_RSAPrivateKey_file"); - Net::SSLeay::CTX_use_certificate_file( $ctx, $file_cert, Net::SSLeay::FILETYPE_PEM()); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_use_certificate_file"); - $sock->SSLeay_context($ctx); + # 0x1: SSL_MODE_ENABLE_PARTIAL_WRITE + # 0x10: SSL_MODE_RELEASE_BUFFERS (ignored before OpenSSL v1.0.0) + Net::SSLeay::CTX_set_mode($ctx, 0x11); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_set_mode"); + + # Load certificate. This will prompt for a password if necessary. + my $file_key = $sock->SSL_key_file || die "SSLeay missing SSL_key_file.\n"; + my $file_cert = $sock->SSL_cert_file || die "SSLeay missing SSL_cert_file.\n"; + Net::SSLeay::CTX_use_RSAPrivateKey_file($ctx, $file_key, Net::SSLeay::FILETYPE_PEM()); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_use_RSAPrivateKey_file"); + Net::SSLeay::CTX_use_certificate_file( $ctx, $file_cert, Net::SSLeay::FILETYPE_PEM()); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_use_certificate_file"); + $sock->SSLeay_context($ctx); } sub close { - my $sock = shift; - if ($sock->SSLeay_is_client) { - Net::SSLeay::free($sock->SSLeay); - } else { - Net::SSLeay::CTX_free($sock->SSLeay_context); - } - $sock->SSLeay_check_fatal("SSLeay close free"); - return $sock->SUPER::close(@_); + my $sock = shift; + if ($sock->SSLeay_is_client) { + Net::SSLeay::free($sock->SSLeay); + } else { + Net::SSLeay::CTX_free($sock->SSLeay_context); + } + $sock->SSLeay_check_fatal("SSLeay close free"); + return $sock->SUPER::close(@_); } sub accept { - my $sock = shift; - my $client = $sock->SUPER::accept; - if (defined $client) { - $client->NS_proto($sock->NS_proto); - $client->SSLeay_context($sock->SSLeay_context); - $client->SSLeay_is_client(1); - } + my $sock = shift; + my $client = $sock->SUPER::accept; + if (defined $client) { + $client->NS_proto( $sock->NS_proto ); + $client->NS_family( $sock->NS_family ); + $client->NS_host( $sock->NS_host ); + $client->NS_port( $sock->NS_port ); + $client->SSLeay_context( $sock->SSLeay_context ); + $client->SSLeay_is_client(1); + } - return $client; + return $client; } sub SSLeay { @@ -280,6 +378,17 @@ return length $read; } +sub sysread { + my ($client, $buf, $size, $offset) = @_; + warn "sysread is not supported by Net::Server::Proto::SSLEAY"; + # not quite right, usable only for testing: + my ($ok, $read) = $client->read_until($size, $/, 1); + substr($_[1], $offset || 0, defined($buf) ? length($buf) : 0, $read); + # should return the number of bytes actually read, 0 at end of file, or + # undef if there was an error (in the latter case $! should also be set) + return length $read; +} + sub getline { my $client = shift; my ($ok, $line) = $client->read_until($client->SSL_max_getline_length, $/); @@ -330,20 +439,24 @@ $client->print($buf); } -sub sysread { die "sysread is not supported by Net::Server::Proto::SSLEAY" } sub syswrite { die "syswrite is not supported by Net::Server::Proto::SSLEAY" } ###----------------------------------------------------------------### sub hup_string { my $sock = shift; - return join "|", map{$sock->$_()} qw(NS_host NS_port NS_proto); + return join("|", + $sock->NS_host, + $sock->NS_port, + $sock->NS_proto, + !$have_inet6 || !$sock->NS_family ? () : $sock->NS_family, + ); } sub show { my $sock = shift; my $t = "Ref = \"" .ref($sock) . "\"\n"; - foreach my $prop ( qw(NS_proto NS_port NS_host SSLeay_context SSLeay_is_client) ){ + foreach my $prop ( qw(NS_proto NS_port NS_host NS_family SSLeay_context SSLeay_is_client) ){ $t .= " $prop = \"" .$sock->$prop()."\"\n"; } return $t; @@ -353,7 +466,7 @@ my $sock = shift; my $prop = $AUTOLOAD =~ /::([^:]+)$/ ? $1 : die "Missing property in AUTOLOAD."; die "Unknown method or property [$prop]" - if $prop !~ /^(NS_proto|NS_port|NS_host|SSLeay_context|SSLeay_is_client|SSL_\w+)$/; + if $prop !~ /^(NS_proto|NS_port|NS_host|NS_family|SSLeay_context|SSLeay_is_client|SSL_\w+)$/; no strict 'refs'; *{__PACKAGE__."::${prop}"} = sub { --- Net-Server-0.99/lib/Net/Server/Proto/SSL.pm.orig 2010-05-04 20:13:03.000000000 -0700 +++ Net-Server-0.99/lib/Net/Server/Proto/SSL.pm 2011-08-01 11:08:50.503627241 -0700 @@ -22,14 +22,47 @@ package Net::Server::Proto::SSL; use strict; -use vars qw($VERSION $AUTOLOAD @ISA); -use Net::Server::Proto::TCP (); -eval { require IO::Socket::SSL; }; -$@ && warn "Module IO::Socket::SSL is required for SSL."; +use vars qw($VERSION $AUTOLOAD @ISA $have_inet6 $io_socket_module); +use IO::Socket; + +BEGIN { + eval { + require Socket6; import Socket6; + require IO::Socket::INET6; + $io_socket_module = 'IO::Socket::INET6'; + $have_inet6 = 1; + } or do { + require IO::Socket::INET; + $io_socket_module = 'IO::Socket::INET'; + }; + @ISA = ( $io_socket_module ); +} + +eval { + require IO::Socket::SSL; import IO::Socket::SSL; + # we could add IO::Socket::SSL to a local copy of @ISA just before calling + # start_SSL and do away with the $io_socket_module trick later, but this + # causes perl 5.12.2 to crash, so do it the way it likes it + unshift(@ISA, qw(IO::Socket::SSL)); 1; +} or do { + warn "Module IO::Socket::SSL is required for SSL: $@"; +}; $VERSION = $Net::Server::VERSION; # done until separated -@ISA = qw(IO::Socket::SSL); +# additional protocol specific arguments +my @ssl_args = qw( + SSL_use_cert + SSL_verify_mode + SSL_key_file + SSL_cert_file + SSL_ca_path + SSL_ca_file + SSL_cipher_list + SSL_passwd_cb + SSL_max_getline_length + SSL_error_callback +); sub object { my $type = shift; @@ -39,11 +72,16 @@ my $prop = $server->{server}; my $host; - ### allow for things like "domain.com:80" - if( $port =~ m/^([\w\.\-\*\/]+):(\w+)$/ ){ + local($1,$2); + ### allow for things like "[::1]:80" or "[host.example.com]:80" + if( $port =~ m/^\[([^\]]*)\]:(\w+)$/ ){ ($host,$port) = ($1,$2); - ### allow for things like "80" + ### allow for things like "host.example.com:80" + }elsif( $port =~ m/^([\w\.\-\*\/]+):(\w+)$/ ){ + ($host,$port) = ($1,$2); + + ### allow for things like "80" or "http" }elsif( $port =~ /^(\w+)$/ ){ ($host,$port) = ($default_host,$1); @@ -52,98 +90,167 @@ $server->fatal("Undeterminate port \"$port\" under ".__PACKAGE__); } - # read any additional protocol specific arguments - my @ssl_args = qw( - SSL_server - SSL_use_cert - SSL_verify_mode - SSL_key_file - SSL_cert_file - SSL_ca_path - SSL_ca_file - SSL_cipher_list - SSL_passwd_cb - SSL_max_getline_length - ); - my %args; - $args{$_} = \$prop->{$_} for @ssl_args; - $server->configure(\%args); - - my $sock = $class->new; - $sock->NS_host($host); - $sock->NS_port($port); - $sock->NS_proto('SSL'); + ### collect bind addresses along with their address family for all hosts + my @bind_tuples; + if( $host =~ /^\d{1,3}(?:\.\d{1,3}){3}\z/ ){ + push(@bind_tuples, [AF_INET,$host,$port]); + }elsif( $host =~ /:/ ){ + die "No IO::Socket::INET6, cannot bind to [$host]:$port" if !$have_inet6; + push(@bind_tuples, [AF_INET6,$host,$port]); + }elsif( !$have_inet6 ){ + push(@bind_tuples, [AF_INET,$host,$port]); + }elsif( $have_inet6 && $host =~ /\*/ ){ + push(@bind_tuples, [AF_INET6,$host,$port], [AF_INET,$host,$port]); + }else{ # we do have IO::Socket::INET6, it handles inet6 as well as inet + # obtain a list of IP addresses for $host, resolve port name + my @res1 = getaddrinfo($host, $port, AF_UNSPEC, SOCK_STREAM, 0, + AI_PASSIVE|AI_ADDRCONFIG); + die "Unresolvable [$host]:$port: $res1[0]" if @res1 < 5; + while (@res1 >= 5) { + my($afam, $socktype, $proto, $saddr, $canonname); + ($afam, $socktype, $proto, $saddr, $canonname, @res1) = @res1; + my @res2 = getnameinfo($saddr, NI_NUMERICHOST | NI_NUMERICSERV); + die "getnameinfo failed on [$host]:$port: $res2[0]" if @res2 < 2; + my($hostip,$portnum) = @res2; + $server->log(4,"Resolved [$host]:$port -> [$hostip]:$portnum, AF $afam"); + push(@bind_tuples, [$afam,$hostip,$portnum]); + } + } - for my $key (@ssl_args) { - my $val = defined($prop->{$key}) ? $prop->{$key} : $server->can($key) ? $server->$key($host, $port, 'SSL') : undef; - $sock->$key($val); + my @sockets_list; + ### create a socket for each specified bind address and family + foreach my $tuple ( @bind_tuples ){ + my $afamily; # address family (AF_* constants) + my $pfamily; # socket protocol family (PF_* constants) + ($afamily,$host,$port) = @$tuple; + my $sock; + if( $have_inet6 ){ + # Using IO::Socket::INET6 to handle both the IPv4 and IPv6. + # Constants PF_INET/PF_INET6 (protocol family) usually happen to have + # the same value as AF_INET/AF_INET6 (address family) constants. + # Still, better safe than sorry: + if ( $afamily == AF_INET ) { + $pfamily = PF_INET; + } elsif ( $afamily == AF_INET6 ) { + $pfamily = PF_INET6; + } else { + $pfamily = $afamily; + } + $server->log(3,"Using IO::Socket::INET6 for [$host]:$port, PF $pfamily"); + $sock = IO::Socket::INET6->new(Domain => $pfamily); # inet or inet6 + }else{ + $pfamily = PF_INET; + $server->log(3,"Using IO::Socket::INET for [$host]:$port, PF $pfamily"); + $sock = IO::Socket::INET->new(); # inet socket (IPv4 only) + } + + if ($sock) { + ### create the handle under this package + bless $sock, $class; + + $sock->NS_host($host); + $sock->NS_port($port); + $sock->NS_proto('SSL'); + $sock->NS_family($pfamily); # socket protocol family + + for my $key (@ssl_args) { + my $val = defined($prop->{$key}) ? $prop->{$key} : $server->can($key) ? $server->$key($host, $port, 'SSL') : undef; + $sock->$key($val); + } + push @sockets_list, $sock; + } } - return $sock; + ### returns any number of sockets, + ### one for each protocol family (PF_INET or PF_INET6) and each bind address + return !wantarray ? $sockets_list[0] : @sockets_list; } sub log_connect { my $sock = shift; - my $server = shift; - my $host = $sock->NS_host; - my $port = $sock->NS_port; - my $proto = $sock->NS_proto; - $server->log(2,"Binding to $proto port $port on host $host\n"); + my $server = shift; + my $host = $sock->NS_host; + my $port = $sock->NS_port; + my $proto = $sock->NS_proto; + my $pfamily = $sock->NS_family || 0; + $server->log(2,"Binding to $proto port $port on host $host, PF $pfamily\n"); } -### connect the first time +### bind the first time sub connect { - my $sock = shift; - my $server = shift; - my $prop = $server->{server}; - - my $host = $sock->NS_host; - my $port = $sock->NS_port; - - my %args = (); - $args{LocalPort} = $port; # what port to bind on - $args{Proto} = 'tcp'; # what procol to use - $args{LocalAddr} = $host if $host !~ /\*/; # what local address (* is all) - $args{Listen} = $prop->{listen}; # how many connections for kernel to queue - $args{Reuse} = 1; # allow us to rebind the port on a restart - - ### add in any ssl specific properties - foreach ( keys %$prop ){ - next unless /^SSL_/; - $args{$_} = $prop->{$_}; - } - - ### connect to the sock - $sock->SUPER::configure(\%args) - or $server->fatal("Can't connect to SSL port $port on $host [$!]"); - - $server->fatal("Back sock [$!]!".caller()) - unless $sock; + my $sock = shift; + my $server = shift; + my $prop = $server->{server}; + + my $host = $sock->NS_host; + my $port = $sock->NS_port; + my $pfamily = $sock->NS_family || 0; + my %args; + $args{LocalPort} = $port; + $args{Proto} = 'tcp'; + $args{LocalAddr} = $host if $host !~ /\*/; # * is all + $args{Domain} = $pfamily if $have_inet6 && $pfamily; + $args{Listen} = $prop->{listen}; + $args{Reuse} = 1; + + ### bind to the sock using the underlying IO Socket module + { local @ISA = ( $io_socket_module ); + $sock->SUPER::configure(\%args) + or $server->fatal("Can't bind to SSL port $port on $host [$!]"); + $server->fatal("Bad sock [$!]!".caller()) if !$sock; + } } ### connect on a sig -HUP sub reconnect { - my $sock = shift; - my $fd = shift; - my $server = shift; - - $sock->fdopen( $fd, 'w' ) - or $server->fatal("Error opening to file descriptor ($fd) [$!]"); + my ($sock, $fd, $server) = @_; + my $host = $sock->NS_host; + my $port = $sock->NS_port; + my $proto = $sock->NS_proto; + my $pfamily = $sock->NS_family || 0; + + $server->log(3,"Reassociating file descriptor $fd ". + "with socket $proto on [$host]:port, PF $pfamily\n"); + + ### fdopen cannot be used on a IO::Socket::SSL object!!! + ### use fdopen() from the underlying IO Socket package + { local @ISA = ( $io_socket_module ); + $sock->fdopen( $fd, 'w' ) + or $server->fatal("Error opening to file descriptor ($fd) [$!]"); + } } ### allow for endowing the child sub accept { my $sock = shift; - my $client = $sock->SUPER::accept(); + my $client; - ### pass items on - if( defined($client) ){ - bless $client, ref($sock); - $client->NS_proto( $sock->NS_proto ); + ### fdopen (in reconnect) cannot be used on an IO::Socket::SSL object, + ### which is why we accept first and upgrade to SSL later + + ### accept() with the underlying IO Socket package, upgrade to SSL later + { local @ISA = ( $io_socket_module ); + $client = $sock->SUPER::accept(); } + if( defined $client ){ + $client->NS_proto( $sock->NS_proto ); + $client->NS_family( $sock->NS_family ); + $client->NS_host( $sock->NS_host ); + $client->NS_port( $sock->NS_port ); + + ### must bless the upgraded SSL object into our package + ### to be able to reference its NS_* properties later + __PACKAGE__->start_SSL($client, + SSL_error_trap => sub { my($sock,$msg) = @_; + die "Error upgrading socket to SSL: $msg" }, + SSL_server => 1, + map { defined $sock->$_() ? ($_,$sock->$_()) : () } @ssl_args, + ) or die "Upgrading socket to SSL failed: ".IO::Socket::SSL::errstr(); + + } return $client; } @@ -157,6 +264,7 @@ $sock->NS_host, $sock->NS_port, $sock->NS_proto, + !$have_inet6 || !$sock->NS_family ? () : $sock->NS_family, ); } @@ -164,7 +272,7 @@ sub show { my $sock = shift; my $t = "Ref = \"" .ref($sock) . "\"\n"; - foreach my $prop ( qw(NS_proto NS_port NS_host) ){ + foreach my $prop ( qw(NS_proto NS_port NS_host NS_family) ){ $t .= " $prop = \"" .$sock->$prop()."\"\n"; } return $t; @@ -179,7 +287,7 @@ die "No property called."; } - if( $prop =~ /^(NS_proto|NS_port|NS_host)$/ ){ + if( $prop =~ /^(NS_proto|NS_port|NS_host|NS_family|SSL_\w+)$/ ){ no strict 'refs'; * { __PACKAGE__ ."::". $prop } = sub { my $sock = shift; @@ -215,8 +323,8 @@ =head1 DESCRIPTION This original SSL module was experimental. It has been superceeded by -Net::Server::Proto::SSLEAY If anybody has any successes or ideas for -improvment under SSL, please email . +Net::Server::Proto::SSLEAY. If anybody has any successes or ideas for +improvement under SSL, please email . Protocol module for Net::Server. This module implements a secure socket layer over tcp (also known as SSL). --- Net-Server-0.99/lib/Net/Server/Proto/TCP.pm.orig 2011-08-01 10:24:36.463625993 -0700 +++ Net-Server-0.99/lib/Net/Server/Proto/TCP.pm 2011-08-01 11:08:27.283623011 -0700 @@ -22,11 +22,22 @@ package Net::Server::Proto::TCP; use strict; -use vars qw($VERSION $AUTOLOAD @ISA); -use IO::Socket (); +use vars qw($VERSION $AUTOLOAD @ISA $have_inet6); +use IO::Socket; + +BEGIN { + eval { + require Socket6; import Socket6; + require IO::Socket::INET6; + @ISA = qw(IO::Socket::INET6); + $have_inet6 = 1; + } or do { + require IO::Socket::INET; + @ISA = qw(IO::Socket::INET); + }; +} $VERSION = $Net::Server::VERSION; # done until separated -@ISA = qw(IO::Socket::INET); sub object { my $type = shift; @@ -35,11 +46,16 @@ my ($default_host,$port,$server) = @_; my $host; - ### allow for things like "domain.com:80" - if( $port =~ m/^([\w\.\-\*\/]+):(\w+)$/ ){ + local($1,$2); + ### allow for things like "[::1]:80" or "[host.example.com]:80" + if( $port =~ m/^\[([^\]]*)\]:(\w+)$/ ){ ($host,$port) = ($1,$2); - ### allow for things like "80" + ### allow for things like "host.example.com:80" + }elsif( $port =~ m/^([\w\.\-\*\/]+):(\w+)$/ ){ + ($host,$port) = ($1,$2); + + ### allow for things like "80" or "http" }elsif( $port =~ /^(\w+)$/ ){ ($host,$port) = ($default_host,$1); @@ -48,65 +64,137 @@ $server->fatal("Undeterminate port \"$port\" under ".__PACKAGE__); } - ### create the handle under this package - my $sock = $class->SUPER::new(); + ### collect bind addresses along with their address family for all hosts + my @bind_tuples; + if( $host =~ /^\d{1,3}(?:\.\d{1,3}){3}\z/ ){ + push(@bind_tuples, [AF_INET,$host,$port]); + }elsif( $host =~ /:/ ){ + die "No IO::Socket::INET6, cannot bind to [$host]:$port" if !$have_inet6; + push(@bind_tuples, [AF_INET6,$host,$port]); + }elsif( !$have_inet6 ){ + push(@bind_tuples, [AF_INET,$host,$port]); + }elsif( $have_inet6 && $host =~ /\*/ ){ + push(@bind_tuples, [AF_INET6,$host,$port], [AF_INET,$host,$port]); + }else{ # we do have IO::Socket::INET6, it handles inet6 as well as inet + # obtain a list of IP addresses for $host, resolve port name + my @res1 = getaddrinfo($host, $port, AF_UNSPEC, SOCK_STREAM, 0, + AI_PASSIVE|AI_ADDRCONFIG); + die "Unresolvable [$host]:$port: $res1[0]" if @res1 < 5; + while (@res1 >= 5) { + my($afam, $socktype, $proto, $saddr, $canonname); + ($afam, $socktype, $proto, $saddr, $canonname, @res1) = @res1; + my @res2 = getnameinfo($saddr, NI_NUMERICHOST | NI_NUMERICSERV); + die "getnameinfo failed on [$host]:$port: $res2[0]" if @res2 < 2; + my($hostip,$portnum) = @res2; + $server->log(4,"Resolved [$host]:$port -> [$hostip]:$portnum, AF $afam"); + push(@bind_tuples, [$afam,$hostip,$portnum]); + } + } - ### store some properties - $sock->NS_host($host); - $sock->NS_port($port); - $sock->NS_proto('TCP'); + my @sockets_list; + ### create a socket for each specified bind address and family + foreach my $tuple ( @bind_tuples ){ + my $afamily; # address family (AF_* constants) + my $pfamily; # socket protocol family (PF_* constants) + ($afamily,$host,$port) = @$tuple; + my $sock; + if( $have_inet6 ){ + # Using IO::Socket::INET6 to handle both the IPv4 and IPv6. + # Constants PF_INET/PF_INET6 (protocol family) usually happen to have + # the same value as AF_INET/AF_INET6 (address family) constants. + # Still, better safe than sorry: + if ( $afamily == AF_INET ) { + $pfamily = PF_INET; + } elsif ( $afamily == AF_INET6 ) { + $pfamily = PF_INET6; + } else { + $pfamily = $afamily; + } + $server->log(3,"Using IO::Socket::INET6 for [$host]:$port, PF $pfamily"); + $sock = IO::Socket::INET6->new(Domain => $pfamily); # inet or inet6 + }else{ + $pfamily = PF_INET; + $server->log(3,"Using IO::Socket::INET for [$host]:$port, PF $pfamily"); + $sock = IO::Socket::INET->new(); # inet socket (IPv4 only) + } - return $sock; + if ($sock) { + ### create the handle under this package + bless $sock, $class; + + ### store some properties + $sock->NS_host($host); + $sock->NS_port($port); + $sock->NS_proto('TCP'); + $sock->NS_family($pfamily); # socket protocol family + push @sockets_list, $sock; + } + } + + ### returns any number of sockets, + ### one for each protocol family (PF_INET or PF_INET6) and each bind address + return !wantarray ? $sockets_list[0] : @sockets_list; } sub log_connect { my $sock = shift; - my $server = shift; - my $host = $sock->NS_host; - my $port = $sock->NS_port; - my $proto = $sock->NS_proto; - $server->log(2,"Binding to $proto port $port on host $host\n"); + my $server = shift; + my $host = $sock->NS_host; + my $port = $sock->NS_port; + my $proto = $sock->NS_proto; + my $pfamily = $sock->NS_family || 0; + $server->log(2,"Binding to $proto port $port on host $host, PF $pfamily\n"); } -### connect the first time +### bind the first time sub connect { - my $sock = shift; - my $server = shift; - my $prop = $server->{server}; + my $sock = shift; + my $server = shift; + my $prop = $server->{server}; + + my $host = $sock->NS_host; + my $port = $sock->NS_port; + my $pfamily = $sock->NS_family || 0; - my $host = $sock->NS_host; - my $port = $sock->NS_port; - - my %args = (); + my %args; $args{LocalPort} = $port; # what port to bind on $args{Proto} = 'tcp'; # what procol to use $args{LocalAddr} = $host if $host !~ /\*/; # what local address (* is all) + $args{Domain} = $pfamily if $have_inet6 && $pfamily; $args{Listen} = $prop->{listen}; # how many connections for kernel to queue $args{Reuse} = 1; # allow us to rebind the port on a restart - ### connect to the sock + ### bind the sock $sock->SUPER::configure(\%args) - or $server->fatal("Can't connect to TCP port $port on $host [$!]"); + or $server->fatal("Can't bind to TCP port $port on $host [$!]"); + $server->fatal("Bad sock [$!]!".caller()) if !$sock; - if ($port == 0 && ($port = $sock->sockport)) { - $sock->NS_port($port); - $server->log(2,"Bound to auto-assigned port $port"); + my $actual_port = $sock->sockport; + # $port may be a service name, compare as strings + if( $actual_port && (!defined $port || $actual_port ne $port) ){ + $sock->NS_port($actual_port); + if( $port =~ /^0*\z/ ){ + $server->log(2,"Bound to auto-assigned port $actual_port"); + }else{ + $server->log(3,"Bound to service \"$port\", port number $actual_port"); + } } - $server->fatal("Back sock [$!]!".caller()) - unless $sock; - } -### connect on a sig -HUP +### reassociate sockets with inherited file descriptors on a sig -HUP sub reconnect { - my $sock = shift; - my $fd = shift; - my $server = shift; + my ($sock, $fd, $server) = @_; + my $host = $sock->NS_host; + my $port = $sock->NS_port; + my $proto = $sock->NS_proto; + my $pfamily = $sock->NS_family || 0; + + $server->log(3,"Reassociating file descriptor $fd ". + "with socket $proto on [$host]:port, PF $pfamily\n"); $sock->fdopen( $fd, 'w' ) or $server->fatal("Error opening to file descriptor ($fd) [$!]"); - } ### allow for endowing the child @@ -115,8 +203,11 @@ my $client = $sock->SUPER::accept(); ### pass items on - if( defined($client) ){ + if( defined $client ){ $client->NS_proto( $sock->NS_proto ); + $client->NS_family( $sock->NS_family ); + $client->NS_host( $sock->NS_host ); + $client->NS_port( $sock->NS_port ); } return $client; @@ -156,6 +247,7 @@ $sock->NS_host, $sock->NS_port, $sock->NS_proto, + !$have_inet6 || !$sock->NS_family ? () : $sock->NS_family, ); } @@ -163,7 +255,7 @@ sub show { my $sock = shift; my $t = "Ref = \"" .ref($sock) . "\"\n"; - foreach my $prop ( qw(NS_proto NS_port NS_host) ){ + foreach my $prop ( qw(NS_proto NS_port NS_host NS_family) ){ $t .= " $prop = \"" .$sock->$prop()."\"\n"; } return $t; @@ -178,7 +270,7 @@ die "No property called."; } - if( $prop =~ /^(NS_proto|NS_port|NS_host|NS_recv_len|NS_recv_flags)$/ ){ + if( $prop =~ /^(NS_proto|NS_port|NS_host|NS_family|NS_recv_len|NS_recv_flags)$/ ){ no strict 'refs'; * { __PACKAGE__ ."::". $prop } = sub { my $sock = shift;