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