linux-x86/lib/perl-base/IO/Socket/IP.pm - LeafOS-Project/android_prebuilts_tools-lineage - Gitiles

 #  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-2015 -- leonerd@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.38';
 }

 use strict;
 use warnings;
 use base qw( IO::Socket );

 use Carp;

 use Socket 1.97 qw(
    getaddrinfo getnameinfo
    sockaddr_family
    AF_INET
    AI_PASSIVE
    IPPROTO_TCP IPPROTO_UDP
    IPPROTO_IPV6 IPV6_V6ONLY
    NI_DGRAM NI_NUMERICHOST NI_NUMERICSERV NIx_NOHOST NIx_NOSERV
    SO_REUSEADDR SO_REUSEPORT SO_BROADCAST SO_ERROR
    SOCK_DGRAM SOCK_STREAM
    SOL_SOCKET
 );
 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 ENOTCONN ETIMEDOUT EWOULDBLOCK );

 use constant HAVE_MSWIN32 => ( $^O eq "MSWin32" );

 # At least one OS (Android) is known not to have getprotobyname()
 use constant HAVE_GETPROTOBYNAME => defined eval { getprotobyname( "tcp" ) };

 my $IPv6_re = do {
    # translation of RFC 3986 3.2.2 ABNF to re
    my $IPv4address = do {
       my $dec_octet = q<(?:[0-9]|[1-9][0-9]|1[0-9][0-9]|2[0-4][0-9]|25[0-5])>;
       qq<$dec_octet(?: \\. $dec_octet){3}>;
    };
    my $IPv6address = do {
       my $h16  = qq<[0-9A-Fa-f]{1,4}>;
       my $ls32 = qq<(?: $h16 : $h16 | $IPv4address)>;
       qq<(?:
                                             (?: $h16 : ){6} $ls32
          |                               :: (?: $h16 : ){5} $ls32
          | (?:                   $h16 )? :: (?: $h16 : ){4} $ls32
          | (?: (?: $h16 : ){0,1} $h16 )? :: (?: $h16 : ){3} $ls32
          | (?: (?: $h16 : ){0,2} $h16 )? :: (?: $h16 : ){2} $ls32
          | (?: (?: $h16 : ){0,3} $h16 )? ::     $h16 :      $ls32
          | (?: (?: $h16 : ){0,4} $h16 )? ::                 $ls32
          | (?: (?: $h16 : ){0,5} $h16 )? ::                 $h16
          | (?: (?: $h16 : ){0,6} $h16 )? ::
       )>
    };
    qr<$IPv6address>xo;
 };

 sub import
 {
    my $pkg = shift;
    my @symbols;

    foreach ( @_ ) {
       if( $_ eq "-register" ) {
          IO::Socket::IP::_ForINET->register_domain( AF_INET );
          IO::Socket::IP::_ForINET6->register_domain( $AF_INET6 ) if defined $AF_INET6;
       }
       else {
          push @symbols, $_;
       }
    }

    @_ = ( $pkg, @symbols );
    goto &IO::Socket::import;
 }

 # Convenient capability test function
 {
    my $can_disable_v6only;
    sub CAN_DISABLE_V6ONLY
    {
       return $can_disable_v6only if defined $can_disable_v6only;

       socket my $testsock, Socket::PF_INET6(), SOCK_STREAM, 0 or
          die "Cannot socket(PF_INET6) - $!";

       if( setsockopt $testsock, IPPROTO_IPV6, IPV6_V6ONLY, 0 ) {
          return $can_disable_v6only = 1;
       }
       elsif( $! == EINVAL ) {
          return $can_disable_v6only = 0;
       }
       else {
          die "Cannot setsockopt() - $!";
       }
    }
 }

 sub new
 {
    my $class = shift;
    my %arg = (@_ == 1) ? (PeerHost => $_[0]) : @_;
    return $class->SUPER::new(%arg);
 }

 # IO::Socket may call this one; neaten up the arguments from IO::Socket::INET
 # before calling our real _configure method
 sub configure
 {
    my $self = shift;
    my ( $arg ) = @_;

    $arg->{PeerHost} = delete $arg->{PeerAddr}
       if exists $arg->{PeerAddr} && !exists $arg->{PeerHost};

    $arg->{PeerService} = delete $arg->{PeerPort}
       if exists $arg->{PeerPort} && !exists $arg->{PeerService};

    $arg->{LocalHost} = delete $arg->{LocalAddr}
       if exists $arg->{LocalAddr} && !exists $arg->{LocalHost};

    $arg->{LocalService} = delete $arg->{LocalPort}
       if exists $arg->{LocalPort} && !exists $arg->{LocalService};

    for my $type (qw(Peer Local)) {
       my $host    = $type . 'Host';
       my $service = $type . 'Service';

       if( defined $arg->{$host} ) {
          ( $arg->{$host}, my $s ) = $self->split_addr( $arg->{$host} );
          # IO::Socket::INET compat - *Host parsed port always takes precedence
          $arg->{$service} = $s if defined $s;
       }
    }

    $self->_io_socket_ip__configure( $arg );
 }

 # Avoid simply calling it _configure, as some subclasses of IO::Socket::INET on CPAN already take that
 sub _io_socket_ip__configure
 {
    my $self = shift;
    my ( $arg ) = @_;

    my %hints;
    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};
    }
    else {
       $hints{flags} = $AI_ADDRCONFIG;
    }

    if( defined( my $family = $arg->{Family} ) ) {
       $hints{family} = $family;
    }

    if( defined( my $type = $arg->{Type} ) ) {
       $hints{socktype} = $type;
    }

    if( defined( my $proto = $arg->{Proto} ) ) {
       unless( $proto =~ m/^\d+$/ ) {
          my $protonum = HAVE_GETPROTOBYNAME
             ? getprotobyname( $proto )
             : eval { Socket->${\"IPPROTO_\U$proto"}() };
          defined $protonum or croak "Unrecognised protocol $proto";
          $proto = $protonum;
       }

       $hints{protocol} = $proto;
    }

    # To maintain compatibility with IO::Socket::INET, imply a default of
    # SOCK_STREAM + IPPROTO_TCP if neither hint is given
    if( !defined $hints{socktype} and !defined $hints{protocol} ) {
       $hints{socktype} = SOCK_STREAM;
       $hints{protocol} = IPPROTO_TCP;
    }

    # Some OSes (NetBSD) don't seem to like just a protocol hint without a
    # socktype hint as well. We'll set a couple of common ones
    if( !defined $hints{socktype} and defined $hints{protocol} ) {
       $hints{socktype} = SOCK_STREAM if $hints{protocol} == IPPROTO_TCP;
       $hints{socktype} = SOCK_DGRAM  if $hints{protocol} == IPPROTO_UDP;
    }

    if( my $info = $arg->{LocalAddrInfo} ) {
       ref $info eq "ARRAY" or croak "Expected 'LocalAddrInfo' to be an ARRAY ref";
       @localinfos = @$info;
    }
    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;

       my %localhints = %hints;
       $localhints{flags} |= AI_PASSIVE;
       ( my $err, @localinfos ) = getaddrinfo( $host, $service, \%localhints );

       if( $err and defined $fallback_port ) {
          ( $err, @localinfos ) = getaddrinfo( $host, $fallback_port, \%localhints );
       }

       if( $err ) {
          $@ = "$err";
          $! = EINVAL;
          return;
       }
    }

    if( my $info = $arg->{PeerAddrInfo} ) {
       ref $info eq "ARRAY" or croak "Expected 'PeerAddrInfo' to be an ARRAY ref";
       @peerinfos = @$info;
    }
    elsif( defined $arg->{PeerHost} or defined $arg->{PeerService} ) {
       defined( my $host = $arg->{PeerHost} ) or
          croak "Expected 'PeerHost'";
       defined( my $service = $arg->{PeerService} ) or
          croak "Expected 'PeerService'";

       local $1; # Placate a taint-related bug; [perl #67962]
       defined $service and $service =~ s/\((\d+)\)$// and
          my $fallback_port = $1;

       ( my $err, @peerinfos ) = getaddrinfo( $host, $service, \%hints );

       if( $err and defined $fallback_port ) {
          ( $err, @peerinfos ) = getaddrinfo( $host, $fallback_port, \%hints );
       }

       if( $err ) {
          $@ = "$err";
          $! = EINVAL;
          return;
       }
    }

    my $INT_1 = pack "i", 1;

    my @sockopts_enabled;
    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 ( $level, $optname, $value ) = @$_;
          # TODO: consider more sanity checking on argument values

          defined $value or $value = $INT_1;
          push @sockopts_enabled, [ $level, $optname, $value ];
       }
    }

    my $blocking = $arg->{Blocking};
    defined $blocking or $blocking = 1;

    my $v6only = $arg->{V6Only};

    # IO::Socket::INET defines this key. IO::Socket::IP always implements the
    # behaviour it requests, so we can ignore it, unless the caller is for some
    # reason asking to disable it.
    if( defined $arg->{MultiHomed} and !$arg->{MultiHomed} ) {
       croak "Cannot disable the MultiHomed parameter";
    }

    my @infos;
    foreach my $local ( @localinfos ? @localinfos : {} ) {
       foreach my $peer ( @peerinfos ? @peerinfos : {} ) {
          next if defined $local->{family}   and defined $peer->{family}   and
             $local->{family} != $peer->{family};
          next if defined $local->{socktype} and defined $peer->{socktype} and
             $local->{socktype} != $peer->{socktype};
          next if defined $local->{protocol} and defined $peer->{protocol} and
             $local->{protocol} != $peer->{protocol};

          my $family   = $local->{family}   || $peer->{family}   or next;
          my $socktype = $local->{socktype} || $peer->{socktype} or next;
          my $protocol = $local->{protocol} || $peer->{protocol} || 0;

          push @infos, {
             family    => $family,
             socktype  => $socktype,
             protocol  => $protocol,
             localaddr => $local->{addr},
             peeraddr  => $peer->{addr},
          };
       }
    }

    if( !@infos ) {
       # If there was a Family hint then create a plain unbound, unconnected socket
       if( defined $hints{family} ) {
          @infos = ( {
             family   => $hints{family},
             socktype => $hints{socktype},
             protocol => $hints{protocol},
          } );
       }
       # If there wasn't, use getaddrinfo()'s AI_ADDRCONFIG side-effect to guess a
       # suitable family first.
       else {
          ( my $err, @infos ) = getaddrinfo( "", "0", \%hints );
          if( $err ) {
             $@ = "$err";
             $! = EINVAL;
             return;
          }

          # We'll take all the @infos anyway, because some OSes (HPUX) are known to
          # ignore the AI_ADDRCONFIG hint and return AF_INET6 even if they don't
          # support them
       }
    }

    # In the nonblocking case, caller will be calling ->setup multiple times.
    # Store configuration in the object for the ->setup method
    # Yes, these are messy. Sorry, I can't help that...

    ${*$self}{io_socket_ip_infos} = \@infos;

    ${*$self}{io_socket_ip_idx} = -1;

    ${*$self}{io_socket_ip_sockopts} = \@sockopts_enabled;
    ${*$self}{io_socket_ip_v6only} = $v6only;
    ${*$self}{io_socket_ip_listenqueue} = $listenqueue;
    ${*$self}{io_socket_ip_blocking} = $blocking;

    ${*$self}{io_socket_ip_errors} = [ undef, undef, undef ];

    # ->setup is allowed to return false in nonblocking mode
    $self->setup or !$blocking or return undef;

    return $self;
 }

 sub setup
 {
    my $self = shift;

    while(1) {
       ${*$self}{io_socket_ip_idx}++;
       last if ${*$self}{io_socket_ip_idx} >= @{ ${*$self}{io_socket_ip_infos} };

       my $info = ${*$self}{io_socket_ip_infos}->[${*$self}{io_socket_ip_idx}];

       $self->socket( @{$info}{qw( family socktype protocol )} ) or
          ( ${*$self}{io_socket_ip_errors}[2] = $!, next );

       $self->blocking( 0 ) unless ${*$self}{io_socket_ip_blocking};

       foreach my $sockopt ( @{ ${*$self}{io_socket_ip_sockopts} } ) {
          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 ) {
          my $v6only = ${*$self}{io_socket_ip_v6only};
          $self->setsockopt( IPPROTO_IPV6, IPV6_V6ONLY, pack "i", $v6only ) or ( $@ = "$!", return undef );
       }

       if( defined( my $addr = $info->{localaddr} ) ) {
          $self->bind( $addr ) or
             ( ${*$self}{io_socket_ip_errors}[1] = $!, next );
       }

       if( defined( my $listenqueue = ${*$self}{io_socket_ip_listenqueue} ) ) {
          $self->listen( $listenqueue ) or ( $@ = "$!", return undef );
       }

       if( defined( my $addr = $info->{peeraddr} ) ) {
          if( $self->connect( $addr ) ) {
             $! = 0;
             return 1;
          }

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

       return 1;
    }

    # Pick the most appropriate error, stringified
    $! = ( grep defined, @{ ${*$self}{io_socket_ip_errors}} )[0];
    $@ = "$!";
    return undef;
 }

 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's connect()
    # directly

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

    # See if a connect attempt has just failed with an error
    if( my $errno = $self->getsockopt( SOL_SOCKET, SO_ERROR ) ) {
       delete ${*$self}{io_socket_ip_connect_in_progress};
       ${*$self}{io_socket_ip_errors}[0] = $! = $errno;
       return $self->setup;
    }

    # No error, so either connect is still in progress, or has completed
    # successfully. We can tell by trying to connect() again; either it will
    # succeed or we'll get EISCONN (connected successfully), or EALREADY
    # (still in progress). This even works on MSWin32.
    my $addr = ${*$self}{io_socket_ip_infos}[${*$self}{io_socket_ip_idx}]{peeraddr};

    if( connect( $self, $addr ) or $! == EISCONN ) {
       delete ${*$self}{io_socket_ip_connect_in_progress};
       $! = 0;
       return 1;
    }
    else {
       $! = EINPROGRESS;
       return 0;
    }
 }

 sub connected
 {
    my $self = shift;
    return defined $self->fileno &&
           !${*$self}{io_socket_ip_connect_in_progress} &&
           defined getpeername( $self ); # ->peername caches, we need to detect disconnection
 }

 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 );
    croak "getnameinfo - $err" if $err;

    return ( $host, $service );
 }

 sub _unpack_sockaddr
 {
    my ( $addr ) = @_;
    my $family = sockaddr_family $addr;

    if( $family == AF_INET ) {
       return ( Socket::unpack_sockaddr_in( $addr ) )[1];
    }
    elsif( defined $AF_INET6 and $family == $AF_INET6 ) {
       return ( Socket::unpack_sockaddr_in6( $addr ) )[1];
    }
    else {
       croak "Unrecognised address family $family";
    }
 }

 sub sockhost_service
 {
    my $self = shift;
    my ( $numeric ) = @_;

    $self->_get_host_service( $self->sockname, $numeric ? NI_NUMERICHOST|NI_NUMERICSERV : 0 );
 }

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

 sub sockaddr { my $self = shift; _unpack_sockaddr $self->sockname }

 sub peerhost_service
 {
    my $self = shift;
    my ( $numeric ) = @_;

    $self->_get_host_service( $self->peername, $numeric ? NI_NUMERICHOST|NI_NUMERICSERV : 0 );
 }

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

 sub peeraddr { my $self = shift; _unpack_sockaddr $self->peername }

 # This unbelievably dodgy hack works around the bug that IO::Socket doesn't do
 # it
 #    https://rt.cpan.org/Ticket/Display.html?id=61577
 sub accept
 {
    my $self = shift;
    my ( $new, $peer ) = $self->SUPER::accept( @_ ) or return;

    ${*$new}{$_} = ${*$self}{$_} for qw( io_socket_domain io_socket_type io_socket_proto );

    return wantarray ? ( $new, $peer )
                     : $new;
 }

 # This second unbelievably dodgy hack guarantees that $self->fileno doesn't
 # change, which is useful during nonblocking connect
 sub socket :method
 {
    my $self = shift;
    return $self->SUPER::socket(@_) if not defined $self->fileno;

    # I hate core prototypes sometimes...
    socket( my $tmph, $_[0], $_[1], $_[2] ) or return undef;

    dup2( $tmph->fileno, $self->fileno ) or die "Unable to dup2 $tmph onto $self - $!";
 }

 # 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( eval($IO::Socket::VERSION) < 1.35 ) {
       *socktype = sub {
          my $self = shift;
          my $type = $self->SUPER::socktype;
          if( !defined $type ) {
             $type = $self->sockopt( Socket::SO_TYPE() );
          }
          return $type;
       };
    }
 }

 sub as_inet
 {
    my $self = shift;
    croak "Cannot downgrade a non-PF_INET socket to IO::Socket::INET" unless $self->sockdomain == AF_INET;
    return IO::Socket::INET->new_from_fd( $self->fileno, "r+" );
 }

 sub split_addr
 {
    shift;
    my ( $addr ) = @_;

    local ( $1, $2 ); # Placate a taint-related bug; [perl #67962]
    if( $addr =~ m/\A\[($IPv6_re)\](?::([^\s:]*))?\z/ or
        $addr =~ m/\A([^\s:]*):([^\s:]*)\z/ ) {
       return ( $1, $2 ) if defined $2 and length $2;
       return ( $1, undef );
    }

    return ( $addr, undef );
 }

 sub join_addr
 {
    shift;
    my ( $host, $port ) = @_;

    $host = "[$host]" if $host =~ m/:/;

    return join ":", $host, $port if defined $port;
    return $host;
 }

 # Since IO::Socket->new( Domain => ... ) will delete the Domain parameter
 # before calling ->configure, we need to keep track of which it was

 package # hide from indexer
    IO::Socket::IP::_ForINET;
 use base qw( IO::Socket::IP );

 sub configure
 {
    # This is evil
    my $self = shift;
    my ( $arg ) = @_;

    bless $self, "IO::Socket::IP";
    $self->configure( { %$arg, Family => Socket::AF_INET() } );
 }

 package # hide from indexer
    IO::Socket::IP::_ForINET6;
 use base qw( IO::Socket::IP );

 sub configure
 {
    # This is evil
    my $self = shift;
    my ( $arg ) = @_;

    bless $self, "IO::Socket::IP";
    $self->configure( { %$arg, Family => Socket::AF_INET6() } );
 }

 0x55AA;
	# 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-2015 -- leonerd@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.38';
	}

	use strict;
	use warnings;
	use base qw( IO::Socket );

	use Carp;

	use Socket 1.97 qw(
	getaddrinfo getnameinfo
	sockaddr_family
	AF_INET
	AI_PASSIVE
	IPPROTO_TCP IPPROTO_UDP
	IPPROTO_IPV6 IPV6_V6ONLY
	NI_DGRAM NI_NUMERICHOST NI_NUMERICSERV NIx_NOHOST NIx_NOSERV
	SO_REUSEADDR SO_REUSEPORT SO_BROADCAST SO_ERROR
	SOCK_DGRAM SOCK_STREAM
	SOL_SOCKET
	);
	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 ENOTCONN ETIMEDOUT EWOULDBLOCK );

	use constant HAVE_MSWIN32 => ( $^O eq "MSWin32" );

	# At least one OS (Android) is known not to have getprotobyname()
	use constant HAVE_GETPROTOBYNAME => defined eval { getprotobyname( "tcp" ) };

	my $IPv6_re = do {
	# translation of RFC 3986 3.2.2 ABNF to re
	my $IPv4address = do {
	my $dec_octet = q<(?:[0-9]\|[1-9][0-9]\|1[0-9][0-9]\|2[0-4][0-9]\|25[0-5])>;
	qq<$dec_octet(?: \\. $dec_octet){3}>;
	};
	my $IPv6address = do {
	my $h16 = qq<[0-9A-Fa-f]{1,4}>;
	my $ls32 = qq<(?: $h16 : $h16 \| $IPv4address)>;
	qq<(?:
	(?: $h16 : ){6} $ls32
	\| :: (?: $h16 : ){5} $ls32
	\| (?: $h16 )? :: (?: $h16 : ){4} $ls32
	\| (?: (?: $h16 : ){0,1} $h16 )? :: (?: $h16 : ){3} $ls32
	\| (?: (?: $h16 : ){0,2} $h16 )? :: (?: $h16 : ){2} $ls32
	\| (?: (?: $h16 : ){0,3} $h16 )? :: $h16 : $ls32
	\| (?: (?: $h16 : ){0,4} $h16 )? :: $ls32
	\| (?: (?: $h16 : ){0,5} $h16 )? :: $h16
	\| (?: (?: $h16 : ){0,6} $h16 )? ::
	)>
	};
	qr<$IPv6address>xo;
	};

	sub import
	{
	my $pkg = shift;
	my @symbols;

	foreach ( @_ ) {
	if( $_ eq "-register" ) {
	IO::Socket::IP::_ForINET->register_domain( AF_INET );
	IO::Socket::IP::_ForINET6->register_domain( $AF_INET6 ) if defined $AF_INET6;
	}
	else {
	push @symbols, $_;
	}
	}

	@_ = ( $pkg, @symbols );
	goto &IO::Socket::import;
	}

	# Convenient capability test function
	{
	my $can_disable_v6only;
	sub CAN_DISABLE_V6ONLY
	{
	return $can_disable_v6only if defined $can_disable_v6only;

	socket my $testsock, Socket::PF_INET6(), SOCK_STREAM, 0 or
	die "Cannot socket(PF_INET6) - $!";

	if( setsockopt $testsock, IPPROTO_IPV6, IPV6_V6ONLY, 0 ) {
	return $can_disable_v6only = 1;
	}
	elsif( $! == EINVAL ) {
	return $can_disable_v6only = 0;
	}
	else {
	die "Cannot setsockopt() - $!";
	}
	}
	}

	sub new
	{
	my $class = shift;
	my %arg = (@_ == 1) ? (PeerHost => $_[0]) : @_;
	return $class->SUPER::new(%arg);
	}

	# IO::Socket may call this one; neaten up the arguments from IO::Socket::INET
	# before calling our real _configure method
	sub configure
	{
	my $self = shift;
	my ( $arg ) = @_;

	$arg->{PeerHost} = delete $arg->{PeerAddr}
	if exists $arg->{PeerAddr} && !exists $arg->{PeerHost};

	$arg->{PeerService} = delete $arg->{PeerPort}
	if exists $arg->{PeerPort} && !exists $arg->{PeerService};

	$arg->{LocalHost} = delete $arg->{LocalAddr}
	if exists $arg->{LocalAddr} && !exists $arg->{LocalHost};

	$arg->{LocalService} = delete $arg->{LocalPort}
	if exists $arg->{LocalPort} && !exists $arg->{LocalService};

	for my $type (qw(Peer Local)) {
	my $host = $type . 'Host';
	my $service = $type . 'Service';

	if( defined $arg->{$host} ) {
	( $arg->{$host}, my $s ) = $self->split_addr( $arg->{$host} );
	# IO::Socket::INET compat - *Host parsed port always takes precedence
	$arg->{$service} = $s if defined $s;
	}
	}

	$self->_io_socket_ip__configure( $arg );
	}

	# Avoid simply calling it _configure, as some subclasses of IO::Socket::INET on CPAN already take that
	sub _io_socket_ip__configure
	{
	my $self = shift;
	my ( $arg ) = @_;

	my %hints;
	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};
	}
	else {
	$hints{flags} = $AI_ADDRCONFIG;
	}

	if( defined( my $family = $arg->{Family} ) ) {
	$hints{family} = $family;
	}

	if( defined( my $type = $arg->{Type} ) ) {
	$hints{socktype} = $type;
	}

	if( defined( my $proto = $arg->{Proto} ) ) {
	unless( $proto =~ m/^\d+$/ ) {
	my $protonum = HAVE_GETPROTOBYNAME
	? getprotobyname( $proto )
	: eval { Socket->${\"IPPROTO_\U$proto"}() };
	defined $protonum or croak "Unrecognised protocol $proto";
	$proto = $protonum;
	}

	$hints{protocol} = $proto;
	}

	# To maintain compatibility with IO::Socket::INET, imply a default of
	# SOCK_STREAM + IPPROTO_TCP if neither hint is given
	if( !defined $hints{socktype} and !defined $hints{protocol} ) {
	$hints{socktype} = SOCK_STREAM;
	$hints{protocol} = IPPROTO_TCP;
	}

	# Some OSes (NetBSD) don't seem to like just a protocol hint without a
	# socktype hint as well. We'll set a couple of common ones
	if( !defined $hints{socktype} and defined $hints{protocol} ) {
	$hints{socktype} = SOCK_STREAM if $hints{protocol} == IPPROTO_TCP;
	$hints{socktype} = SOCK_DGRAM if $hints{protocol} == IPPROTO_UDP;
	}

	if( my $info = $arg->{LocalAddrInfo} ) {
	ref $info eq "ARRAY" or croak "Expected 'LocalAddrInfo' to be an ARRAY ref";
	@localinfos = @$info;
	}
	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;

	my %localhints = %hints;
	$localhints{flags} \|= AI_PASSIVE;
	( my $err, @localinfos ) = getaddrinfo( $host, $service, \%localhints );

	if( $err and defined $fallback_port ) {
	( $err, @localinfos ) = getaddrinfo( $host, $fallback_port, \%localhints );
	}

	if( $err ) {
	$@ = "$err";
	$! = EINVAL;
	return;
	}
	}

	if( my $info = $arg->{PeerAddrInfo} ) {
	ref $info eq "ARRAY" or croak "Expected 'PeerAddrInfo' to be an ARRAY ref";
	@peerinfos = @$info;
	}
	elsif( defined $arg->{PeerHost} or defined $arg->{PeerService} ) {
	defined( my $host = $arg->{PeerHost} ) or
	croak "Expected 'PeerHost'";
	defined( my $service = $arg->{PeerService} ) or
	croak "Expected 'PeerService'";

	local $1; # Placate a taint-related bug; [perl #67962]
	defined $service and $service =~ s/\((\d+)\)$// and
	my $fallback_port = $1;

	( my $err, @peerinfos ) = getaddrinfo( $host, $service, \%hints );

	if( $err and defined $fallback_port ) {
	( $err, @peerinfos ) = getaddrinfo( $host, $fallback_port, \%hints );
	}

	if( $err ) {
	$@ = "$err";
	$! = EINVAL;
	return;
	}
	}

	my $INT_1 = pack "i", 1;

	my @sockopts_enabled;
	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 ( $level, $optname, $value ) = @$_;
	# TODO: consider more sanity checking on argument values

	defined $value or $value = $INT_1;
	push @sockopts_enabled, [ $level, $optname, $value ];
	}
	}

	my $blocking = $arg->{Blocking};
	defined $blocking or $blocking = 1;

	my $v6only = $arg->{V6Only};

	# IO::Socket::INET defines this key. IO::Socket::IP always implements the
	# behaviour it requests, so we can ignore it, unless the caller is for some
	# reason asking to disable it.
	if( defined $arg->{MultiHomed} and !$arg->{MultiHomed} ) {
	croak "Cannot disable the MultiHomed parameter";
	}

	my @infos;
	foreach my $local ( @localinfos ? @localinfos : {} ) {
	foreach my $peer ( @peerinfos ? @peerinfos : {} ) {
	next if defined $local->{family} and defined $peer->{family} and
	$local->{family} != $peer->{family};
	next if defined $local->{socktype} and defined $peer->{socktype} and
	$local->{socktype} != $peer->{socktype};
	next if defined $local->{protocol} and defined $peer->{protocol} and
	$local->{protocol} != $peer->{protocol};

	my $family = $local->{family} \|\| $peer->{family} or next;
	my $socktype = $local->{socktype} \|\| $peer->{socktype} or next;
	my $protocol = $local->{protocol} \|\| $peer->{protocol} \|\| 0;

	push @infos, {
	family => $family,
	socktype => $socktype,
	protocol => $protocol,
	localaddr => $local->{addr},
	peeraddr => $peer->{addr},
	};
	}
	}

	if( !@infos ) {
	# If there was a Family hint then create a plain unbound, unconnected socket
	if( defined $hints{family} ) {
	@infos = ( {
	family => $hints{family},
	socktype => $hints{socktype},
	protocol => $hints{protocol},
	} );
	}
	# If there wasn't, use getaddrinfo()'s AI_ADDRCONFIG side-effect to guess a
	# suitable family first.
	else {
	( my $err, @infos ) = getaddrinfo( "", "0", \%hints );
	if( $err ) {
	$@ = "$err";
	$! = EINVAL;
	return;
	}

	# We'll take all the @infos anyway, because some OSes (HPUX) are known to
	# ignore the AI_ADDRCONFIG hint and return AF_INET6 even if they don't
	# support them
	}
	}

	# In the nonblocking case, caller will be calling ->setup multiple times.
	# Store configuration in the object for the ->setup method
	# Yes, these are messy. Sorry, I can't help that...

	${*$self}{io_socket_ip_infos} = \@infos;

	${*$self}{io_socket_ip_idx} = -1;

	${*$self}{io_socket_ip_sockopts} = \@sockopts_enabled;
	${*$self}{io_socket_ip_v6only} = $v6only;
	${*$self}{io_socket_ip_listenqueue} = $listenqueue;
	${*$self}{io_socket_ip_blocking} = $blocking;

	${*$self}{io_socket_ip_errors} = [ undef, undef, undef ];

	# ->setup is allowed to return false in nonblocking mode
	$self->setup or !$blocking or return undef;

	return $self;
	}

	sub setup
	{
	my $self = shift;

	while(1) {
	${*$self}{io_socket_ip_idx}++;
	last if ${$self}{io_socket_ip_idx} >= @{ ${$self}{io_socket_ip_infos} };

	my $info = ${$self}{io_socket_ip_infos}->[${$self}{io_socket_ip_idx}];

	$self->socket( @{$info}{qw( family socktype protocol )} ) or
	( ${*$self}{io_socket_ip_errors}[2] = $!, next );

	$self->blocking( 0 ) unless ${*$self}{io_socket_ip_blocking};

	foreach my $sockopt ( @{ ${*$self}{io_socket_ip_sockopts} } ) {
	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 ) {
	my $v6only = ${*$self}{io_socket_ip_v6only};
	$self->setsockopt( IPPROTO_IPV6, IPV6_V6ONLY, pack "i", $v6only ) or ( $@ = "$!", return undef );
	}

	if( defined( my $addr = $info->{localaddr} ) ) {
	$self->bind( $addr ) or
	( ${*$self}{io_socket_ip_errors}[1] = $!, next );
	}

	if( defined( my $listenqueue = ${*$self}{io_socket_ip_listenqueue} ) ) {
	$self->listen( $listenqueue ) or ( $@ = "$!", return undef );
	}

	if( defined( my $addr = $info->{peeraddr} ) ) {
	if( $self->connect( $addr ) ) {
	$! = 0;
	return 1;
	}

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

	return 1;
	}

	# Pick the most appropriate error, stringified
	$! = ( grep defined, @{ ${*$self}{io_socket_ip_errors}} )[0];
	$@ = "$!";
	return undef;
	}

	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's connect()
	# directly

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

	# See if a connect attempt has just failed with an error
	if( my $errno = $self->getsockopt( SOL_SOCKET, SO_ERROR ) ) {
	delete ${*$self}{io_socket_ip_connect_in_progress};
	${*$self}{io_socket_ip_errors}[0] = $! = $errno;
	return $self->setup;
	}

	# No error, so either connect is still in progress, or has completed
	# successfully. We can tell by trying to connect() again; either it will
	# succeed or we'll get EISCONN (connected successfully), or EALREADY
	# (still in progress). This even works on MSWin32.
	my $addr = ${$self}{io_socket_ip_infos}[${$self}{io_socket_ip_idx}]{peeraddr};

	if( connect( $self, $addr ) or $! == EISCONN ) {
	delete ${*$self}{io_socket_ip_connect_in_progress};
	$! = 0;
	return 1;
	}
	else {
	$! = EINPROGRESS;
	return 0;
	}
	}

	sub connected
	{
	my $self = shift;
	return defined $self->fileno &&
	!${*$self}{io_socket_ip_connect_in_progress} &&
	defined getpeername( $self ); # ->peername caches, we need to detect disconnection
	}

	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 );
	croak "getnameinfo - $err" if $err;

	return ( $host, $service );
	}

	sub _unpack_sockaddr
	{
	my ( $addr ) = @_;
	my $family = sockaddr_family $addr;

	if( $family == AF_INET ) {
	return ( Socket::unpack_sockaddr_in( $addr ) )[1];
	}
	elsif( defined $AF_INET6 and $family == $AF_INET6 ) {
	return ( Socket::unpack_sockaddr_in6( $addr ) )[1];
	}
	else {
	croak "Unrecognised address family $family";
	}
	}

	sub sockhost_service
	{
	my $self = shift;
	my ( $numeric ) = @_;

	$self->_get_host_service( $self->sockname, $numeric ? NI_NUMERICHOST\|NI_NUMERICSERV : 0 );
	}

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

	sub sockaddr { my $self = shift; _unpack_sockaddr $self->sockname }

	sub peerhost_service
	{
	my $self = shift;
	my ( $numeric ) = @_;

	$self->_get_host_service( $self->peername, $numeric ? NI_NUMERICHOST\|NI_NUMERICSERV : 0 );
	}

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

	sub peeraddr { my $self = shift; _unpack_sockaddr $self->peername }

	# This unbelievably dodgy hack works around the bug that IO::Socket doesn't do
	# it
	# https://rt.cpan.org/Ticket/Display.html?id=61577
	sub accept
	{
	my $self = shift;
	my ( $new, $peer ) = $self->SUPER::accept( @_ ) or return;

	${$new}{$_} = ${$self}{$_} for qw( io_socket_domain io_socket_type io_socket_proto );

	return wantarray ? ( $new, $peer )
	: $new;
	}

	# This second unbelievably dodgy hack guarantees that $self->fileno doesn't
	# change, which is useful during nonblocking connect
	sub socket :method
	{
	my $self = shift;
	return $self->SUPER::socket(@_) if not defined $self->fileno;

	# I hate core prototypes sometimes...
	socket( my $tmph, $_[0], $_[1], $_[2] ) or return undef;

	dup2( $tmph->fileno, $self->fileno ) or die "Unable to dup2 $tmph onto $self - $!";
	}

	# 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( eval($IO::Socket::VERSION) < 1.35 ) {
	*socktype = sub {
	my $self = shift;
	my $type = $self->SUPER::socktype;
	if( !defined $type ) {
	$type = $self->sockopt( Socket::SO_TYPE() );
	}
	return $type;
	};
	}
	}

	sub as_inet
	{
	my $self = shift;
	croak "Cannot downgrade a non-PF_INET socket to IO::Socket::INET" unless $self->sockdomain == AF_INET;
	return IO::Socket::INET->new_from_fd( $self->fileno, "r+" );
	}

	sub split_addr
	{
	shift;
	my ( $addr ) = @_;

	local ( $1, $2 ); # Placate a taint-related bug; [perl #67962]
	if( $addr =~ m/\A\[($IPv6_re)\](?::([^\s:]*))?\z/ or
	$addr =~ m/\A([^\s:]):([^\s:])\z/ ) {
	return ( $1, $2 ) if defined $2 and length $2;
	return ( $1, undef );
	}

	return ( $addr, undef );
	}

	sub join_addr
	{
	shift;
	my ( $host, $port ) = @_;

	$host = "[$host]" if $host =~ m/:/;

	return join ":", $host, $port if defined $port;
	return $host;
	}

	# Since IO::Socket->new( Domain => ... ) will delete the Domain parameter
	# before calling ->configure, we need to keep track of which it was

	package # hide from indexer
	IO::Socket::IP::_ForINET;
	use base qw( IO::Socket::IP );

	sub configure
	{
	# This is evil
	my $self = shift;
	my ( $arg ) = @_;

	bless $self, "IO::Socket::IP";
	$self->configure( { %$arg, Family => Socket::AF_INET() } );
	}

	package # hide from indexer
	IO::Socket::IP::_ForINET6;
	use base qw( IO::Socket::IP );

	sub configure
	{
	# This is evil
	my $self = shift;
	my ( $arg ) = @_;

	bless $self, "IO::Socket::IP";
	$self->configure( { %$arg, Family => Socket::AF_INET6() } );
	}

	0x55AA;