Base perl got a deprecated HTTP Tiny code (0.29), one can use a package but base may enjoy the correction around or a better one.
# Annoyingly IO::Socket's connect() is where the timeout logic is Index: IP.pm =================================================================== RCS file: /cvs/src/gnu/usr.bin/perl/cpan/IO-Socket-IP/lib/IO/Socket/IP.pm,v retrieving revision 1.1.1.1 diff -u -p -r1.1.1.1 IP.pm --- IP.pm 17 Nov 2014 20:52:48 -0000 1.1.1.1 +++ IP.pm 5 Aug 2016 20:53:17 -0000 @@ -1,13 +1,13 @@ # You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # -# (C) Paul Evans, 2010-2014 -- leon...@leonerd.org.uk +# (C) Paul Evans, 2010-2015 -- leon...@leonerd.org.uk package IO::Socket::IP; # $VERSION needs to be set before use base 'IO::Socket' # - https://rt.cpan.org/Ticket/Display.html?id=92107 BEGIN { - $VERSION = '0.29'; + $VERSION = '0.38'; } use strict; @@ -31,7 +31,7 @@ use Socket 1.97 qw( my $AF_INET6 = eval { Socket::AF_INET6() }; # may not be defined my $AI_ADDRCONFIG = eval { Socket::AI_ADDRCONFIG() } || 0; use POSIX qw( dup2 ); -use Errno qw( EINVAL EINPROGRESS EISCONN ); +use Errno qw( EINVAL EINPROGRESS EISCONN ENOTCONN ETIMEDOUT EWOULDBLOCK ); use constant HAVE_MSWIN32 => ( $^O eq "MSWin32" ); @@ -265,6 +265,22 @@ If true, set the C<SO_REUSEPORT> sockopt If true, set the C<SO_BROADCAST> sockopt +=item Sockopts => ARRAY + +An optional array of other socket options to apply after the three listed +above. The value is an ARRAY containing 2- or 3-element ARRAYrefs. Each inner +array relates to a single option, giving the level and option name, and an +optional value. If the value element is missing, it will be given the value of +a platform-sized integer 1 constant (i.e. suitable to enable most of the +common boolean options). + +For example, both options given below are equivalent to setting C<ReuseAddr>. + + Sockopts => [ + [ SOL_SOCKET, SO_REUSEADDR ], + [ SOL_SOCKET, SO_REUSEADDR, pack( "i", 1 ) ], + ] + =item V6Only => BOOL If defined, set the C<IPV6_V6ONLY> sockopt when creating C<PF_INET6> sockets @@ -304,6 +320,22 @@ If defined but false, the socket will be it will default to blocking mode. See the NON-BLOCKING section below for more detail. +=item Timeout => NUM + +If defined, gives a maximum time in seconds to block per C<connect()> call +when in blocking mode. If missing, no timeout is applied other than that +provided by the underlying operating system. When in non-blocking mode this +parameter is ignored. + +Note that if the hostname resolves to multiple address candidates, the same +timeout will apply to each connection attempt individually, rather than to the +operation as a whole. Further note that the timeout does not apply to the +initial hostname resolve operation, if connecting by hostname. + +This behviour is copied inspired by C<IO::Socket::INET>; for more fine grained +control over connection timeouts, consider performing a nonblocking connect +directly. + =back If neither C<Type> nor C<Proto> hints are provided, a default of @@ -380,6 +412,12 @@ sub _io_socket_ip__configure my @localinfos; my @peerinfos; + my $listenqueue = $arg->{Listen}; + if( defined $listenqueue and + ( defined $arg->{PeerHost} || defined $arg->{PeerService} || defined $arg->{PeerAddrInfo} ) ) { + croak "Cannot Listen with a peer address"; + } + if( defined $arg->{GetAddrInfoFlags} ) { $hints{flags} = $arg->{GetAddrInfoFlags}; } @@ -425,11 +463,17 @@ sub _io_socket_ip__configure ref $info eq "ARRAY" or croak "Expected 'LocalAddrInfo' to be an ARRAY ref"; @localinfos = @$info; } - elsif( defined $arg->{LocalHost} or defined $arg->{LocalService} ) { + elsif( defined $arg->{LocalHost} or + defined $arg->{LocalService} or + HAVE_MSWIN32 and $arg->{Listen} ) { # Either may be undef my $host = $arg->{LocalHost}; my $service = $arg->{LocalService}; + unless ( defined $host or defined $service ) { + $service = 0; + } + local $1; # Placate a taint-related bug; [perl #67962] defined $service and $service =~ s/\((\d+)\)$// and my $fallback_port = $1; @@ -476,14 +520,27 @@ sub _io_socket_ip__configure } } + my $INT_1 = pack "i", 1; + my @sockopts_enabled; - push @sockopts_enabled, SO_REUSEADDR if $arg->{ReuseAddr}; - push @sockopts_enabled, SO_REUSEPORT if $arg->{ReusePort}; - push @sockopts_enabled, SO_BROADCAST if $arg->{Broadcast}; + push @sockopts_enabled, [ SOL_SOCKET, SO_REUSEADDR, $INT_1 ] if $arg->{ReuseAddr}; + push @sockopts_enabled, [ SOL_SOCKET, SO_REUSEPORT, $INT_1 ] if $arg->{ReusePort}; + push @sockopts_enabled, [ SOL_SOCKET, SO_BROADCAST, $INT_1 ] if $arg->{Broadcast}; + + if( my $sockopts = $arg->{Sockopts} ) { + ref $sockopts eq "ARRAY" or croak "Expected 'Sockopts' to be an ARRAY ref"; + foreach ( @$sockopts ) { + ref $_ eq "ARRAY" or croak "Bad Sockopts item - expected ARRAYref"; + @$_ >= 2 and @$_ <= 3 or + croak "Bad Sockopts item - expected 2 or 3 elements"; - my $listenqueue = $arg->{Listen}; + my ( $level, $optname, $value ) = @$_; + # TODO: consider more sanity checking on argument values - croak "Cannot Listen with a PeerHost" if defined $listenqueue and @peerinfos; + defined $value or $value = $INT_1; + push @sockopts_enabled, [ $level, $optname, $value ]; + } + } my $blocking = $arg->{Blocking}; defined $blocking or $blocking = 1; @@ -583,7 +640,8 @@ sub setup $self->blocking( 0 ) unless ${*$self}{io_socket_ip_blocking}; foreach my $sockopt ( @{ ${*$self}{io_socket_ip_sockopts} } ) { - $self->setsockopt( SOL_SOCKET, $sockopt, pack "i", 1 ) or ( $@ = "$!", return undef ); + my ( $level, $optname, $value ) = @$sockopt; + $self->setsockopt( $level, $optname, $value ) or ( $@ = "$!", return undef ); } if( defined ${*$self}{io_socket_ip_v6only} and defined $AF_INET6 and $info->{family} == $AF_INET6 ) { @@ -606,11 +664,18 @@ sub setup return 1; } - if( $! == EINPROGRESS or HAVE_MSWIN32 && $! == Errno::EWOULDBLOCK() ) { + if( $! == EINPROGRESS or $! == EWOULDBLOCK ) { ${*$self}{io_socket_ip_connect_in_progress} = 1; return 0; } + # If connect failed but we have no system error there must be an error + # at the application layer, like a bad certificate with + # IO::Socket::SSL. + # In this case don't continue IP based multi-homing because the problem + # cannot be solved at the IP layer. + return 0 if ! $!; + ${*$self}{io_socket_ip_errors}[0] = $!; next; } @@ -624,17 +689,60 @@ sub setup return undef; } -sub connect +sub connect :method { my $self = shift; # It seems that IO::Socket hides EINPROGRESS errors, making them look like # a success. This is annoying here. # Instead of putting up with its frankly-irritating intentional breakage of - # useful APIs I'm just going to end-run around it and call CORE::connect() + # useful APIs I'm just going to end-run around it and call core's connect() # directly - return CORE::connect( $self, $_[0] ) if @_; + if( @_ ) { + my ( $addr ) = @_; + + # Annoyingly IO::Socket's connect() is where the timeout logic is + # implemented, so we'll have to reinvent it here + my $timeout = ${*$self}{'io_socket_timeout'}; + + return connect( $self, $addr ) unless defined $timeout; + + my $was_blocking = $self->blocking( 0 ); + + my $err = defined connect( $self, $addr ) ? 0 : $!+0; + + if( !$err ) { + # All happy + $self->blocking( $was_blocking ); + return 1; + } + elsif( not( $err == EINPROGRESS or $err == EWOULDBLOCK ) ) { + # Failed for some other reason + $self->blocking( $was_blocking ); + return undef; + } + elsif( !$was_blocking ) { + # We shouldn't block anyway + return undef; + } + + my $vec = ''; vec( $vec, $self->fileno, 1 ) = 1; + if( !select( undef, $vec, $vec, $timeout ) ) { + $self->blocking( $was_blocking ); + $! = ETIMEDOUT; + return undef; + } + + # Hoist the error by connect()ing a second time + $err = $self->getsockopt( SOL_SOCKET, SO_ERROR ); + $err = 0 if $err == EISCONN; # Some OSes give EISCONN + + $self->blocking( $was_blocking ); + + $! = $err, return undef if $err; + return 1; + } return 1 if !${*$self}{io_socket_ip_connect_in_progress}; @@ -651,7 +759,7 @@ sub connect # (still in progress). This even works on MSWin32. my $addr = ${*$self}{io_socket_ip_infos}[${*$self}{io_socket_ip_idx}]{peeraddr}; - if( $self->connect( $addr ) or $! == EISCONN ) { + if( connect( $self, $addr ) or $! == EISCONN ) { delete ${*$self}{io_socket_ip_connect_in_progress}; $! = 0; return 1; @@ -682,6 +790,9 @@ sub _get_host_service my $self = shift; my ( $addr, $flags, $xflags ) = @_; + defined $addr or + $! = ENOTCONN, return; + $flags |= NI_DGRAM if $self->socktype == SOCK_DGRAM; my ( $err, $host, $service ) = getnameinfo( $addr, $flags, $xflags || 0 ); @@ -747,11 +858,11 @@ Return the resolved name of the local po =cut -sub sockhost { my $self = shift; ( $self->_get_host_service( $self->sockname, NI_NUMERICHOST, NIx_NOSERV ) )[0] } -sub sockport { my $self = shift; ( $self->_get_host_service( $self->sockname, NI_NUMERICSERV, NIx_NOHOST ) )[1] } +sub sockhost { my $self = shift; scalar +( $self->_get_host_service( $self->sockname, NI_NUMERICHOST, NIx_NOSERV ) )[0] } +sub sockport { my $self = shift; scalar +( $self->_get_host_service( $self->sockname, NI_NUMERICSERV, NIx_NOHOST ) )[1] } -sub sockhostname { my $self = shift; ( $self->_get_host_service( $self->sockname, 0, NIx_NOSERV ) )[0] } -sub sockservice { my $self = shift; ( $self->_get_host_service( $self->sockname, 0, NIx_NOHOST ) )[1] } +sub sockhostname { my $self = shift; scalar +( $self->_get_host_service( $self->sockname, 0, NIx_NOSERV ) )[0] } +sub sockservice { my $self = shift; scalar +( $self->_get_host_service( $self->sockname, 0, NIx_NOHOST ) )[1] } =head2 $addr = $sock->sockaddr @@ -800,11 +911,11 @@ Return the resolved name of the peer por =cut -sub peerhost { my $self = shift; ( $self->_get_host_service( $self->peername, NI_NUMERICHOST, NIx_NOSERV ) )[0] } -sub peerport { my $self = shift; ( $self->_get_host_service( $self->peername, NI_NUMERICSERV, NIx_NOHOST ) )[1] } +sub peerhost { my $self = shift; scalar +( $self->_get_host_service( $self->peername, NI_NUMERICHOST, NIx_NOSERV ) )[0] } +sub peerport { my $self = shift; scalar +( $self->_get_host_service( $self->peername, NI_NUMERICSERV, NIx_NOHOST ) )[1] } -sub peerhostname { my $self = shift; ( $self->_get_host_service( $self->peername, 0, NIx_NOSERV ) )[0] } -sub peerservice { my $self = shift; ( $self->_get_host_service( $self->peername, 0, NIx_NOHOST ) )[1] } +sub peerhostname { my $self = shift; scalar +( $self->_get_host_service( $self->peername, 0, NIx_NOSERV ) )[0] } +sub peerservice { my $self = shift; scalar +( $self->_get_host_service( $self->peername, 0, NIx_NOHOST ) )[1] } =head2 $addr = $peer->peeraddr @@ -830,13 +941,13 @@ sub accept # This second unbelievably dodgy hack guarantees that $self->fileno doesn't # change, which is useful during nonblocking connect -sub socket +sub socket :method { my $self = shift; return $self->SUPER::socket(@_) if not defined $self->fileno; # I hate core prototypes sometimes... - CORE::socket( my $tmph, $_[0], $_[1], $_[2] ) or return undef; + socket( my $tmph, $_[0], $_[1], $_[2] ) or return undef; dup2( $tmph->fileno, $self->fileno ) or die "Unable to dup2 $tmph onto $self - $!"; } @@ -844,7 +955,7 @@ sub socket # Versions of IO::Socket before 1.35 may leave socktype undef if from, say, an # ->fdopen call. In this case we'll apply a fix BEGIN { - if( $IO::Socket::VERSION < 1.35 ) { + if( eval($IO::Socket::VERSION) < 1.35 ) { *socktype = sub { my $self = shift; my $type = $self->SUPER::socktype; @@ -1082,6 +1193,37 @@ useable address from the results of the constructor will ignore the value of this argument, except if it is defined but false. An exception is thrown in this case, because that would request it disable the C<getaddrinfo(3)> search behaviour in the first place. + +=item * + +C<IO::Socket::IP> implements both the C<Blocking> and C<Timeout> parameters, +but it implements the interaction of both in a different way. + +In C<::INET>, supplying a timeout overrides the non-blocking behaviour, +meaning that the C<connect()> operation will still block despite that the +caller asked for a non-blocking socket. This is not explicitly specified in +its documentation, nor does this author believe that is a useful behaviour - +it appears to come from a quirk of implementation. + +In C<::IP> therefore, the C<Blocking> parameter takes precedence - if a +non-blocking socket is requested, no operation will block. The C<Timeout> +parameter here simply defines the maximum time that a blocking C<connect()> +call will wait, if it blocks at all. + +In order to specifically obtain the "blocking connect then non-blocking send +and receive" behaviour of specifying this combination of options to C<::INET> +when using C<::IP>, perform first a blocking connect, then afterwards turn the +socket into nonblocking mode. + + my $sock = IO::Socket::IP->new( + PeerHost => $peer, + Timeout => 20, + ) or die "Cannot connect - $@"; + + $sock->blocking( 0 ); + +This code will behave identically under both C<IO::Socket::INET> and +C<IO::Socket::IP>. =back -- --------------------------------------------------------------------------------------------------------------------- () ascii ribbon campaign - against html e-mail /\