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