<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">#  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-2020 -- leonerd@leonerd.org.uk

package IO::Socket::IP;

use v5;
use strict;
use warnings;

# $VERSION needs to be set before  use base 'IO::Socket'
#  - https://rt.cpan.org/Ticket/Display.html?id=92107
BEGIN {
   our $VERSION = '0.41_01';
   $VERSION = eval $VERSION;
}

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;
my $AI_NUMERICHOST = eval { Socket::AI_NUMERICHOST() } || 0;
use POSIX qw( dup2 );
use Errno qw( EINVAL EINPROGRESS EISCONN ENOTCONN ETIMEDOUT EWOULDBLOCK EOPNOTSUPP );

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

# At least one OS (Android) is known not to have getprotobyname()
use constant HAVE_GETPROTOBYNAME =&gt; 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&lt;(?:[0-9]|[1-9][0-9]|1[0-9][0-9]|2[0-4][0-9]|25[0-5])&gt;;
      qq&lt;$dec_octet(?: \\. $dec_octet){3}&gt;;
   };
   my $IPv6address = do {
      my $h16  = qq&lt;[0-9A-Fa-f]{1,4}&gt;;
      my $ls32 = qq&lt;(?: $h16 : $h16 | $IPv4address)&gt;;
      qq&lt;(?:
                                            (?: $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 )? ::
      )&gt;
   };
   qr&lt;$IPv6address&gt;xo;
};

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

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

   @_ = ( $pkg, @symbols );
   goto &amp;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 ) {
         if ($^O eq "dragonfly") {
            # dragonflybsd 6.4 lies about successfully turning this off
            if (getsockopt $testsock, IPPROTO_IPV6, IPV6_V6ONLY) {
               return $can_disable_v6only = 0;
            }
         }
         return $can_disable_v6only = 1;
      }
      elsif( $! == EINVAL || $! == EOPNOTSUPP ) {
         return $can_disable_v6only = 0;
      }
      else {
         die "Cannot setsockopt() - $!";
      }
   }
}

sub new
{
   my $class = shift;
   my %arg = (@_ == 1) ? (PeerHost =&gt; $_[0]) : @_;
   return $class-&gt;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-&gt;{PeerHost} = delete $arg-&gt;{PeerAddr}
      if exists $arg-&gt;{PeerAddr} &amp;&amp; !exists $arg-&gt;{PeerHost};

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

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

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

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

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

   $self-&gt;_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 $localflags;
   my $peerflags;
   my @localinfos;
   my @peerinfos;

   my $listenqueue = $arg-&gt;{Listen};
   if( defined $listenqueue and
       ( defined $arg-&gt;{PeerHost} || defined $arg-&gt;{PeerService} || defined $arg-&gt;{PeerAddrInfo} ) ) {
      croak "Cannot Listen with a peer address";
   }

   if( defined $arg-&gt;{GetAddrInfoFlags} ) {
      $hints{flags} = $arg-&gt;{GetAddrInfoFlags};
      $localflags  = $arg-&gt;{GetAddrInfoFlags};
      $peerflags  = $arg-&gt;{GetAddrInfoFlags};
   }
   else {
      if (defined $arg-&gt;{LocalHost} and $arg-&gt;{LocalHost} =~ /^\d+\.\d+\.\d+\.\d+$/) {
              $localflags = $AI_NUMERICHOST;
      } else {
              $localflags = $AI_ADDRCONFIG;
      }
      if (defined $arg-&gt;{PeerHost} and $arg-&gt;{PeerHost} =~ /^\d+\.\d+\.\d+\.\d+$/) {
              $peerflags = $AI_NUMERICHOST;
      } elsif (defined $arg-&gt;{PeerHost} and $arg-&gt;{PeerHost} ne 'localhost') {
              $peerflags = $AI_ADDRCONFIG;
      }
   }

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

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

   if( defined( my $proto = $arg-&gt;{Proto} ) ) {
      unless( $proto =~ m/^\d+$/ ) {
         my $protonum = HAVE_GETPROTOBYNAME
            ? getprotobyname( $proto )
            : eval { Socket-&gt;${\"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-&gt;{LocalAddrInfo} ) {
      ref $info eq "ARRAY" or croak "Expected 'LocalAddrInfo' to be an ARRAY ref";
      @localinfos = @$info;
   }
   elsif( defined $arg-&gt;{LocalHost} or
          defined $arg-&gt;{LocalService} or
          HAVE_MSWIN32 and $arg-&gt;{Listen} ) {
      # Either may be undef
      my $host = $arg-&gt;{LocalHost};
      my $service = $arg-&gt;{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} = $localflags;
      $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-&gt;{PeerAddrInfo} ) {
      ref $info eq "ARRAY" or croak "Expected 'PeerAddrInfo' to be an ARRAY ref";
      @peerinfos = @$info;
   }
   elsif( defined $arg-&gt;{PeerHost} or defined $arg-&gt;{PeerService} ) {
      defined( my $host = $arg-&gt;{PeerHost} ) or
         croak "Expected 'PeerHost'";
      defined( my $service = $arg-&gt;{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 %peerhints = %hints;
      $peerhints{flags} = $peerflags;
      ( my $err, @peerinfos ) = getaddrinfo( $host, $service, \%peerhints );

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

      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-&gt;{ReuseAddr};
   push @sockopts_enabled, [ SOL_SOCKET, SO_REUSEPORT, $INT_1 ] if $arg-&gt;{ReusePort};
   push @sockopts_enabled, [ SOL_SOCKET, SO_BROADCAST, $INT_1 ] if $arg-&gt;{Broadcast};

   if( my $sockopts = $arg-&gt;{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";
         @$_ &gt;= 2 and @$_ &lt;= 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-&gt;{Blocking};
   defined $blocking or $blocking = 1;

   my $v6only = $arg-&gt;{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-&gt;{MultiHomed} and !$arg-&gt;{MultiHomed} ) {
      croak "Cannot disable the MultiHomed parameter";
   }

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

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

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

   if( !@infos ) {
      # If there was a Family hint then create a plain unbound, unconnected socket
      if( defined $hints{family} ) {
         @infos = ( {
            family   =&gt; $hints{family},
            socktype =&gt; $hints{socktype},
            protocol =&gt; $hints{protocol},
         } );
      }
      # If there wasn't, use getaddrinfo()'s AI_ADDRCONFIG side-effect to guess a
      # suitable family first.
      else {
         $hints{flags} |= $AI_ADDRCONFIG;
         ( 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 -&gt;setup multiple times.
   # Store configuration in the object for the -&gt;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 ];

   # -&gt;setup is allowed to return false in nonblocking mode
   $self-&gt;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} &gt;= @{ ${*$self}{io_socket_ip_infos} };

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

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

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

      foreach my $sockopt ( @{ ${*$self}{io_socket_ip_sockopts} } ) {
         my ( $level, $optname, $value ) = @$sockopt;
         $self-&gt;setsockopt( $level, $optname, $value ) or ( $@ = "$!", return undef );
      }

      if( defined ${*$self}{io_socket_ip_v6only} and defined $AF_INET6 and $info-&gt;{family} == $AF_INET6 ) {
         my $v6only = ${*$self}{io_socket_ip_v6only};
         $self-&gt;setsockopt( IPPROTO_IPV6, IPV6_V6ONLY, pack "i", $v6only ) or ( $@ = "$!", return undef );
      }

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

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

      if( defined( my $addr = $info-&gt;{peeraddr} ) ) {
         if( $self-&gt;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-&gt;blocking( 0 );

      my $err = defined connect( $self, $addr ) ? 0 : $!+0;

      if( !$err ) {
         # All happy
         $self-&gt;blocking( $was_blocking );
         return 1;
      }
      elsif( not( $err == EINPROGRESS or $err == EWOULDBLOCK ) ) {
         # Failed for some other reason
         $self-&gt;blocking( $was_blocking );
         return undef;
      }
      elsif( !$was_blocking ) {
         # We shouldn't block anyway
         return undef;
      }

      my $vec = ''; vec( $vec, $self-&gt;fileno, 1 ) = 1;
      if( !select( undef, $vec, $vec, $timeout ) ) {
         $self-&gt;blocking( $was_blocking );
         $! = ETIMEDOUT;
         return undef;
      }

      # Hoist the error by connect()ing a second time
      $err = $self-&gt;getsockopt( SOL_SOCKET, SO_ERROR );
      $err = 0 if $err == EISCONN; # Some OSes give EISCONN

      $self-&gt;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-&gt;getsockopt( SOL_SOCKET, SO_ERROR ) ) {
      delete ${*$self}{io_socket_ip_connect_in_progress};
      ${*$self}{io_socket_ip_errors}[0] = $! = $errno;
      return $self-&gt;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-&gt;fileno &amp;&amp;
          !${*$self}{io_socket_ip_connect_in_progress} &amp;&amp;
          defined getpeername( $self ); # -&gt;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-&gt;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-&gt;_get_host_service( $self-&gt;sockname, $numeric ? NI_NUMERICHOST|NI_NUMERICSERV : 0 );
}

sub sockhost { my $self = shift; scalar +( $self-&gt;_get_host_service( $self-&gt;sockname, NI_NUMERICHOST, NIx_NOSERV ) )[0] }
sub sockport { my $self = shift; scalar +( $self-&gt;_get_host_service( $self-&gt;sockname, NI_NUMERICSERV, NIx_NOHOST ) )[1] }

sub sockhostname { my $self = shift; scalar +( $self-&gt;_get_host_service( $self-&gt;sockname, 0, NIx_NOSERV ) )[0] }
sub sockservice  { my $self = shift; scalar +( $self-&gt;_get_host_service( $self-&gt;sockname, 0, NIx_NOHOST ) )[1] }

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

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

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

sub peerhost { my $self = shift; scalar +( $self-&gt;_get_host_service( $self-&gt;peername, NI_NUMERICHOST, NIx_NOSERV ) )[0] }
sub peerport { my $self = shift; scalar +( $self-&gt;_get_host_service( $self-&gt;peername, NI_NUMERICSERV, NIx_NOHOST ) )[1] }

sub peerhostname { my $self = shift; scalar +( $self-&gt;_get_host_service( $self-&gt;peername, 0, NIx_NOSERV ) )[0] }
sub peerservice  { my $self = shift; scalar +( $self-&gt;_get_host_service( $self-&gt;peername, 0, NIx_NOHOST ) )[1] }

sub peeraddr { my $self = shift; _unpack_sockaddr $self-&gt;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-&gt;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-&gt;fileno doesn't
# change, which is useful during nonblocking connect
sub socket :method
{
   my $self = shift;
   return $self-&gt;SUPER::socket(@_) if not defined $self-&gt;fileno;

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

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

# Versions of IO::Socket before 1.35 may leave socktype undef if from, say, an
#   -&gt;fdopen call. In this case we'll apply a fix
BEGIN {
   if( eval($IO::Socket::VERSION) &lt; 1.35 ) {
      *socktype = sub {
         my $self = shift;
         my $type = $self-&gt;SUPER::socktype;
         if( !defined $type ) {
            $type = $self-&gt;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-&gt;sockdomain == AF_INET;
   return IO::Socket::INET-&gt;new_from_fd( $self-&gt;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-&gt;new( Domain =&gt; ... ) will delete the Domain parameter
# before calling -&gt;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-&gt;configure( { %$arg, Family =&gt; 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-&gt;configure( { %$arg, Family =&gt; Socket::AF_INET6() } );
}

0x55AA;
</pre></body></html>