This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
1911145cece15e36a84ead2365fc35ab0edb133d
[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.30';
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->IO::Socket::IP::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          ${*$self}{io_socket_ip_errors}[0] = $!;
615          next;
616       }
617
618       return 1;
619    }
620
621    # Pick the most appropriate error, stringified
622    $! = ( grep defined, @{ ${*$self}{io_socket_ip_errors}} )[0];
623    $@ = "$!";
624    return undef;
625 }
626
627 sub connect
628 {
629    my $self = shift;
630
631    # It seems that IO::Socket hides EINPROGRESS errors, making them look like
632    # a success. This is annoying here.
633    # Instead of putting up with its frankly-irritating intentional breakage of
634    # useful APIs I'm just going to end-run around it and call CORE::connect()
635    # directly
636
637    return CORE::connect( $self, $_[0] ) if @_;
638
639    return 1 if !${*$self}{io_socket_ip_connect_in_progress};
640
641    # See if a connect attempt has just failed with an error
642    if( my $errno = $self->getsockopt( SOL_SOCKET, SO_ERROR ) ) {
643       delete ${*$self}{io_socket_ip_connect_in_progress};
644       ${*$self}{io_socket_ip_errors}[0] = $! = $errno;
645       return $self->setup;
646    }
647
648    # No error, so either connect is still in progress, or has completed
649    # successfully. We can tell by trying to connect() again; either it will
650    # succeed or we'll get EISCONN (connected successfully), or EALREADY
651    # (still in progress). This even works on MSWin32.
652    my $addr = ${*$self}{io_socket_ip_infos}[${*$self}{io_socket_ip_idx}]{peeraddr};
653
654    if( $self->IO::Socket::IP::connect( $addr ) or $! == EISCONN ) {
655       delete ${*$self}{io_socket_ip_connect_in_progress};
656       $! = 0;
657       return 1;
658    }
659    else {
660       $! = EINPROGRESS;
661       return 0;
662    }
663 }
664
665 sub connected
666 {
667    my $self = shift;
668    return defined $self->fileno &&
669           !${*$self}{io_socket_ip_connect_in_progress} &&
670           defined getpeername( $self ); # ->peername caches, we need to detect disconnection
671 }
672
673 =head1 METHODS
674
675 As well as the following methods, this class inherits all the methods in
676 L<IO::Socket> and L<IO::Handle>.
677
678 =cut
679
680 sub _get_host_service
681 {
682    my $self = shift;
683    my ( $addr, $flags, $xflags ) = @_;
684
685    $flags |= NI_DGRAM if $self->socktype == SOCK_DGRAM;
686
687    my ( $err, $host, $service ) = getnameinfo( $addr, $flags, $xflags || 0 );
688    croak "getnameinfo - $err" if $err;
689
690    return ( $host, $service );
691 }
692
693 sub _unpack_sockaddr
694 {
695    my ( $addr ) = @_;
696    my $family = sockaddr_family $addr;
697
698    if( $family == AF_INET ) {
699       return ( Socket::unpack_sockaddr_in( $addr ) )[1];
700    }
701    elsif( defined $AF_INET6 and $family == $AF_INET6 ) {
702       return ( Socket::unpack_sockaddr_in6( $addr ) )[1];
703    }
704    else {
705       croak "Unrecognised address family $family";
706    }
707 }
708
709 =head2 ( $host, $service ) = $sock->sockhost_service( $numeric )
710
711 Returns the hostname and service name of the local address (that is, the
712 socket address given by the C<sockname> method).
713
714 If C<$numeric> is true, these will be given in numeric form rather than being
715 resolved into names.
716
717 The following four convenience wrappers may be used to obtain one of the two
718 values returned here. If both host and service names are required, this method
719 is preferable to the following wrappers, because it will call
720 C<getnameinfo(3)> only once.
721
722 =cut
723
724 sub sockhost_service
725 {
726    my $self = shift;
727    my ( $numeric ) = @_;
728
729    $self->_get_host_service( $self->sockname, $numeric ? NI_NUMERICHOST|NI_NUMERICSERV : 0 );
730 }
731
732 =head2 $addr = $sock->sockhost
733
734 Return the numeric form of the local address as a textual representation
735
736 =head2 $port = $sock->sockport
737
738 Return the numeric form of the local port number
739
740 =head2 $host = $sock->sockhostname
741
742 Return the resolved name of the local address
743
744 =head2 $service = $sock->sockservice
745
746 Return the resolved name of the local port number
747
748 =cut
749
750 sub sockhost { my $self = shift; ( $self->_get_host_service( $self->sockname, NI_NUMERICHOST, NIx_NOSERV ) )[0] }
751 sub sockport { my $self = shift; ( $self->_get_host_service( $self->sockname, NI_NUMERICSERV, NIx_NOHOST ) )[1] }
752
753 sub sockhostname { my $self = shift; ( $self->_get_host_service( $self->sockname, 0, NIx_NOSERV ) )[0] }
754 sub sockservice  { my $self = shift; ( $self->_get_host_service( $self->sockname, 0, NIx_NOHOST ) )[1] }
755
756 =head2 $addr = $sock->sockaddr
757
758 Return the local address as a binary octet string
759
760 =cut
761
762 sub sockaddr { my $self = shift; _unpack_sockaddr $self->sockname }
763
764 =head2 ( $host, $service ) = $sock->peerhost_service( $numeric )
765
766 Returns the hostname and service name of the peer address (that is, the
767 socket address given by the C<peername> method), similar to the
768 C<sockhost_service> method.
769
770 The following four convenience wrappers may be used to obtain one of the two
771 values returned here. If both host and service names are required, this method
772 is preferable to the following wrappers, because it will call
773 C<getnameinfo(3)> only once.
774
775 =cut
776
777 sub peerhost_service
778 {
779    my $self = shift;
780    my ( $numeric ) = @_;
781
782    $self->_get_host_service( $self->peername, $numeric ? NI_NUMERICHOST|NI_NUMERICSERV : 0 );
783 }
784
785 =head2 $addr = $sock->peerhost
786
787 Return the numeric form of the peer address as a textual representation
788
789 =head2 $port = $sock->peerport
790
791 Return the numeric form of the peer port number
792
793 =head2 $host = $sock->peerhostname
794
795 Return the resolved name of the peer address
796
797 =head2 $service = $sock->peerservice
798
799 Return the resolved name of the peer port number
800
801 =cut
802
803 sub peerhost { my $self = shift; ( $self->_get_host_service( $self->peername, NI_NUMERICHOST, NIx_NOSERV ) )[0] }
804 sub peerport { my $self = shift; ( $self->_get_host_service( $self->peername, NI_NUMERICSERV, NIx_NOHOST ) )[1] }
805
806 sub peerhostname { my $self = shift; ( $self->_get_host_service( $self->peername, 0, NIx_NOSERV ) )[0] }
807 sub peerservice  { my $self = shift; ( $self->_get_host_service( $self->peername, 0, NIx_NOHOST ) )[1] }
808
809 =head2 $addr = $peer->peeraddr
810
811 Return the peer address as a binary octet string
812
813 =cut
814
815 sub peeraddr { my $self = shift; _unpack_sockaddr $self->peername }
816
817 # This unbelievably dodgy hack works around the bug that IO::Socket doesn't do
818 # it
819 #    https://rt.cpan.org/Ticket/Display.html?id=61577
820 sub accept
821 {
822    my $self = shift;
823    my ( $new, $peer ) = $self->SUPER::accept( @_ ) or return;
824
825    ${*$new}{$_} = ${*$self}{$_} for qw( io_socket_domain io_socket_type io_socket_proto );
826
827    return wantarray ? ( $new, $peer )
828                     : $new;
829 }
830
831 # This second unbelievably dodgy hack guarantees that $self->fileno doesn't
832 # change, which is useful during nonblocking connect
833 sub socket
834 {
835    my $self = shift;
836    return $self->SUPER::socket(@_) if not defined $self->fileno;
837
838    # I hate core prototypes sometimes...
839    CORE::socket( my $tmph, $_[0], $_[1], $_[2] ) or return undef;
840
841    dup2( $tmph->fileno, $self->fileno ) or die "Unable to dup2 $tmph onto $self - $!";
842 }
843
844 # Versions of IO::Socket before 1.35 may leave socktype undef if from, say, an
845 #   ->fdopen call. In this case we'll apply a fix
846 BEGIN {
847    if( $IO::Socket::VERSION < 1.35 ) {
848       *socktype = sub {
849          my $self = shift;
850          my $type = $self->SUPER::socktype;
851          if( !defined $type ) {
852             $type = $self->sockopt( Socket::SO_TYPE() );
853          }
854          return $type;
855       };
856    }
857 }
858
859 =head2 $inet = $sock->as_inet
860
861 Returns a new L<IO::Socket::INET> instance wrapping the same filehandle. This
862 may be useful in cases where it is required, for backward-compatibility, to
863 have a real object of C<IO::Socket::INET> type instead of C<IO::Socket::IP>.
864 The new object will wrap the same underlying socket filehandle as the
865 original, so care should be taken not to continue to use both objects
866 concurrently. Ideally the original C<$sock> should be discarded after this
867 method is called.
868
869 This method checks that the socket domain is C<PF_INET> and will throw an
870 exception if it isn't.
871
872 =cut
873
874 sub as_inet
875 {
876    my $self = shift;
877    croak "Cannot downgrade a non-PF_INET socket to IO::Socket::INET" unless $self->sockdomain == AF_INET;
878    return IO::Socket::INET->new_from_fd( $self->fileno, "r+" );
879 }
880
881 =head1 NON-BLOCKING
882
883 If the constructor is passed a defined but false value for the C<Blocking>
884 argument then the socket is put into non-blocking mode. When in non-blocking
885 mode, the socket will not be set up by the time the constructor returns,
886 because the underlying C<connect(2)> syscall would otherwise have to block.
887
888 The non-blocking behaviour is an extension of the C<IO::Socket::INET> API,
889 unique to C<IO::Socket::IP>, because the former does not support multi-homed
890 non-blocking connect.
891
892 When using non-blocking mode, the caller must repeatedly check for
893 writeability on the filehandle (for instance using C<select> or C<IO::Poll>).
894 Each time the filehandle is ready to write, the C<connect> method must be
895 called, with no arguments. Note that some operating systems, most notably
896 C<MSWin32> do not report a C<connect()> failure using write-ready; so you must
897 also C<select()> for exceptional status.
898
899 While C<connect> returns false, the value of C<$!> indicates whether it should
900 be tried again (by being set to the value C<EINPROGRESS>, or C<EWOULDBLOCK> on
901 MSWin32), or whether a permanent error has occurred (e.g. C<ECONNREFUSED>).
902
903 Once the socket has been connected to the peer, C<connect> will return true
904 and the socket will now be ready to use.
905
906 Note that calls to the platform's underlying C<getaddrinfo(3)> function may
907 block. If C<IO::Socket::IP> has to perform this lookup, the constructor will
908 block even when in non-blocking mode.
909
910 To avoid this blocking behaviour, the caller should pass in the result of such
911 a lookup using the C<PeerAddrInfo> or C<LocalAddrInfo> arguments. This can be
912 achieved by using L<Net::LibAsyncNS>, or the C<getaddrinfo(3)> function can be
913 called in a child process.
914
915  use IO::Socket::IP;
916  use Errno qw( EINPROGRESS EWOULDBLOCK );
917
918  my @peeraddrinfo = ... # Caller must obtain the getaddinfo result here
919
920  my $socket = IO::Socket::IP->new(
921     PeerAddrInfo => \@peeraddrinfo,
922     Blocking     => 0,
923  ) or die "Cannot construct socket - $@";
924
925  while( !$socket->connect and ( $! == EINPROGRESS || $! == EWOULDBLOCK ) ) {
926     my $wvec = '';
927     vec( $wvec, fileno $socket, 1 ) = 1;
928     my $evec = '';
929     vec( $evec, fileno $socket, 1 ) = 1;
930
931     select( undef, $wvec, $evec, undef ) or die "Cannot select - $!";
932  }
933
934  die "Cannot connect - $!" if $!;
935
936  ...
937
938 The example above uses C<select()>, but any similar mechanism should work
939 analogously. C<IO::Socket::IP> takes care when creating new socket filehandles
940 to preserve the actual file descriptor number, so such techniques as C<poll>
941 or C<epoll> should be transparent to its reallocation of a different socket
942 underneath, perhaps in order to switch protocol family between C<PF_INET> and
943 C<PF_INET6>.
944
945 For another example using C<IO::Poll> and C<Net::LibAsyncNS>, see the
946 F<examples/nonblocking_libasyncns.pl> file in the module distribution.
947
948 =cut
949
950 =head1 C<PeerHost> AND C<LocalHost> PARSING
951
952 To support the C<IO::Socket::INET> API, the host and port information may be
953 passed in a single string rather than as two separate arguments.
954
955 If either C<LocalHost> or C<PeerHost> (or their C<...Addr> synonyms) have any
956 of the following special forms then special parsing is applied.
957
958 The value of the C<...Host> argument will be split to give both the hostname
959 and port (or service name):
960
961  hostname.example.org:http    # Host name
962  192.0.2.1:80                 # IPv4 address
963  [2001:db8::1]:80             # IPv6 address
964
965 In each case, the port or service name (e.g. C<80>) is passed as the
966 C<LocalService> or C<PeerService> argument.
967
968 Either of C<LocalService> or C<PeerService> (or their C<...Port> synonyms) can
969 be either a service name, a decimal number, or a string containing both a
970 service name and number, in a form such as
971
972  http(80)
973
974 In this case, the name (C<http>) will be tried first, but if the resolver does
975 not understand it then the port number (C<80>) will be used instead.
976
977 If the C<...Host> argument is in this special form and the corresponding
978 C<...Service> or C<...Port> argument is also defined, the one parsed from
979 the C<...Host> argument will take precedence and the other will be ignored.
980
981 =head2 ( $host, $port ) = IO::Socket::IP->split_addr( $addr )
982
983 Utility method that provides the parsing functionality described above.
984 Returns a 2-element list, containing either the split hostname and port
985 description if it could be parsed, or the given address and C<undef> if it was
986 not recognised.
987
988  IO::Socket::IP->split_addr( "hostname:http" )
989                               # ( "hostname",  "http" )
990
991  IO::Socket::IP->split_addr( "192.0.2.1:80" )
992                               # ( "192.0.2.1", "80"   )
993
994  IO::Socket::IP->split_addr( "[2001:db8::1]:80" )
995                               # ( "2001:db8::1", "80" )
996
997  IO::Socket::IP->split_addr( "something.else" )
998                               # ( "something.else", undef )
999
1000 =cut
1001
1002 sub split_addr
1003 {
1004    shift;
1005    my ( $addr ) = @_;
1006
1007    local ( $1, $2 ); # Placate a taint-related bug; [perl #67962]
1008    if( $addr =~ m/\A\[($IPv6_re)\](?::([^\s:]*))?\z/ or
1009        $addr =~ m/\A([^\s:]*):([^\s:]*)\z/ ) {
1010       return ( $1, $2 ) if defined $2 and length $2;
1011       return ( $1, undef );
1012    }
1013
1014    return ( $addr, undef );
1015 }
1016
1017 =head2 $addr = IO::Socket::IP->join_addr( $host, $port )
1018
1019 Utility method that performs the reverse of C<split_addr>, returning a string
1020 formed by joining the specified host address and port number. The host address
1021 will be wrapped in C<[]> brackets if required (because it is a raw IPv6
1022 numeric address).
1023
1024 This can be especially useful when combined with the C<sockhost_service> or
1025 C<peerhost_service> methods.
1026
1027  say "Connected to ", IO::Socket::IP->join_addr( $sock->peerhost_service );
1028
1029 =cut
1030
1031 sub join_addr
1032 {
1033    shift;
1034    my ( $host, $port ) = @_;
1035
1036    $host = "[$host]" if $host =~ m/:/;
1037
1038    return join ":", $host, $port if defined $port;
1039    return $host;
1040 }
1041
1042 # Since IO::Socket->new( Domain => ... ) will delete the Domain parameter
1043 # before calling ->configure, we need to keep track of which it was
1044
1045 package # hide from indexer
1046    IO::Socket::IP::_ForINET;
1047 use base qw( IO::Socket::IP );
1048
1049 sub configure
1050 {
1051    # This is evil
1052    my $self = shift;
1053    my ( $arg ) = @_;
1054
1055    bless $self, "IO::Socket::IP";
1056    $self->configure( { %$arg, Family => Socket::AF_INET() } );
1057 }
1058
1059 package # hide from indexer
1060    IO::Socket::IP::_ForINET6;
1061 use base qw( IO::Socket::IP );
1062
1063 sub configure
1064 {
1065    # This is evil
1066    my $self = shift;
1067    my ( $arg ) = @_;
1068
1069    bless $self, "IO::Socket::IP";
1070    $self->configure( { %$arg, Family => Socket::AF_INET6() } );
1071 }
1072
1073 =head1 C<IO::Socket::INET> INCOMPATIBILITES
1074
1075 =over 4
1076
1077 =item *
1078
1079 The behaviour enabled by C<MultiHomed> is in fact implemented by
1080 C<IO::Socket::IP> as it is required to correctly support searching for a
1081 useable address from the results of the C<getaddrinfo(3)> call. The
1082 constructor will ignore the value of this argument, except if it is defined
1083 but false. An exception is thrown in this case, because that would request it
1084 disable the C<getaddrinfo(3)> search behaviour in the first place.
1085
1086 =back
1087
1088 =cut
1089
1090 =head1 TODO
1091
1092 =over 4
1093
1094 =item *
1095
1096 Investigate whether C<POSIX::dup2> upsets BSD's C<kqueue> watchers, and if so,
1097 consider what possible workarounds might be applied.
1098
1099 =back
1100
1101 =head1 AUTHOR
1102
1103 Paul Evans <leonerd@leonerd.org.uk>
1104
1105 =cut
1106
1107 0x55AA;