cpan/IO-Socket-IP/lib/IO/Socket/IP.pm

   1 #  You may distribute under the terms of either the GNU General Public License
   2 #  or the Artistic License (the same terms as Perl itself)
   3 #
   4 #  (C) Paul Evans, 2010-2014 -- leonerd@leonerd.org.uk
   5
   6 package IO::Socket::IP;
   7 # $VERSION needs to be set before  use base 'IO::Socket'
   8 #  - https://rt.cpan.org/Ticket/Display.html?id=92107
   9 BEGIN {
  10    $VERSION = '0.32';
  11 }
  12
  13 use strict;
  14 use warnings;
  15 use base qw( IO::Socket );
  16
  17 use Carp;
  18
  19 use Socket 1.97 qw(
  20    getaddrinfo getnameinfo
  21    sockaddr_family
  22    AF_INET
  23    AI_PASSIVE
  24    IPPROTO_TCP IPPROTO_UDP
  25    IPPROTO_IPV6 IPV6_V6ONLY
  26    NI_DGRAM NI_NUMERICHOST NI_NUMERICSERV NIx_NOHOST NIx_NOSERV
  27    SO_REUSEADDR SO_REUSEPORT SO_BROADCAST SO_ERROR
  28    SOCK_DGRAM SOCK_STREAM
  29    SOL_SOCKET
  30 );
  31 my $AF_INET6 = eval { Socket::AF_INET6() }; # may not be defined
  32 my $AI_ADDRCONFIG = eval { Socket::AI_ADDRCONFIG() } || 0;
  33 use POSIX qw( dup2 );
  34 use Errno qw( EINVAL EINPROGRESS EISCONN ETIMEDOUT EWOULDBLOCK );
  35
  36 use constant HAVE_MSWIN32 => ( $^O eq "MSWin32" );
  37
  38 # At least one OS (Android) is known not to have getprotobyname()
  39 use constant HAVE_GETPROTOBYNAME => defined eval { getprotobyname( "tcp" ) };
  40
  41 my $IPv6_re = do {
  42    # translation of RFC 3986 3.2.2 ABNF to re
  43    my $IPv4address = do {
  44       my $dec_octet = q<(?:[0-9]|[1-9][0-9]|1[0-9][0-9]|2[0-4][0-9]|25[0-5])>;
  45       qq<$dec_octet(?: \\. $dec_octet){3}>;
  46    };
  47    my $IPv6address = do {
  48       my $h16  = qq<[0-9A-Fa-f]{1,4}>;
  49       my $ls32 = qq<(?: $h16 : $h16 | $IPv4address)>;
  50       qq<(?:
  51                                             (?: $h16 : ){6} $ls32
  52          |                               :: (?: $h16 : ){5} $ls32
  53          | (?:                   $h16 )? :: (?: $h16 : ){4} $ls32
  54          | (?: (?: $h16 : ){0,1} $h16 )? :: (?: $h16 : ){3} $ls32
  55          | (?: (?: $h16 : ){0,2} $h16 )? :: (?: $h16 : ){2} $ls32
  56          | (?: (?: $h16 : ){0,3} $h16 )? ::     $h16 :      $ls32
  57          | (?: (?: $h16 : ){0,4} $h16 )? ::                 $ls32
  58          | (?: (?: $h16 : ){0,5} $h16 )? ::                 $h16
  59          | (?: (?: $h16 : ){0,6} $h16 )? ::
  60       )>
  61    };
  62    qr<$IPv6address>xo;
  63 };
  64
  65 =head1 NAME
  66
  67 C<IO::Socket::IP> - Family-neutral IP socket supporting both IPv4 and IPv6
  68
  69 =head1 SYNOPSIS
  70
  71  use IO::Socket::IP;
  72
  73  my $sock = IO::Socket::IP->new(
  74     PeerHost => "www.google.com",
  75     PeerPort => "http",
  76     Type     => SOCK_STREAM,
  77  ) or die "Cannot construct socket - $@";
  78
  79  my $familyname = ( $sock->sockdomain == PF_INET6 ) ? "IPv6" :
  80                   ( $sock->sockdomain == PF_INET  ) ? "IPv4" :
  81                                                       "unknown";
  82
  83  printf "Connected to google via %s\n", $familyname;
  84
  85 =head1 DESCRIPTION
  86
  87 This module provides a protocol-independent way to use IPv4 and IPv6 sockets,
  88 intended as a replacement for L<IO::Socket::INET>. Most constructor arguments
  89 and methods are provided in a backward-compatible way. For a list of known
  90 differences, see the C<IO::Socket::INET> INCOMPATIBILITES section below.
  91
  92 It uses the C<getaddrinfo(3)> function to convert hostnames and service names
  93 or port numbers into sets of possible addresses to connect to or listen on.
  94 This allows it to work for IPv6 where the system supports it, while still
  95 falling back to IPv4-only on systems which don't.
  96
  97 =head1 REPLACING C<IO::Socket> DEFAULT BEHAVIOUR
  98
  99 By placing C<-register> in the import list, L<IO::Socket> uses
 100 C<IO::Socket::IP> rather than C<IO::Socket::INET> as the class that handles
 101 C<PF_INET>.  C<IO::Socket> will also use C<IO::Socket::IP> rather than
 102 C<IO::Socket::INET6> to handle C<PF_INET6>, provided that the C<AF_INET6>
 103 constant is available.
 104
 105 Changing C<IO::Socket>'s default behaviour means that calling the
 106 C<IO::Socket> constructor with either C<PF_INET> or C<PF_INET6> as the
 107 C<Domain> parameter will yield an C<IO::Socket::IP> object.
 108
 109  use IO::Socket::IP -register;
 110
 111  my $sock = IO::Socket->new(
 112     Domain    => PF_INET6,
 113     LocalHost => "::1",
 114     Listen    => 1,
 115  ) or die "Cannot create socket - $@\n";
 116
 117  print "Created a socket of type " . ref($sock) . "\n";
 118
 119 Note that C<-register> is a global setting that applies to the entire program;
 120 it cannot be applied only for certain callers, removed, or limited by lexical
 121 scope.
 122
 123 =cut
 124
 125 sub import
 126 {
 127    my $pkg = shift;
 128    my @symbols;
 129
 130    foreach ( @_ ) {
 131       if( $_ eq "-register" ) {
 132          IO::Socket::IP::_ForINET->register_domain( AF_INET );
 133          IO::Socket::IP::_ForINET6->register_domain( $AF_INET6 ) if defined $AF_INET6;
 134       }
 135       else {
 136          push @symbols, $_;
 137       }
 138    }
 139
 140    @_ = ( $pkg, @symbols );
 141    goto &IO::Socket::import;
 142 }
 143
 144 # Convenient capability test function
 145 {
 146    my $can_disable_v6only;
 147    sub CAN_DISABLE_V6ONLY
 148    {
 149       return $can_disable_v6only if defined $can_disable_v6only;
 150
 151       socket my $testsock, Socket::PF_INET6(), SOCK_STREAM, 0 or
 152          die "Cannot socket(PF_INET6) - $!";
 153
 154       if( setsockopt $testsock, IPPROTO_IPV6, IPV6_V6ONLY, 0 ) {
 155          return $can_disable_v6only = 1;
 156       }
 157       elsif( $! == EINVAL ) {
 158          return $can_disable_v6only = 0;
 159       }
 160       else {
 161          die "Cannot setsockopt() - $!";
 162       }
 163    }
 164 }
 165
 166 =head1 CONSTRUCTORS
 167
 168 =cut
 169
 170 =head2 $sock = IO::Socket::IP->new( %args )
 171
 172 Creates a new C<IO::Socket::IP> object, containing a newly created socket
 173 handle according to the named arguments passed. The recognised arguments are:
 174
 175 =over 8
 176
 177 =item PeerHost => STRING
 178
 179 =item PeerService => STRING
 180
 181 Hostname and service name for the peer to C<connect()> to. The service name
 182 may be given as a port number, as a decimal string.
 183
 184 =item PeerAddr => STRING
 185
 186 =item PeerPort => STRING
 187
 188 For symmetry with the accessor methods and compatibility with
 189 C<IO::Socket::INET>, these are accepted as synonyms for C<PeerHost> and
 190 C<PeerService> respectively.
 191
 192 =item PeerAddrInfo => ARRAY
 193
 194 Alternate form of specifying the peer to C<connect()> to. This should be an
 195 array of the form returned by C<Socket::getaddrinfo>.
 196
 197 This parameter takes precedence over the C<Peer*>, C<Family>, C<Type> and
 198 C<Proto> arguments.
 199
 200 =item LocalHost => STRING
 201
 202 =item LocalService => STRING
 203
 204 Hostname and service name for the local address to C<bind()> to.
 205
 206 =item LocalAddr => STRING
 207
 208 =item LocalPort => STRING
 209
 210 For symmetry with the accessor methods and compatibility with
 211 C<IO::Socket::INET>, these are accepted as synonyms for C<LocalHost> and
 212 C<LocalService> respectively.
 213
 214 =item LocalAddrInfo => ARRAY
 215
 216 Alternate form of specifying the local address to C<bind()> to. This should be
 217 an array of the form returned by C<Socket::getaddrinfo>.
 218
 219 This parameter takes precedence over the C<Local*>, C<Family>, C<Type> and
 220 C<Proto> arguments.
 221
 222 =item Family => INT
 223
 224 The address family to pass to C<getaddrinfo> (e.g. C<AF_INET>, C<AF_INET6>).
 225 Normally this will be left undefined, and C<getaddrinfo> will search using any
 226 address family supported by the system.
 227
 228 =item Type => INT
 229
 230 The socket type to pass to C<getaddrinfo> (e.g. C<SOCK_STREAM>,
 231 C<SOCK_DGRAM>). Normally defined by the caller; if left undefined
 232 C<getaddrinfo> may attempt to infer the type from the service name.
 233
 234 =item Proto => STRING or INT
 235
 236 The IP protocol to use for the socket (e.g. C<'tcp'>, C<IPPROTO_TCP>,
 237 C<'udp'>,C<IPPROTO_UDP>). Normally this will be left undefined, and either
 238 C<getaddrinfo> or the kernel will choose an appropriate value. May be given
 239 either in string name or numeric form.
 240
 241 =item GetAddrInfoFlags => INT
 242
 243 More flags to pass to the C<getaddrinfo()> function. If not supplied, a
 244 default of C<AI_ADDRCONFIG> will be used.
 245
 246 These flags will be combined with C<AI_PASSIVE> if the C<Listen> argument is
 247 given. For more information see the documentation about C<getaddrinfo()> in
 248 the L<Socket> module.
 249
 250 =item Listen => INT
 251
 252 If defined, puts the socket into listening mode where new connections can be
 253 accepted using the C<accept> method. The value given is used as the
 254 C<listen(2)> queue size.
 255
 256 =item ReuseAddr => BOOL
 257
 258 If true, set the C<SO_REUSEADDR> sockopt
 259
 260 =item ReusePort => BOOL
 261
 262 If true, set the C<SO_REUSEPORT> sockopt (not all OSes implement this sockopt)
 263
 264 =item Broadcast => BOOL
 265
 266 If true, set the C<SO_BROADCAST> sockopt
 267
 268 =item V6Only => BOOL
 269
 270 If defined, set the C<IPV6_V6ONLY> sockopt when creating C<PF_INET6> sockets
 271 to the given value. If true, a listening-mode socket will only listen on the
 272 C<AF_INET6> addresses; if false it will also accept connections from
 273 C<AF_INET> addresses.
 274
 275 If not defined, the socket option will not be changed, and default value set
 276 by the operating system will apply. For repeatable behaviour across platforms
 277 it is recommended this value always be defined for listening-mode sockets.
 278
 279 Note that not all platforms support disabling this option. Some, at least
 280 OpenBSD and MirBSD, will fail with C<EINVAL> if you attempt to disable it.
 281 To determine whether it is possible to disable, you may use the class method
 282
 283  if( IO::Socket::IP->CAN_DISABLE_V6ONLY ) {
 284     ...
 285  }
 286  else {
 287     ...
 288  }
 289
 290 If your platform does not support disabling this option but you still want to
 291 listen for both C<AF_INET> and C<AF_INET6> connections you will have to create
 292 two listening sockets, one bound to each protocol.
 293
 294 =item MultiHomed
 295
 296 This C<IO::Socket::INET>-style argument is ignored, except if it is defined
 297 but false. See the C<IO::Socket::INET> INCOMPATIBILITES section below.
 298
 299 However, the behaviour it enables is always performed by C<IO::Socket::IP>.
 300
 301 =item Blocking => BOOL
 302
 303 If defined but false, the socket will be set to non-blocking mode. Otherwise
 304 it will default to blocking mode. See the NON-BLOCKING section below for more
 305 detail.
 306
 307 =item Timeout => NUM
 308
 309 If defined, gives a maximum time in seconds to block per C<connect()> call
 310 when in blocking mode. If missing, no timeout is applied other than that
 311 provided by the underlying operating system. When in non-blocking mode this
 312 parameter is ignored.
 313
 314 Note that if the hostname resolves to multiple address candidates, the same
 315 timeout will apply to each connection attempt individually, rather than to the
 316 operation as a whole. Further note that the timeout does not apply to the
 317 initial hostname resolve operation, if connecting by hostname.
 318
 319 This behviour is copied inspired by C<IO::Socket::INET>; for more fine grained
 320 control over connection timeouts, consider performing a nonblocking connect
 321 directly.
 322
 323 =back
 324
 325 If neither C<Type> nor C<Proto> hints are provided, a default of
 326 C<SOCK_STREAM> and C<IPPROTO_TCP> respectively will be set, to maintain
 327 compatibility with C<IO::Socket::INET>. Other named arguments that are not
 328 recognised are ignored.
 329
 330 If neither C<Family> nor any hosts or addresses are passed, nor any
 331 C<*AddrInfo>, then the constructor has no information on which to decide a
 332 socket family to create. In this case, it performs a C<getaddinfo> call with
 333 the C<AI_ADDRCONFIG> flag, no host name, and a service name of C<"0">, and
 334 uses the family of the first returned result.
 335
 336 If the constructor fails, it will set C<$@> to an appropriate error message;
 337 this may be from C<$!> or it may be some other string; not every failure
 338 necessarily has an associated C<errno> value.
 339
 340 =head2 $sock = IO::Socket::IP->new( $peeraddr )
 341
 342 As a special case, if the constructor is passed a single argument (as
 343 opposed to an even-sized list of key/value pairs), it is taken to be the value
 344 of the C<PeerAddr> parameter. This is parsed in the same way, according to the
 345 behaviour given in the C<PeerHost> AND C<LocalHost> PARSING section below.
 346
 347 =cut
 348
 349 sub new
 350 {
 351    my $class = shift;
 352    my %arg = (@_ == 1) ? (PeerHost => $_[0]) : @_;
 353    return $class->SUPER::new(%arg);
 354 }
 355
 356 # IO::Socket may call this one; neaten up the arguments from IO::Socket::INET
 357 # before calling our real _configure method
 358 sub configure
 359 {
 360    my $self = shift;
 361    my ( $arg ) = @_;
 362
 363    $arg->{PeerHost} = delete $arg->{PeerAddr}
 364       if exists $arg->{PeerAddr} && !exists $arg->{PeerHost};
 365
 366    $arg->{PeerService} = delete $arg->{PeerPort}
 367       if exists $arg->{PeerPort} && !exists $arg->{PeerService};
 368
 369    $arg->{LocalHost} = delete $arg->{LocalAddr}
 370       if exists $arg->{LocalAddr} && !exists $arg->{LocalHost};
 371
 372    $arg->{LocalService} = delete $arg->{LocalPort}
 373       if exists $arg->{LocalPort} && !exists $arg->{LocalService};
 374
 375    for my $type (qw(Peer Local)) {
 376       my $host    = $type . 'Host';
 377       my $service = $type . 'Service';
 378
 379       if( defined $arg->{$host} ) {
 380          ( $arg->{$host}, my $s ) = $self->split_addr( $arg->{$host} );
 381          # IO::Socket::INET compat - *Host parsed port always takes precedence
 382          $arg->{$service} = $s if defined $s;
 383       }
 384    }
 385
 386    $self->_io_socket_ip__configure( $arg );
 387 }
 388
 389 # Avoid simply calling it _configure, as some subclasses of IO::Socket::INET on CPAN already take that
 390 sub _io_socket_ip__configure
 391 {
 392    my $self = shift;
 393    my ( $arg ) = @_;
 394
 395    my %hints;
 396    my @localinfos;
 397    my @peerinfos;
 398
 399    if( defined $arg->{GetAddrInfoFlags} ) {
 400       $hints{flags} = $arg->{GetAddrInfoFlags};
 401    }
 402    else {
 403       $hints{flags} = $AI_ADDRCONFIG;
 404    }
 405
 406    if( defined( my $family = $arg->{Family} ) ) {
 407       $hints{family} = $family;
 408    }
 409
 410    if( defined( my $type = $arg->{Type} ) ) {
 411       $hints{socktype} = $type;
 412    }
 413
 414    if( defined( my $proto = $arg->{Proto} ) ) {
 415       unless( $proto =~ m/^\d+$/ ) {
 416          my $protonum = HAVE_GETPROTOBYNAME
 417             ? getprotobyname( $proto )
 418             : eval { Socket->${\"IPPROTO_\U$proto"}() };
 419          defined $protonum or croak "Unrecognised protocol $proto";
 420          $proto = $protonum;
 421       }
 422
 423       $hints{protocol} = $proto;
 424    }
 425
 426    # To maintain compatibility with IO::Socket::INET, imply a default of
 427    # SOCK_STREAM + IPPROTO_TCP if neither hint is given
 428    if( !defined $hints{socktype} and !defined $hints{protocol} ) {
 429       $hints{socktype} = SOCK_STREAM;
 430       $hints{protocol} = IPPROTO_TCP;
 431    }
 432
 433    # Some OSes (NetBSD) don't seem to like just a protocol hint without a
 434    # socktype hint as well. We'll set a couple of common ones
 435    if( !defined $hints{socktype} and defined $hints{protocol} ) {
 436       $hints{socktype} = SOCK_STREAM if $hints{protocol} == IPPROTO_TCP;
 437       $hints{socktype} = SOCK_DGRAM  if $hints{protocol} == IPPROTO_UDP;
 438    }
 439
 440    if( my $info = $arg->{LocalAddrInfo} ) {
 441       ref $info eq "ARRAY" or croak "Expected 'LocalAddrInfo' to be an ARRAY ref";
 442       @localinfos = @$info;
 443    }
 444    elsif( defined $arg->{LocalHost} or defined $arg->{LocalService} ) {
 445       # Either may be undef
 446       my $host = $arg->{LocalHost};
 447       my $service = $arg->{LocalService};
 448
 449       local $1; # Placate a taint-related bug; [perl #67962]
 450       defined $service and $service =~ s/\((\d+)\)$// and
 451          my $fallback_port = $1;
 452
 453       my %localhints = %hints;
 454       $localhints{flags} |= AI_PASSIVE;
 455       ( my $err, @localinfos ) = getaddrinfo( $host, $service, \%localhints );
 456
 457       if( $err and defined $fallback_port ) {
 458          ( $err, @localinfos ) = getaddrinfo( $host, $fallback_port, \%localhints );
 459       }
 460
 461       if( $err ) {
 462          $@ = "$err";
 463          $! = EINVAL;
 464          return;
 465       }
 466    }
 467
 468    if( my $info = $arg->{PeerAddrInfo} ) {
 469       ref $info eq "ARRAY" or croak "Expected 'PeerAddrInfo' to be an ARRAY ref";
 470       @peerinfos = @$info;
 471    }
 472    elsif( defined $arg->{PeerHost} or defined $arg->{PeerService} ) {
 473       defined( my $host = $arg->{PeerHost} ) or
 474          croak "Expected 'PeerHost'";
 475       defined( my $service = $arg->{PeerService} ) or
 476          croak "Expected 'PeerService'";
 477
 478       local $1; # Placate a taint-related bug; [perl #67962]
 479       defined $service and $service =~ s/\((\d+)\)$// and
 480          my $fallback_port = $1;
 481
 482       ( my $err, @peerinfos ) = getaddrinfo( $host, $service, \%hints );
 483
 484       if( $err and defined $fallback_port ) {
 485          ( $err, @peerinfos ) = getaddrinfo( $host, $fallback_port, \%hints );
 486       }
 487
 488       if( $err ) {
 489          $@ = "$err";
 490          $! = EINVAL;
 491          return;
 492       }
 493    }
 494
 495    my @sockopts_enabled;
 496    push @sockopts_enabled, SO_REUSEADDR if $arg->{ReuseAddr};
 497    push @sockopts_enabled, SO_REUSEPORT if $arg->{ReusePort};
 498    push @sockopts_enabled, SO_BROADCAST if $arg->{Broadcast};
 499
 500    my $listenqueue = $arg->{Listen};
 501
 502    croak "Cannot Listen with a PeerHost" if defined $listenqueue and @peerinfos;
 503
 504    my $blocking = $arg->{Blocking};
 505    defined $blocking or $blocking = 1;
 506
 507    my $v6only = $arg->{V6Only};
 508
 509    # IO::Socket::INET defines this key. IO::Socket::IP always implements the
 510    # behaviour it requests, so we can ignore it, unless the caller is for some
 511    # reason asking to disable it.
 512    if( defined $arg->{MultiHomed} and !$arg->{MultiHomed} ) {
 513       croak "Cannot disable the MultiHomed parameter";
 514    }
 515
 516    my @infos;
 517    foreach my $local ( @localinfos ? @localinfos : {} ) {
 518       foreach my $peer ( @peerinfos ? @peerinfos : {} ) {
 519          next if defined $local->{family}   and defined $peer->{family}   and
 520             $local->{family} != $peer->{family};
 521          next if defined $local->{socktype} and defined $peer->{socktype} and
 522             $local->{socktype} != $peer->{socktype};
 523          next if defined $local->{protocol} and defined $peer->{protocol} and
 524             $local->{protocol} != $peer->{protocol};
 525
 526          my $family   = $local->{family}   || $peer->{family}   or next;
 527          my $socktype = $local->{socktype} || $peer->{socktype} or next;
 528          my $protocol = $local->{protocol} || $peer->{protocol} || 0;
 529
 530          push @infos, {
 531             family    => $family,
 532             socktype  => $socktype,
 533             protocol  => $protocol,
 534             localaddr => $local->{addr},
 535             peeraddr  => $peer->{addr},
 536          };
 537       }
 538    }
 539
 540    if( !@infos ) {
 541       # If there was a Family hint then create a plain unbound, unconnected socket
 542       if( defined $hints{family} ) {
 543          @infos = ( {
 544             family   => $hints{family},
 545             socktype => $hints{socktype},
 546             protocol => $hints{protocol},
 547          } );
 548       }
 549       # If there wasn't, use getaddrinfo()'s AI_ADDRCONFIG side-effect to guess a
 550       # suitable family first.
 551       else {
 552          ( my $err, @infos ) = getaddrinfo( "", "0", \%hints );
 553          if( $err ) {
 554             $@ = "$err";
 555             $! = EINVAL;
 556             return;
 557          }
 558
 559          # We'll take all the @infos anyway, because some OSes (HPUX) are known to
 560          # ignore the AI_ADDRCONFIG hint and return AF_INET6 even if they don't
 561          # support them
 562       }
 563    }
 564
 565    # In the nonblocking case, caller will be calling ->setup multiple times.
 566    # Store configuration in the object for the ->setup method
 567    # Yes, these are messy. Sorry, I can't help that...
 568
 569    ${*$self}{io_socket_ip_infos} = \@infos;
 570
 571    ${*$self}{io_socket_ip_idx} = -1;
 572
 573    ${*$self}{io_socket_ip_sockopts} = \@sockopts_enabled;
 574    ${*$self}{io_socket_ip_v6only} = $v6only;
 575    ${*$self}{io_socket_ip_listenqueue} = $listenqueue;
 576    ${*$self}{io_socket_ip_blocking} = $blocking;
 577
 578    ${*$self}{io_socket_ip_errors} = [ undef, undef, undef ];
 579
 580    # ->setup is allowed to return false in nonblocking mode
 581    $self->setup or !$blocking or return undef;
 582
 583    return $self;
 584 }
 585
 586 sub setup
 587 {
 588    my $self = shift;
 589
 590    while(1) {
 591       ${*$self}{io_socket_ip_idx}++;
 592       last if ${*$self}{io_socket_ip_idx} >= @{ ${*$self}{io_socket_ip_infos} };
 593
 594       my $info = ${*$self}{io_socket_ip_infos}->[${*$self}{io_socket_ip_idx}];
 595
 596       $self->socket( @{$info}{qw( family socktype protocol )} ) or
 597          ( ${*$self}{io_socket_ip_errors}[2] = $!, next );
 598
 599       $self->blocking( 0 ) unless ${*$self}{io_socket_ip_blocking};
 600
 601       foreach my $sockopt ( @{ ${*$self}{io_socket_ip_sockopts} } ) {
 602          $self->setsockopt( SOL_SOCKET, $sockopt, pack "i", 1 ) or ( $@ = "$!", return undef );
 603       }
 604
 605       if( defined ${*$self}{io_socket_ip_v6only} and defined $AF_INET6 and $info->{family} == $AF_INET6 ) {
 606          my $v6only = ${*$self}{io_socket_ip_v6only};
 607          $self->setsockopt( IPPROTO_IPV6, IPV6_V6ONLY, pack "i", $v6only ) or ( $@ = "$!", return undef );
 608       }
 609
 610       if( defined( my $addr = $info->{localaddr} ) ) {
 611          $self->bind( $addr ) or
 612             ( ${*$self}{io_socket_ip_errors}[1] = $!, next );
 613       }
 614
 615       if( defined( my $listenqueue = ${*$self}{io_socket_ip_listenqueue} ) ) {
 616          $self->listen( $listenqueue ) or ( $@ = "$!", return undef );
 617       }
 618
 619       if( defined( my $addr = $info->{peeraddr} ) ) {
 620          if( $self->connect( $addr ) ) {
 621             $! = 0;
 622             return 1;
 623          }
 624
 625          if( $! == EINPROGRESS or HAVE_MSWIN32 && $! == Errno::EWOULDBLOCK() ) {
 626             ${*$self}{io_socket_ip_connect_in_progress} = 1;
 627             return 0;
 628          }
 629
 630          # If connect failed but we have no system error there must be an error
 631          # at the application layer, like a bad certificate with
 632          # IO::Socket::SSL.
 633          # In this case don't continue IP based multi-homing because the problem
 634          # cannot be solved at the IP layer.
 635          return 0 if ! $!;
 636
 637          ${*$self}{io_socket_ip_errors}[0] = $!;
 638          next;
 639       }
 640
 641       return 1;
 642    }
 643
 644    # Pick the most appropriate error, stringified
 645    $! = ( grep defined, @{ ${*$self}{io_socket_ip_errors}} )[0];
 646    $@ = "$!";
 647    return undef;
 648 }
 649
 650 sub connect
 651 {
 652    my $self = shift;
 653
 654    # It seems that IO::Socket hides EINPROGRESS errors, making them look like
 655    # a success. This is annoying here.
 656    # Instead of putting up with its frankly-irritating intentional breakage of
 657    # useful APIs I'm just going to end-run around it and call CORE::connect()
 658    # directly
 659
 660    if( @_ ) {
 661       my ( $addr ) = @_;
 662
 663       # Annoyingly IO::Socket's connect() is where the timeout logic is
 664       # implemented, so we'll have to reinvent it here
 665       my $timeout = ${*$self}{'io_socket_timeout'};
 666
 667       return CORE::connect( $self, $addr ) unless defined $timeout;
 668
 669       my $was_blocking = $self->blocking( 0 );
 670
 671       my $err = defined CORE::connect( $self, $addr ) ? 0 : $!+0;
 672
 673       if( !$err ) {
 674          # All happy
 675          return 1;
 676       }
 677       elsif( not( $err == EINPROGRESS or $err == EWOULDBLOCK ) ) {
 678          # Failed for some other reason
 679          return undef;
 680       }
 681       elsif( !$was_blocking ) {
 682          # We shouldn't block anyway
 683          return undef;
 684       }
 685
 686       my $vec = ''; vec( $vec, $self->fileno, 1 ) = 1;
 687       if( !select( $vec, $vec, $vec, $timeout ) ) {
 688          $! = ETIMEDOUT;
 689          return undef;
 690       }
 691
 692       # Hoist the error by connect()ing a second time
 693       $err = defined CORE::connect( $self, $addr ) ? 0 : $!+0;
 694       $err = 0 if $err == EISCONN; # Some OSes give EISCONN
 695
 696       $self->blocking( $was_blocking );
 697
 698       $! = $err, return undef if $err;
 699       return 1;
 700    }
 701
 702    return 1 if !${*$self}{io_socket_ip_connect_in_progress};
 703
 704    # See if a connect attempt has just failed with an error
 705    if( my $errno = $self->getsockopt( SOL_SOCKET, SO_ERROR ) ) {
 706       delete ${*$self}{io_socket_ip_connect_in_progress};
 707       ${*$self}{io_socket_ip_errors}[0] = $! = $errno;
 708       return $self->setup;
 709    }
 710
 711    # No error, so either connect is still in progress, or has completed
 712    # successfully. We can tell by trying to connect() again; either it will
 713    # succeed or we'll get EISCONN (connected successfully), or EALREADY
 714    # (still in progress). This even works on MSWin32.
 715    my $addr = ${*$self}{io_socket_ip_infos}[${*$self}{io_socket_ip_idx}]{peeraddr};
 716
 717    if( CORE::connect( $self, $addr ) or $! == EISCONN ) {
 718       delete ${*$self}{io_socket_ip_connect_in_progress};
 719       $! = 0;
 720       return 1;
 721    }
 722    else {
 723       $! = EINPROGRESS;
 724       return 0;
 725    }
 726 }
 727
 728 sub connected
 729 {
 730    my $self = shift;
 731    return defined $self->fileno &&
 732           !${*$self}{io_socket_ip_connect_in_progress} &&
 733           defined getpeername( $self ); # ->peername caches, we need to detect disconnection
 734 }
 735
 736 =head1 METHODS
 737
 738 As well as the following methods, this class inherits all the methods in
 739 L<IO::Socket> and L<IO::Handle>.
 740
 741 =cut
 742
 743 sub _get_host_service
 744 {
 745    my $self = shift;
 746    my ( $addr, $flags, $xflags ) = @_;
 747
 748    $flags |= NI_DGRAM if $self->socktype == SOCK_DGRAM;
 749
 750    my ( $err, $host, $service ) = getnameinfo( $addr, $flags, $xflags || 0 );
 751    croak "getnameinfo - $err" if $err;
 752
 753    return ( $host, $service );
 754 }
 755
 756 sub _unpack_sockaddr
 757 {
 758    my ( $addr ) = @_;
 759    my $family = sockaddr_family $addr;
 760
 761    if( $family == AF_INET ) {
 762       return ( Socket::unpack_sockaddr_in( $addr ) )[1];
 763    }
 764    elsif( defined $AF_INET6 and $family == $AF_INET6 ) {
 765       return ( Socket::unpack_sockaddr_in6( $addr ) )[1];
 766    }
 767    else {
 768       croak "Unrecognised address family $family";
 769    }
 770 }
 771
 772 =head2 ( $host, $service ) = $sock->sockhost_service( $numeric )
 773
 774 Returns the hostname and service name of the local address (that is, the
 775 socket address given by the C<sockname> method).
 776
 777 If C<$numeric> is true, these will be given in numeric form rather than being
 778 resolved into names.
 779
 780 The following four convenience wrappers may be used to obtain one of the two
 781 values returned here. If both host and service names are required, this method
 782 is preferable to the following wrappers, because it will call
 783 C<getnameinfo(3)> only once.
 784
 785 =cut
 786
 787 sub sockhost_service
 788 {
 789    my $self = shift;
 790    my ( $numeric ) = @_;
 791
 792    $self->_get_host_service( $self->sockname, $numeric ? NI_NUMERICHOST|NI_NUMERICSERV : 0 );
 793 }
 794
 795 =head2 $addr = $sock->sockhost
 796
 797 Return the numeric form of the local address as a textual representation
 798
 799 =head2 $port = $sock->sockport
 800
 801 Return the numeric form of the local port number
 802
 803 =head2 $host = $sock->sockhostname
 804
 805 Return the resolved name of the local address
 806
 807 =head2 $service = $sock->sockservice
 808
 809 Return the resolved name of the local port number
 810
 811 =cut
 812
 813 sub sockhost { my $self = shift; ( $self->_get_host_service( $self->sockname, NI_NUMERICHOST, NIx_NOSERV ) )[0] }
 814 sub sockport { my $self = shift; ( $self->_get_host_service( $self->sockname, NI_NUMERICSERV, NIx_NOHOST ) )[1] }
 815
 816 sub sockhostname { my $self = shift; ( $self->_get_host_service( $self->sockname, 0, NIx_NOSERV ) )[0] }
 817 sub sockservice  { my $self = shift; ( $self->_get_host_service( $self->sockname, 0, NIx_NOHOST ) )[1] }
 818
 819 =head2 $addr = $sock->sockaddr
 820
 821 Return the local address as a binary octet string
 822
 823 =cut
 824
 825 sub sockaddr { my $self = shift; _unpack_sockaddr $self->sockname }
 826
 827 =head2 ( $host, $service ) = $sock->peerhost_service( $numeric )
 828
 829 Returns the hostname and service name of the peer address (that is, the
 830 socket address given by the C<peername> method), similar to the
 831 C<sockhost_service> method.
 832
 833 The following four convenience wrappers may be used to obtain one of the two
 834 values returned here. If both host and service names are required, this method
 835 is preferable to the following wrappers, because it will call
 836 C<getnameinfo(3)> only once.
 837
 838 =cut
 839
 840 sub peerhost_service
 841 {
 842    my $self = shift;
 843    my ( $numeric ) = @_;
 844
 845    $self->_get_host_service( $self->peername, $numeric ? NI_NUMERICHOST|NI_NUMERICSERV : 0 );
 846 }
 847
 848 =head2 $addr = $sock->peerhost
 849
 850 Return the numeric form of the peer address as a textual representation
 851
 852 =head2 $port = $sock->peerport
 853
 854 Return the numeric form of the peer port number
 855
 856 =head2 $host = $sock->peerhostname
 857
 858 Return the resolved name of the peer address
 859
 860 =head2 $service = $sock->peerservice
 861
 862 Return the resolved name of the peer port number
 863
 864 =cut
 865
 866 sub peerhost { my $self = shift; ( $self->_get_host_service( $self->peername, NI_NUMERICHOST, NIx_NOSERV ) )[0] }
 867 sub peerport { my $self = shift; ( $self->_get_host_service( $self->peername, NI_NUMERICSERV, NIx_NOHOST ) )[1] }
 868
 869 sub peerhostname { my $self = shift; ( $self->_get_host_service( $self->peername, 0, NIx_NOSERV ) )[0] }
 870 sub peerservice  { my $self = shift; ( $self->_get_host_service( $self->peername, 0, NIx_NOHOST ) )[1] }
 871
 872 =head2 $addr = $peer->peeraddr
 873
 874 Return the peer address as a binary octet string
 875
 876 =cut
 877
 878 sub peeraddr { my $self = shift; _unpack_sockaddr $self->peername }
 879
 880 # This unbelievably dodgy hack works around the bug that IO::Socket doesn't do
 881 # it
 882 #    https://rt.cpan.org/Ticket/Display.html?id=61577
 883 sub accept
 884 {
 885    my $self = shift;
 886    my ( $new, $peer ) = $self->SUPER::accept( @_ ) or return;
 887
 888    ${*$new}{$_} = ${*$self}{$_} for qw( io_socket_domain io_socket_type io_socket_proto );
 889
 890    return wantarray ? ( $new, $peer )
 891                     : $new;
 892 }
 893
 894 # This second unbelievably dodgy hack guarantees that $self->fileno doesn't
 895 # change, which is useful during nonblocking connect
 896 sub socket
 897 {
 898    my $self = shift;
 899    return $self->SUPER::socket(@_) if not defined $self->fileno;
 900
 901    # I hate core prototypes sometimes...
 902    CORE::socket( my $tmph, $_[0], $_[1], $_[2] ) or return undef;
 903
 904    dup2( $tmph->fileno, $self->fileno ) or die "Unable to dup2 $tmph onto $self - $!";
 905 }
 906
 907 # Versions of IO::Socket before 1.35 may leave socktype undef if from, say, an
 908 #   ->fdopen call. In this case we'll apply a fix
 909 BEGIN {
 910    if( $IO::Socket::VERSION < 1.35 ) {
 911       *socktype = sub {
 912          my $self = shift;
 913          my $type = $self->SUPER::socktype;
 914          if( !defined $type ) {
 915             $type = $self->sockopt( Socket::SO_TYPE() );
 916          }
 917          return $type;
 918       };
 919    }
 920 }
 921
 922 =head2 $inet = $sock->as_inet
 923
 924 Returns a new L<IO::Socket::INET> instance wrapping the same filehandle. This
 925 may be useful in cases where it is required, for backward-compatibility, to
 926 have a real object of C<IO::Socket::INET> type instead of C<IO::Socket::IP>.
 927 The new object will wrap the same underlying socket filehandle as the
 928 original, so care should be taken not to continue to use both objects
 929 concurrently. Ideally the original C<$sock> should be discarded after this
 930 method is called.
 931
 932 This method checks that the socket domain is C<PF_INET> and will throw an
 933 exception if it isn't.
 934
 935 =cut
 936
 937 sub as_inet
 938 {
 939    my $self = shift;
 940    croak "Cannot downgrade a non-PF_INET socket to IO::Socket::INET" unless $self->sockdomain == AF_INET;
 941    return IO::Socket::INET->new_from_fd( $self->fileno, "r+" );
 942 }
 943
 944 =head1 NON-BLOCKING
 945
 946 If the constructor is passed a defined but false value for the C<Blocking>
 947 argument then the socket is put into non-blocking mode. When in non-blocking
 948 mode, the socket will not be set up by the time the constructor returns,
 949 because the underlying C<connect(2)> syscall would otherwise have to block.
 950
 951 The non-blocking behaviour is an extension of the C<IO::Socket::INET> API,
 952 unique to C<IO::Socket::IP>, because the former does not support multi-homed
 953 non-blocking connect.
 954
 955 When using non-blocking mode, the caller must repeatedly check for
 956 writeability on the filehandle (for instance using C<select> or C<IO::Poll>).
 957 Each time the filehandle is ready to write, the C<connect> method must be
 958 called, with no arguments. Note that some operating systems, most notably
 959 C<MSWin32> do not report a C<connect()> failure using write-ready; so you must
 960 also C<select()> for exceptional status.
 961
 962 While C<connect> returns false, the value of C<$!> indicates whether it should
 963 be tried again (by being set to the value C<EINPROGRESS>, or C<EWOULDBLOCK> on
 964 MSWin32), or whether a permanent error has occurred (e.g. C<ECONNREFUSED>).
 965
 966 Once the socket has been connected to the peer, C<connect> will return true
 967 and the socket will now be ready to use.
 968
 969 Note that calls to the platform's underlying C<getaddrinfo(3)> function may
 970 block. If C<IO::Socket::IP> has to perform this lookup, the constructor will
 971 block even when in non-blocking mode.
 972
 973 To avoid this blocking behaviour, the caller should pass in the result of such
 974 a lookup using the C<PeerAddrInfo> or C<LocalAddrInfo> arguments. This can be
 975 achieved by using L<Net::LibAsyncNS>, or the C<getaddrinfo(3)> function can be
 976 called in a child process.
 977
 978  use IO::Socket::IP;
 979  use Errno qw( EINPROGRESS EWOULDBLOCK );
 980
 981  my @peeraddrinfo = ... # Caller must obtain the getaddinfo result here
 982
 983  my $socket = IO::Socket::IP->new(
 984     PeerAddrInfo => \@peeraddrinfo,
 985     Blocking     => 0,
 986  ) or die "Cannot construct socket - $@";
 987
 988  while( !$socket->connect and ( $! == EINPROGRESS || $! == EWOULDBLOCK ) ) {
 989     my $wvec = '';
 990     vec( $wvec, fileno $socket, 1 ) = 1;
 991     my $evec = '';
 992     vec( $evec, fileno $socket, 1 ) = 1;
 993
 994     select( undef, $wvec, $evec, undef ) or die "Cannot select - $!";
 995  }
 996
 997  die "Cannot connect - $!" if $!;
 998
 999  ...
1000
1001 The example above uses C<select()>, but any similar mechanism should work
1002 analogously. C<IO::Socket::IP> takes care when creating new socket filehandles
1003 to preserve the actual file descriptor number, so such techniques as C<poll>
1004 or C<epoll> should be transparent to its reallocation of a different socket
1005 underneath, perhaps in order to switch protocol family between C<PF_INET> and
1006 C<PF_INET6>.
1007
1008 For another example using C<IO::Poll> and C<Net::LibAsyncNS>, see the
1009 F<examples/nonblocking_libasyncns.pl> file in the module distribution.
1010
1011 =cut
1012
1013 =head1 C<PeerHost> AND C<LocalHost> PARSING
1014
1015 To support the C<IO::Socket::INET> API, the host and port information may be
1016 passed in a single string rather than as two separate arguments.
1017
1018 If either C<LocalHost> or C<PeerHost> (or their C<...Addr> synonyms) have any
1019 of the following special forms then special parsing is applied.
1020
1021 The value of the C<...Host> argument will be split to give both the hostname
1022 and port (or service name):
1023
1024  hostname.example.org:http    # Host name
1025  192.0.2.1:80                 # IPv4 address
1026  [2001:db8::1]:80             # IPv6 address
1027
1028 In each case, the port or service name (e.g. C<80>) is passed as the
1029 C<LocalService> or C<PeerService> argument.
1030
1031 Either of C<LocalService> or C<PeerService> (or their C<...Port> synonyms) can
1032 be either a service name, a decimal number, or a string containing both a
1033 service name and number, in a form such as
1034
1035  http(80)
1036
1037 In this case, the name (C<http>) will be tried first, but if the resolver does
1038 not understand it then the port number (C<80>) will be used instead.
1039
1040 If the C<...Host> argument is in this special form and the corresponding
1041 C<...Service> or C<...Port> argument is also defined, the one parsed from
1042 the C<...Host> argument will take precedence and the other will be ignored.
1043
1044 =head2 ( $host, $port ) = IO::Socket::IP->split_addr( $addr )
1045
1046 Utility method that provides the parsing functionality described above.
1047 Returns a 2-element list, containing either the split hostname and port
1048 description if it could be parsed, or the given address and C<undef> if it was
1049 not recognised.
1050
1051  IO::Socket::IP->split_addr( "hostname:http" )
1052                               # ( "hostname",  "http" )
1053
1054  IO::Socket::IP->split_addr( "192.0.2.1:80" )
1055                               # ( "192.0.2.1", "80"   )
1056
1057  IO::Socket::IP->split_addr( "[2001:db8::1]:80" )
1058                               # ( "2001:db8::1", "80" )
1059
1060  IO::Socket::IP->split_addr( "something.else" )
1061                               # ( "something.else", undef )
1062
1063 =cut
1064
1065 sub split_addr
1066 {
1067    shift;
1068    my ( $addr ) = @_;
1069
1070    local ( $1, $2 ); # Placate a taint-related bug; [perl #67962]
1071    if( $addr =~ m/\A\[($IPv6_re)\](?::([^\s:]*))?\z/ or
1072        $addr =~ m/\A([^\s:]*):([^\s:]*)\z/ ) {
1073       return ( $1, $2 ) if defined $2 and length $2;
1074       return ( $1, undef );
1075    }
1076
1077    return ( $addr, undef );
1078 }
1079
1080 =head2 $addr = IO::Socket::IP->join_addr( $host, $port )
1081
1082 Utility method that performs the reverse of C<split_addr>, returning a string
1083 formed by joining the specified host address and port number. The host address
1084 will be wrapped in C<[]> brackets if required (because it is a raw IPv6
1085 numeric address).
1086
1087 This can be especially useful when combined with the C<sockhost_service> or
1088 C<peerhost_service> methods.
1089
1090  say "Connected to ", IO::Socket::IP->join_addr( $sock->peerhost_service );
1091
1092 =cut
1093
1094 sub join_addr
1095 {
1096    shift;
1097    my ( $host, $port ) = @_;
1098
1099    $host = "[$host]" if $host =~ m/:/;
1100
1101    return join ":", $host, $port if defined $port;
1102    return $host;
1103 }
1104
1105 # Since IO::Socket->new( Domain => ... ) will delete the Domain parameter
1106 # before calling ->configure, we need to keep track of which it was
1107
1108 package # hide from indexer
1109    IO::Socket::IP::_ForINET;
1110 use base qw( IO::Socket::IP );
1111
1112 sub configure
1113 {
1114    # This is evil
1115    my $self = shift;
1116    my ( $arg ) = @_;
1117
1118    bless $self, "IO::Socket::IP";
1119    $self->configure( { %$arg, Family => Socket::AF_INET() } );
1120 }
1121
1122 package # hide from indexer
1123    IO::Socket::IP::_ForINET6;
1124 use base qw( IO::Socket::IP );
1125
1126 sub configure
1127 {
1128    # This is evil
1129    my $self = shift;
1130    my ( $arg ) = @_;
1131
1132    bless $self, "IO::Socket::IP";
1133    $self->configure( { %$arg, Family => Socket::AF_INET6() } );
1134 }
1135
1136 =head1 C<IO::Socket::INET> INCOMPATIBILITES
1137
1138 =over 4
1139
1140 =item *
1141
1142 The behaviour enabled by C<MultiHomed> is in fact implemented by
1143 C<IO::Socket::IP> as it is required to correctly support searching for a
1144 useable address from the results of the C<getaddrinfo(3)> call. The
1145 constructor will ignore the value of this argument, except if it is defined
1146 but false. An exception is thrown in this case, because that would request it
1147 disable the C<getaddrinfo(3)> search behaviour in the first place.
1148
1149 =item *
1150
1151 C<IO::Socket::IP> implements both the C<Blocking> and C<Timeout> parameters,
1152 but it implements the interaction of both in a different way.
1153
1154 In C<::INET>, supplying a timeout overrides the non-blocking behaviour,
1155 meaning that the C<connect()> operation will still block despite that the
1156 caller asked for a non-blocking socket. This is not explicitly specified in
1157 its documentation, nor does this author believe that is a useful behaviour -
1158 it appears to come from a quirk of implementation.
1159
1160 In C<::IP> therefore, the C<Blocking> parameter takes precedence - if a
1161 non-blocking socket is requested, no operation will block. The C<Timeout>
1162 parameter here simply defines the maximum time that a blocking C<connect()>
1163 call will wait, if it blocks at all.
1164
1165 In order to specifically obtain the "blocking connect then non-blocking send
1166 and receive" behaviour of specifying this combination of options to C<::INET>
1167 when using C<::IP>, perform first a blocking connect, then afterwards turn the
1168 socket into nonblocking mode.
1169
1170  my $sock = IO::Socket::IP->new(
1171     PeerHost => $peer,
1172     Timeout => 20,
1173  ) or die "Cannot connect - $@";
1174
1175  $sock->blocking( 0 );
1176
1177 This code will behave identically under both C<IO::Socket::INET> and
1178 C<IO::Socket::IP>.
1179
1180 =back
1181
1182 =cut
1183
1184 =head1 TODO
1185
1186 =over 4
1187
1188 =item *
1189
1190 Investigate whether C<POSIX::dup2> upsets BSD's C<kqueue> watchers, and if so,
1191 consider what possible workarounds might be applied.
1192
1193 =back
1194
1195 =head1 AUTHOR
1196
1197 Paul Evans <leonerd@leonerd.org.uk>
1198
1199 =cut
1200
1201 0x55AA;