This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade IO-Socket-IP from version 0.30 to 0.31
[perl5.git] / 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.31';
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 );
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 =back
308
309 If neither C<Type> nor C<Proto> hints are provided, a default of
310 C<SOCK_STREAM> and C<IPPROTO_TCP> respectively will be set, to maintain
311 compatibility with C<IO::Socket::INET>. Other named arguments that are not
312 recognised are ignored.
313
314 If neither C<Family> nor any hosts or addresses are passed, nor any
315 C<*AddrInfo>, then the constructor has no information on which to decide a
316 socket family to create. In this case, it performs a C<getaddinfo> call with
317 the C<AI_ADDRCONFIG> flag, no host name, and a service name of C<"0">, and
318 uses the family of the first returned result.
319
320 If the constructor fails, it will set C<$@> to an appropriate error message;
321 this may be from C<$!> or it may be some other string; not every failure
322 necessarily has an associated C<errno> value.
323
324 =head2 $sock = IO::Socket::IP->new( $peeraddr )
325
326 As a special case, if the constructor is passed a single argument (as
327 opposed to an even-sized list of key/value pairs), it is taken to be the value
328 of the C<PeerAddr> parameter. This is parsed in the same way, according to the
329 behaviour given in the C<PeerHost> AND C<LocalHost> PARSING section below.
330
331 =cut
332
333 sub new
334 {
335    my $class = shift;
336    my %arg = (@_ == 1) ? (PeerHost => $_[0]) : @_;
337    return $class->SUPER::new(%arg);
338 }
339
340 # IO::Socket may call this one; neaten up the arguments from IO::Socket::INET
341 # before calling our real _configure method
342 sub configure
343 {
344    my $self = shift;
345    my ( $arg ) = @_;
346
347    $arg->{PeerHost} = delete $arg->{PeerAddr}
348       if exists $arg->{PeerAddr} && !exists $arg->{PeerHost};
349
350    $arg->{PeerService} = delete $arg->{PeerPort}
351       if exists $arg->{PeerPort} && !exists $arg->{PeerService};
352
353    $arg->{LocalHost} = delete $arg->{LocalAddr}
354       if exists $arg->{LocalAddr} && !exists $arg->{LocalHost};
355
356    $arg->{LocalService} = delete $arg->{LocalPort}
357       if exists $arg->{LocalPort} && !exists $arg->{LocalService};
358
359    for my $type (qw(Peer Local)) {
360       my $host    = $type . 'Host';
361       my $service = $type . 'Service';
362
363       if( defined $arg->{$host} ) {
364          ( $arg->{$host}, my $s ) = $self->split_addr( $arg->{$host} );
365          # IO::Socket::INET compat - *Host parsed port always takes precedence
366          $arg->{$service} = $s if defined $s;
367       }
368    }
369
370    $self->_io_socket_ip__configure( $arg );
371 }
372
373 # Avoid simply calling it _configure, as some subclasses of IO::Socket::INET on CPAN already take that
374 sub _io_socket_ip__configure
375 {
376    my $self = shift;
377    my ( $arg ) = @_;
378
379    my %hints;
380    my @localinfos;
381    my @peerinfos;
382
383    if( defined $arg->{GetAddrInfoFlags} ) {
384       $hints{flags} = $arg->{GetAddrInfoFlags};
385    }
386    else {
387       $hints{flags} = $AI_ADDRCONFIG;
388    }
389
390    if( defined( my $family = $arg->{Family} ) ) {
391       $hints{family} = $family;
392    }
393
394    if( defined( my $type = $arg->{Type} ) ) {
395       $hints{socktype} = $type;
396    }
397
398    if( defined( my $proto = $arg->{Proto} ) ) {
399       unless( $proto =~ m/^\d+$/ ) {
400          my $protonum = HAVE_GETPROTOBYNAME
401             ? getprotobyname( $proto )
402             : eval { Socket->${\"IPPROTO_\U$proto"}() };
403          defined $protonum or croak "Unrecognised protocol $proto";
404          $proto = $protonum;
405       }
406
407       $hints{protocol} = $proto;
408    }
409
410    # To maintain compatibility with IO::Socket::INET, imply a default of
411    # SOCK_STREAM + IPPROTO_TCP if neither hint is given
412    if( !defined $hints{socktype} and !defined $hints{protocol} ) {
413       $hints{socktype} = SOCK_STREAM;
414       $hints{protocol} = IPPROTO_TCP;
415    }
416
417    # Some OSes (NetBSD) don't seem to like just a protocol hint without a
418    # socktype hint as well. We'll set a couple of common ones
419    if( !defined $hints{socktype} and defined $hints{protocol} ) {
420       $hints{socktype} = SOCK_STREAM if $hints{protocol} == IPPROTO_TCP;
421       $hints{socktype} = SOCK_DGRAM  if $hints{protocol} == IPPROTO_UDP;
422    }
423
424    if( my $info = $arg->{LocalAddrInfo} ) {
425       ref $info eq "ARRAY" or croak "Expected 'LocalAddrInfo' to be an ARRAY ref";
426       @localinfos = @$info;
427    }
428    elsif( defined $arg->{LocalHost} or defined $arg->{LocalService} ) {
429       # Either may be undef
430       my $host = $arg->{LocalHost};
431       my $service = $arg->{LocalService};
432
433       local $1; # Placate a taint-related bug; [perl #67962]
434       defined $service and $service =~ s/\((\d+)\)$// and
435          my $fallback_port = $1;
436
437       my %localhints = %hints;
438       $localhints{flags} |= AI_PASSIVE;
439       ( my $err, @localinfos ) = getaddrinfo( $host, $service, \%localhints );
440
441       if( $err and defined $fallback_port ) {
442          ( $err, @localinfos ) = getaddrinfo( $host, $fallback_port, \%localhints );
443       }
444
445       if( $err ) {
446          $@ = "$err";
447          $! = EINVAL;
448          return;
449       }
450    }
451
452    if( my $info = $arg->{PeerAddrInfo} ) {
453       ref $info eq "ARRAY" or croak "Expected 'PeerAddrInfo' to be an ARRAY ref";
454       @peerinfos = @$info;
455    }
456    elsif( defined $arg->{PeerHost} or defined $arg->{PeerService} ) {
457       defined( my $host = $arg->{PeerHost} ) or
458          croak "Expected 'PeerHost'";
459       defined( my $service = $arg->{PeerService} ) or
460          croak "Expected 'PeerService'";
461
462       local $1; # Placate a taint-related bug; [perl #67962]
463       defined $service and $service =~ s/\((\d+)\)$// and
464          my $fallback_port = $1;
465
466       ( my $err, @peerinfos ) = getaddrinfo( $host, $service, \%hints );
467
468       if( $err and defined $fallback_port ) {
469          ( $err, @peerinfos ) = getaddrinfo( $host, $fallback_port, \%hints );
470       }
471
472       if( $err ) {
473          $@ = "$err";
474          $! = EINVAL;
475          return;
476       }
477    }
478
479    my @sockopts_enabled;
480    push @sockopts_enabled, SO_REUSEADDR if $arg->{ReuseAddr};
481    push @sockopts_enabled, SO_REUSEPORT if $arg->{ReusePort};
482    push @sockopts_enabled, SO_BROADCAST if $arg->{Broadcast};
483
484    my $listenqueue = $arg->{Listen};
485
486    croak "Cannot Listen with a PeerHost" if defined $listenqueue and @peerinfos;
487
488    my $blocking = $arg->{Blocking};
489    defined $blocking or $blocking = 1;
490
491    my $v6only = $arg->{V6Only};
492
493    # IO::Socket::INET defines this key. IO::Socket::IP always implements the
494    # behaviour it requests, so we can ignore it, unless the caller is for some
495    # reason asking to disable it.
496    if( defined $arg->{MultiHomed} and !$arg->{MultiHomed} ) {
497       croak "Cannot disable the MultiHomed parameter";
498    }
499
500    my @infos;
501    foreach my $local ( @localinfos ? @localinfos : {} ) {
502       foreach my $peer ( @peerinfos ? @peerinfos : {} ) {
503          next if defined $local->{family}   and defined $peer->{family}   and
504             $local->{family} != $peer->{family};
505          next if defined $local->{socktype} and defined $peer->{socktype} and
506             $local->{socktype} != $peer->{socktype};
507          next if defined $local->{protocol} and defined $peer->{protocol} and
508             $local->{protocol} != $peer->{protocol};
509
510          my $family   = $local->{family}   || $peer->{family}   or next;
511          my $socktype = $local->{socktype} || $peer->{socktype} or next;
512          my $protocol = $local->{protocol} || $peer->{protocol} || 0;
513
514          push @infos, {
515             family    => $family,
516             socktype  => $socktype,
517             protocol  => $protocol,
518             localaddr => $local->{addr},
519             peeraddr  => $peer->{addr},
520          };
521       }
522    }
523
524    if( !@infos ) {
525       # If there was a Family hint then create a plain unbound, unconnected socket
526       if( defined $hints{family} ) {
527          @infos = ( {
528             family   => $hints{family},
529             socktype => $hints{socktype},
530             protocol => $hints{protocol},
531          } );
532       }
533       # If there wasn't, use getaddrinfo()'s AI_ADDRCONFIG side-effect to guess a
534       # suitable family first.
535       else {
536          ( my $err, @infos ) = getaddrinfo( "", "0", \%hints );
537          if( $err ) {
538             $@ = "$err";
539             $! = EINVAL;
540             return;
541          }
542
543          # We'll take all the @infos anyway, because some OSes (HPUX) are known to
544          # ignore the AI_ADDRCONFIG hint and return AF_INET6 even if they don't
545          # support them
546       }
547    }
548
549    # In the nonblocking case, caller will be calling ->setup multiple times.
550    # Store configuration in the object for the ->setup method
551    # Yes, these are messy. Sorry, I can't help that...
552
553    ${*$self}{io_socket_ip_infos} = \@infos;
554
555    ${*$self}{io_socket_ip_idx} = -1;
556
557    ${*$self}{io_socket_ip_sockopts} = \@sockopts_enabled;
558    ${*$self}{io_socket_ip_v6only} = $v6only;
559    ${*$self}{io_socket_ip_listenqueue} = $listenqueue;
560    ${*$self}{io_socket_ip_blocking} = $blocking;
561
562    ${*$self}{io_socket_ip_errors} = [ undef, undef, undef ];
563
564    # ->setup is allowed to return false in nonblocking mode
565    $self->setup or !$blocking or return undef;
566
567    return $self;
568 }
569
570 sub setup
571 {
572    my $self = shift;
573
574    while(1) {
575       ${*$self}{io_socket_ip_idx}++;
576       last if ${*$self}{io_socket_ip_idx} >= @{ ${*$self}{io_socket_ip_infos} };
577
578       my $info = ${*$self}{io_socket_ip_infos}->[${*$self}{io_socket_ip_idx}];
579
580       $self->socket( @{$info}{qw( family socktype protocol )} ) or
581          ( ${*$self}{io_socket_ip_errors}[2] = $!, next );
582
583       $self->blocking( 0 ) unless ${*$self}{io_socket_ip_blocking};
584
585       foreach my $sockopt ( @{ ${*$self}{io_socket_ip_sockopts} } ) {
586          $self->setsockopt( SOL_SOCKET, $sockopt, pack "i", 1 ) or ( $@ = "$!", return undef );
587       }
588
589       if( defined ${*$self}{io_socket_ip_v6only} and defined $AF_INET6 and $info->{family} == $AF_INET6 ) {
590          my $v6only = ${*$self}{io_socket_ip_v6only};
591          $self->setsockopt( IPPROTO_IPV6, IPV6_V6ONLY, pack "i", $v6only ) or ( $@ = "$!", return undef );
592       }
593
594       if( defined( my $addr = $info->{localaddr} ) ) {
595          $self->bind( $addr ) or
596             ( ${*$self}{io_socket_ip_errors}[1] = $!, next );
597       }
598
599       if( defined( my $listenqueue = ${*$self}{io_socket_ip_listenqueue} ) ) {
600          $self->listen( $listenqueue ) or ( $@ = "$!", return undef );
601       }
602
603       if( defined( my $addr = $info->{peeraddr} ) ) {
604          if( $self->connect( $addr ) ) {
605             $! = 0;
606             return 1;
607          }
608
609          if( $! == EINPROGRESS or HAVE_MSWIN32 && $! == Errno::EWOULDBLOCK() ) {
610             ${*$self}{io_socket_ip_connect_in_progress} = 1;
611             return 0;
612          }
613
614          # If connect failed but we have no system error there must be an error
615          # at the application layer, like a bad certificate with
616          # IO::Socket::SSL.
617          # In this case don't continue IP based multi-homing because the problem
618          # cannot be solved at the IP layer.
619          return 0 if ! $!;
620
621          ${*$self}{io_socket_ip_errors}[0] = $!;
622          next;
623       }
624
625       return 1;
626    }
627
628    # Pick the most appropriate error, stringified
629    $! = ( grep defined, @{ ${*$self}{io_socket_ip_errors}} )[0];
630    $@ = "$!";
631    return undef;
632 }
633
634 sub connect
635 {
636    my $self = shift;
637
638    # It seems that IO::Socket hides EINPROGRESS errors, making them look like
639    # a success. This is annoying here.
640    # Instead of putting up with its frankly-irritating intentional breakage of
641    # useful APIs I'm just going to end-run around it and call CORE::connect()
642    # directly
643
644    return CORE::connect( $self, $_[0] ) if @_;
645
646    return 1 if !${*$self}{io_socket_ip_connect_in_progress};
647
648    # See if a connect attempt has just failed with an error
649    if( my $errno = $self->getsockopt( SOL_SOCKET, SO_ERROR ) ) {
650       delete ${*$self}{io_socket_ip_connect_in_progress};
651       ${*$self}{io_socket_ip_errors}[0] = $! = $errno;
652       return $self->setup;
653    }
654
655    # No error, so either connect is still in progress, or has completed
656    # successfully. We can tell by trying to connect() again; either it will
657    # succeed or we'll get EISCONN (connected successfully), or EALREADY
658    # (still in progress). This even works on MSWin32.
659    my $addr = ${*$self}{io_socket_ip_infos}[${*$self}{io_socket_ip_idx}]{peeraddr};
660
661    if( CORE::connect( $self, $addr ) or $! == EISCONN ) {
662       delete ${*$self}{io_socket_ip_connect_in_progress};
663       $! = 0;
664       return 1;
665    }
666    else {
667       $! = EINPROGRESS;
668       return 0;
669    }
670 }
671
672 sub connected
673 {
674    my $self = shift;
675    return defined $self->fileno &&
676           !${*$self}{io_socket_ip_connect_in_progress} &&
677           defined getpeername( $self ); # ->peername caches, we need to detect disconnection
678 }
679
680 =head1 METHODS
681
682 As well as the following methods, this class inherits all the methods in
683 L<IO::Socket> and L<IO::Handle>.
684
685 =cut
686
687 sub _get_host_service
688 {
689    my $self = shift;
690    my ( $addr, $flags, $xflags ) = @_;
691
692    $flags |= NI_DGRAM if $self->socktype == SOCK_DGRAM;
693
694    my ( $err, $host, $service ) = getnameinfo( $addr, $flags, $xflags || 0 );
695    croak "getnameinfo - $err" if $err;
696
697    return ( $host, $service );
698 }
699
700 sub _unpack_sockaddr
701 {
702    my ( $addr ) = @_;
703    my $family = sockaddr_family $addr;
704
705    if( $family == AF_INET ) {
706       return ( Socket::unpack_sockaddr_in( $addr ) )[1];
707    }
708    elsif( defined $AF_INET6 and $family == $AF_INET6 ) {
709       return ( Socket::unpack_sockaddr_in6( $addr ) )[1];
710    }
711    else {
712       croak "Unrecognised address family $family";
713    }
714 }
715
716 =head2 ( $host, $service ) = $sock->sockhost_service( $numeric )
717
718 Returns the hostname and service name of the local address (that is, the
719 socket address given by the C<sockname> method).
720
721 If C<$numeric> is true, these will be given in numeric form rather than being
722 resolved into names.
723
724 The following four convenience wrappers may be used to obtain one of the two
725 values returned here. If both host and service names are required, this method
726 is preferable to the following wrappers, because it will call
727 C<getnameinfo(3)> only once.
728
729 =cut
730
731 sub sockhost_service
732 {
733    my $self = shift;
734    my ( $numeric ) = @_;
735
736    $self->_get_host_service( $self->sockname, $numeric ? NI_NUMERICHOST|NI_NUMERICSERV : 0 );
737 }
738
739 =head2 $addr = $sock->sockhost
740
741 Return the numeric form of the local address as a textual representation
742
743 =head2 $port = $sock->sockport
744
745 Return the numeric form of the local port number
746
747 =head2 $host = $sock->sockhostname
748
749 Return the resolved name of the local address
750
751 =head2 $service = $sock->sockservice
752
753 Return the resolved name of the local port number
754
755 =cut
756
757 sub sockhost { my $self = shift; ( $self->_get_host_service( $self->sockname, NI_NUMERICHOST, NIx_NOSERV ) )[0] }
758 sub sockport { my $self = shift; ( $self->_get_host_service( $self->sockname, NI_NUMERICSERV, NIx_NOHOST ) )[1] }
759
760 sub sockhostname { my $self = shift; ( $self->_get_host_service( $self->sockname, 0, NIx_NOSERV ) )[0] }
761 sub sockservice  { my $self = shift; ( $self->_get_host_service( $self->sockname, 0, NIx_NOHOST ) )[1] }
762
763 =head2 $addr = $sock->sockaddr
764
765 Return the local address as a binary octet string
766
767 =cut
768
769 sub sockaddr { my $self = shift; _unpack_sockaddr $self->sockname }
770
771 =head2 ( $host, $service ) = $sock->peerhost_service( $numeric )
772
773 Returns the hostname and service name of the peer address (that is, the
774 socket address given by the C<peername> method), similar to the
775 C<sockhost_service> method.
776
777 The following four convenience wrappers may be used to obtain one of the two
778 values returned here. If both host and service names are required, this method
779 is preferable to the following wrappers, because it will call
780 C<getnameinfo(3)> only once.
781
782 =cut
783
784 sub peerhost_service
785 {
786    my $self = shift;
787    my ( $numeric ) = @_;
788
789    $self->_get_host_service( $self->peername, $numeric ? NI_NUMERICHOST|NI_NUMERICSERV : 0 );
790 }
791
792 =head2 $addr = $sock->peerhost
793
794 Return the numeric form of the peer address as a textual representation
795
796 =head2 $port = $sock->peerport
797
798 Return the numeric form of the peer port number
799
800 =head2 $host = $sock->peerhostname
801
802 Return the resolved name of the peer address
803
804 =head2 $service = $sock->peerservice
805
806 Return the resolved name of the peer port number
807
808 =cut
809
810 sub peerhost { my $self = shift; ( $self->_get_host_service( $self->peername, NI_NUMERICHOST, NIx_NOSERV ) )[0] }
811 sub peerport { my $self = shift; ( $self->_get_host_service( $self->peername, NI_NUMERICSERV, NIx_NOHOST ) )[1] }
812
813 sub peerhostname { my $self = shift; ( $self->_get_host_service( $self->peername, 0, NIx_NOSERV ) )[0] }
814 sub peerservice  { my $self = shift; ( $self->_get_host_service( $self->peername, 0, NIx_NOHOST ) )[1] }
815
816 =head2 $addr = $peer->peeraddr
817
818 Return the peer address as a binary octet string
819
820 =cut
821
822 sub peeraddr { my $self = shift; _unpack_sockaddr $self->peername }
823
824 # This unbelievably dodgy hack works around the bug that IO::Socket doesn't do
825 # it
826 #    https://rt.cpan.org/Ticket/Display.html?id=61577
827 sub accept
828 {
829    my $self = shift;
830    my ( $new, $peer ) = $self->SUPER::accept( @_ ) or return;
831
832    ${*$new}{$_} = ${*$self}{$_} for qw( io_socket_domain io_socket_type io_socket_proto );
833
834    return wantarray ? ( $new, $peer )
835                     : $new;
836 }
837
838 # This second unbelievably dodgy hack guarantees that $self->fileno doesn't
839 # change, which is useful during nonblocking connect
840 sub socket
841 {
842    my $self = shift;
843    return $self->SUPER::socket(@_) if not defined $self->fileno;
844
845    # I hate core prototypes sometimes...
846    CORE::socket( my $tmph, $_[0], $_[1], $_[2] ) or return undef;
847
848    dup2( $tmph->fileno, $self->fileno ) or die "Unable to dup2 $tmph onto $self - $!";
849 }
850
851 # Versions of IO::Socket before 1.35 may leave socktype undef if from, say, an
852 #   ->fdopen call. In this case we'll apply a fix
853 BEGIN {
854    if( $IO::Socket::VERSION < 1.35 ) {
855       *socktype = sub {
856          my $self = shift;
857          my $type = $self->SUPER::socktype;
858          if( !defined $type ) {
859             $type = $self->sockopt( Socket::SO_TYPE() );
860          }
861          return $type;
862       };
863    }
864 }
865
866 =head2 $inet = $sock->as_inet
867
868 Returns a new L<IO::Socket::INET> instance wrapping the same filehandle. This
869 may be useful in cases where it is required, for backward-compatibility, to
870 have a real object of C<IO::Socket::INET> type instead of C<IO::Socket::IP>.
871 The new object will wrap the same underlying socket filehandle as the
872 original, so care should be taken not to continue to use both objects
873 concurrently. Ideally the original C<$sock> should be discarded after this
874 method is called.
875
876 This method checks that the socket domain is C<PF_INET> and will throw an
877 exception if it isn't.
878
879 =cut
880
881 sub as_inet
882 {
883    my $self = shift;
884    croak "Cannot downgrade a non-PF_INET socket to IO::Socket::INET" unless $self->sockdomain == AF_INET;
885    return IO::Socket::INET->new_from_fd( $self->fileno, "r+" );
886 }
887
888 =head1 NON-BLOCKING
889
890 If the constructor is passed a defined but false value for the C<Blocking>
891 argument then the socket is put into non-blocking mode. When in non-blocking
892 mode, the socket will not be set up by the time the constructor returns,
893 because the underlying C<connect(2)> syscall would otherwise have to block.
894
895 The non-blocking behaviour is an extension of the C<IO::Socket::INET> API,
896 unique to C<IO::Socket::IP>, because the former does not support multi-homed
897 non-blocking connect.
898
899 When using non-blocking mode, the caller must repeatedly check for
900 writeability on the filehandle (for instance using C<select> or C<IO::Poll>).
901 Each time the filehandle is ready to write, the C<connect> method must be
902 called, with no arguments. Note that some operating systems, most notably
903 C<MSWin32> do not report a C<connect()> failure using write-ready; so you must
904 also C<select()> for exceptional status.
905
906 While C<connect> returns false, the value of C<$!> indicates whether it should
907 be tried again (by being set to the value C<EINPROGRESS>, or C<EWOULDBLOCK> on
908 MSWin32), or whether a permanent error has occurred (e.g. C<ECONNREFUSED>).
909
910 Once the socket has been connected to the peer, C<connect> will return true
911 and the socket will now be ready to use.
912
913 Note that calls to the platform's underlying C<getaddrinfo(3)> function may
914 block. If C<IO::Socket::IP> has to perform this lookup, the constructor will
915 block even when in non-blocking mode.
916
917 To avoid this blocking behaviour, the caller should pass in the result of such
918 a lookup using the C<PeerAddrInfo> or C<LocalAddrInfo> arguments. This can be
919 achieved by using L<Net::LibAsyncNS>, or the C<getaddrinfo(3)> function can be
920 called in a child process.
921
922  use IO::Socket::IP;
923  use Errno qw( EINPROGRESS EWOULDBLOCK );
924
925  my @peeraddrinfo = ... # Caller must obtain the getaddinfo result here
926
927  my $socket = IO::Socket::IP->new(
928     PeerAddrInfo => \@peeraddrinfo,
929     Blocking     => 0,
930  ) or die "Cannot construct socket - $@";
931
932  while( !$socket->connect and ( $! == EINPROGRESS || $! == EWOULDBLOCK ) ) {
933     my $wvec = '';
934     vec( $wvec, fileno $socket, 1 ) = 1;
935     my $evec = '';
936     vec( $evec, fileno $socket, 1 ) = 1;
937
938     select( undef, $wvec, $evec, undef ) or die "Cannot select - $!";
939  }
940
941  die "Cannot connect - $!" if $!;
942
943  ...
944
945 The example above uses C<select()>, but any similar mechanism should work
946 analogously. C<IO::Socket::IP> takes care when creating new socket filehandles
947 to preserve the actual file descriptor number, so such techniques as C<poll>
948 or C<epoll> should be transparent to its reallocation of a different socket
949 underneath, perhaps in order to switch protocol family between C<PF_INET> and
950 C<PF_INET6>.
951
952 For another example using C<IO::Poll> and C<Net::LibAsyncNS>, see the
953 F<examples/nonblocking_libasyncns.pl> file in the module distribution.
954
955 =cut
956
957 =head1 C<PeerHost> AND C<LocalHost> PARSING
958
959 To support the C<IO::Socket::INET> API, the host and port information may be
960 passed in a single string rather than as two separate arguments.
961
962 If either C<LocalHost> or C<PeerHost> (or their C<...Addr> synonyms) have any
963 of the following special forms then special parsing is applied.
964
965 The value of the C<...Host> argument will be split to give both the hostname
966 and port (or service name):
967
968  hostname.example.org:http    # Host name
969  192.0.2.1:80                 # IPv4 address
970  [2001:db8::1]:80             # IPv6 address
971
972 In each case, the port or service name (e.g. C<80>) is passed as the
973 C<LocalService> or C<PeerService> argument.
974
975 Either of C<LocalService> or C<PeerService> (or their C<...Port> synonyms) can
976 be either a service name, a decimal number, or a string containing both a
977 service name and number, in a form such as
978
979  http(80)
980
981 In this case, the name (C<http>) will be tried first, but if the resolver does
982 not understand it then the port number (C<80>) will be used instead.
983
984 If the C<...Host> argument is in this special form and the corresponding
985 C<...Service> or C<...Port> argument is also defined, the one parsed from
986 the C<...Host> argument will take precedence and the other will be ignored.
987
988 =head2 ( $host, $port ) = IO::Socket::IP->split_addr( $addr )
989
990 Utility method that provides the parsing functionality described above.
991 Returns a 2-element list, containing either the split hostname and port
992 description if it could be parsed, or the given address and C<undef> if it was
993 not recognised.
994
995  IO::Socket::IP->split_addr( "hostname:http" )
996                               # ( "hostname",  "http" )
997
998  IO::Socket::IP->split_addr( "192.0.2.1:80" )
999                               # ( "192.0.2.1", "80"   )
1000
1001  IO::Socket::IP->split_addr( "[2001:db8::1]:80" )
1002                               # ( "2001:db8::1", "80" )
1003
1004  IO::Socket::IP->split_addr( "something.else" )
1005                               # ( "something.else", undef )
1006
1007 =cut
1008
1009 sub split_addr
1010 {
1011    shift;
1012    my ( $addr ) = @_;
1013
1014    local ( $1, $2 ); # Placate a taint-related bug; [perl #67962]
1015    if( $addr =~ m/\A\[($IPv6_re)\](?::([^\s:]*))?\z/ or
1016        $addr =~ m/\A([^\s:]*):([^\s:]*)\z/ ) {
1017       return ( $1, $2 ) if defined $2 and length $2;
1018       return ( $1, undef );
1019    }
1020
1021    return ( $addr, undef );
1022 }
1023
1024 =head2 $addr = IO::Socket::IP->join_addr( $host, $port )
1025
1026 Utility method that performs the reverse of C<split_addr>, returning a string
1027 formed by joining the specified host address and port number. The host address
1028 will be wrapped in C<[]> brackets if required (because it is a raw IPv6
1029 numeric address).
1030
1031 This can be especially useful when combined with the C<sockhost_service> or
1032 C<peerhost_service> methods.
1033
1034  say "Connected to ", IO::Socket::IP->join_addr( $sock->peerhost_service );
1035
1036 =cut
1037
1038 sub join_addr
1039 {
1040    shift;
1041    my ( $host, $port ) = @_;
1042
1043    $host = "[$host]" if $host =~ m/:/;
1044
1045    return join ":", $host, $port if defined $port;
1046    return $host;
1047 }
1048
1049 # Since IO::Socket->new( Domain => ... ) will delete the Domain parameter
1050 # before calling ->configure, we need to keep track of which it was
1051
1052 package # hide from indexer
1053    IO::Socket::IP::_ForINET;
1054 use base qw( IO::Socket::IP );
1055
1056 sub configure
1057 {
1058    # This is evil
1059    my $self = shift;
1060    my ( $arg ) = @_;
1061
1062    bless $self, "IO::Socket::IP";
1063    $self->configure( { %$arg, Family => Socket::AF_INET() } );
1064 }
1065
1066 package # hide from indexer
1067    IO::Socket::IP::_ForINET6;
1068 use base qw( IO::Socket::IP );
1069
1070 sub configure
1071 {
1072    # This is evil
1073    my $self = shift;
1074    my ( $arg ) = @_;
1075
1076    bless $self, "IO::Socket::IP";
1077    $self->configure( { %$arg, Family => Socket::AF_INET6() } );
1078 }
1079
1080 =head1 C<IO::Socket::INET> INCOMPATIBILITES
1081
1082 =over 4
1083
1084 =item *
1085
1086 The behaviour enabled by C<MultiHomed> is in fact implemented by
1087 C<IO::Socket::IP> as it is required to correctly support searching for a
1088 useable address from the results of the C<getaddrinfo(3)> call. The
1089 constructor will ignore the value of this argument, except if it is defined
1090 but false. An exception is thrown in this case, because that would request it
1091 disable the C<getaddrinfo(3)> search behaviour in the first place.
1092
1093 =back
1094
1095 =cut
1096
1097 =head1 TODO
1098
1099 =over 4
1100
1101 =item *
1102
1103 Investigate whether C<POSIX::dup2> upsets BSD's C<kqueue> watchers, and if so,
1104 consider what possible workarounds might be applied.
1105
1106 =back
1107
1108 =head1 AUTHOR
1109
1110 Paul Evans <leonerd@leonerd.org.uk>
1111
1112 =cut
1113
1114 0x55AA;