Attachment #300019 for bug #370355




  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};

    && $prop->{udp_broadcast};

  my @sockets_list = $class->SUPER::object( @_ );
  $sock->NS_recv_flags( $prop->{udp_recv_flags} );

  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;
}


### 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 $pfamily = $sock->NS_family || 0;

  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};

  ### bind to the sock
  $sock->SUPER::configure(\%args)
    or $server->fatal("Can't bind to UDP port $port on $host [$!]");

  $server->fatal("Bad sock [$!]!".caller())
    unless $sock;


Lines 69-73 Link Here

(-)Net-Server-0.99/lib/Net/Server/Proto.pm (-7 / +22 lines)
69		69
70		70
71	### return an object of that procol class	71	### returns any number of objects (socket),
		72	### one for each protocol family (PF_INET or PF_INET6) and each bind address
72	return $proto_class->object($default_host,$port,$server);	73	return $proto_class->object($default_host,$port,$server);
73		74
Lines 84-88 Link Here
84	=head1 SYNOPSIS	85	=head1 SYNOPSIS
85		86
86	# Net::Server::Proto and its accompianying modules are not	87	# Net::Server::Proto and its accompanying modules are not
87	# intended to be used outside the scope of Net::Server.	88	# intended to be used outside the scope of Net::Server.
88		89
Lines 103-107 Link Here
103		104
104	### Net::Server::Proto will attempt to interface with	105	### Net::Server::Proto will attempt to interface with
105	### sub modules named simillar to Net::Server::Proto::TCP	106	### sub modules named similar to Net::Server::Proto::TCP
106	### Individual sub modules will be loaded by	107	### Individual sub modules will be loaded by
107	### Net::Server::Proto as they are needed.	108	### Net::Server::Proto as they are needed.
Lines 225-232 Link Here
225	The port is the most important argument passed to the sub	226	The port is the most important argument passed to the sub
226	module classes and to Net::Server::Proto itself. For tcp,	227	module classes and to Net::Server::Proto itself. For tcp,
227	udp, and ssl style ports, the form is generally	228	udp, and ssl style ports, the form is generally host:port/protocol
228	host:port/protocol, host\|port\|protocol, host/port, or port.	229	or [host]:port/protocol, host\|port\|protocol, host/port, or port.
229	For unix the form is generally socket_file\|type\|unix or	230	If I<host> is a numerical IPv6 address it must be enclosed in square
230	socket_file.	231	brackets to avoid ambiguity in parsing a port number, e.g.: "[::1]:80".
		232	For unix sockets the form is generally socket_file\|type\|unix or socket_file.
		233
		234	A socket protocol family PF_INET or PF_INET6 is derived from a specified
		235	address family of the binding address. A PF_INET socket can only accept
		236	IPv4 connections. A PF_INET6 socket accepts IPv6 connections, but may also
		237	accept IPv4 connections, depending on OS and its settings. For example,
		238	on FreeBSD systems setting a sysctl net.inet6.ip6.v6only to 0 will allow
		239	IPv4 connections to a PF_INET6 socket.
		240
		241	The Net::Server::Proto::object method returns a list of objects corresponding
		242	to created sockets. For Unix and INET sockets the list typically contains
		243	just one element, but may return multiple objects when multiple protocol
		244	families are allowed or when a host name resolves to multiple local
		245	binding addresses.
231		246
232	You can see what Net::Server::Proto parsed out by looking at	247	You can see what Net::Server::Proto parsed out by looking at

Lines 26-30 Link Here

(-)Net-Server-0.99/lib/Net/Server.pm (-32 / +58 lines)
26	use strict;	26	use strict;
27	use vars qw($VERSION);	27	use vars qw($VERSION);
28	use Socket qw(inet_aton inet_ntoa AF_INET AF_UNIX SOCK_DGRAM SOCK_STREAM);	28	use Socket qw(AF_INET AF_UNIX SOCK_DGRAM SOCK_STREAM);
29	use IO::Socket ();	29	use IO::Socket ();
30	use IO::Select ();	30	use IO::Select ();
Lines 356-361 Link Here
356	push @{ $prop->{host} }, (($prop->{host}->[-1]) x (@{ $prop->{port} } - @{ $prop->{host}})); # augment hosts with as many as port	356	push @{ $prop->{host} }, (($prop->{host}->[-1]) x (@{ $prop->{port} } - @{ $prop->{host}})); # augment hosts with as many as port
357	foreach my $host (@{ $prop->{host} }) {	357	foreach my $host (@{ $prop->{host} }) {
358	$host = '*' if ! defined $host \|\| ! length $host;;	358	local $1;
359	$host = ($host =~ /^([\w\.\-\*\/]+)$/) ? $1 : $self->fatal("Unsecure host \"$host\"");	359	if (!defined $host \|\| $host eq '' \|\| $host eq '*') {
		360	$host = '*';
		361	} elsif ($host =~ /^\[([\w\/.:-]+)\]$/ \|\| $host =~ /^([\w\/.:-]+)$/) {
		362	$host = $1;
		363	} else {
		364	$self->fatal("Unsecure host \"$host\"");
		365	}
360	}	366	}
361		367
Lines 377-386 Link Here
377	my $host = $prop->{host}->[$i];	383	my $host = $prop->{host}->[$i];
378	my $proto = $prop->{proto}->[$i];	384	my $proto = $prop->{proto}->[$i];
379	if ($port ne 0 && $bound{"$host/$port/$proto"}++) {	385	if ($port ne "0" && $bound{"$host/$port/$proto"}++) {
380	$self->log(2, "Duplicate configuration (".(uc $proto)." port $port on host $host - skipping");	386	$self->log(2, "Duplicate configuration (".(uc $proto)." port $port on host $host - skipping");
381	next;	387	next;
382	}	388	}
383	my $obj = $self->proto_object($host, $port, $proto) \|\| next;	389	my @obj_list = $self->proto_object($host, $port, $proto);
384	push @{ $prop->{sock} }, $obj;	390	for my $obj (@obj_list) {
		391	push @{ $prop->{sock} }, $obj if $obj;
		392	}
385	}	393	}
386	if (! @{ $prop->{sock} }) {	394	if (! @{ $prop->{sock} }) {
Lines 397-401 Link Here
397	}	405	}
398		406
399	### method for invoking procol specific bindings	407	### method for invoking procol specific bindings;
		408	### returns any number of sockets,
		409	### one for each protocol family (PF_INET or PF_INET6) and each bind address
400	sub proto_object {	410	sub proto_object {
401	my $self = shift;	411	my $self = shift;
Lines 440-445 Link Here
440	}	450	}
441		451
442	### if more than one port we'll need to select on it	452	### if more than one socket we'll need to select on it;
443	if( @{ $prop->{port} } > 1 \|\| $prop->{multi_port} ){	453	### note there may be more than one socket per port,
		454	### one for each protocol family (PF_INET and PF_INET6)
		455	if( @{ $prop->{sock} } > 1 \|\| $prop->{multi_port} ){
444	$prop->{multi_port} = 1;	456	$prop->{multi_port} = 1;
445	$prop->{select} = IO::Select->new();	457	$prop->{select} = IO::Select->new();
Lines 748-752 Link Here
748	return;	760	return;
749	} elsif ($self->isa('Net::Server::INET')) {	761	} elsif ($self->isa('Net::Server::INET')) {
750	$prop->{sockaddr} = $ENV{'REMOTE_HOST'} \|\| '0.0.0.0';	762	# since we do not know a socket protocol family, we are unable
		763	# to choose between '0.0.0.0' and '::' as an unspecified address
		764	$prop->{sockaddr} = $ENV{'REMOTE_HOST'} \|\| '0.0.0.0'; # or is is a '::' ?
751	$prop->{peeraddr} = '0.0.0.0';	765	$prop->{peeraddr} = '0.0.0.0';
752	$prop->{sockhost} = $prop->{peerhost} = 'inetd.server';	766	$prop->{sockhost} = $prop->{peerhost} = 'inetd.server';
Lines 756-767 Link Here
756		770
757	### read information about this connection	771	### read information about this connection
758	my $sockname = getsockname( $sock );	772	my $sockname = $sock->sockname;
759	if( $sockname ){	773	if( $sockname ){
760	($prop->{sockport}, $prop->{sockaddr})	774	$prop->{sockaddr} = $sock->sockhost;
761	= Socket::unpack_sockaddr_in( $sockname );	775	$prop->{sockport} = $sock->sockport;
762	$prop->{sockaddr} = inet_ntoa( $prop->{sockaddr} );
763
764	}else{	776	}else{
765	### does this only happen from command line?	777	### does this only happen from command line?
		778	# since we do not know a socket protocol family, we are unable
		779	# to choose between '0.0.0.0' and '::' as an unspecified address
766	$prop->{sockaddr} = $ENV{'REMOTE_HOST'} \|\| '0.0.0.0';	780	$prop->{sockaddr} = $ENV{'REMOTE_HOST'} \|\| '0.0.0.0';
767	$prop->{sockhost} = 'inet.test';	781	$prop->{sockhost} = 'inet.test';
Lines 773-788 Link Here
773	if( $prop->{udp_true} ){	787	if( $prop->{udp_true} ){
774	$proto_type = 'UDP';	788	$proto_type = 'UDP';
775	($prop->{peerport} ,$prop->{peeraddr})	789	if ($sock->sockdomain == AF_INET) { ($prop->{peerport}, $prop->{peeraddrn}) = Socket::sockaddr_in($prop->{udp_peer});
776	= Socket::sockaddr_in( $prop->{udp_peer} );	790	} else { ($prop->{peerport}, $prop->{peeraddrn}) = Socket6::sockaddr_in6($prop->{udp_peer});
777	}elsif( $prop->{peername} = getpeername( $sock ) ){	791	}
778	($prop->{peerport}, $prop->{peeraddr})	792	$prop->{peeraddr} = Socket6->UNIVERSAL::can('inet_ntop')
779	= Socket::unpack_sockaddr_in( $prop->{peername} );	793	? Socket6::inet_ntop($sock->sockdomain, $prop->{peeraddrn})
780	}	794	: Socket::inet_ntoa( $prop->{peeraddrn} );
781		795	}elsif( $prop->{peername} = $sock->peername ){
782	if( $prop->{peername} \|\| $prop->{udp_true} ){	796	$prop->{peeraddrn} = $sock->peeraddr; # binary
783	$prop->{peeraddr} = inet_ntoa( $prop->{peeraddr} );	797	$prop->{peeraddr} = $sock->peerhost; # ascii
784		798	$prop->{peerport} = $sock->peerport;
785	if( defined $prop->{reverse_lookups} ){	799	}
786	$prop->{peerhost} = gethostbyaddr( inet_aton($prop->{peeraddr}), AF_INET );	800
		801	if( $prop->{peeraddrn} ){
		802	if( !defined $prop->{reverse_lookups} ){
		803	# no reverse DNS resolving
		804	}elsif( Socket6->UNIVERSAL::can('getnameinfo') ){
		805	my @res = Socket6::getnameinfo( $prop->{peeraddrn}, 0 );
		806	$prop->{peerhost} = $res[0] if @res > 1;
		807	}else{
		808	$prop->{peerhost} = gethostbyaddr( $prop->{peeraddrn}, AF_INET );
787	}	809	}
788	$prop->{peerhost} = '' unless defined $prop->{peerhost};	810	$prop->{peerhost} = '' unless defined $prop->{peerhost};
Lines 790-793 Link Here
790	}else{	812	}else{
791	### does this only happen from command line?	813	### does this only happen from command line?
		814	# since we do not know a socket protocol family, we are unable
		815	# to choose between '0.0.0.0' and '::' as an unspecified address
792	$prop->{peeraddr} = '0.0.0.0';	816	$prop->{peeraddr} = '0.0.0.0';
793	$prop->{peerhost} = 'inet.test';	817	$prop->{peerhost} = 'inet.test';
Lines 796-801 Link Here
796		820
797	$self->log(3,$self->log_time	821	$self->log(3,$self->log_time
798	." CONNECT $proto_type Peer: \"$prop->{peeraddr}:$prop->{peerport}\""	822	." CONNECT $proto_type Peer: \"[$prop->{peeraddr}]:$prop->{peerport}\""
799	." Local: \"$prop->{sockaddr}:$prop->{sockport}\"\n");	823	." Local: \"[$prop->{sockaddr}]:$prop->{sockport}\"\n");
800		824
801	}	825	}
Lines 1141-1149 Link Here
1141	foreach my $sock ( @{ $prop->{sock} } ){	1165	foreach my $sock ( @{ $prop->{sock} } ){
1142		1166
1143	### duplicate the sock	1167	### duplicate the socket descriptor
1144	my $fd = POSIX::dup($sock->fileno)	1168	my $fd = POSIX::dup($sock->fileno)
1145	or $self->fatal("Can't dup socket [$!]");	1169	or $self->fatal("Can't dup socket [$!]");
1146		1170
1147	### hold on to the socket copy until exec	1171	### hold on to the socket copy until exec;
		1172	### just temporary: any socket domain will do,
		1173	### forked process will decide to use IO::Socket::INET6 if necessary
1148	$prop->{_HUP}->[$i] = IO::Socket::INET->new;	1174	$prop->{_HUP}->[$i] = IO::Socket::INET->new;
1149	$prop->{_HUP}->[$i]->fdopen($fd, 'w')	1175	$prop->{_HUP}->[$i]->fdopen($fd, 'w')
Lines 1153-1157 Link Here
1153	$prop->{_HUP}->[$i]->fcntl( Fcntl::F_SETFD(), my $flags = "" );	1179	$prop->{_HUP}->[$i]->fcntl( Fcntl::F_SETFD(), my $flags = "" );
1154		1180
1155	### save host,port,proto, and file descriptor	1181	### save file descriptor and host\|port\|proto\|family
1156	push @fd, $fd .'\|'. $sock->hup_string;	1182	push @fd, $fd .'\|'. $sock->hup_string;
1157		1183




bound at server startup.  May be of the form
C<host:port/proto>, C<host:port>, C<port/proto>, or C<port>,
where I<host> represents a hostname residing on the local box,
where I<port> represents either the number of the port (eg. "80")
or the service designation (eg. "http"), and where I<proto>
represents the protocol to be used. See L<Net::Server::Proto>.

An explicit I<host> given in a port specification overrides
a default binding address (a C<host> setting, see below).
The I<host> part may be enclosed in square brackets, but when it is
a numerical IPv6 address it B<must> 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<socket_file|unix> or C<socket_file|type|unix> where type is SOCK_DGRAM
or SOCK_STREAM.  If the protocol is not specified, I<proto> will
default to the C<proto> specified in the arguments.  If C<proto> is not
specified there it will default to "tcp".  If I<host> is not
specified, I<host> will default to C<host> specified in the
arguments.  If C<host> 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<host>, either in the C<port> or in the C<host> 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

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.  The C<host> argument provides a default local host
address if the C<port> argument omits a host specification.
See L<Net::Server::Proto>. See L<IO::Socket>.  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




package Net::Server::Proto::SSLEAY;

use strict;
use vars qw($VERSION $AUTOLOAD @ISA $have_inet6);
use IO::Socket::INET;
use Fcntl ();
use Errno ();
use Socket ();
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);
  };
  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

# 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 ($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) {
        my $val = defined($prop->{$key}) ? $prop->{$key} : $server->can($key) ? $server->$key($host, $port, 'SSLEAY') : undef;
        $sock->$key($val);
      }
      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;
  my $pfamily = $sock->NS_family || 0;
  $server->log(2,"Binding to $proto port $port on host $host, PF $pfamily\n");
}

###----------------------------------------------------------------###

### 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");

  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);
}

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(@_);
}

sub accept {
  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;
}

sub SSLeay {

    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, $/);

    $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("|",
                $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 NS_family SSLeay_context SSLeay_is_client) ){
        $t .= "  $prop = \"" .$sock->$prop()."\"\n";
    }
    return $t;

    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|NS_family|SSLeay_context|SSLeay_is_client|SSL_\w+)$/;

    no strict 'refs';
    *{__PACKAGE__."::${prop}"} = sub {




package Net::Server::Proto::SSL;

use strict;
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;

  my $prop = $server->{server};
  my $host;

  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);


    $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) {
      ### 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;
    }
  }

  ### 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;
  my $pfamily = $sock->NS_family || 0;
  $server->log(2,"Binding to $proto port $port on host $host, PF $pfamily\n");
}

### 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;                  # 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 %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, $fd, $server) = @_;
  my $fd   = shift;
  my $server = shift;

  $sock->fdopen( $fd, 'w' )
    or $server->fatal("Error opening to file descriptor ($fd) [$!]");

  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;

  ### 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;
}


              $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 NS_family) ){
    $t .= "  $prop = \"" .$sock->$prop()."\"\n";
  }
  return $t;

    die "No property called.";
  }

  if( $prop =~ /^(NS_proto|NS_port|NS_host|NS_family|SSL_\w+)$/ ){
    no strict 'refs';
    * { __PACKAGE__ ."::". $prop } = sub {
      my $sock = shift;

=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
improvement under SSL, please email <paul@seamons.com>.

Protocol module for Net::Server.  This module implements a
secure socket layer over tcp (also known as SSL).




package Net::Server::Proto::TCP;

use strict;
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;

  my ($default_host,$port,$server) = @_;
  my $host;

  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);


    $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) {
      ### 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;
  my $pfamily = $sock->NS_family || 0;
  $server->log(2,"Binding to $proto port $port on host $host, PF $pfamily\n");
}

### 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;
  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{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

  ### bind the sock
  $sock->SUPER::configure(\%args)
    or $server->fatal("Can't bind to TCP 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");
    }
  }

  $server->fatal("Back sock [$!]!".caller())
    unless $sock;

}

### reassociate sockets with inherited file descriptors on a sig -HUP
sub reconnect {
  my ($sock, $fd, $server) = @_;
  my $fd   = 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(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

  my $client = $sock->SUPER::accept();

  ### pass items on
  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;

              $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 NS_family) ){
    $t .= "  $prop = \"" .$sock->$prop()."\"\n";
  }
  return $t;

    die "No property called.";
  }

  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;

Return to bug 370355

Lines 556-574 Link Here

(-)Net-Server-0.99/lib/Net/Server.pod (-13 / +42 lines)
556	bound at server startup. May be of the form	556	bound at server startup. May be of the form
557	C<host:port/proto>, C<host:port>, C<port/proto>, or C<port>,	557	C<host:port/proto>, C<host:port>, C<port/proto>, or C<port>,
558	where I<host> represents a hostname residing on the local	558	where I<host> represents a hostname residing on the local box,
559	box, where I<port> represents either the number of the port	559	where I<port> represents either the number of the port (eg. "80")
560	(eg. "80") or the service designation (eg. "http"), and	560	or the service designation (eg. "http"), and where I<proto>
561	where I<proto> represents the protocol to be used. See	561	represents the protocol to be used. See L<Net::Server::Proto>.
562	L<Net::Server::Proto>. If you are working with unix sockets,	562
563	you may also specify C<socket_file\|unix> or	563	An explicit I<host> given in a port specification overrides
564	C<socket_file\|type\|unix> where type is SOCK_DGRAM or	564	a default binding address (a C<host> setting, see below).
565	SOCK_STREAM. If the protocol is not specified, I<proto> will	565	The I<host> part may be enclosed in square brackets, but when it is
		566	a numerical IPv6 address it B<must> be enclosed in square brackets
		567	to avoid ambiguity in parsing a port number, e.g.: "[::1]:80".
		568
		569	If you are working with unix sockets, you may also specify
		570	C<socket_file\|unix> or C<socket_file\|type\|unix> where type is SOCK_DGRAM
		571	or SOCK_STREAM. If the protocol is not specified, I<proto> will
566	default to the C<proto> specified in the arguments. If C<proto> is not	572	default to the C<proto> specified in the arguments. If C<proto> is not
567	specified there it will default to "tcp". If I<host> is not	573	specified there it will default to "tcp". If I<host> is not
568	specified, I<host> will default to C<host> specified in the	574	specified, I<host> will default to C<host> specified in the
569	arguments. If C<host> is not specified there it will	575	arguments. If C<host> is not specified there it will default to "*".
570	default to "*". Default port is 20203. Configuration passed	576	Default port is 20203. Configuration passed to new or run may be either
571	to new or run may be either a scalar containing a single port	577	a scalar containing a single port number or an arrayref of ports.
572	number or an arrayref of ports.	578
		579	On an IPv6-enabled host where a module IO::Socket::INET6 is installed
		580	the "*" implies two listening sockets, one for each of the protocols
		581	(PF_INET and PF_INET6) and is equivalent to specifying two ports, bound
		582	to an 'unspecified' address of each address family ("0.0.0.0" and "::").
		583	If listening on an INET6 socket is not desired despite IO::Socket::INET6
		584	module being available, please supply the 'unspecifed' INET (IPv4) address
		585	'0.0.0.0' as a I<host>, either in the C<port> or in the C<host> argument.
		586
		587	An INET socket can only accept IPv4 connections. An INET6 socket accepts
		588	IPv6 connections, but may also accept IPv4 connections depending on
		589	OS and its settings. For example, on FreeBSD systems setting a sysctl
		590	net.inet6.ip6.v6only to 0 will allow IPv4 connections to an INET6 socket.
		591	If this is the case, specifying "::" as a binding address instead of a "*"
		592	might be desired to reduce the number of sockets needed. Note that a
		593	textual representation of a peer's IPv4 address as connected to an INET6
		594	socket will typically be in a form of an IPv4-mapped IPv6 addresses,
		595	e.g. "::FFFF:127.0.0.1" .
		596
		597	Restricting binding to a loopback interface on systems where an INET6
		598	socket does not accept IPv4 connections requires creating two sockets,
		599	one bound to address "127.0.0.1" and the other bound to address "::1".
573		600
574	On systems that support it, a port value of 0 may be used to ask	601	On systems that support it, a port value of 0 may be used to ask
Lines 583-587 Link Here
583	Local host or addr upon which to bind port. If a value of '*' is	610	Local host or addr upon which to bind port. If a value of '*' is
584	given, the server will bind that port on all available addresses	611	given, the server will bind that port on all available addresses
585	on the box. See L<Net::Server::Proto>. See L<IO::Socket>. Configuration	612	on the box. The C<host> argument provides a default local host
		613	address if the C<port> argument omits a host specification.
		614	See L<Net::Server::Proto>. See L<IO::Socket>. Configuration
586	passed to new or run may be either a scalar containing a single	615	passed to new or run may be either a scalar containing a single
587	host or an arrayref of hosts - if the hosts array is shorter than	616	host or an arrayref of hosts - if the hosts array is shorter than

Lines 35-43 Link Here

(-)Net-Server-0.99/lib/Net/Server/Proto/UDP.pm (-19 / +23 lines)
35	my $class = ref($type) \|\| $type \|\| __PACKAGE__;	35	my $class = ref($type) \|\| $type \|\| __PACKAGE__;
36		36
37	my $sock = $class->SUPER::object( @_ );
38
39	$sock->NS_proto('UDP');
40
41	### set a few more parameters
42	my($default_host,$port,$server) = @_;	37	my($default_host,$port,$server) = @_;
43	my $prop = $server->{server};	38	my $prop = $server->{server};
Lines 62-94 Link Here
62	&& $prop->{udp_broadcast};	57	&& $prop->{udp_broadcast};
63		58
64	$sock->NS_recv_len( $prop->{udp_recv_len} );	59	my @sockets_list = $class->SUPER::object( @_ );
65	$sock->NS_recv_flags( $prop->{udp_recv_flags} );
66		60
67	return $sock;	61	foreach my $sock ( @sockets_list ){
		62	$sock->NS_proto('UDP');
		63	$sock->NS_recv_len( $prop->{udp_recv_len} );
		64	$sock->NS_recv_flags( $prop->{udp_recv_flags} );
		65	}
		66
		67	### returns any number of sockets,
		68	### one for each protocol family (PF_INET or PF_INET6) and each bind address
		69	return !wantarray ? $sockets_list[0] : @sockets_list;
68	}	70	}
69		71
70		72
71	### connect the first time	73	### bind the first time
72	### doesn't support the listen or the reuse option	74	### doesn't support the listen or the reuse option
73	sub connect {	75	sub connect {
74	my $sock = shift;	76	my $sock = shift;
75	my $server = shift;	77	my $server = shift;
76	my $prop = $server->{server};	78	my $prop = $server->{server};
77		79
78	my $host = $sock->NS_host;	80	my $host = $sock->NS_host;
79	my $port = $sock->NS_port;	81	my $port = $sock->NS_port;
		82	my $pfamily = $sock->NS_family \|\| 0;
80		83
81	my %args = ();	84	my %args;
82	$args{LocalPort} = $port; # what port to bind on	85	$args{LocalPort} = $port; # what port to bind on
83	$args{Proto} = 'udp'; # what procol to use	86	$args{Proto} = 'udp'; # what procol to use
84	$args{LocalAddr} = $host if $host !~ /\/; # what local address ( is all)	87	$args{LocalAddr} = $host if $host !~ /\/; # what local address ( is all)
		88	$args{Domain} = $pfamily if $Net::Server::Proto::TCP::have_inet6 && $pfamily;
85	$args{Reuse} = 1; # allow us to rebind the port on a restart	89	$args{Reuse} = 1; # allow us to rebind the port on a restart
86	$args{Broadcast} = 1 if $prop->{udp_broadcast};	90	$args{Broadcast} = 1 if $prop->{udp_broadcast};
87		91
88	### connect to the sock	92	### bind to the sock
89	$sock->SUPER::configure(\%args)	93	$sock->SUPER::configure(\%args)
90	or $server->fatal("Can't connect to UDP port $port on $host [$!]");	94	or $server->fatal("Can't bind to UDP port $port on $host [$!]");
91		95
92	$server->fatal("Back sock [$!]!".caller())	96	$server->fatal("Bad sock [$!]!".caller())
93	unless $sock;	97	unless $sock;
94		98

Lines 22-177 Link Here

(-)Net-Server-0.99/lib/Net/Server/Proto/SSLEAY.pm.orig (-119 / +232 lines)
22	package Net::Server::Proto::SSLEAY;	22	package Net::Server::Proto::SSLEAY;
23		23
24	use strict;	24	use strict;
25	use vars qw($VERSION $AUTOLOAD @ISA);	25	use vars qw($VERSION $AUTOLOAD @ISA $have_inet6);
26	use IO::Socket::INET;
27	use Fcntl ();	26	use Fcntl ();
28	use Errno ();	27	use Errno ();
29	use Socket ();	28	use Socket ();
		29	use IO::Socket;
30		30
31	BEGIN {	31	BEGIN {
32	eval { require Net::SSLeay };	32	eval {
33	$@ && warn "Module Net::SSLeay is required for SSLeay.";	33	require Socket6; import Socket6;
34	# Net::SSLeay gets mad if we call these multiple times - the question is - who will call them multiple times?	34	require IO::Socket::INET6;
35	for my $sub (qw(load_error_strings SSLeay_add_ssl_algorithms ENGINE_load_builtin_engines ENGINE_register_all_complete randomize)) {	35	@ISA = qw(IO::Socket::INET6);
36	Net::SSLeay->can($sub)->();	36	$have_inet6 = 1;
37	}	37	} or do {
		38	require IO::Socket::INET;
		39	@ISA = qw(IO::Socket::INET);
		40	};
		41	eval { require Net::SSLeay };
		42	$@ && warn "Module Net::SSLeay is required for SSLeay.";
		43	# Net::SSLeay gets mad if we call these multiple times - the question is - who will call them multiple times?
		44	for my $sub (qw(load_error_strings SSLeay_add_ssl_algorithms ENGINE_load_builtin_engines ENGINE_register_all_complete randomize)) {
		45	Net::SSLeay->can($sub)->();
		46	}
38	}	47	}
39		48
40	$VERSION = $Net::Server::VERSION; # done until separated	49	$VERSION = $Net::Server::VERSION; # done until separated
41	@ISA = qw(IO::Socket::INET);	50
		51	# additional protocol specific arguments
		52	my @ssl_args = qw(
		53	SSL_use_cert
		54	SSL_verify_mode
		55	SSL_key_file
		56	SSL_cert_file
		57	SSL_ca_path
		58	SSL_ca_file
		59	SSL_cipher_list
		60	SSL_passwd_cb
		61	SSL_max_getline_length
		62	SSL_error_callback
		63	);
42		64
43	sub object {	65	sub object {
44	my $type = shift;	66	my $type = shift;
45	my $class = ref($type) \|\| $type \|\| __PACKAGE__;	67	my $class = ref($type) \|\| $type \|\| __PACKAGE__;
46		68
47	my ($default_host,$port,$server) = @_;	69	my ($default_host,$port,$server) = @_;
48	my $prop = $server->{'server'};	70	my $host;
49	my $host;	71	my $prop = $server->{'server'};
50		72
51	if ($port =~ m/^([\w\.\-\*\/]+):(\w+)$/) { # allow for things like "domain.com:80"	73	local($1,$2);
52	($host, $port) = ($1, $2);	74	### allow for things like "[::1]:80" or "[host.example.com]:80"
53	}	75	if( $port =~ m/^\[([^\]]*)\]:(\w+)$/ ){
54	elsif ($port =~ /^(\w+)$/) { # allow for things like "80"	76	($host,$port) = ($1,$2);
55	($host, $port) = ($default_host, $1);	77
56	}	78	### allow for things like "host.example.com:80"
57	else {	79	}elsif( $port =~ m/^([\w\.\-\*\/]+):(\w+)$/ ){
58	$server->fatal("Undeterminate port \"$port\" under ".__PACKAGE__);	80	($host,$port) = ($1,$2);
59	}	81
60		82	### allow for things like "80" or "http"
61	# read any additional protocol specific arguments	83	}elsif( $port =~ /^(\w+)$/ ){
62	my @ssl_args = qw(	84	($host,$port) = ($default_host,$1);
63	SSL_server	85
64	SSL_use_cert	86	### don't know that style of port
65	SSL_verify_mode	87	}else{
66	SSL_key_file	88	$server->fatal("Undeterminate port \"$port\" under ".__PACKAGE__);
67	SSL_cert_file	89	}
68	SSL_ca_path	90
69	SSL_ca_file	91	### collect bind addresses along with their address family for all hosts
70	SSL_cipher_list	92	my @bind_tuples;
71	SSL_passwd_cb	93	if( $host =~ /^\d{1,3}(?:\.\d{1,3}){3}\z/ ){
72	SSL_error_callback	94	push(@bind_tuples, [AF_INET,$host,$port]);
73	SSL_max_getline_length	95	}elsif( $host =~ /:/ ){
74	);	96	die "No IO::Socket::INET6, cannot bind to [$host]:$port" if !$have_inet6;
75	my %args;	97	push(@bind_tuples, [AF_INET6,$host,$port]);
76	$args{$_} = \$prop->{$_} for @ssl_args;	98	}elsif( !$have_inet6 ){
77	$server->configure(\%args);	99	push(@bind_tuples, [AF_INET,$host,$port]);
78		100	}elsif( $have_inet6 && $host =~ /\*/ ){
79	my $sock = $class->new;	101	push(@bind_tuples, [AF_INET6,$host,$port], [AF_INET,$host,$port]);
80	$sock->NS_host($host);	102	}else{ # we do have IO::Socket::INET6, it handles inet6 as well as inet
81	$sock->NS_port($port);	103	# obtain a list of IP addresses for $host, resolve port name
82	$sock->NS_proto('SSLEAY');	104	my @res1 = getaddrinfo($host, $port, AF_UNSPEC, SOCK_STREAM, 0,
		105	AI_PASSIVE\|AI_ADDRCONFIG);
		106	die "Unresolvable [$host]:$port: $res1[0]" if @res1 < 5;
		107	while (@res1 >= 5) {
		108	my($afam, $socktype, $proto, $saddr, $canonname);
		109	($afam, $socktype, $proto, $saddr, $canonname, @res1) = @res1;
		110	my @res2 = getnameinfo($saddr, NI_NUMERICHOST \| NI_NUMERICSERV);
		111	die "getnameinfo failed on [$host]:$port: $res2[0]" if @res2 < 2;
		112	my($hostip,$portnum) = @res2;
		113	$server->log(4,"Resolved [$host]:$port -> [$hostip]:$portnum, AF $afam");
		114	push(@bind_tuples, [$afam,$hostip,$portnum]);
		115	}
		116	}
		117
		118	my @sockets_list;
		119	### create a socket for each specified bind address and family
		120	foreach my $tuple ( @bind_tuples ){
		121	my $afamily; # address family (AF_* constants)
		122	my $pfamily; # socket protocol family (PF_* constants)
		123	($afamily,$host,$port) = @$tuple;
		124	my $sock;
		125	if( $have_inet6 ){
		126	# Using IO::Socket::INET6 to handle both the IPv4 and IPv6.
		127	# Constants PF_INET/PF_INET6 (protocol family) usually happen to have
		128	# the same value as AF_INET/AF_INET6 (address family) constants.
		129	# Still, better safe than sorry:
		130	if ( $afamily == AF_INET ) {
		131	$pfamily = PF_INET;
		132	} elsif ( $afamily == AF_INET6 ) {
		133	$pfamily = PF_INET6;
		134	} else {
		135	$pfamily = $afamily;
		136	}
		137	$server->log(3,"Using IO::Socket::INET6 for [$host]:$port, PF $pfamily");
		138	$sock = IO::Socket::INET6->new(Domain => $pfamily); # inet or inet6
		139	}else{
		140	$pfamily = PF_INET;
		141	$server->log(3,"Using IO::Socket::INET for [$host]:$port, PF $pfamily");
		142	$sock = IO::Socket::INET->new(); # inet socket (IPv4 only)
		143	}
		144
		145	if ($sock) {
		146	bless $sock, $class;
		147
		148	$sock->NS_host($host);
		149	$sock->NS_port($port);
		150	$sock->NS_proto('SSLEAY');
		151	$sock->NS_family($pfamily); # socket protocol family
83		152
84	for my $key (@ssl_args) {	153	for my $key (@ssl_args) {
85	my $val = defined($prop->{$key}) ? $prop->{$key} : $server->can($key) ? $server->$key($host, $port, 'SSLEAY') : undef;	154	my $val = defined($prop->{$key}) ? $prop->{$key} : $server->can($key) ? $server->$key($host, $port, 'SSLEAY') : undef;
86	$sock->$key($val);	155	$sock->$key($val);
		156	}
		157	push @sockets_list, $sock;
87	}	158	}
		159	}
88		160
89	return $sock;	161	### returns any number of sockets,
		162	### one for each protocol family (PF_INET or PF_INET6) and each bind address
		163	return !wantarray ? $sockets_list[0] : @sockets_list;
90	}	164	}
91		165
92	sub log_connect {	166	sub log_connect {
93	my $sock = shift;	167	my $sock = shift;
94	my $server = shift;	168	my $server = shift;
95	my $host = $sock->NS_host;	169	my $host = $sock->NS_host;
96	my $port = $sock->NS_port;	170	my $port = $sock->NS_port;
97	my $proto = $sock->NS_proto;	171	my $proto = $sock->NS_proto;
98	$server->log(2,"Binding to $proto port $port on host $host\n");	172	my $pfamily = $sock->NS_family \|\| 0;
		173	$server->log(2,"Binding to $proto port $port on host $host, PF $pfamily\n");
99	}	174	}
100		175
101	###----------------------------------------------------------------###	176	###----------------------------------------------------------------###
102		177
103	sub connect { # connect the first time	178	### bind the first time
104	my $sock = shift;	179	sub connect {
105	my $server = shift;	180	my $sock = shift;
106	my $prop = $server->{'server'};	181	my $server = shift;
107		182	my $prop = $server->{server};
108	my $host = $sock->NS_host;	183
109	my $port = $sock->NS_port;	184	my $host = $sock->NS_host;
110		185	my $port = $sock->NS_port;
111	my %args;	186	my $pfamily = $sock->NS_family \|\| 0;
112	$args{'LocalPort'} = $port;	187
113	$args{'Proto'} = 'tcp';	188	my %args;
114	$args{'LocalAddr'} = $host if $host !~ /\/; # is all	189	$args{LocalPort} = $port;
115	$args{'Listen'} = $prop->{'listen'};	190	$args{Proto} = 'tcp';
116	$args{'Reuse'} = 1;	191	$args{LocalAddr} = $host if $host !~ /\/; # is all
117		192	$args{Domain} = $pfamily if $have_inet6 && $pfamily;
118	$sock->SUPER::configure(\%args) \|\| $server->fatal("Can't connect to SSL port $port on $host [$!]");	193	$args{Listen} = $prop->{listen};
119	$server->fatal("Bad sock [$!]!".caller()) if ! $sock;	194	$args{Reuse} = 1;
120		195
121	if ($port == 0 && ($port = $sock->sockport)) {	196	$sock->SUPER::configure(\%args)
122	$sock->NS_port($port);	197	or $server->fatal("Can't bind to SSL port $port on $host [$!]");
123	$server->log(2,"Bound to auto-assigned port $port");	198	$server->fatal("Bad sock [$!]!".caller()) if !$sock;
124	}	199
125		200	my $actual_port = $sock->sockport;
126	$sock->bind_SSL($server);	201	# $port may be a service name, compare as strings
127	}	202	if( $actual_port && (!defined $port \|\| $actual_port ne $port) ){
128		203	$sock->NS_port($actual_port);
129	sub reconnect { # connect on a sig -HUP	204	if( $port =~ /^0*\z/ ){
130	my ($sock, $fd, $server) = @_;	205	$server->log(2,"Bound to auto-assigned port $actual_port");
131	my $resp = $sock->fdopen( $fd, 'w' ) \|\| $server->fatal("Error opening to file descriptor ($fd) [$!]");	206	}else{
132	$sock->bind_SSL($server);	207	$server->log(3,"Bound to service \"$port\", port number $actual_port");
133	return $resp;	208	}
		209	}
		210
		211	$sock->bind_SSL($server);
		212	}
		213
		214	### reassociate sockets with inherited file descriptors on a sig -HUP
		215	sub reconnect {
		216	my ($sock, $fd, $server) = @_;
		217
		218	my $host = $sock->NS_host;
		219	my $port = $sock->NS_port;
		220	my $proto = $sock->NS_proto;
		221	my $pfamily = $sock->NS_family \|\| 0;
		222
		223	$server->log(3,"Reassociating file descriptor $fd ".
		224	"with socket $proto on [$host]:port, PF $pfamily\n");
		225	my $resp = $sock->fdopen( $fd, 'w' )
		226	or $server->fatal("Error opening to file descriptor ($fd) [$!]");
		227	$sock->bind_SSL($server);
		228	return $resp;
134	}	229	}
135		230
136	sub bind_SSL {	231	sub bind_SSL {
137	my ($sock, $server) = @_;	232	my ($sock, $server) = @_;
138	my $ctx = Net::SSLeay::CTX_new(); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_new");	233	my $ctx = Net::SSLeay::CTX_new(); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_new");
139		234
140	Net::SSLeay::CTX_set_options($ctx, Net::SSLeay::OP_ALL()); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_set_options");	235	Net::SSLeay::CTX_set_options($ctx, Net::SSLeay::OP_ALL()); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_set_options");
141		236
142	# 0x1: SSL_MODE_ENABLE_PARTIAL_WRITE	237	# 0x1: SSL_MODE_ENABLE_PARTIAL_WRITE
143	# 0x10: SSL_MODE_RELEASE_BUFFERS (ignored before OpenSSL v1.0.0)	238	# 0x10: SSL_MODE_RELEASE_BUFFERS (ignored before OpenSSL v1.0.0)
144	Net::SSLeay::CTX_set_mode($ctx, 0x11); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_set_mode");	239	Net::SSLeay::CTX_set_mode($ctx, 0x11); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_set_mode");
145		240
146	# Load certificate. This will prompt for a password if necessary.	241	# Load certificate. This will prompt for a password if necessary.
147	my $file_key = $sock->SSL_key_file \|\| die "SSLeay missing SSL_key_file.\n";	242	my $file_key = $sock->SSL_key_file \|\| die "SSLeay missing SSL_key_file.\n";
148	my $file_cert = $sock->SSL_cert_file \|\| die "SSLeay missing SSL_cert_file.\n";	243	my $file_cert = $sock->SSL_cert_file \|\| die "SSLeay missing SSL_cert_file.\n";
149	Net::SSLeay::CTX_use_RSAPrivateKey_file($ctx, $file_key, Net::SSLeay::FILETYPE_PEM()); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_use_RSAPrivateKey_file");	244	Net::SSLeay::CTX_use_RSAPrivateKey_file($ctx, $file_key, Net::SSLeay::FILETYPE_PEM()); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_use_RSAPrivateKey_file");
150	Net::SSLeay::CTX_use_certificate_file( $ctx, $file_cert, Net::SSLeay::FILETYPE_PEM()); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_use_certificate_file");	245	Net::SSLeay::CTX_use_certificate_file( $ctx, $file_cert, Net::SSLeay::FILETYPE_PEM()); $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_use_certificate_file");
151	$sock->SSLeay_context($ctx);	246	$sock->SSLeay_context($ctx);
152	}	247	}
153		248
154	sub close {	249	sub close {
155	my $sock = shift;	250	my $sock = shift;
156	if ($sock->SSLeay_is_client) {	251	if ($sock->SSLeay_is_client) {
157	Net::SSLeay::free($sock->SSLeay);	252	Net::SSLeay::free($sock->SSLeay);
158	} else {	253	} else {
159	Net::SSLeay::CTX_free($sock->SSLeay_context);	254	Net::SSLeay::CTX_free($sock->SSLeay_context);
160	}	255	}
161	$sock->SSLeay_check_fatal("SSLeay close free");	256	$sock->SSLeay_check_fatal("SSLeay close free");
162	return $sock->SUPER::close(@_);	257	return $sock->SUPER::close(@_);
163	}	258	}
164		259
165	sub accept {	260	sub accept {
166	my $sock = shift;	261	my $sock = shift;
167	my $client = $sock->SUPER::accept;	262	my $client = $sock->SUPER::accept;
168	if (defined $client) {	263	if (defined $client) {
169	$client->NS_proto($sock->NS_proto);	264	$client->NS_proto( $sock->NS_proto );
170	$client->SSLeay_context($sock->SSLeay_context);	265	$client->NS_family( $sock->NS_family );
171	$client->SSLeay_is_client(1);	266	$client->NS_host( $sock->NS_host );
172	}	267	$client->NS_port( $sock->NS_port );
		268	$client->SSLeay_context( $sock->SSLeay_context );
		269	$client->SSLeay_is_client(1);
		270	}
173		271
174	return $client;	272	return $client;
175	}	273	}
176		274
177	sub SSLeay {	275	sub SSLeay {
Lines 280-285 Link Here
280	return length $read;	378	return length $read;
281	}	379	}
282		380
		381	sub sysread {
		382	my ($client, $buf, $size, $offset) = @_;
		383	warn "sysread is not supported by Net::Server::Proto::SSLEAY";
		384	# not quite right, usable only for testing:
		385	my ($ok, $read) = $client->read_until($size, $/, 1);
		386	substr($_[1], $offset \|\| 0, defined($buf) ? length($buf) : 0, $read);
		387	# should return the number of bytes actually read, 0 at end of file, or
		388	# undef if there was an error (in the latter case $! should also be set)
		389	return length $read;
		390	}
		391
283	sub getline {	392	sub getline {
284	my $client = shift;	393	my $client = shift;
285	my ($ok, $line) = $client->read_until($client->SSL_max_getline_length, $/);	394	my ($ok, $line) = $client->read_until($client->SSL_max_getline_length, $/);
Lines 330-349 Link Here
330	$client->print($buf);	439	$client->print($buf);
331	}	440	}
332		441
333	sub sysread { die "sysread is not supported by Net::Server::Proto::SSLEAY" }
334	sub syswrite { die "syswrite is not supported by Net::Server::Proto::SSLEAY" }	442	sub syswrite { die "syswrite is not supported by Net::Server::Proto::SSLEAY" }
335		443
336	###----------------------------------------------------------------###	444	###----------------------------------------------------------------###
337		445
338	sub hup_string {	446	sub hup_string {
339	my $sock = shift;	447	my $sock = shift;
340	return join "\|", map{$sock->$_()} qw(NS_host NS_port NS_proto);	448	return join("\|",
		449	$sock->NS_host,
		450	$sock->NS_port,
		451	$sock->NS_proto,
		452	!$have_inet6 \|\| !$sock->NS_family ? () : $sock->NS_family,
		453	);
341	}	454	}
342		455
343	sub show {	456	sub show {
344	my $sock = shift;	457	my $sock = shift;
345	my $t = "Ref = \"" .ref($sock) . "\"\n";	458	my $t = "Ref = \"" .ref($sock) . "\"\n";
346	foreach my $prop ( qw(NS_proto NS_port NS_host SSLeay_context SSLeay_is_client) ){	459	foreach my $prop ( qw(NS_proto NS_port NS_host NS_family SSLeay_context SSLeay_is_client) ){
347	$t .= " $prop = \"" .$sock->$prop()."\"\n";	460	$t .= " $prop = \"" .$sock->$prop()."\"\n";
348	}	461	}
349	return $t;	462	return $t;
Lines 353-359 Link Here
353	my $sock = shift;	466	my $sock = shift;
354	my $prop = $AUTOLOAD =~ /::([^:]+)$/ ? $1 : die "Missing property in AUTOLOAD.";	467	my $prop = $AUTOLOAD =~ /::([^:]+)$/ ? $1 : die "Missing property in AUTOLOAD.";
355	die "Unknown method or property [$prop]"	468	die "Unknown method or property [$prop]"
356	if $prop !~ /^(NS_proto\|NS_port\|NS_host\|SSLeay_context\|SSLeay_is_client\|SSL_\w+)$/;	469	if $prop !~ /^(NS_proto\|NS_port\|NS_host\|NS_family\|SSLeay_context\|SSLeay_is_client\|SSL_\w+)$/;
357		470
358	no strict 'refs';	471	no strict 'refs';
359	*{__PACKAGE__."::${prop}"} = sub {	472	*{__PACKAGE__."::${prop}"} = sub {

Lines 22-35 Link Here

(-)Net-Server-0.99/lib/Net/Server/Proto/SSL.pm.orig (-80 / +188 lines)
22	package Net::Server::Proto::SSL;	22	package Net::Server::Proto::SSL;
23		23
24	use strict;	24	use strict;
25	use vars qw($VERSION $AUTOLOAD @ISA);	25	use vars qw($VERSION $AUTOLOAD @ISA $have_inet6 $io_socket_module);
26	use Net::Server::Proto::TCP ();	26	use IO::Socket;
27	eval { require IO::Socket::SSL; };	27
28	$@ && warn "Module IO::Socket::SSL is required for SSL.";	28	BEGIN {
		29	eval {
		30	require Socket6; import Socket6;
		31	require IO::Socket::INET6;
		32	$io_socket_module = 'IO::Socket::INET6';
		33	$have_inet6 = 1;
		34	} or do {
		35	require IO::Socket::INET;
		36	$io_socket_module = 'IO::Socket::INET';
		37	};
		38	@ISA = ( $io_socket_module );
		39	}
		40
		41	eval {
		42	require IO::Socket::SSL; import IO::Socket::SSL;
		43	# we could add IO::Socket::SSL to a local copy of @ISA just before calling
		44	# start_SSL and do away with the $io_socket_module trick later, but this
		45	# causes perl 5.12.2 to crash, so do it the way it likes it
		46	unshift(@ISA, qw(IO::Socket::SSL)); 1;
		47	} or do {
		48	warn "Module IO::Socket::SSL is required for SSL: $@";
		49	};
29		50
30	$VERSION = $Net::Server::VERSION; # done until separated	51	$VERSION = $Net::Server::VERSION; # done until separated
31	@ISA = qw(IO::Socket::SSL);
32		52
		53	# additional protocol specific arguments
		54	my @ssl_args = qw(
		55	SSL_use_cert
		56	SSL_verify_mode
		57	SSL_key_file
		58	SSL_cert_file
		59	SSL_ca_path
		60	SSL_ca_file
		61	SSL_cipher_list
		62	SSL_passwd_cb
		63	SSL_max_getline_length
		64	SSL_error_callback
		65	);
33		66
34	sub object {	67	sub object {
35	my $type = shift;	68	my $type = shift;
Lines 39-49 Link Here
39	my $prop = $server->{server};	72	my $prop = $server->{server};
40	my $host;	73	my $host;
41		74
42	### allow for things like "domain.com:80"	75	local($1,$2);
43	if( $port =~ m/^([\w\.\-\*\/]+):(\w+)$/ ){	76	### allow for things like "[::1]:80" or "[host.example.com]:80"
		77	if( $port =~ m/^\[([^\]]*)\]:(\w+)$/ ){
44	($host,$port) = ($1,$2);	78	($host,$port) = ($1,$2);
45		79
46	### allow for things like "80"	80	### allow for things like "host.example.com:80"
		81	}elsif( $port =~ m/^([\w\.\-\*\/]+):(\w+)$/ ){
		82	($host,$port) = ($1,$2);
		83
		84	### allow for things like "80" or "http"
47	}elsif( $port =~ /^(\w+)$/ ){	85	}elsif( $port =~ /^(\w+)$/ ){
48	($host,$port) = ($default_host,$1);	86	($host,$port) = ($default_host,$1);
49		87
Lines 52-149 Link Here
52	$server->fatal("Undeterminate port \"$port\" under ".__PACKAGE__);	90	$server->fatal("Undeterminate port \"$port\" under ".__PACKAGE__);
53	}	91	}
54		92
55	# read any additional protocol specific arguments	93	### collect bind addresses along with their address family for all hosts
56	my @ssl_args = qw(	94	my @bind_tuples;
57	SSL_server	95	if( $host =~ /^\d{1,3}(?:\.\d{1,3}){3}\z/ ){
58	SSL_use_cert	96	push(@bind_tuples, [AF_INET,$host,$port]);
59	SSL_verify_mode	97	}elsif( $host =~ /:/ ){
60	SSL_key_file	98	die "No IO::Socket::INET6, cannot bind to [$host]:$port" if !$have_inet6;
61	SSL_cert_file	99	push(@bind_tuples, [AF_INET6,$host,$port]);
62	SSL_ca_path	100	}elsif( !$have_inet6 ){
63	SSL_ca_file	101	push(@bind_tuples, [AF_INET,$host,$port]);
64	SSL_cipher_list	102	}elsif( $have_inet6 && $host =~ /\*/ ){
65	SSL_passwd_cb	103	push(@bind_tuples, [AF_INET6,$host,$port], [AF_INET,$host,$port]);
66	SSL_max_getline_length	104	}else{ # we do have IO::Socket::INET6, it handles inet6 as well as inet
67	);	105	# obtain a list of IP addresses for $host, resolve port name
68	my %args;	106	my @res1 = getaddrinfo($host, $port, AF_UNSPEC, SOCK_STREAM, 0,
69	$args{$_} = \$prop->{$_} for @ssl_args;	107	AI_PASSIVE\|AI_ADDRCONFIG);
70	$server->configure(\%args);	108	die "Unresolvable [$host]:$port: $res1[0]" if @res1 < 5;
71		109	while (@res1 >= 5) {
72	my $sock = $class->new;	110	my($afam, $socktype, $proto, $saddr, $canonname);
73	$sock->NS_host($host);	111	($afam, $socktype, $proto, $saddr, $canonname, @res1) = @res1;
74	$sock->NS_port($port);	112	my @res2 = getnameinfo($saddr, NI_NUMERICHOST \| NI_NUMERICSERV);
75	$sock->NS_proto('SSL');	113	die "getnameinfo failed on [$host]:$port: $res2[0]" if @res2 < 2;
		114	my($hostip,$portnum) = @res2;
		115	$server->log(4,"Resolved [$host]:$port -> [$hostip]:$portnum, AF $afam");
		116	push(@bind_tuples, [$afam,$hostip,$portnum]);
		117	}
		118	}
76		119
77	for my $key (@ssl_args) {	120	my @sockets_list;
78	my $val = defined($prop->{$key}) ? $prop->{$key} : $server->can($key) ? $server->$key($host, $port, 'SSL') : undef;	121	### create a socket for each specified bind address and family
79	$sock->$key($val);	122	foreach my $tuple ( @bind_tuples ){
		123	my $afamily; # address family (AF_* constants)
		124	my $pfamily; # socket protocol family (PF_* constants)
		125	($afamily,$host,$port) = @$tuple;
		126	my $sock;
		127	if( $have_inet6 ){
		128	# Using IO::Socket::INET6 to handle both the IPv4 and IPv6.
		129	# Constants PF_INET/PF_INET6 (protocol family) usually happen to have
		130	# the same value as AF_INET/AF_INET6 (address family) constants.
		131	# Still, better safe than sorry:
		132	if ( $afamily == AF_INET ) {
		133	$pfamily = PF_INET;
		134	} elsif ( $afamily == AF_INET6 ) {
		135	$pfamily = PF_INET6;
		136	} else {
		137	$pfamily = $afamily;
		138	}
		139	$server->log(3,"Using IO::Socket::INET6 for [$host]:$port, PF $pfamily");
		140	$sock = IO::Socket::INET6->new(Domain => $pfamily); # inet or inet6
		141	}else{
		142	$pfamily = PF_INET;
		143	$server->log(3,"Using IO::Socket::INET for [$host]:$port, PF $pfamily");
		144	$sock = IO::Socket::INET->new(); # inet socket (IPv4 only)
		145	}
		146
		147	if ($sock) {
		148	### create the handle under this package
		149	bless $sock, $class;
		150
		151	$sock->NS_host($host);
		152	$sock->NS_port($port);
		153	$sock->NS_proto('SSL');
		154	$sock->NS_family($pfamily); # socket protocol family
		155
		156	for my $key (@ssl_args) {
		157	my $val = defined($prop->{$key}) ? $prop->{$key} : $server->can($key) ? $server->$key($host, $port, 'SSL') : undef;
		158	$sock->$key($val);
		159	}
		160	push @sockets_list, $sock;
		161	}
80	}	162	}
81		163
82	return $sock;	164	### returns any number of sockets,
		165	### one for each protocol family (PF_INET or PF_INET6) and each bind address
		166	return !wantarray ? $sockets_list[0] : @sockets_list;
83	}	167	}
84		168
85	sub log_connect {	169	sub log_connect {
86	my $sock = shift;	170	my $sock = shift;
87	my $server = shift;	171	my $server = shift;
88	my $host = $sock->NS_host;	172	my $host = $sock->NS_host;
89	my $port = $sock->NS_port;	173	my $port = $sock->NS_port;
90	my $proto = $sock->NS_proto;	174	my $proto = $sock->NS_proto;
91	$server->log(2,"Binding to $proto port $port on host $host\n");	175	my $pfamily = $sock->NS_family \|\| 0;
		176	$server->log(2,"Binding to $proto port $port on host $host, PF $pfamily\n");
92	}	177	}
93		178
94	### connect the first time	179	### bind the first time
95	sub connect {	180	sub connect {
96	my $sock = shift;	181	my $sock = shift;
97	my $server = shift;	182	my $server = shift;
98	my $prop = $server->{server};	183	my $prop = $server->{server};
99		184
100	my $host = $sock->NS_host;	185	my $host = $sock->NS_host;
101	my $port = $sock->NS_port;	186	my $port = $sock->NS_port;
102		187	my $pfamily = $sock->NS_family \|\| 0;
103	my %args = ();
104	$args{LocalPort} = $port; # what port to bind on
105	$args{Proto} = 'tcp'; # what procol to use
106	$args{LocalAddr} = $host if $host !~ /\/; # what local address ( is all)
107	$args{Listen} = $prop->{listen}; # how many connections for kernel to queue
108	$args{Reuse} = 1; # allow us to rebind the port on a restart
109
110	### add in any ssl specific properties
111	foreach ( keys %$prop ){
112	next unless /^SSL_/;
113	$args{$_} = $prop->{$_};
114	}
115
116	### connect to the sock
117	$sock->SUPER::configure(\%args)
118	or $server->fatal("Can't connect to SSL port $port on $host [$!]");
119
120	$server->fatal("Back sock [$!]!".caller())
121	unless $sock;
122		188
		189	my %args;
		190	$args{LocalPort} = $port;
		191	$args{Proto} = 'tcp';
		192	$args{LocalAddr} = $host if $host !~ /\/; # is all
		193	$args{Domain} = $pfamily if $have_inet6 && $pfamily;
		194	$args{Listen} = $prop->{listen};
		195	$args{Reuse} = 1;
		196
		197	### bind to the sock using the underlying IO Socket module
		198	{ local @ISA = ( $io_socket_module );
		199	$sock->SUPER::configure(\%args)
		200	or $server->fatal("Can't bind to SSL port $port on $host [$!]");
		201	$server->fatal("Bad sock [$!]!".caller()) if !$sock;
		202	}
123	}	203	}
124		204
125	### connect on a sig -HUP	205	### connect on a sig -HUP
126	sub reconnect {	206	sub reconnect {
127	my $sock = shift;	207	my ($sock, $fd, $server) = @_;
128	my $fd = shift;
129	my $server = shift;
130
131	$sock->fdopen( $fd, 'w' )
132	or $server->fatal("Error opening to file descriptor ($fd) [$!]");
133		208
		209	my $host = $sock->NS_host;
		210	my $port = $sock->NS_port;
		211	my $proto = $sock->NS_proto;
		212	my $pfamily = $sock->NS_family \|\| 0;
		213
		214	$server->log(3,"Reassociating file descriptor $fd ".
		215	"with socket $proto on [$host]:port, PF $pfamily\n");
		216
		217	### fdopen cannot be used on a IO::Socket::SSL object!!!
		218	### use fdopen() from the underlying IO Socket package
		219	{ local @ISA = ( $io_socket_module );
		220	$sock->fdopen( $fd, 'w' )
		221	or $server->fatal("Error opening to file descriptor ($fd) [$!]");
		222	}
134	}	223	}
135		224
136	### allow for endowing the child	225	### allow for endowing the child
137	sub accept {	226	sub accept {
138	my $sock = shift;	227	my $sock = shift;
139	my $client = $sock->SUPER::accept();	228	my $client;
140		229
141	### pass items on	230	### fdopen (in reconnect) cannot be used on an IO::Socket::SSL object,
142	if( defined($client) ){	231	### which is why we accept first and upgrade to SSL later
143	bless $client, ref($sock);	232
144	$client->NS_proto( $sock->NS_proto );	233	### accept() with the underlying IO Socket package, upgrade to SSL later
		234	{ local @ISA = ( $io_socket_module );
		235	$client = $sock->SUPER::accept();
145	}	236	}
146		237
		238	if( defined $client ){
		239	$client->NS_proto( $sock->NS_proto );
		240	$client->NS_family( $sock->NS_family );
		241	$client->NS_host( $sock->NS_host );
		242	$client->NS_port( $sock->NS_port );
		243
		244	### must bless the upgraded SSL object into our package
		245	### to be able to reference its NS_* properties later
		246	__PACKAGE__->start_SSL($client,
		247	SSL_error_trap => sub { my($sock,$msg) = @_;
		248	die "Error upgrading socket to SSL: $msg" },
		249	SSL_server => 1,
		250	map { defined $sock->$_() ? ($_,$sock->$_()) : () } @ssl_args,
		251	) or die "Upgrading socket to SSL failed: ".IO::Socket::SSL::errstr();
		252
		253	}
147	return $client;	254	return $client;
148	}	255	}
149		256
Lines 157-162 Link Here
157	$sock->NS_host,	264	$sock->NS_host,
158	$sock->NS_port,	265	$sock->NS_port,
159	$sock->NS_proto,	266	$sock->NS_proto,
		267	!$have_inet6 \|\| !$sock->NS_family ? () : $sock->NS_family,
160	);	268	);
161	}	269	}
162		270
Lines 164-170 Link Here
164	sub show {	272	sub show {
165	my $sock = shift;	273	my $sock = shift;
166	my $t = "Ref = \"" .ref($sock) . "\"\n";	274	my $t = "Ref = \"" .ref($sock) . "\"\n";
167	foreach my $prop ( qw(NS_proto NS_port NS_host) ){	275	foreach my $prop ( qw(NS_proto NS_port NS_host NS_family) ){
168	$t .= " $prop = \"" .$sock->$prop()."\"\n";	276	$t .= " $prop = \"" .$sock->$prop()."\"\n";
169	}	277	}
170	return $t;	278	return $t;
Lines 179-185 Link Here
179	die "No property called.";	287	die "No property called.";
180	}	288	}
181		289
182	if( $prop =~ /^(NS_proto\|NS_port\|NS_host)$/ ){	290	if( $prop =~ /^(NS_proto\|NS_port\|NS_host\|NS_family\|SSL_\w+)$/ ){
183	no strict 'refs';	291	no strict 'refs';
184	* { __PACKAGE__ ."::". $prop } = sub {	292	* { __PACKAGE__ ."::". $prop } = sub {
185	my $sock = shift;	293	my $sock = shift;
Lines 215-222 Link Here
215	=head1 DESCRIPTION	323	=head1 DESCRIPTION
216		324
217	This original SSL module was experimental. It has been superceeded by	325	This original SSL module was experimental. It has been superceeded by
218	Net::Server::Proto::SSLEAY If anybody has any successes or ideas for	326	Net::Server::Proto::SSLEAY. If anybody has any successes or ideas for
219	improvment under SSL, please email <paul@seamons.com>.	327	improvement under SSL, please email <paul@seamons.com>.
220		328
221	Protocol module for Net::Server. This module implements a	329	Protocol module for Net::Server. This module implements a
222	secure socket layer over tcp (also known as SSL).	330	secure socket layer over tcp (also known as SSL).

Lines 22-32 Link Here

(-)Net-Server-0.99/lib/Net/Server/Proto/TCP.pm.orig (-42 / +134 lines)
22	package Net::Server::Proto::TCP;	22	package Net::Server::Proto::TCP;
23		23
24	use strict;	24	use strict;
25	use vars qw($VERSION $AUTOLOAD @ISA);	25	use vars qw($VERSION $AUTOLOAD @ISA $have_inet6);
26	use IO::Socket ();	26	use IO::Socket;
		27
		28	BEGIN {
		29	eval {
		30	require Socket6; import Socket6;
		31	require IO::Socket::INET6;
		32	@ISA = qw(IO::Socket::INET6);
		33	$have_inet6 = 1;
		34	} or do {
		35	require IO::Socket::INET;
		36	@ISA = qw(IO::Socket::INET);
		37	};
		38	}
27		39
28	$VERSION = $Net::Server::VERSION; # done until separated	40	$VERSION = $Net::Server::VERSION; # done until separated
29	@ISA = qw(IO::Socket::INET);
30		41
31	sub object {	42	sub object {
32	my $type = shift;	43	my $type = shift;
Lines 35-45 Link Here
35	my ($default_host,$port,$server) = @_;	46	my ($default_host,$port,$server) = @_;
36	my $host;	47	my $host;
37		48
38	### allow for things like "domain.com:80"	49	local($1,$2);
39	if( $port =~ m/^([\w\.\-\*\/]+):(\w+)$/ ){	50	### allow for things like "[::1]:80" or "[host.example.com]:80"
		51	if( $port =~ m/^\[([^\]]*)\]:(\w+)$/ ){
40	($host,$port) = ($1,$2);	52	($host,$port) = ($1,$2);
41		53
42	### allow for things like "80"	54	### allow for things like "host.example.com:80"
		55	}elsif( $port =~ m/^([\w\.\-\*\/]+):(\w+)$/ ){
		56	($host,$port) = ($1,$2);
		57
		58	### allow for things like "80" or "http"
43	}elsif( $port =~ /^(\w+)$/ ){	59	}elsif( $port =~ /^(\w+)$/ ){
44	($host,$port) = ($default_host,$1);	60	($host,$port) = ($default_host,$1);
45		61
Lines 48-112 Link Here
48	$server->fatal("Undeterminate port \"$port\" under ".__PACKAGE__);	64	$server->fatal("Undeterminate port \"$port\" under ".__PACKAGE__);
49	}	65	}
50		66
51	### create the handle under this package	67	### collect bind addresses along with their address family for all hosts
52	my $sock = $class->SUPER::new();	68	my @bind_tuples;
		69	if( $host =~ /^\d{1,3}(?:\.\d{1,3}){3}\z/ ){
		70	push(@bind_tuples, [AF_INET,$host,$port]);
		71	}elsif( $host =~ /:/ ){
		72	die "No IO::Socket::INET6, cannot bind to [$host]:$port" if !$have_inet6;
		73	push(@bind_tuples, [AF_INET6,$host,$port]);
		74	}elsif( !$have_inet6 ){
		75	push(@bind_tuples, [AF_INET,$host,$port]);
		76	}elsif( $have_inet6 && $host =~ /\*/ ){
		77	push(@bind_tuples, [AF_INET6,$host,$port], [AF_INET,$host,$port]);
		78	}else{ # we do have IO::Socket::INET6, it handles inet6 as well as inet
		79	# obtain a list of IP addresses for $host, resolve port name
		80	my @res1 = getaddrinfo($host, $port, AF_UNSPEC, SOCK_STREAM, 0,
		81	AI_PASSIVE\|AI_ADDRCONFIG);
		82	die "Unresolvable [$host]:$port: $res1[0]" if @res1 < 5;
		83	while (@res1 >= 5) {
		84	my($afam, $socktype, $proto, $saddr, $canonname);
		85	($afam, $socktype, $proto, $saddr, $canonname, @res1) = @res1;
		86	my @res2 = getnameinfo($saddr, NI_NUMERICHOST \| NI_NUMERICSERV);
		87	die "getnameinfo failed on [$host]:$port: $res2[0]" if @res2 < 2;
		88	my($hostip,$portnum) = @res2;
		89	$server->log(4,"Resolved [$host]:$port -> [$hostip]:$portnum, AF $afam");
		90	push(@bind_tuples, [$afam,$hostip,$portnum]);
		91	}
		92	}
53		93
54	### store some properties	94	my @sockets_list;
55	$sock->NS_host($host);	95	### create a socket for each specified bind address and family
56	$sock->NS_port($port);	96	foreach my $tuple ( @bind_tuples ){
57	$sock->NS_proto('TCP');	97	my $afamily; # address family (AF_* constants)
		98	my $pfamily; # socket protocol family (PF_* constants)
		99	($afamily,$host,$port) = @$tuple;
		100	my $sock;
		101	if( $have_inet6 ){
		102	# Using IO::Socket::INET6 to handle both the IPv4 and IPv6.
		103	# Constants PF_INET/PF_INET6 (protocol family) usually happen to have
		104	# the same value as AF_INET/AF_INET6 (address family) constants.
		105	# Still, better safe than sorry:
		106	if ( $afamily == AF_INET ) {
		107	$pfamily = PF_INET;
		108	} elsif ( $afamily == AF_INET6 ) {
		109	$pfamily = PF_INET6;
		110	} else {
		111	$pfamily = $afamily;
		112	}
		113	$server->log(3,"Using IO::Socket::INET6 for [$host]:$port, PF $pfamily");
		114	$sock = IO::Socket::INET6->new(Domain => $pfamily); # inet or inet6
		115	}else{
		116	$pfamily = PF_INET;
		117	$server->log(3,"Using IO::Socket::INET for [$host]:$port, PF $pfamily");
		118	$sock = IO::Socket::INET->new(); # inet socket (IPv4 only)
		119	}
58		120
59	return $sock;	121	if ($sock) {
		122	### create the handle under this package
		123	bless $sock, $class;
		124
		125	### store some properties
		126	$sock->NS_host($host);
		127	$sock->NS_port($port);
		128	$sock->NS_proto('TCP');
		129	$sock->NS_family($pfamily); # socket protocol family
		130	push @sockets_list, $sock;
		131	}
		132	}
		133
		134	### returns any number of sockets,
		135	### one for each protocol family (PF_INET or PF_INET6) and each bind address
		136	return !wantarray ? $sockets_list[0] : @sockets_list;
60	}	137	}
61		138
62	sub log_connect {	139	sub log_connect {
63	my $sock = shift;	140	my $sock = shift;
64	my $server = shift;	141	my $server = shift;
65	my $host = $sock->NS_host;	142	my $host = $sock->NS_host;
66	my $port = $sock->NS_port;	143	my $port = $sock->NS_port;
67	my $proto = $sock->NS_proto;	144	my $proto = $sock->NS_proto;
68	$server->log(2,"Binding to $proto port $port on host $host\n");	145	my $pfamily = $sock->NS_family \|\| 0;
		146	$server->log(2,"Binding to $proto port $port on host $host, PF $pfamily\n");
69	}	147	}
70		148
71	### connect the first time	149	### bind the first time
72	sub connect {	150	sub connect {
73	my $sock = shift;	151	my $sock = shift;
74	my $server = shift;	152	my $server = shift;
75	my $prop = $server->{server};	153	my $prop = $server->{server};
		154
		155	my $host = $sock->NS_host;
		156	my $port = $sock->NS_port;
		157	my $pfamily = $sock->NS_family \|\| 0;
76		158
77	my $host = $sock->NS_host;	159	my %args;
78	my $port = $sock->NS_port;
79
80	my %args = ();
81	$args{LocalPort} = $port; # what port to bind on	160	$args{LocalPort} = $port; # what port to bind on
82	$args{Proto} = 'tcp'; # what procol to use	161	$args{Proto} = 'tcp'; # what procol to use
83	$args{LocalAddr} = $host if $host !~ /\/; # what local address ( is all)	162	$args{LocalAddr} = $host if $host !~ /\/; # what local address ( is all)
		163	$args{Domain} = $pfamily if $have_inet6 && $pfamily;
84	$args{Listen} = $prop->{listen}; # how many connections for kernel to queue	164	$args{Listen} = $prop->{listen}; # how many connections for kernel to queue
85	$args{Reuse} = 1; # allow us to rebind the port on a restart	165	$args{Reuse} = 1; # allow us to rebind the port on a restart
86		166
87	### connect to the sock	167	### bind the sock
88	$sock->SUPER::configure(\%args)	168	$sock->SUPER::configure(\%args)
89	or $server->fatal("Can't connect to TCP port $port on $host [$!]");	169	or $server->fatal("Can't bind to TCP port $port on $host [$!]");
		170	$server->fatal("Bad sock [$!]!".caller()) if !$sock;
90		171
91	if ($port == 0 && ($port = $sock->sockport)) {	172	my $actual_port = $sock->sockport;
92	$sock->NS_port($port);	173	# $port may be a service name, compare as strings
93	$server->log(2,"Bound to auto-assigned port $port");	174	if( $actual_port && (!defined $port \|\| $actual_port ne $port) ){
		175	$sock->NS_port($actual_port);
		176	if( $port =~ /^0*\z/ ){
		177	$server->log(2,"Bound to auto-assigned port $actual_port");
		178	}else{
		179	$server->log(3,"Bound to service \"$port\", port number $actual_port");
		180	}
94	}	181	}
95		182
96	$server->fatal("Back sock [$!]!".caller())
97	unless $sock;
98
99	}	183	}
100		184
101	### connect on a sig -HUP	185	### reassociate sockets with inherited file descriptors on a sig -HUP
102	sub reconnect {	186	sub reconnect {
103	my $sock = shift;	187	my ($sock, $fd, $server) = @_;
104	my $fd = shift;
105	my $server = shift;
106		188
		189	my $host = $sock->NS_host;
		190	my $port = $sock->NS_port;
		191	my $proto = $sock->NS_proto;
		192	my $pfamily = $sock->NS_family \|\| 0;
		193
		194	$server->log(3,"Reassociating file descriptor $fd ".
		195	"with socket $proto on [$host]:port, PF $pfamily\n");
107	$sock->fdopen( $fd, 'w' )	196	$sock->fdopen( $fd, 'w' )
108	or $server->fatal("Error opening to file descriptor ($fd) [$!]");	197	or $server->fatal("Error opening to file descriptor ($fd) [$!]");
109
110	}	198	}
111		199
112	### allow for endowing the child	200	### allow for endowing the child
Lines 115-122 Link Here
115	my $client = $sock->SUPER::accept();	203	my $client = $sock->SUPER::accept();
116		204
117	### pass items on	205	### pass items on
118	if( defined($client) ){	206	if( defined $client ){
119	$client->NS_proto( $sock->NS_proto );	207	$client->NS_proto( $sock->NS_proto );
		208	$client->NS_family( $sock->NS_family );
		209	$client->NS_host( $sock->NS_host );
		210	$client->NS_port( $sock->NS_port );
120	}	211	}
121		212
122	return $client;	213	return $client;
Lines 156-161 Link Here
156	$sock->NS_host,	247	$sock->NS_host,
157	$sock->NS_port,	248	$sock->NS_port,
158	$sock->NS_proto,	249	$sock->NS_proto,
		250	!$have_inet6 \|\| !$sock->NS_family ? () : $sock->NS_family,
159	);	251	);
160	}	252	}
161		253
Lines 163-169 Link Here
163	sub show {	255	sub show {
164	my $sock = shift;	256	my $sock = shift;
165	my $t = "Ref = \"" .ref($sock) . "\"\n";	257	my $t = "Ref = \"" .ref($sock) . "\"\n";
166	foreach my $prop ( qw(NS_proto NS_port NS_host) ){	258	foreach my $prop ( qw(NS_proto NS_port NS_host NS_family) ){
167	$t .= " $prop = \"" .$sock->$prop()."\"\n";	259	$t .= " $prop = \"" .$sock->$prop()."\"\n";
168	}	260	}
169	return $t;	261	return $t;
Lines 178-184 Link Here
178	die "No property called.";	270	die "No property called.";
179	}	271	}
180		272
181	if( $prop =~ /^(NS_proto\|NS_port\|NS_host\|NS_recv_len\|NS_recv_flags)$/ ){	273	if( $prop =~ /^(NS_proto\|NS_port\|NS_host\|NS_family\|NS_recv_len\|NS_recv_flags)$/ ){
182	no strict 'refs';	274	no strict 'refs';
183	* { __PACKAGE__ ."::". $prop } = sub {	275	* { __PACKAGE__ ."::". $prop } = sub {
184	my $sock = shift;	276	my $sock = shift;