On Fri, Aug 05, 2016 at 05:01:10PM -0400, sven falempin wrote: > 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.
I'm planning to update perl in base after I get mod_perl working under a version > 5.20, which hopefully won't be too far in the future. Doing that will update IO::Socket::IP to 0.37 which includes the Timeout options. > # 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 > /\ -- andrew - http://afresh1.com There are two ways to write error-free programs; only the third one works.
