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-2011 -- leonerd@leonerd.org.uk
   5
   6 package IO::Socket::IP;
   7
   8 use strict;
   9 use warnings;
  10 use base qw( IO::Socket );
  11
  12 our $VERSION = '0.08';
  13
  14 use Carp;
  15
  16 use Socket 1.95 qw(
  17    getaddrinfo getnameinfo
  18    AF_INET
  19    AI_PASSIVE
  20    IPPROTO_TCP IPPROTO_UDP
  21    NI_DGRAM NI_NUMERICHOST NI_NUMERICSERV
  22    SO_REUSEADDR SO_REUSEPORT SO_BROADCAST SO_ERROR
  23    SOCK_DGRAM SOCK_STREAM
  24    SOL_SOCKET
  25 );
  26 my $AF_INET6 = eval { Socket::AF_INET6() }; # may not be defined
  27 my $AI_ADDRCONFIG = eval { Socket::AI_ADDRCONFIG() } || 0;
  28 use POSIX qw( dup2 );
  29 use Errno qw( EINPROGRESS );
  30
  31 use constant HAVE_MSWIN32 => ( $^O eq "MSWin32" );
  32
  33 my $IPv6_re = do {
  34    # translation of RFC 3986 3.2.2 ABNF to re
  35    my $IPv4address = do {
  36       my $dec_octet = q<(?:[0-9]|[1-9][0-9]|1[0-9][0-9]|2[0-4][0-9]|25[0-5])>;
  37       qq<$dec_octet(?: \\. $dec_octet){3}>;
  38    };
  39    my $IPv6address = do {
  40       my $h16  = qq<[0-9A-Fa-f]{1,4}>;
  41       my $ls32 = qq<(?: $h16 : $h16 | $IPv4address)>;
  42       qq<(?:
  43                                             (?: $h16 : ){6} $ls32
  44          |                               :: (?: $h16 : ){5} $ls32
  45          | (?:                   $h16 )? :: (?: $h16 : ){4} $ls32
  46          | (?: (?: $h16 : ){0,1} $h16 )? :: (?: $h16 : ){3} $ls32
  47          | (?: (?: $h16 : ){0,2} $h16 )? :: (?: $h16 : ){2} $ls32
  48          | (?: (?: $h16 : ){0,3} $h16 )? ::     $h16 :      $ls32
  49          | (?: (?: $h16 : ){0,4} $h16 )? ::                 $ls32
  50          | (?: (?: $h16 : ){0,5} $h16 )? ::                 $h16
  51          | (?: (?: $h16 : ){0,6} $h16 )? ::
  52       )>
  53    };
  54    qr<$IPv6address>xo;
  55 };
  56
  57 =head1 NAME
  58
  59 C<IO::Socket::IP> - A drop-in replacement for C<IO::Socket::INET> supporting
  60 both IPv4 and IPv6
  61
  62 =head1 SYNOPSIS
  63
  64  use IO::Socket::IP;
  65
  66  my $sock = IO::Socket::IP->new(
  67     PeerHost => "www.google.com",
  68     PeerPort => "http",
  69     Type     => SOCK_STREAM,
  70  ) or die "Cannot construct socket - $@";
  71
  72  my $familyname = ( $sock->sockdomain == PF_INET6 ) ? "IPv6" :
  73                   ( $sock->sockdomain == PF_INET  ) ? "IPv4" :
  74                                                       "unknown";
  75
  76  printf "Connected to google via %s\n", $familyname;
  77
  78 =head1 DESCRIPTION
  79
  80 This module provides a protocol-independent way to use IPv4 and IPv6 sockets,
  81 as a drop-in replacement for L<IO::Socket::INET>. Most constructor arguments
  82 and methods are provided in a backward-compatible way. For a list of known
  83 differences, see the C<IO::Socket::INET> INCOMPATIBILITES section below.
  84
  85 It uses the C<getaddrinfo(3)> function to convert hostnames and service names
  86 or port numbers into sets of possible addresses to connect to or listen on.
  87 This allows it to work for IPv6 where the system supports it, while still
  88 falling back to IPv4-only on systems which don't.
  89
  90 =head1 REPLACING C<IO::Socket> DEFAULT BEHAVIOUR
  91
  92 By placing C<-register> in the import list, C<IO::Socket> uses
  93 C<IO::Socket::IP> rather than C<IO::Socket::INET> as the class that handles
  94 C<PF_INET>.  C<IO::Socket> will also use C<IO::Socket::IP> rather than
  95 C<IO::Socket::INET6> to handle C<PF_INET6>, provided that the C<AF_INET6>
  96 constant is available.
  97
  98 Changing C<IO::Socket>'s default behaviour means that calling the
  99 C<IO::Socket> constructor with either C<PF_INET> or C<PF_INET6> as the
 100 C<Domain> parameter will yield an C<IO::Socket::IP> object.
 101
 102  use IO::Socket::IP -register;
 103
 104  my $sock = IO::Socket->new(
 105     Domain    => PF_INET6,
 106     LocalHost => "::1",
 107     Listen    => 1,
 108  ) or die "Cannot create socket - $@\n";
 109
 110  print "Created a socket of type " . ref($sock) . "\n";
 111
 112 Note that C<-register> is a global setting that applies to the entire program;
 113 it cannot be applied only for certain callers, removed, or limited by lexical
 114 scope.
 115
 116 =cut
 117
 118 sub import
 119 {
 120    my $pkg = shift;
 121    my @symbols;
 122
 123    foreach ( @_ ) {
 124       if( $_ eq "-register" ) {
 125          $pkg->register_domain( AF_INET );
 126          $pkg->register_domain( $AF_INET6 ) if defined $AF_INET6;
 127       }
 128       else {
 129          push @symbols, $_;
 130       }
 131    }
 132
 133    @_ = ( $pkg, @symbols );
 134    goto &IO::Socket::import;
 135 }
 136
 137 =head1 CONSTRUCTORS
 138
 139 =cut
 140
 141 =head2 $sock = IO::Socket::IP->new( %args )
 142
 143 Creates a new C<IO::Socket::IP> object, containing a newly created socket
 144 handle according to the named arguments passed. The recognised arguments are:
 145
 146 =over 8
 147
 148 =item PeerHost => STRING
 149
 150 =item PeerService => STRING
 151
 152 Hostname and service name for the peer to C<connect()> to. The service name
 153 may be given as a port number, as a decimal string.
 154
 155 =item PeerAddr => STRING
 156
 157 =item PeerPort => STRING
 158
 159 For symmetry with the accessor methods and compatibility with
 160 C<IO::Socket::INET>, these are accepted as synonyms for C<PeerHost> and
 161 C<PeerService> respectively.
 162
 163 =item PeerAddrInfo => ARRAY
 164
 165 Alternate form of specifying the peer to C<connect()> to. This should be an
 166 array of the form returned by C<Socket::getaddrinfo>.
 167
 168 This parameter takes precedence over the C<Peer*>, C<Family>, C<Type> and
 169 C<Proto> arguments.
 170
 171 =item LocalHost => STRING
 172
 173 =item LocalService => STRING
 174
 175 Hostname and service name for the local address to C<bind()> to.
 176
 177 =item LocalAddr => STRING
 178
 179 =item LocalPort => STRING
 180
 181 For symmetry with the accessor methods and compatibility with
 182 C<IO::Socket::INET>, these are accepted as synonyms for C<LocalHost> and
 183 C<LocalService> respectively.
 184
 185 =item LocalAddrInfo => ARRAY
 186
 187 Alternate form of specifying the local address to C<bind()> to. This should be
 188 an array of the form returned by C<Socket::getaddrinfo>.
 189
 190 This parameter takes precedence over the C<Local*>, C<Family>, C<Type> and
 191 C<Proto> arguments.
 192
 193 =item Family => INT
 194
 195 The address family to pass to C<getaddrinfo> (e.g. C<AF_INET>, C<AF_INET6>).
 196 Normally this will be left undefined, and C<getaddrinfo> will search using any
 197 address family supported by the system.
 198
 199 =item Type => INT
 200
 201 The socket type to pass to C<getaddrinfo> (e.g. C<SOCK_STREAM>,
 202 C<SOCK_DGRAM>). Normally defined by the caller; if left undefined
 203 C<getaddrinfo> may attempt to infer the type from the service name.
 204
 205 =item Proto => STRING or INT
 206
 207 The IP protocol to use for the socket (e.g. C<'tcp'>, C<IPPROTO_TCP>,
 208 C<'udp'>,C<IPPROTO_UDP>). Normally this will be left undefined, and either
 209 C<getaddrinfo> or the kernel will choose an appropriate value. May be given
 210 either in string name or numeric form.
 211
 212 =item Listen => INT
 213
 214 If defined, puts the socket into listening mode where new connections can be
 215 accepted using the C<accept> method. The value given is used as the
 216 C<listen(2)> queue size.
 217
 218 =item ReuseAddr => BOOL
 219
 220 If true, set the C<SO_REUSEADDR> sockopt
 221
 222 =item ReusePort => BOOL
 223
 224 If true, set the C<SO_REUSEPORT> sockopt (not all OSes implement this sockopt)
 225
 226 =item Broadcast => BOOL
 227
 228 If true, set the C<SO_BROADCAST> sockopt
 229
 230 =item Timeout
 231
 232 This C<IO::Socket::INET>-style argument is not currently supported. See the
 233 C<IO::Socket::INET> INCOMPATIBILITES section below.
 234
 235 =item MultiHomed
 236
 237 This C<IO::Socket::INET>-style argument is not currently supported. See the
 238 C<IO::Socket::INET> INCOMPATIBILITES section below. However, the behaviour it
 239 enables is always performed by C<IO::Socket::IP>.
 240
 241 =item Blocking => BOOL
 242
 243 If defined but false, the socket will be set to non-blocking mode. Otherwise
 244 it will default to blocking mode. See the NON-BLOCKING section below for more
 245 detail.
 246
 247 =back
 248
 249 If neither C<Type> nor C<Proto> hints are provided, a default of
 250 C<SOCK_STREAM> and C<IPPROTO_TCP> respectively will be set, to maintain
 251 compatibility with C<IO::Socket::INET>.
 252
 253 If the constructor fails, it will set C<$@> to an appropriate error message;
 254 this may be from C<$!> or it may be some other string; not every failure
 255 necessarily has an associated C<errno> value.
 256
 257 =head2 $sock = IO::Socket::IP->new( $peeraddr )
 258
 259 As a special case, if the constructor is passed a single argument (as
 260 opposed to an even-sized list of key/value pairs), it is taken to be the value
 261 of the C<PeerAddr> parameter. This is parsed in the same way, according to the
 262 behaviour given in the C<PeerHost> AND C<LocalHost> PARSING section below.
 263
 264 =cut
 265
 266 sub new
 267 {
 268    my $class = shift;
 269    my %arg = (@_ == 1) ? (PeerHost => $_[0]) : @_;
 270    return $class->SUPER::new(%arg);
 271 }
 272
 273 # IO::Socket may call this one; neaten up the arguments from IO::Socket::INET
 274 # before calling our real _configure method
 275 sub configure
 276 {
 277    my $self = shift;
 278    my ( $arg ) = @_;
 279
 280    $arg->{PeerHost} = delete $arg->{PeerAddr}
 281       if exists $arg->{PeerAddr} && !exists $arg->{PeerHost};
 282
 283    $arg->{PeerService} = delete $arg->{PeerPort}
 284       if exists $arg->{PeerPort} && !exists $arg->{PeerService};
 285
 286    $arg->{LocalHost} = delete $arg->{LocalAddr}
 287       if exists $arg->{LocalAddr} && !exists $arg->{LocalHost};
 288
 289    $arg->{LocalService} = delete $arg->{LocalPort}
 290       if exists $arg->{LocalPort} && !exists $arg->{LocalService};
 291
 292    for my $type (qw(Peer Local)) {
 293       my $host    = $type . 'Host';
 294       my $service = $type . 'Service';
 295
 296       if (exists $arg->{$host} && !exists $arg->{$service}) {
 297          local $_ = $arg->{$host};
 298          defined or next;
 299          local ( $1, $2 ); # Placate a taint-related bug; [perl #67962]
 300          if (/\A\[($IPv6_re)\](?::([^\s:]*))?\z/o || /\A([^\s:]*):([^\s:]*)\z/) {
 301             $arg->{$host}    = $1;
 302             $arg->{$service} = $2 if defined $2 && length $2;
 303          }
 304       }
 305    }
 306
 307    $self->_configure( $arg );
 308 }
 309
 310 sub _configure
 311 {
 312    my $self = shift;
 313    my ( $arg ) = @_;
 314
 315    my %hints;
 316    my @localinfos;
 317    my @peerinfos;
 318
 319    my @sockopts_enabled;
 320
 321    $hints{flags} = $AI_ADDRCONFIG;
 322
 323    if( defined $arg->{Family} ) {
 324       my $family = delete $arg->{Family};
 325       $hints{family} = $family;
 326    }
 327
 328    if( defined $arg->{Type} ) {
 329       my $type = delete $arg->{Type};
 330       $hints{socktype} = $type;
 331    }
 332
 333    if( defined $arg->{Proto} ) {
 334       my $proto = delete $arg->{Proto};
 335
 336       unless( $proto =~ m/^\d+$/ ) {
 337          my $protonum = getprotobyname( $proto );
 338          defined $protonum or croak "Unrecognised protocol $proto";
 339          $proto = $protonum;
 340       }
 341
 342       $hints{protocol} = $proto;
 343    }
 344
 345    # To maintain compatibilty with IO::Socket::INET, imply a default of
 346    # SOCK_STREAM + IPPROTO_TCP if neither hint is given
 347    if( !defined $hints{socktype} and !defined $hints{protocol} ) {
 348       $hints{socktype} = SOCK_STREAM;
 349       $hints{protocol} = IPPROTO_TCP;
 350    }
 351
 352    # Some OSes (NetBSD) don't seem to like just a protocol hint without a
 353    # socktype hint as well. We'll set a couple of common ones
 354    if( !defined $hints{socktype} and defined $hints{protocol} ) {
 355       $hints{socktype} = SOCK_STREAM if $hints{protocol} == IPPROTO_TCP;
 356       $hints{socktype} = SOCK_DGRAM  if $hints{protocol} == IPPROTO_UDP;
 357    }
 358
 359    if( my $info = delete $arg->{LocalAddrInfo} ) {
 360       @localinfos = @$info;
 361    }
 362    elsif( defined $arg->{LocalHost} or defined $arg->{LocalService} ) {
 363       # Either may be undef
 364       my $host = delete $arg->{LocalHost};
 365       my $service = delete $arg->{LocalService};
 366
 367       local $1; # Placate a taint-related bug; [perl #67962]
 368       defined $service and $service =~ s/\((\d+)\)$// and
 369          my $fallback_port = $1;
 370
 371       my %localhints = %hints;
 372       $localhints{flags} |= AI_PASSIVE;
 373       ( my $err, @localinfos ) = getaddrinfo( $host, $service, \%localhints );
 374
 375       if( $err and defined $fallback_port ) {
 376          ( $err, @localinfos ) = getaddrinfo( $host, $fallback_port, \%localhints );
 377       }
 378
 379       $err and ( $@ = "$err", return );
 380    }
 381
 382    if( my $info = delete $arg->{PeerAddrInfo} ) {
 383       @peerinfos = @$info;
 384    }
 385    elsif( defined $arg->{PeerHost} or defined $arg->{PeerService} ) {
 386       defined( my $host = delete $arg->{PeerHost} ) or
 387          croak "Expected 'PeerHost'";
 388       defined( my $service = delete $arg->{PeerService} ) or
 389          croak "Expected 'PeerService'";
 390
 391       local $1; # Placate a taint-related bug; [perl #67962]
 392       defined $service and $service =~ s/\((\d+)\)$// and
 393          my $fallback_port = $1;
 394
 395       ( my $err, @peerinfos ) = getaddrinfo( $host, $service, \%hints );
 396
 397       if( $err and defined $fallback_port ) {
 398          ( $err, @peerinfos ) = getaddrinfo( $host, $fallback_port, \%hints );
 399       }
 400
 401       $err and ( $@ = "$err", return );
 402    }
 403
 404    push @sockopts_enabled, SO_REUSEADDR if delete $arg->{ReuseAddr};
 405    push @sockopts_enabled, SO_REUSEPORT if delete $arg->{ReusePort};
 406    push @sockopts_enabled, SO_BROADCAST if delete $arg->{Broadcast};
 407
 408    my $listenqueue = delete $arg->{Listen};
 409
 410    croak "Cannot Listen with a PeerHost" if defined $listenqueue and @peerinfos;
 411
 412    my $blocking = delete $arg->{Blocking};
 413    defined $blocking or $blocking = 1;
 414
 415    keys %$arg and croak "Unexpected keys - " . join( ", ", sort keys %$arg );
 416
 417    my @infos;
 418    foreach my $local ( @localinfos ? @localinfos : {} ) {
 419       foreach my $peer ( @peerinfos ? @peerinfos : {} ) {
 420          next if defined $local->{family}   and defined $peer->{family}   and
 421             $local->{family} != $peer->{family};
 422          next if defined $local->{socktype} and defined $peer->{socktype} and
 423             $local->{socktype} != $peer->{socktype};
 424          next if defined $local->{protocol} and defined $peer->{protocol} and
 425             $local->{protocol} != $peer->{protocol};
 426
 427          my $family   = $local->{family}   || $peer->{family}   or next;
 428          my $socktype = $local->{socktype} || $peer->{socktype} or next;
 429          my $protocol = $local->{protocol} || $peer->{protocol} || 0;
 430
 431          push @infos, {
 432             family    => $family,
 433             socktype  => $socktype,
 434             protocol  => $protocol,
 435             localaddr => $local->{addr},
 436             peeraddr  => $peer->{addr},
 437          };
 438       }
 439    }
 440
 441    # In the nonblocking case, caller will be calling ->setup multiple times.
 442    # Store configuration in the object for the ->setup method
 443    # Yes, these are messy. Sorry, I can't help that...
 444
 445    ${*$self}{io_socket_ip_infos} = \@infos;
 446
 447    ${*$self}{io_socket_ip_idx} = -1;
 448
 449    ${*$self}{io_socket_ip_sockopts} = \@sockopts_enabled;
 450    ${*$self}{io_socket_ip_listenqueue} = $listenqueue;
 451    ${*$self}{io_socket_ip_blocking} = $blocking;
 452
 453    ${*$self}{io_socket_ip_errors} = [ undef, undef, undef ];
 454
 455    if( $blocking ) {
 456       $self->setup or return undef;
 457    }
 458    return $self;
 459 }
 460
 461 sub setup
 462 {
 463    my $self = shift;
 464
 465    while(1) {
 466       ${*$self}{io_socket_ip_idx}++;
 467       last if ${*$self}{io_socket_ip_idx} >= @{ ${*$self}{io_socket_ip_infos} };
 468
 469       my $info = ${*$self}{io_socket_ip_infos}->[${*$self}{io_socket_ip_idx}];
 470
 471       $self->socket( @{$info}{qw( family socktype protocol )} ) or
 472          ( ${*$self}{io_socket_ip_errors}[2] = $!, next );
 473
 474       $self->blocking( 0 ) unless ${*$self}{io_socket_ip_blocking};
 475
 476       foreach my $sockopt ( @{ ${*$self}{io_socket_ip_sockopts} } ) {
 477          $self->setsockopt( SOL_SOCKET, $sockopt, pack "i", 1 ) or ( $@ = "$!", return undef );
 478       }
 479
 480       if( defined( my $addr = $info->{localaddr} ) ) {
 481          $self->bind( $addr ) or
 482             ( ${*$self}{io_socket_ip_errors}[1] = $!, next );
 483       }
 484
 485       if( defined( my $listenqueue = ${*$self}{io_socket_ip_listenqueue} ) ) {
 486          $self->listen( $listenqueue ) or ( $@ = "$!", return undef );
 487       }
 488
 489       if( defined( my $addr = $info->{peeraddr} ) ) {
 490          # It seems that IO::Socket hides EINPROGRESS errors, making them look
 491          # like a success. This is annoying here.
 492          # Instead of putting up with its frankly-irritating intentional
 493          # breakage of useful APIs I'm just going to end-run around it and
 494          # call CORE::connect() directly
 495          if( CORE::connect( $self, $addr ) ) {
 496             $! = 0;
 497             return 1;
 498          }
 499
 500          return 0 if $! == EINPROGRESS or HAVE_MSWIN32 && $! == Errno::EWOULDBLOCK();
 501
 502          ${*$self}{io_socket_ip_errors}[0] = $!;
 503          next;
 504       }
 505
 506       return 1;
 507    }
 508
 509    $self->close;
 510
 511    # Pick the most appropriate error, stringified
 512    $! = ( grep defined, @{ ${*$self}{io_socket_ip_errors}} )[0];
 513    $@ = "$!";
 514    return undef;
 515 }
 516
 517 sub connect
 518 {
 519    my $self = shift;
 520    return $self->SUPER::connect( @_ ) if @_;
 521
 522    $! = 0, return 1 if $self->fileno and defined $self->peername;
 523
 524    if( $self->fileno ) {
 525       # A connect has just failed, get its error value
 526       ${*$self}{io_socket_ip_errors}[0] = $self->getsockopt( SOL_SOCKET, SO_ERROR );
 527    }
 528
 529    return $self->setup;
 530 }
 531
 532 =head1 METHODS
 533
 534 As well as the following methods, this class inherits all the methods in
 535 L<IO::Socket> and L<IO::Handle>.
 536
 537 =cut
 538
 539 sub _get_host_service
 540 {
 541    my $self = shift;
 542    my ( $addr, $numeric ) = @_;
 543
 544    my $flags = 0;
 545
 546    $flags |= NI_DGRAM if $self->socktype == SOCK_DGRAM;
 547    $flags |= NI_NUMERICHOST|NI_NUMERICSERV if $numeric;
 548
 549    my ( $err, $host, $service ) = getnameinfo( $addr, $flags );
 550    croak "getnameinfo - $err" if $err;
 551
 552    return ( $host, $service );
 553 }
 554
 555 =head2 ( $host, $service ) = $sock->sockhost_service( $numeric )
 556
 557 Returns the hostname and service name of the local address (that is, the
 558 socket address given by the C<sockname> method).
 559
 560 If C<$numeric> is true, these will be given in numeric form rather than being
 561 resolved into names.
 562
 563 The following four convenience wrappers may be used to obtain one of the two
 564 values returned here. If both host and service names are required, this method
 565 is preferable to the following wrappers, because it will call
 566 C<getnameinfo(3)> only once.
 567
 568 =cut
 569
 570 sub sockhost_service
 571 {
 572    my $self = shift;
 573    my ( $numeric ) = @_;
 574
 575    $self->_get_host_service( $self->sockname, $numeric );
 576 }
 577
 578 =head2 $addr = $sock->sockhost
 579
 580 Return the numeric form of the local address
 581
 582 =head2 $port = $sock->sockport
 583
 584 Return the numeric form of the local port number
 585
 586 =head2 $host = $sock->sockhostname
 587
 588 Return the resolved name of the local address
 589
 590 =head2 $service = $sock->sockservice
 591
 592 Return the resolved name of the local port number
 593
 594 =cut
 595
 596 sub sockhost { ( shift->sockhost_service(1) )[0] }
 597 sub sockport { ( shift->sockhost_service(1) )[1] }
 598
 599 sub sockhostname { ( shift->sockhost_service(0) )[0] }
 600 sub sockservice  { ( shift->sockhost_service(0) )[1] }
 601
 602 =head2 ( $host, $service ) = $sock->peerhost_service( $numeric )
 603
 604 Returns the hostname and service name of the peer address (that is, the
 605 socket address given by the C<peername> method), similar to the
 606 C<sockhost_service> method.
 607
 608 The following four convenience wrappers may be used to obtain one of the two
 609 values returned here. If both host and service names are required, this method
 610 is preferable to the following wrappers, because it will call
 611 C<getnameinfo(3)> only once.
 612
 613 =cut
 614
 615 sub peerhost_service
 616 {
 617    my $self = shift;
 618    my ( $numeric ) = @_;
 619
 620    $self->_get_host_service( $self->peername, $numeric );
 621 }
 622
 623 =head2 $addr = $sock->peerhost
 624
 625 Return the numeric form of the peer address
 626
 627 =head2 $port = $sock->peerport
 628
 629 Return the numeric form of the peer port number
 630
 631 =head2 $host = $sock->peerhostname
 632
 633 Return the resolved name of the peer address
 634
 635 =head2 $service = $sock->peerservice
 636
 637 Return the resolved name of the peer port number
 638
 639 =cut
 640
 641 sub peerhost    { ( shift->peerhost_service(1) )[0] }
 642 sub peerport    { ( shift->peerhost_service(1) )[1] }
 643
 644 sub peerhostname { ( shift->peerhost_service(0) )[0] }
 645 sub peerservice  { ( shift->peerhost_service(0) )[1] }
 646
 647 # This unbelievably dodgy hack works around the bug that IO::Socket doesn't do
 648 # it
 649 #    https://rt.cpan.org/Ticket/Display.html?id=61577
 650 sub accept
 651 {
 652    my $self = shift;
 653    my ( $new, $peer ) = $self->SUPER::accept or return;
 654
 655    ${*$new}{$_} = ${*$self}{$_} for qw( io_socket_domain io_socket_type io_socket_proto );
 656
 657    return wantarray ? ( $new, $peer )
 658                     : $new;
 659 }
 660
 661 # This second unbelievably dodgy hack guarantees that $self->fileno doesn't
 662 # change, which is useful during nonblocking connect
 663 sub socket
 664 {
 665    my $self = shift;
 666    return $self->SUPER::socket(@_) if not defined $self->fileno;
 667
 668    # I hate core prototypes sometimes...
 669    CORE::socket( my $tmph, $_[0], $_[1], $_[2] ) or return undef;
 670
 671    dup2( $tmph->fileno, $self->fileno ) or die "Unable to dup2 $tmph onto $self - $!";
 672 }
 673
 674 =head1 NON-BLOCKING
 675
 676 If the constructor is passed a defined but false value for the C<Blocking>
 677 argument then the socket is put into non-blocking mode. When in non-blocking
 678 mode, the socket will not be set up by the time the constructor returns,
 679 because the underlying C<connect(2)> syscall would otherwise have to block.
 680
 681 The non-blocking behaviour is an extension of the C<IO::Socket::INET> API,
 682 unique to C<IO::Socket::IP>, because the former does not support multi-homed
 683 non-blocking connect.
 684
 685 When using non-blocking mode, the caller must repeatedly check for
 686 writeability on the filehandle (for instance using C<select> or C<IO::Poll>).
 687 Each time the filehandle is ready to write, the C<connect> method must be
 688 called, with no arguments. Note that some operating systems, most notably
 689 C<MSWin32> do not report a C<connect()> failure using write-ready; so you must
 690 also C<select()> for exceptional status.
 691
 692 While C<connect> returns false, the value of C<$!> indicates whether it should
 693 be tried again (by being set to the value C<EINPROGRESS>, or C<EWOULDBLOCK> on
 694 MSWin32), or whether a permanent error has occurred (e.g. C<ECONNREFUSED>).
 695
 696 Once the socket has been connected to the peer, C<connect> will return true
 697 and the socket will now be ready to use.
 698
 699 Note that calls to the platform's underlying C<getaddrinfo(3)> function may
 700 block. If C<IO::Socket::IP> has to perform this lookup, the constructor will
 701 block even when in non-blocking mode.
 702
 703 To avoid this blocking behaviour, the caller should pass in the result of such
 704 a lookup using the C<PeerAddrInfo> or C<LocalAddrInfo> arguments. This can be
 705 achieved by using L<Net::LibAsyncNS>, or the C<getaddrinfo(3)> function can be
 706 called in a child process.
 707
 708  use IO::Socket::IP;
 709  use Errno qw( EINPROGRESS EWOULDBLOCK );
 710
 711  my @peeraddrinfo = ... # Caller must obtain the getaddinfo result here
 712
 713  my $socket = IO::Socket::IP->new(
 714     PeerAddrInfo => \@peeraddrinfo,
 715     Blocking     => 0,
 716  ) or die "Cannot construct socket - $@";
 717
 718  while( !$socket->connect and ( $! == EINPROGRESS || $! == EWOULDBLOCK ) ) {
 719     my $wvec = '';
 720     vec( $wvec, fileno $socket, 1 ) = 1;
 721     my $evec = '';
 722     vec( $evec, fileno $socket, 1 ) = 1;
 723
 724     select( undef, $wvec, $evec, undef ) or die "Cannot select - $!";
 725  }
 726
 727  die "Cannot connect - $!" if $!;
 728
 729  ...
 730
 731 The example above uses C<select()>, but any similar mechanism should work
 732 analogously. C<IO::Socket::IP> takes care when creating new socket filehandles
 733 to preserve the actual file descriptor number, so such techniques as C<poll>
 734 or C<epoll> should be transparent to its reallocation of a different socket
 735 underneath, perhaps in order to switch protocol family between C<PF_INET> and
 736 C<PF_INET6>.
 737
 738 For another example using C<IO::Poll> and C<Net::LibAsyncNS>, see the
 739 F<examples/nonblocking_libasyncns.pl> file in the module distribution.
 740
 741 =head1 C<PeerHost> AND C<LocalHost> PARSING
 742
 743 To support the C<IO::Socket::INET> API, the host and port information may be
 744 passed in a single string rather than as two separate arguments.
 745
 746 If either C<LocalHost> or C<PeerHost> (or their C<...Addr> synonyms) have any
 747 of the following special forms, and C<LocalService> or C<PeerService> (or
 748 their C<...Port> synonyms) are absent, special parsing is applied.
 749
 750 The value of the C<...Host> argument will be split to give both the hostname
 751 and port (or service name):
 752
 753  hostname.example.org:http    # Host name
 754  192.0.2.1:80                 # IPv4 address
 755  [2001:db8::1]:80             # IPv6 address
 756
 757 In each case, the port or service name (e.g. C<80>) is passed as the
 758 C<LocalService> or C<PeerService> argument.
 759
 760 Either of C<LocalService> or C<PeerService> (or their C<...Port> synonyms) can
 761 be either a service name, a decimal number, or a string containing both a
 762 service name and number, in a form such as
 763
 764  http(80)
 765
 766 In this case, the name (C<http>) will be tried first, but if the resolver does
 767 not understand it then the port number (C<80>) will be used instead.
 768
 769 =head1 C<IO::Socket::INET> INCOMPATIBILITES
 770
 771 =over 4
 772
 773 =item *
 774
 775 The C<Timeout> and C<MultiHomed> constructor arguments are currently not
 776 recognised.
 777
 778 The behaviour enabled by C<MultiHomed> is in fact implemented by
 779 C<IO::Socket::IP> as it is required to correctly support searching for a
 780 useable address from the results of the C<getaddrinfo(3)> call.
 781
 782 =back
 783
 784 =cut
 785
 786 =head1 TODO
 787
 788 =over 4
 789
 790 =item *
 791
 792 Cache the returns from C<sockhost_service> and C<peerhost_service> to avoid
 793 double-lookup overhead in such code as
 794
 795   printf "Peer is %s:%d\n", $sock->peerhost, $sock->peerport;
 796
 797 =item *
 798
 799 Investigate whether C<POSIX::dup2> upsets BSD's C<kqueue> watchers, and if so,
 800 consider what possible workarounds might be applied.
 801
 802 =back
 803
 804 =head1 BUGS
 805
 806 =over 4
 807
 808 =item *
 809
 810 Nonblocking connect fails unit tests on MSWin32 smoke-testing machines. The
 811 specifics of the failure are that C<connect()> seems to block anyway despite
 812 being asked not to, and that failure to connect is not detected properly. I am
 813 as yet unsure why this is.
 814
 815 Blocking connect on MSWin32, and both blocking and nonblocking connect on
 816 other platforms, all test OK on smoke testing.
 817
 818 =back
 819
 820 =head1 AUTHOR
 821
 822 Paul Evans <leonerd@leonerd.org.uk>
 823
 824 =cut
 825
 826 0x55AA;