1=head1 NAME 2 3AnyEvent::Socket - useful IPv4 and IPv6 stuff. also unix domain sockets. and stuff. 4 5=head1 SYNOPSIS 6 7 use AnyEvent::Socket; 8 9 tcp_connect "gameserver.deliantra.net", 13327, sub { 10 my ($fh) = @_ 11 or die "gameserver.deliantra.net connect failed: $!"; 12 13 # enjoy your filehandle 14 }; 15 16 # a simple tcp server 17 tcp_server undef, 8888, sub { 18 my ($fh, $host, $port) = @_; 19 20 syswrite $fh, "The internet is full, $host:$port. Go away!\015\012"; 21 }; 22 23=head1 DESCRIPTION 24 25This module implements various utility functions for handling internet 26protocol addresses and sockets, in an as transparent and simple way as 27possible. 28 29All functions documented without C<AnyEvent::Socket::> prefix are exported 30by default. 31 32=over 4 33 34=cut 35 36package AnyEvent::Socket; 37 38use Carp (); 39use Errno (); 40use Socket qw(AF_INET AF_UNIX SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR); 41 42use AnyEvent (); BEGIN { AnyEvent::common_sense } 43use AnyEvent::Util qw(guard AF_INET6); 44use AnyEvent::DNS (); 45 46use base 'Exporter'; 47 48our @EXPORT = qw( 49 getprotobyname 50 parse_hostport format_hostport 51 parse_ipv4 parse_ipv6 52 parse_ip parse_address 53 format_ipv4 format_ipv6 54 format_ip format_address 55 address_family 56 inet_aton 57 tcp_server 58 tcp_connect 59); 60 61our $VERSION = $AnyEvent::VERSION; 62 63=item $ipn = parse_ipv4 $dotted_quad 64 65Tries to parse the given dotted quad IPv4 address and return it in 66octet form (or undef when it isn't in a parsable format). Supports all 67forms specified by POSIX (e.g. C<10.0.0.1>, C<10.1>, C<10.0x020304>, 68C<0x12345678> or C<0377.0377.0377.0377>). 69 70=cut 71 72sub parse_ipv4($) { 73 $_[0] =~ /^ (?: 0x[0-9a-fA-F]+ | 0[0-7]* | [1-9][0-9]* ) 74 (?:\. (?: 0x[0-9a-fA-F]+ | 0[0-7]* | [1-9][0-9]* ) ){0,3}$/x 75 or return undef; 76 77 @_ = map /^0/ ? oct : $_, split /\./, $_[0]; 78 79 # check leading parts against range 80 return undef if grep $_ >= 256, @_[0 .. @_ - 2]; 81 82 # check trailing part against range 83 return undef if $_[-1] >= 2 ** (8 * (4 - $#_)); 84 85 pack "N", (pop) 86 + ($_[0] << 24) 87 + ($_[1] << 16) 88 + ($_[2] << 8); 89} 90 91=item $ipn = parse_ipv6 $textual_ipv6_address 92 93Tries to parse the given IPv6 address and return it in 94octet form (or undef when it isn't in a parsable format). 95 96Should support all forms specified by RFC 2373 (and additionally all IPv4 97forms supported by parse_ipv4). Note that scope-id's are not supported 98(and will not parse). 99 100This function works similarly to C<inet_pton AF_INET6, ...>. 101 102Example: 103 104 print unpack "H*", parse_ipv6 "2002:5345::10.0.0.1"; 105 # => 2002534500000000000000000a000001 106 107 print unpack "H*", parse_ipv6 "192.89.98.1"; 108 # => 00000000000000000000ffffc0596201 109 110=cut 111 112sub parse_ipv6($) { 113 # quick test to avoid longer processing 114 my $n = $_[0] =~ y/://; 115 116 if ($n < 2 || $n > 8) { 117 if (!$n && (my $ipn = parse_ipv4 $_[0])) { 118 return "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff$ipn"; 119 } 120 return undef; 121 } 122 123 my ($h, $t) = split /::/, $_[0], 2; 124 125 unless (defined $t) { 126 ($h, $t) = (undef, $h); 127 } 128 129 my @h = split /:/, $h, -1; 130 my @t = split /:/, $t, -1; 131 132 # check for ipv4 tail 133 if (@t && $t[-1]=~ /\./) { 134 return undef if $n > 6; 135 136 my $ipn = parse_ipv4 pop @t 137 or return undef; 138 139 push @t, map +(sprintf "%x", $_), unpack "nn", $ipn; 140 } 141 142 # no :: then we need to have exactly 8 components 143 return undef unless @h + @t == 8 || $_[0] =~ /::/; 144 145 # now check all parts for validity 146 return undef if grep !/^[0-9a-fA-F]{1,4}$/, @h, @t; 147 148 # now pad... 149 push @h, 0 while @h + @t < 8; 150 151 # and done 152 pack "n*", map hex, @h, @t 153} 154 155=item $token = parse_unix $hostname 156 157This function exists mainly for symmetry to the other C<parse_protocol> 158functions - it takes a hostname and, if it is C<unix/>, it returns a 159special address token, otherwise C<undef>. 160 161The only use for this function is probably to detect whether a hostname 162matches whatever AnyEvent uses for unix domain sockets. 163 164=cut 165 166sub parse_unix($) { 167 $_[0] eq "unix/" 168 ? pack "S", AF_UNIX 169 : undef 170 171} 172 173=item $ipn = parse_address $ip 174 175Combines C<parse_ipv4>, C<parse_ipv6> and C<parse_unix> in one 176function. The address here refers to the host address (not socket address) 177in network form (binary). 178 179If the C<$text> is C<unix/>, then this function returns a special token 180recognised by the other functions in this module to mean "UNIX domain 181socket". 182 183If the C<$text> to parse is a plain IPv4 or mapped IPv4 in IPv6 address 184(:ffff::<ipv4>), then it will be treated as an IPv4 address and four 185octets will be returned. If you don't want that, you have to call 186C<parse_ipv4> and/or C<parse_ipv6> manually (the latter always returning a 18716 octet IPv6 address for mapped IPv4 addresses). 188 189Example: 190 191 print unpack "H*", parse_address "10.1.2.3"; 192 # => 0a010203 193 194=item $ipn = AnyEvent::Socket::aton $ip 195 196Same as C<parse_address>, but not exported (think C<Socket::inet_aton> but 197I<without> name resolution). 198 199=cut 200 201sub parse_address($) { 202 for (&parse_ipv6) { 203 if ($_) { 204 s/^\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff//; 205 return $_ 206 } else { 207 return &parse_unix 208 } 209 } 210} 211 212*aton = \&parse_address; 213 214=item ($name, $aliases, $proto) = getprotobyname $name 215 216Works like the builtin function of the same name, except it tries hard to 217work even on broken platforms (well, that's windows), where getprotobyname 218is traditionally very unreliable. 219 220Example: get the protocol number for TCP (usually 6) 221 222 my $proto = getprotobyname "tcp"; 223 224=cut 225 226# microsoft can't even get getprotobyname working (the etc/protocols file 227# gets lost fairly often on windows), so we have to hardcode some common 228# protocol numbers ourselves. 229our %PROTO_BYNAME; 230 231$PROTO_BYNAME{tcp} = Socket::IPPROTO_TCP () if defined &Socket::IPPROTO_TCP; 232$PROTO_BYNAME{udp} = Socket::IPPROTO_UDP () if defined &Socket::IPPROTO_UDP; 233$PROTO_BYNAME{icmp} = Socket::IPPROTO_ICMP() if defined &Socket::IPPROTO_ICMP; 234 235sub getprotobyname($) { 236 my $name = lc shift; 237 238 defined (my $proton = $PROTO_BYNAME{$name} || (getprotobyname $name)[2]) 239 or return; 240 241 ($name, uc $name, $proton) 242} 243 244=item ($host, $service) = parse_hostport $string[, $default_service] 245 246Splitting a string of the form C<hostname:port> is a common 247problem. Unfortunately, just splitting on the colon makes it hard to 248specify IPv6 addresses and doesn't support the less common but well 249standardised C<[ip literal]> syntax. 250 251This function tries to do this job in a better way, it supports (at 252least) the following formats, where C<port> can be a numerical port 253number of a service name, or a C<name=port> string, and the C< port> and 254C<:port> parts are optional. Also, everywhere where an IP address is 255supported a hostname or unix domain socket address is also supported (see 256C<parse_unix>), and strings starting with C</> will also be interpreted as 257unix domain sockets. 258 259 hostname:port e.g. "www.linux.org", "www.x.de:443", "www.x.de:https=443", 260 ipv4:port e.g. "198.182.196.56", "127.1:22" 261 ipv6 e.g. "::1", "affe::1" 262 [ipv4or6]:port e.g. "[::1]", "[10.0.1]:80" 263 [ipv4or6] port e.g. "[127.0.0.1]", "[www.x.org] 17" 264 ipv4or6 port e.g. "::1 443", "10.0.0.1 smtp" 265 unix/:path e.g. "unix/:/path/to/socket" 266 /path e.g. "/path/to/socket" 267 268It also supports defaulting the service name in a simple way by using 269C<$default_service> if no service was detected. If neither a service was 270detected nor a default was specified, then this function returns the 271empty list. The same happens when a parse error was detected, such as a 272hostname with a colon in it (the function is rather forgiving, though). 273 274Example: 275 276 print join ",", parse_hostport "localhost:443"; 277 # => "localhost,443" 278 279 print join ",", parse_hostport "localhost", "https"; 280 # => "localhost,https" 281 282 print join ",", parse_hostport "[::1]"; 283 # => "," (empty list) 284 285 print join ",", parse_hostport "/tmp/debug.sock"; 286 # => "unix/", "/tmp/debug.sock" 287 288=cut 289 290sub parse_hostport($;$) { 291 my ($host, $port); 292 293 for ("$_[0]") { # work on a copy, just in case, and also reset pos 294 295 # shortcut for /path 296 return ("unix/", $_) 297 if m%^/%; 298 299 # parse host, special cases: "ipv6" or "ipv6[#p ]port" 300 unless ( 301 ($host) = /^\s* ([0-9a-fA-F:]*:[0-9a-fA-F:]*:[0-9a-fA-F\.:]*)/xgc 302 and parse_ipv6 $host 303 ) { 304 /^\s*/xgc; 305 306 if (/^ \[ ([^\[\]]+) \]/xgc) { 307 $host = $1; 308 } elsif (/^ ([^\[\]:\ ]+) /xgc) { 309 $host = $1; 310 } else { 311 return; 312 } 313 } 314 315 # parse port 316 if (/\G (?:\s+|:|\#) ([^:[:space:]]+) \s*$/xgc) { 317 $port = $1; 318 } elsif (/\G\s*$/gc && length $_[1]) { 319 $port = $_[1]; 320 } else { 321 return; 322 } 323 324 } 325 326 # hostnames must not contain :'s 327 return if $host =~ /:/ && !parse_ipv6 $host; 328 329 ($host, $port) 330} 331 332=item $string = format_hostport $host, $port 333 334Takes a host (in textual form) and a port and formats in unambigiously in 335a way that C<parse_hostport> can parse it again. C<$port> can be C<undef>. 336 337=cut 338 339sub format_hostport($;$) { 340 my ($host, $port) = @_; 341 342 $port = ":$port" if length $port; 343 $host = "[$host]" if $host =~ /:/; 344 345 "$host$port" 346} 347 348=item $sa_family = address_family $ipn 349 350Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :) 351of the given host address in network format. 352 353=cut 354 355sub address_family($) { 356 4 == length $_[0] 357 ? AF_INET 358 : 16 == length $_[0] 359 ? AF_INET6 360 : unpack "S", $_[0] 361} 362 363=item $text = format_ipv4 $ipn 364 365Expects a four octet string representing a binary IPv4 address and returns 366its textual format. Rarely used, see C<format_address> for a nicer 367interface. 368 369=item $text = format_ipv6 $ipn 370 371Expects a sixteen octet string representing a binary IPv6 address and 372returns its textual format. Rarely used, see C<format_address> for a 373nicer interface. 374 375=item $text = format_address $ipn 376 377Covnvert a host address in network format (e.g. 4 octets for IPv4 or 16 378octets for IPv6) and convert it into textual form. 379 380Returns C<unix/> for UNIX domain sockets. 381 382This function works similarly to C<inet_ntop AF_INET || AF_INET6, ...>, 383except it automatically detects the address type. 384 385Returns C<undef> if it cannot detect the type. 386 387If the C<$ipn> is a mapped IPv4 in IPv6 address (:ffff::<ipv4>), then just 388the contained IPv4 address will be returned. If you do not want that, you 389have to call C<format_ipv6> manually. 390 391Example: 392 393 print format_address "\x01\x02\x03\x05"; 394 => 1.2.3.5 395 396=item $text = AnyEvent::Socket::ntoa $ipn 397 398Same as format_address, but not exported (think C<inet_ntoa>). 399 400=cut 401 402sub format_ipv4($) { 403 join ".", unpack "C4", $_[0] 404} 405 406sub format_ipv6($) { 407 if ($_[0] =~ /^\x00\x00\x00\x00\x00\x00\x00\x00/) { 408 if (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0 eq $_[0]) { 409 return "::"; 410 } elsif (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1 eq $_[0]) { 411 return "::1"; 412 } elsif (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) { 413 # v4compatible 414 return "::" . format_ipv4 substr $_[0], 12; 415 } elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) { 416 # v4mapped 417 return "::ffff:" . format_ipv4 substr $_[0], 12; 418 } elsif (v0.0.0.0.0.0.0.0.255.255.0.0 eq substr $_[0], 0, 12) { 419 # v4translated 420 return "::ffff:0:" . format_ipv4 substr $_[0], 12; 421 } 422 } 423 424 my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0]; 425 426 # this is admittedly rather sucky 427 $ip =~ s/(?:^|:) 0:0:0:0:0:0:0 (?:$|:)/::/x 428 or $ip =~ s/(?:^|:) 0:0:0:0:0:0 (?:$|:)/::/x 429 or $ip =~ s/(?:^|:) 0:0:0:0:0 (?:$|:)/::/x 430 or $ip =~ s/(?:^|:) 0:0:0:0 (?:$|:)/::/x 431 or $ip =~ s/(?:^|:) 0:0:0 (?:$|:)/::/x 432 or $ip =~ s/(?:^|:) 0:0 (?:$|:)/::/x; 433 434 $ip 435} 436 437sub format_address($) { 438 if (4 == length $_[0]) { 439 return &format_ipv4; 440 } elsif (16 == length $_[0]) { 441 return $_[0] =~ /^\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff(....)$/s 442 ? format_ipv4 $1 443 : &format_ipv6; 444 } elsif (AF_UNIX == address_family $_[0]) { 445 return "unix/" 446 } else { 447 return undef 448 } 449} 450 451*ntoa = \&format_address; 452 453=item inet_aton $name_or_address, $cb->(@addresses) 454 455Works similarly to its Socket counterpart, except that it uses a 456callback. Use the length to distinguish between ipv4 and ipv6 (4 octets 457for IPv4, 16 for IPv6), or use C<format_address> to convert it to a more 458readable format. 459 460Note that C<resolve_sockaddr>, while initially a more complex interface, 461resolves host addresses, IDNs, service names and SRV records and gives you 462an ordered list of socket addresses to try and should be preferred over 463C<inet_aton>. 464 465Example. 466 467 inet_aton "www.google.com", my $cv = AE::cv; 468 say unpack "H*", $_ 469 for $cv->recv; 470 # => d155e363 471 # => d155e367 etc. 472 473 inet_aton "ipv6.google.com", my $cv = AE::cv; 474 say unpack "H*", $_ 475 for $cv->recv; 476 # => 20014860a00300000000000000000068 477 478=cut 479 480sub inet_aton { 481 my ($name, $cb) = @_; 482 483 if (my $ipn = &parse_ipv4) { 484 $cb->($ipn); 485 } elsif (my $ipn = &parse_ipv6) { 486 $cb->($ipn); 487 } elsif ($name eq "localhost") { # rfc2606 et al. 488 $cb->(v127.0.0.1, v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1); 489 } else { 490 require AnyEvent::DNS unless $AnyEvent::DNS::VERSION; 491 492 my $ipv4 = $AnyEvent::PROTOCOL{ipv4}; 493 my $ipv6 = $AnyEvent::PROTOCOL{ipv6}; 494 495 my @res; 496 497 my $cv = AE::cv { 498 $cb->(map @$_, reverse @res); 499 }; 500 501 $cv->begin; 502 503 if ($ipv4) { 504 $cv->begin; 505 AnyEvent::DNS::a ($name, sub { 506 $res[$ipv4] = [map { parse_ipv4 $_ } @_]; 507 $cv->end; 508 }); 509 }; 510 511 if ($ipv6) { 512 $cv->begin; 513 AnyEvent::DNS::aaaa ($name, sub { 514 $res[$ipv6] = [map { parse_ipv6 $_ } @_]; 515 $cv->end; 516 }); 517 }; 518 519 $cv->end; 520 } 521} 522 523BEGIN { 524 *sockaddr_family = $Socket::VERSION >= 1.75 525 ? \&Socket::sockaddr_family 526 : # for 5.6.x, we need to do something much more horrible 527 (Socket::pack_sockaddr_in 0x5555, "\x55\x55\x55\x55" 528 | eval { Socket::pack_sockaddr_un "U" }) =~ /^\x00/ 529 ? sub { unpack "xC", $_[0] } 530 : sub { unpack "S" , $_[0] }; 531} 532 533# check for broken platforms with an extra field in sockaddr structure 534# kind of a rfc vs. bsd issue, as usual (ok, normally it's a 535# unix vs. bsd issue, a iso C vs. bsd issue or simply a 536# correctness vs. bsd issue.) 537my $pack_family = 0x55 == sockaddr_family ("\x55\x55") 538 ? "xC" : "S"; 539 540=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host 541 542Pack the given port/host combination into a binary sockaddr 543structure. Handles both IPv4 and IPv6 host addresses, as well as UNIX 544domain sockets (C<$host> == C<unix/> and C<$service> == absolute 545pathname). 546 547Example: 548 549 my $bind = AnyEvent::Socket::pack_sockaddr 43, v195.234.53.120; 550 bind $socket, $bind 551 or die "bind: $!"; 552 553=cut 554 555sub pack_sockaddr($$) { 556 my $af = address_family $_[1]; 557 558 if ($af == AF_INET) { 559 Socket::pack_sockaddr_in $_[0], $_[1] 560 } elsif ($af == AF_INET6) { 561 pack "$pack_family nL a16 L", 562 AF_INET6, 563 $_[0], # port 564 0, # flowinfo 565 $_[1], # addr 566 0 # scope id 567 } elsif ($af == AF_UNIX) { 568 Socket::pack_sockaddr_un $_[0] 569 } else { 570 Carp::croak "pack_sockaddr: invalid host"; 571 } 572} 573 574=item ($service, $host) = AnyEvent::Socket::unpack_sockaddr $sa 575 576Unpack the given binary sockaddr structure (as used by bind, getpeername 577etc.) into a C<$service, $host> combination. 578 579For IPv4 and IPv6, C<$service> is the port number and C<$host> the host 580address in network format (binary). 581 582For UNIX domain sockets, C<$service> is the absolute pathname and C<$host> 583is a special token that is understood by the other functions in this 584module (C<format_address> converts it to C<unix/>). 585 586=cut 587 588# perl contains a bug (imho) where it requires that the kernel always returns 589# sockaddr_un structures of maximum length (which is not, AFAICS, required 590# by any standard). try to 0-pad structures for the benefit of those platforms. 591# unfortunately, the IO::Async author chose to break Socket again in version 592# 2.011 - it now contains a bogus length check, so we disable the workaround. 593 594my $sa_un_zero = $Socket::VERSION >= 2.011 595 ? "" 596 : eval { Socket::pack_sockaddr_un "" }; 597 598$sa_un_zero ^= $sa_un_zero; 599 600sub unpack_sockaddr($) { 601 my $af = sockaddr_family $_[0]; 602 603 if ($af == AF_INET) { 604 Socket::unpack_sockaddr_in $_[0] 605 } elsif ($af == AF_INET6) { 606 unpack "x2 n x4 a16", $_[0] 607 } elsif ($af == AF_UNIX) { 608 ((Socket::unpack_sockaddr_un $_[0] ^ $sa_un_zero), pack "S", AF_UNIX) 609 } else { 610 Carp::croak "unpack_sockaddr: unsupported protocol family $af"; 611 } 612} 613 614=item AnyEvent::Socket::resolve_sockaddr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...) 615 616Tries to resolve the given nodename and service name into protocol families 617and sockaddr structures usable to connect to this node and service in a 618protocol-independent way. It works remotely similar to the getaddrinfo 619posix function. 620 621For internet addresses, C<$node> is either an IPv4 or IPv6 address, an 622internet hostname (DNS domain name or IDN), and C<$service> is either 623a service name (port name from F</etc/services>) or a numerical port 624number. If both C<$node> and C<$service> are names, then SRV records 625will be consulted to find the real service, otherwise they will be 626used as-is. If you know that the service name is not in your services 627database, then you can specify the service in the format C<name=port> 628(e.g. C<http=80>). 629 630If a host cannot be found via DNS, then it will be looked up in 631F</etc/hosts> (or the file specified via C<< $ENV{PERL_ANYEVENT_HOSTS} 632>>). If they are found, the addresses there will be used. The effect is as 633if entries from F</etc/hosts> would yield C<A> and C<AAAA> records for the 634host name unless DNS already had records for them. 635 636For UNIX domain sockets, C<$node> must be the string C<unix/> and 637C<$service> must be the absolute pathname of the socket. In this case, 638C<$proto> will be ignored. 639 640C<$proto> must be a protocol name, currently C<tcp>, C<udp> or 641C<sctp>. The default is currently C<tcp>, but in the future, this function 642might try to use other protocols such as C<sctp>, depending on the socket 643type and any SRV records it might find. 644 645C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use 646only IPv4) or C<6> (use only IPv6). The default is influenced by 647C<$ENV{PERL_ANYEVENT_PROTOCOLS}>. 648 649C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or 650C<undef> in which case it gets automatically chosen to be C<SOCK_STREAM> 651unless C<$proto> is C<udp>). 652 653The callback will receive zero or more array references that contain 654C<$family, $type, $proto> for use in C<socket> and a binary 655C<$sockaddr> for use in C<connect> (or C<bind>). 656 657The application should try these in the order given. 658 659Example: 660 661 resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... }; 662 663=cut 664 665our %HOSTS; # $HOSTS{$nodename}[$ipv6] = [@aliases...] 666our @HOSTS_CHECKING; # callbacks to call when hosts have been loaded 667our $HOSTS_MTIME; 668 669sub _parse_hosts($) { 670 %HOSTS = (); 671 672 for (split /\n/, $_[0]) { 673 s/#.*$//; 674 s/^[ \t]+//; 675 y/A-Z/a-z/; 676 677 my ($addr, @aliases) = split /[ \t]+/; 678 next unless @aliases; 679 680 if (my $ip = parse_ipv4 $addr) { 681 ($ip) = $ip =~ /^(.*)$/s if AnyEvent::TAINT; 682 push @{ $HOSTS{$_}[0] }, $ip 683 for @aliases; 684 } elsif (my $ip = parse_ipv6 $addr) { 685 ($ip) = $ip =~ /^(.*)$/s if AnyEvent::TAINT; 686 push @{ $HOSTS{$_}[1] }, $ip 687 for @aliases; 688 } 689 } 690} 691 692# helper function - unless dns delivered results, check and parse hosts, then call continuation code 693sub _load_hosts_unless(&$@) { 694 my ($cont, $cv, @dns) = @_; 695 696 if (@dns) { 697 $cv->end; 698 } else { 699 my $etc_hosts = length $ENV{PERL_ANYEVENT_HOSTS} ? $ENV{PERL_ANYEVENT_HOSTS} 700 : AnyEvent::WIN32 ? "$ENV{SystemRoot}/system32/drivers/etc/hosts" 701 : "/etc/hosts"; 702 703 push @HOSTS_CHECKING, sub { 704 $cont->(); 705 $cv->end; 706 }; 707 708 unless ($#HOSTS_CHECKING) { 709 # we are not the first, so we actually have to do the work 710 require AnyEvent::IO; 711 712 AnyEvent::IO::aio_stat ($etc_hosts, sub { 713 if ((stat _)[9] ne $HOSTS_MTIME) { 714 AE::log 8 => "(re)loading $etc_hosts."; 715 $HOSTS_MTIME = (stat _)[9]; 716 # we might load a newer version of hosts,but that's a harmless race, 717 # as the next call will just load it again. 718 AnyEvent::IO::aio_load ($etc_hosts, sub { 719 _parse_hosts $_[0]; 720 (shift @HOSTS_CHECKING)->() while @HOSTS_CHECKING; 721 }); 722 } else { 723 (shift @HOSTS_CHECKING)->() while @HOSTS_CHECKING; 724 } 725 }); 726 } 727 } 728} 729 730sub resolve_sockaddr($$$$$$) { 731 my ($node, $service, $proto, $family, $type, $cb) = @_; 732 733 if ($node eq "unix/") { 734 return $cb->() if $family || $service !~ /^\//; # no can do 735 736 return $cb->([AF_UNIX, defined $type ? $type : SOCK_STREAM, 0, Socket::pack_sockaddr_un $service]); 737 } 738 739 unless (AF_INET6) { 740 $family != 6 741 or return $cb->(); 742 743 $family = 4; 744 } 745 746 $cb->() if $family == 4 && !$AnyEvent::PROTOCOL{ipv4}; 747 $cb->() if $family == 6 && !$AnyEvent::PROTOCOL{ipv6}; 748 749 $family ||= 4 unless $AnyEvent::PROTOCOL{ipv6}; 750 $family ||= 6 unless $AnyEvent::PROTOCOL{ipv4}; 751 752 $proto ||= "tcp"; 753 $type ||= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM; 754 755 my $proton = AnyEvent::Socket::getprotobyname $proto 756 or Carp::croak "$proto: protocol unknown"; 757 758 my $port; 759 760 if ($service =~ /^(\S+)=(\d+)$/) { 761 ($service, $port) = ($1, $2); 762 } elsif ($service =~ /^\d+$/) { 763 ($service, $port) = (undef, $service); 764 } else { 765 $port = (getservbyname $service, $proto)[2] 766 or Carp::croak "$service/$proto: service unknown"; 767 } 768 769 # resolve a records / provide sockaddr structures 770 my $resolve = sub { 771 my @target = @_; 772 773 my @res; 774 my $cv = AE::cv { 775 $cb->( 776 map $_->[2], 777 sort { 778 $AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]} 779 or $a->[0] <=> $b->[0] 780 } 781 @res 782 ) 783 }; 784 785 $cv->begin; 786 for my $idx (0 .. $#target) { 787 my ($node, $port) = @{ $target[$idx] }; 788 789 if (my $noden = parse_address $node) { 790 my $af = address_family $noden; 791 792 if ($af == AF_INET && $family != 6) { 793 push @res, [$idx, "ipv4", [AF_INET, $type, $proton, 794 pack_sockaddr $port, $noden]] 795 } 796 797 if ($af == AF_INET6 && $family != 4) { 798 push @res, [$idx, "ipv6", [AF_INET6, $type, $proton, 799 pack_sockaddr $port, $noden]] 800 } 801 } else { 802 $node =~ y/A-Z/a-z/; 803 804 # a records 805 if ($family != 6) { 806 $cv->begin; 807 AnyEvent::DNS::a $node, sub { 808 push @res, [$idx, "ipv4", [AF_INET, $type, $proton, pack_sockaddr $port, parse_ipv4 $_]] 809 for @_; 810 811 # dns takes precedence over hosts 812 _load_hosts_unless { 813 push @res, 814 map [$idx, "ipv4", [AF_INET, $type, $proton, pack_sockaddr $port, $_]], 815 @{ ($HOSTS{$node} || [])->[0] }; 816 } $cv, @_; 817 }; 818 } 819 820 # aaaa records 821 if ($family != 4) { 822 $cv->begin; 823 AnyEvent::DNS::aaaa $node, sub { 824 push @res, [$idx, "ipv6", [AF_INET6, $type, $proton, pack_sockaddr $port, parse_ipv6 $_]] 825 for @_; 826 827 _load_hosts_unless { 828 push @res, 829 map [$idx + 0.5, "ipv6", [AF_INET6, $type, $proton, pack_sockaddr $port, $_]], 830 @{ ($HOSTS{$node} || [])->[1] } 831 } $cv, @_; 832 }; 833 } 834 } 835 } 836 $cv->end; 837 }; 838 839 $node = AnyEvent::Util::idn_to_ascii $node 840 if $node =~ /[^\x00-\x7f]/; 841 842 # try srv records, if applicable 843 if ($node eq "localhost") { 844 $resolve->(["127.0.0.1", $port], ["::1", $port]); 845 } elsif (defined $service && !parse_address $node) { 846 AnyEvent::DNS::srv $service, $proto, $node, sub { 847 my (@srv) = @_; 848 849 if (@srv) { 850 # the only srv record has "." ("" here) => abort 851 $srv[0][2] ne "" || $#srv 852 or return $cb->(); 853 854 # use srv records then 855 $resolve->( 856 map ["$_->[3].", $_->[2]], 857 grep $_->[3] ne ".", 858 @srv 859 ); 860 } else { 861 # no srv records, continue traditionally 862 $resolve->([$node, $port]); 863 } 864 }; 865 } else { 866 # most common case 867 $resolve->([$node, $port]); 868 } 869} 870 871=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb] 872 873This is a convenience function that creates a TCP socket and makes a 874100% non-blocking connect to the given C<$host> (which can be a DNS/IDN 875hostname or a textual IP address, or the string C<unix/> for UNIX domain 876sockets) and C<$service> (which can be a numeric port number or a service 877name, or a C<servicename=portnumber> string, or the pathname to a UNIX 878domain socket). 879 880If both C<$host> and C<$port> are names, then this function will use SRV 881records to locate the real target(s). 882 883In either case, it will create a list of target hosts (e.g. for multihomed 884hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to 885each in turn. 886 887After the connection is established, then the C<$connect_cb> will be 888invoked with the socket file handle (in non-blocking mode) as first, and 889the peer host (as a textual IP address) and peer port as second and third 890arguments, respectively. The fourth argument is a code reference that you 891can call if, for some reason, you don't like this connection, which will 892cause C<tcp_connect> to try the next one (or call your callback without 893any arguments if there are no more connections). In most cases, you can 894simply ignore this argument. 895 896 $cb->($filehandle, $host, $port, $retry) 897 898If the connect is unsuccessful, then the C<$connect_cb> will be invoked 899without any arguments and C<$!> will be set appropriately (with C<ENXIO> 900indicating a DNS resolution failure). 901 902The callback will I<never> be invoked before C<tcp_connect> returns, even 903if C<tcp_connect> was able to connect immediately (e.g. on unix domain 904sockets). 905 906The file handle is perfect for being plugged into L<AnyEvent::Handle>, but 907can be used as a normal perl file handle as well. 908 909Unless called in void context, C<tcp_connect> returns a guard object that 910will automatically cancel the connection attempt when it gets destroyed 911- in which case the callback will not be invoked. Destroying it does not 912do anything to the socket after the connect was successful - you cannot 913"uncall" a callback that has been invoked already. 914 915Sometimes you need to "prepare" the socket before connecting, for example, 916to C<bind> it to some port, or you want a specific connect timeout that 917is lower than your kernel's default timeout. In this case you can specify 918a second callback, C<$prepare_cb>. It will be called with the file handle 919in not-yet-connected state as only argument and must return the connection 920timeout value (or C<0>, C<undef> or the empty list to indicate the default 921timeout is to be used). 922 923Note to the poor Microsoft Windows users: Windows (of course) doesn't 924correctly signal connection errors, so unless your event library works 925around this, failed connections will simply hang. The only event libraries 926that handle this condition correctly are L<EV> and L<Glib>. Additionally, 927AnyEvent works around this bug with L<Event> and in its pure-perl 928backend. All other libraries cannot correctly handle this condition. To 929lessen the impact of this windows bug, a default timeout of 30 seconds 930will be imposed on windows. Cygwin is not affected. 931 932Simple Example: connect to localhost on port 22. 933 934 tcp_connect localhost => 22, sub { 935 my $fh = shift 936 or die "unable to connect: $!"; 937 # do something 938 }; 939 940Complex Example: connect to www.google.com on port 80 and make a simple 941GET request without much error handling. Also limit the connection timeout 942to 15 seconds. 943 944 tcp_connect "www.google.com", "http", 945 sub { 946 my ($fh) = @_ 947 or die "unable to connect: $!"; 948 949 my $handle; # avoid direct assignment so on_eof has it in scope. 950 $handle = new AnyEvent::Handle 951 fh => $fh, 952 on_error => sub { 953 AE::log error => $_[2]; 954 $_[0]->destroy; 955 }, 956 on_eof => sub { 957 $handle->destroy; # destroy handle 958 AE::log info => "Done."; 959 }; 960 961 $handle->push_write ("GET / HTTP/1.0\015\012\015\012"); 962 963 $handle->push_read (line => "\015\012\015\012", sub { 964 my ($handle, $line) = @_; 965 966 # print response header 967 print "HEADER\n$line\n\nBODY\n"; 968 969 $handle->on_read (sub { 970 # print response body 971 print $_[0]->rbuf; 972 $_[0]->rbuf = ""; 973 }); 974 }); 975 }, sub { 976 my ($fh) = @_; 977 # could call $fh->bind etc. here 978 979 15 980 }; 981 982Example: connect to a UNIX domain socket. 983 984 tcp_connect "unix/", "/tmp/.X11-unix/X0", sub { 985 ... 986 } 987 988=cut 989 990sub tcp_connect($$$;$) { 991 my ($host, $port, $connect, $prepare) = @_; 992 993 # see http://cr.yp.to/docs/connect.html for some tricky aspects 994 # also http://advogato.org/article/672.html 995 996 my %state = ( fh => undef ); 997 998 # name/service to type/sockaddr resolution 999 resolve_sockaddr $host, $port, 0, 0, undef, sub { 1000 my @target = @_; 1001 1002 $state{next} = sub { 1003 return unless exists $state{fh}; 1004 1005 my $errno = $!; 1006 my $target = shift @target 1007 or return AE::postpone { 1008 return unless exists $state{fh}; 1009 %state = (); 1010 $! = $errno; 1011 $connect->(); 1012 }; 1013 1014 my ($domain, $type, $proto, $sockaddr) = @$target; 1015 1016 # socket creation 1017 socket $state{fh}, $domain, $type, $proto 1018 or return $state{next}(); 1019 1020 AnyEvent::fh_unblock $state{fh}; 1021 1022 my $timeout = $prepare && $prepare->($state{fh}); 1023 1024 $timeout ||= 30 if AnyEvent::WIN32; 1025 1026 $state{to} = AE::timer $timeout, 0, sub { 1027 $! = Errno::ETIMEDOUT; 1028 $state{next}(); 1029 } if $timeout; 1030 1031 # now connect 1032 if ( 1033 (connect $state{fh}, $sockaddr) 1034 || ($! == Errno::EINPROGRESS # POSIX 1035 || $! == Errno::EWOULDBLOCK 1036 # WSAEINPROGRESS intentionally not checked - it means something else entirely 1037 || $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt 1038 || $! == AnyEvent::Util::WSAEWOULDBLOCK) 1039 ) { 1040 $state{ww} = AE::io $state{fh}, 1, sub { 1041 # we are connected, or maybe there was an error 1042 if (my $sin = getpeername $state{fh}) { 1043 my ($port, $host) = unpack_sockaddr $sin; 1044 1045 delete $state{ww}; delete $state{to}; 1046 1047 my $guard = guard { %state = () }; 1048 1049 $connect->(delete $state{fh}, format_address $host, $port, sub { 1050 $guard->cancel; 1051 $state{next}(); 1052 }); 1053 } else { 1054 if ($! == Errno::ENOTCONN) { 1055 # dummy read to fetch real error code if !cygwin 1056 sysread $state{fh}, my $buf, 1; 1057 1058 # cygwin 1.5 continously reports "ready' but never delivers 1059 # an error with getpeername or sysread. 1060 # cygwin 1.7 only reports readyness *once*, but is otherwise 1061 # the same, which is actually more broken. 1062 # Work around both by using unportable SO_ERROR for cygwin. 1063 $! = (unpack "l", getsockopt $state{fh}, Socket::SOL_SOCKET(), Socket::SO_ERROR()) || Errno::EAGAIN 1064 if AnyEvent::CYGWIN && $! == Errno::EAGAIN; 1065 } 1066 1067 return if $! == Errno::EAGAIN; # skip spurious wake-ups 1068 1069 delete $state{ww}; delete $state{to}; 1070 1071 $state{next}(); 1072 } 1073 }; 1074 } else { 1075 $state{next}(); 1076 } 1077 }; 1078 1079 $! = Errno::ENXIO; 1080 $state{next}(); 1081 }; 1082 1083 defined wantarray && guard { %state = () } 1084} 1085 1086=item $guard = tcp_server $host, $service, $accept_cb[, $prepare_cb] 1087 1088Create and bind a stream socket to the given host address and port, set 1089the SO_REUSEADDR flag (if applicable) and call C<listen>. Unlike the name 1090implies, this function can also bind on UNIX domain sockets. 1091 1092For internet sockets, C<$host> must be an IPv4 or IPv6 address (or 1093C<undef>, in which case it binds either to C<0> or to C<::>, depending 1094on whether IPv4 or IPv6 is the preferred protocol, and maybe to both in 1095future versions, as applicable). 1096 1097To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6 1098wildcard address, use C<::>. 1099 1100The port is specified by C<$service>, which must be either a service name 1101or a numeric port number (or C<0> or C<undef>, in which case an ephemeral 1102port will be used). 1103 1104For UNIX domain sockets, C<$host> must be C<unix/> and C<$service> must be 1105the absolute pathname of the socket. This function will try to C<unlink> 1106the socket before it tries to bind to it, and will try to unlink it after 1107it stops using it. See SECURITY CONSIDERATIONS, below. 1108 1109For each new connection that could be C<accept>ed, call the C<< 1110$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking 1111mode) as first, and the peer host and port as second and third arguments 1112(see C<tcp_connect> for details). 1113 1114Croaks on any errors it can detect before the listen. 1115 1116In non-void context, this function returns a guard object whose lifetime 1117it tied to the TCP server: If the object gets destroyed, the server will 1118be stopped and the listening socket will be cleaned up/unlinked (already 1119accepted connections will not be affected). 1120 1121When called in void-context, AnyEvent will keep the listening socket alive 1122internally. In this case, there is no guarantee that the listening socket 1123will be cleaned up or unlinked. 1124 1125In all cases, when the function returns to the caller, the socket is bound 1126and in listening state. 1127 1128If you need more control over the listening socket, you can provide a 1129C<< $prepare_cb->($fh, $host, $port) >>, which is called just before the 1130C<listen ()> call, with the listen file handle as first argument, and IP 1131address and port number of the local socket endpoint as second and third 1132arguments. 1133 1134It should return the length of the listen queue (or C<0> for the default). 1135 1136Note to IPv6 users: RFC-compliant behaviour for IPv6 sockets listening on 1137C<::> is to bind to both IPv6 and IPv4 addresses by default on dual-stack 1138hosts. Unfortunately, only GNU/Linux seems to implement this properly, so 1139if you want both IPv4 and IPv6 listening sockets you should create the 1140IPv6 socket first and then attempt to bind on the IPv4 socket, but ignore 1141any C<EADDRINUSE> errors. 1142 1143Example: bind on some TCP port on the local machine and tell each client 1144to go away. 1145 1146 tcp_server undef, undef, sub { 1147 my ($fh, $host, $port) = @_; 1148 1149 syswrite $fh, "The internet is full, $host:$port. Go away!\015\012"; 1150 }, sub { 1151 my ($fh, $thishost, $thisport) = @_; 1152 AE::log info => "Bound to $thishost, port $thisport."; 1153 }; 1154 1155Example: bind a server on a unix domain socket. 1156 1157 tcp_server "unix/", "/tmp/mydir/mysocket", sub { 1158 my ($fh) = @_; 1159 }; 1160 1161=item $guard = AnyEvent::Socket::tcp_bind $host, $service, $done_cb[, $prepare_cb] 1162 1163Same as C<tcp_server>, except it doesn't call C<accept> in a loop for you 1164but simply passes the listen socket to the C<$done_cb>. This is useful 1165when you want to have a convenient set up for your listen socket, but want 1166to do the C<accept>'ing yourself, for example, in another process. 1167 1168In case of an error, C<tcp_bind> either croaks, or passes C<undef> to the 1169C<$done_cb>. 1170 1171In non-void context, a guard will be returned. It will clean up/unlink the 1172listening socket when destroyed. In void context, no automatic clean up 1173might be performed. 1174 1175=cut 1176 1177sub _tcp_bind($$$;$) { 1178 my ($host, $service, $done, $prepare) = @_; 1179 1180 $host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6 1181 ? "::" : "0" 1182 unless defined $host; 1183 1184 my $ipn = parse_address $host 1185 or Carp::croak "tcp_bind: cannot parse '$host' as host address"; 1186 1187 my $af = address_family $ipn; 1188 1189 my %state; 1190 1191 # win32 perl is too stupid to get this right :/ 1192 Carp::croak "tcp_bind: AF_UNIX address family not supported on win32" 1193 if AnyEvent::WIN32 && $af == AF_UNIX; 1194 1195 socket my $fh, $af, SOCK_STREAM, 0 1196 or Carp::croak "tcp_bind: $!"; 1197 1198 $state{fh} = $fh; 1199 1200 if ($af == AF_INET || $af == AF_INET6) { 1201 setsockopt $fh, SOL_SOCKET, SO_REUSEADDR, 1 1202 or Carp::croak "tcp_bind: so_reuseaddr: $!" 1203 unless AnyEvent::WIN32; # work around windows bug 1204 1205 unless ($service =~ /^\d*$/) { 1206 $service = (getservbyname $service, "tcp")[2] 1207 or Carp::croak "tcp_bind: unknown service '$service'" 1208 } 1209 } elsif ($af == AF_UNIX) { 1210 unlink $service; 1211 } 1212 1213 bind $fh, pack_sockaddr $service, $ipn 1214 or Carp::croak "tcp_bind: $!"; 1215 1216 if ($af == AF_UNIX and defined wantarray) { 1217 # this is racy, but is not designed to be foolproof, just best-effort 1218 my $ino = (lstat $service)[1]; 1219 $state{unlink} = guard { 1220 unlink $service 1221 if (lstat $service)[1] == $ino; 1222 }; 1223 } 1224 1225 AnyEvent::fh_unblock $fh; 1226 1227 my $len; 1228 1229 if ($prepare) { 1230 my ($service, $host) = unpack_sockaddr getsockname $fh; 1231 $len = $prepare && $prepare->($fh, format_address $host, $service); 1232 } 1233 1234 $len ||= 128; 1235 1236 listen $fh, $len 1237 or Carp::croak "tcp_bind: $!"; 1238 1239 $done->(\%state); 1240 1241 defined wantarray 1242 ? guard { %state = () } # clear fh, unlink 1243 : () 1244} 1245 1246sub tcp_bind($$$;$) { 1247 my ($host, $service, $done, $prepare) = @_; 1248 1249 _tcp_bind $host, $service, sub { 1250 $done->(delete shift->{fh}); 1251 }, $prepare 1252} 1253 1254sub tcp_server($$$;$) { 1255 my ($host, $service, $accept, $prepare) = @_; 1256 1257 _tcp_bind $host, $service, sub { 1258 my $rstate = shift; 1259 1260 $rstate->{aw} = AE::io $rstate->{fh}, 0, sub { 1261 # this closure keeps $state alive 1262 while ($rstate->{fh} && (my $peer = accept my $fh, $rstate->{fh})) { 1263 AnyEvent::fh_unblock $fh; # POSIX requires inheritance, the outside world does not 1264 1265 my ($service, $host) = unpack_sockaddr $peer; 1266 $accept->($fh, format_address $host, $service); 1267 } 1268 }; 1269 }, $prepare 1270} 1271 1272=item tcp_nodelay $fh, $enable 1273 1274Enables (or disables) the C<TCP_NODELAY> socket option (also known as 1275Nagle's algorithm). Returns false on error, true otherwise. 1276 1277=cut 1278 1279sub tcp_nodelay($$) { 1280 my $onoff = int ! ! $_[1]; 1281 1282 setsockopt $_[0], Socket::IPPROTO_TCP (), Socket::TCP_NODELAY (), $onoff 1283} 1284 1285=item tcp_congestion $fh, $algorithm 1286 1287Sets the tcp congestion avoidance algorithm (via the C<TCP_CONGESTION> 1288socket option). The default is OS-specific, but is usually 1289C<reno>. Typical other available choices include C<cubic>, C<lp>, C<bic>, 1290C<highspeed>, C<htcp>, C<hybla>, C<illinois>, C<scalable>, C<vegas>, 1291C<veno>, C<westwood> and C<yeah>. 1292 1293=cut 1294 1295sub tcp_congestion($$) { 1296 defined TCP_CONGESTION 1297 ? setsockopt $_[0], Socket::IPPROTO_TCP (), TCP_CONGESTION, "$_[1]" 1298 : undef 1299} 1300 1301=back 1302 1303=head1 SECURITY CONSIDERATIONS 1304 1305This module is quite powerful, with with power comes the ability to abuse 1306as well: If you accept "hostnames" and ports from untrusted sources, 1307then note that this can be abused to delete files (host=C<unix/>). This 1308is not really a problem with this module, however, as blindly accepting 1309any address and protocol and trying to bind a server or connect to it is 1310harmful in general. 1311 1312=head1 AUTHOR 1313 1314 Marc Lehmann <schmorp@schmorp.de> 1315 http://anyevent.schmorp.de 1316 1317=cut 1318 13191 1320 1321