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