ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent/lib/AnyEvent/DNS.pm
(Generate patch)

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.11 by root, Fri May 23 06:05:59 2008 UTC vs.
Revision 1.24 by root, Sat May 24 02:50:45 2008 UTC

… …
9=head1 DESCRIPTION 9=head1 DESCRIPTION
10 10
11This module offers both a number of DNS convenience functions as well 11This module offers both a number of DNS convenience functions as well
12as a fully asynchronous and high-performance pure-perl stub resolver. 12as a fully asynchronous and high-performance pure-perl stub resolver.
13 13
14The stub resolver supports DNS over UDP, optional EDNS0 support for up to
154kiB datagrams and automatically falls back to virtual circuit mode for
16large responses.
17
14=head2 CONVENIENCE FUNCTIONS 18=head2 CONVENIENCE FUNCTIONS
15 19
16=over 4 20=over 4
17 21
18=cut 22=cut
… …
20package AnyEvent::DNS; 24package AnyEvent::DNS;
21 25
22no warnings; 26no warnings;
23use strict; 27use strict;
24 28
25use AnyEvent::Util ();
26use AnyEvent::Handle (); 29use AnyEvent::Handle ();
27 30
28=item AnyEvent::DNS::addr $node, $service, $family, $type, $cb->(@addrs) 31=item AnyEvent::DNS::addr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)
29 32
30NOT YET IMPLEMENTED
31
32Tries to resolve the given nodename and service name into sockaddr 33Tries to resolve the given nodename and service name into protocol families
33structures usable to connect to this node and service in a 34and sockaddr structures usable to connect to this node and service in a
34protocol-independent way. It works similarly to the getaddrinfo posix 35protocol-independent way. It works remotely similar to the getaddrinfo
35function. 36posix function.
37
38C<$node> is either an IPv4 or IPv6 address or a hostname, C<$service> is
39either a service name (port name from F</etc/services>) or a numerical
40port number. If both C<$node> and C<$service> are names, then SRV records
41will be consulted to find the real service, otherwise they will be
42used as-is. If you know that the service name is not in your services
43database, then you can specify the service in the format C<name=port>
44(e.g. C<http=80>).
45
46C<$proto> must be a protocol name, currently C<tcp>, C<udp> or
47C<sctp>. The default is C<tcp>.
48
49C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use
50only IPv4) or C<6> (use only IPv6). This setting might be influenced by
51C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.
52
53C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or
54C<undef> in which case it gets automatically chosen).
55
56The callback will receive zero or more array references that contain
57C<$family, $type, $proto> for use in C<socket> and a binary
58C<$sockaddr> for use in C<connect> (or C<bind>).
59
60The application should try these in the order given.
36 61
37Example: 62Example:
38 63
39 AnyEvent::DNS::addr "google.com", "http", AF_UNSPEC, SOCK_STREAM, sub { ... }; 64 AnyEvent::DNS::addr "google.com", "http", 0, undef, undef, sub { ... };
40 65
41=item AnyEvent::DNS::a $domain, $cb->(@addrs) 66=item AnyEvent::DNS::a $domain, $cb->(@addrs)
42 67
43Tries to resolve the given domain to IPv4 address(es). 68Tries to resolve the given domain to IPv4 address(es).
69
70=item AnyEvent::DNS::aaaa $domain, $cb->(@addrs)
71
72Tries to resolve the given domain to IPv6 address(es).
44 73
45=item AnyEvent::DNS::mx $domain, $cb->(@hostnames) 74=item AnyEvent::DNS::mx $domain, $cb->(@hostnames)
46 75
47Tries to resolve the given domain into a sorted (lower preference value 76Tries to resolve the given domain into a sorted (lower preference value
48first) list of domain names. 77first) list of domain names.
… …
58=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr) 87=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
59 88
60Tries to resolve the given service, protocol and domain name into a list 89Tries to resolve the given service, protocol and domain name into a list
61of service records. 90of service records.
62 91
63Each srv_rr is an arrayref with the following contents: 92Each srv_rr is an array reference with the following contents:
64C<[$priority, $weight, $transport, $target]>. 93C<[$priority, $weight, $transport, $target]>.
65 94
66They will be sorted with lowest priority, highest weight first (TODO: 95They will be sorted with lowest priority, highest weight first (TODO:
67should use the rfc algorithm to reorder same-priority records for weight). 96should use the RFC algorithm to reorder same-priority records for weight).
68 97
69Example: 98Example:
70 99
71 AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ... 100 AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
72 # @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] ) 101 # @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
… …
74=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames) 103=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames)
75 104
76Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form) 105Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form)
77into it's hostname(s). 106into it's hostname(s).
78 107
79Requires the Socket6 module for IPv6 support.
80
81Example: 108Example:
82 109
83 AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift }; 110 AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
84 # => f.root-servers.net 111 # => f.root-servers.net
85 112
… …
94 121
95sub a($$) { 122sub a($$) {
96 my ($domain, $cb) = @_; 123 my ($domain, $cb) = @_;
97 124
98 resolver->resolve ($domain => "a", sub { 125 resolver->resolve ($domain => "a", sub {
126 $cb->(map $_->[3], @_);
127 });
128}
129
130sub aaaa($$) {
131 my ($domain, $cb) = @_;
132
133 resolver->resolve ($domain => "aaaa", sub {
99 $cb->(map $_->[3], @_); 134 $cb->(map $_->[3], @_);
100 }); 135 });
101} 136}
102 137
103sub mx($$) { 138sub mx($$) {
… …
134} 169}
135 170
136sub ptr($$) { 171sub ptr($$) {
137 my ($ip, $cb) = @_; 172 my ($ip, $cb) = @_;
138 173
139 my $name; 174 $ip = AnyEvent::Socket::parse_ip ($ip)
175 or return $cb->();
140 176
141 if (AnyEvent::Util::dotted_quad $ip) { 177 if (4 == length $ip) {
142 $name = join ".", (reverse split /\./, $ip), "in-addr.arpa."; 178 $ip = join ".", (reverse split /\./, $ip), "in-addr.arpa.";
143 } else { 179 } else {
144 require Socket6; 180 $ip = join ".", (reverse split //, unpack "H*", $ip), "ip6.arpa.";
145 $name = join ".",
146 (reverse split //,
147 unpack "H*", Socket6::inet_pton (Socket::AF_INET6, $ip)),
148 "ip6.arpa.";
149 } 181 }
150 182
151 resolver->resolve ($name => "ptr", sub { 183 resolver->resolve ($ip => "ptr", sub {
152 $cb->(map $_->[3], @_); 184 $cb->(map $_->[3], @_);
153 }); 185 });
154} 186}
155 187
156sub any($$) { 188sub any($$) {
157 my ($domain, $cb) = @_; 189 my ($domain, $cb) = @_;
158 190
159 resolver->resolve ($domain => "*", $cb); 191 resolver->resolve ($domain => "*", $cb);
160} 192}
161 193
194#############################################################################
195
196sub addr($$$$$$) {
197 my ($node, $service, $proto, $family, $type, $cb) = @_;
198
199 unless (&AnyEvent::Socket::AF_INET6) {
200 $family != 6
201 or return $cb->();
202
203 $family ||= 4;
204 }
205
206 $cb->() if $family == 4 && !$AnyEvent::PROTOCOL{ipv4};
207 $cb->() if $family == 6 && !$AnyEvent::PROTOCOL{ipv6};
208
209 $family ||=4 unless $AnyEvent::PROTOCOL{ipv6};
210 $family ||=6 unless $AnyEvent::PROTOCOL{ipv4};
211
212 $proto ||= "tcp";
213 $type ||= $proto eq "udp" ? Socket::SOCK_DGRAM : Socket::SOCK_STREAM;
214
215 my $proton = (getprotobyname $proto)[2]
216 or Carp::croak "$proto: protocol unknown";
217
218 my $port;
219
220 if ($service =~ /^(\S+)=(\d+)$/) {
221 ($service, $port) = ($1, $2);
222 } elsif ($service =~ /^\d+$/) {
223 ($service, $port) = (undef, $service);
224 } else {
225 $port = (getservbyname $service, $proto)[2]
226 or Carp::croak "$service/$proto: service unknown";
227 }
228
229 my @target = [$node, $port];
230
231 # resolve a records / provide sockaddr structures
232 my $resolve = sub {
233 my @res;
234 my $cv = AnyEvent->condvar (cb => sub {
235 $cb->(
236 map $_->[1],
237 sort {
238 $AnyEvent::PROTOCOL{$a->[1][0]} <=> $AnyEvent::PROTOCOL{$b->[1][0]}
239 or $a->[0] <=> $b->[0]
240 }
241 @res
242 )
243 });
244
245 $cv->begin;
246 for my $idx (0 .. $#target) {
247 my ($node, $port) = @{ $target[$idx] };
248
249 if (my $noden = AnyEvent::Socket::parse_ip ($node)) {
250 if (4 == length $noden && $family != 6) {
251 push @res, [$idx, [Socket::AF_INET, $type, $proton,
252 AnyEvent::Socket::pack_sockaddr ($port, $noden)]]
253 }
254
255 if (16 == length $noden && $family != 4) {
256 push @res, [$idx, [&AnyEvent::Socket::AF_INET6, $type, $proton,
257 AnyEvent::Socket::pack_sockaddr ( $port, $noden)]]
258 }
259 } else {
260 # ipv4
261 if ($family != 6) {
262 $cv->begin;
263 a $node, sub {
264 push @res, [$idx, [Socket::AF_INET, $type, $proton,
265 AnyEvent::Socket::pack_sockaddr ($port, AnyEvent::Socket::parse_ipv4 ($_))]]
266 for @_;
267 $cv->end;
268 };
269 }
270
271 # ipv6
272 if ($family != 4) {
273 $cv->begin;
274 aaaa $node, sub {
275 push @res, [$idx, [&AnyEvent::Socket::AF_INET6, $type, $proton,
276 AnyEvent::Socket::pack_sockaddr ($port, AnyEvent::Socket::parse_ipv6 ($_))]]
277 for @_;
278 $cv->end;
279 };
280 }
281 }
282 }
283 $cv->end;
284 };
285
286 # try srv records, if applicable
287 if ($node eq "localhost") {
288 @target = (["127.0.0.1", $port], ["::1", $port]);
289 &$resolve;
290 } elsif (defined $service && !AnyEvent::Socket::parse_ip ($node)) {
291 srv $service, $proto, $node, sub {
292 my (@srv) = @_;
293
294 # no srv records, continue traditionally
295 @srv
296 or return &$resolve;
297
298 # only srv record has "." => abort
299 $srv[0][2] ne "." || $#srv
300 or return $cb->();
301
302 # use srv records then
303 @target = map ["$_->[3].", $_->[2]],
304 grep $_->[3] ne ".",
305 @srv;
306
307 &$resolve;
308 };
309 } else {
310 &$resolve;
311 }
312}
313
314#############################################################################
315
316=back
317
162=head2 DNS EN-/DECODING FUNCTIONS 318=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS
163 319
164=over 4 320=over 4
165 321
166=item $AnyEvent::DNS::EDNS0 322=item $AnyEvent::DNS::EDNS0
167 323
168This variable decides wether dns_pack automatically enables EDNS0 324This variable decides whether dns_pack automatically enables EDNS0
169support. By default, this is disabled (C<0>), but when set to C<1>, 325support. By default, this is disabled (C<0>), unless overridden by
170AnyEvent::DNS will use EDNS0 in all requests. 326C<$ENV{PERL_ANYEVENT_EDNS0>), but when set to C<1>, AnyEvent::DNS will use
327EDNS0 in all requests.
171 328
172=cut 329=cut
173 330
174our $EDNS0 = 0; # set to 1 to enable (partial) edns0 331our $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0} * 1; # set to 1 to enable (partial) edns0
175 332
176our %opcode_id = ( 333our %opcode_id = (
177 query => 0, 334 query => 0,
178 iquery => 1, 335 iquery => 1,
179 status => 2, 336 status => 2,
… …
363 my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4; 520 my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;
364 [$qname, $type_str{$qt} || $qt, $class_str{$qc} || $qc] 521 [$qname, $type_str{$qt} || $qt, $class_str{$qc} || $qc]
365} 522}
366 523
367our %dec_rr = ( 524our %dec_rr = (
368 1 => sub { Socket::inet_ntoa $_ }, # a 525 1 => sub { join ".", unpack "C4" }, # a
369 2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns 526 2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns
370 5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname 527 5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname
371 6 => sub { 528 6 => sub {
372 local $ofs = $ofs - length; 529 local $ofs = $ofs - length;
373 my $mname = _dec_qname; 530 my $mname = _dec_qname;
374 my $rname = _dec_qname; 531 my $rname = _dec_qname;
375 ($mname, $rname, unpack "NNNNN", substr $pkt, $ofs) 532 ($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
376 }, # soa 533 }, # soa
377 11 => sub { ((Socket::inet_aton substr $_, 0, 4), unpack "C a*", substr $_, 4) }, # wks 534 11 => sub { ((join ".", unpack "C4"), unpack "C a*", substr $_, 4) }, # wks
378 12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr 535 12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr
379 13 => sub { unpack "C/a C/a", $_ }, # hinfo 536 13 => sub { unpack "C/a C/a", $_ }, # hinfo
380 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx 537 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx
381 16 => sub { unpack "(C/a)*", $_ }, # txt 538 16 => sub { unpack "(C/a)*", $_ }, # txt
382 28 => sub { sprintf "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x", unpack "n8" }, # aaaa 539 28 => sub { AnyEvent::Socket::format_ip ($_) }, # aaaa
383 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv 540 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv
384 99 => sub { unpack "(C/a)*", $_ }, # spf 541 99 => sub { unpack "(C/a)*", $_ }, # spf
385); 542);
386 543
387sub _dec_rr { 544sub _dec_rr {
… …
402 559
403Unpacks a DNS packet into a perl data structure. 560Unpacks a DNS packet into a perl data structure.
404 561
405Examples: 562Examples:
406 563
407 # a non-successful reply 564 # an unsuccessful reply
408 { 565 {
409 'qd' => [ 566 'qd' => [
410 [ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ] 567 [ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
411 ], 568 ],
412 'rc' => 'nxdomain', 569 'rc' => 'nxdomain',
… …
416 'uni-karlsruhe.de', 573 'uni-karlsruhe.de',
417 'soa', 574 'soa',
418 'in', 575 'in',
419 'netserv.rz.uni-karlsruhe.de', 576 'netserv.rz.uni-karlsruhe.de',
420 'hostmaster.rz.uni-karlsruhe.de', 577 'hostmaster.rz.uni-karlsruhe.de',
421 2008052201, 578 2008052201, 10800, 1800, 2592000, 86400
422 10800,
423 1800,
424 2592000,
425 86400
426 ] 579 ]
427 ], 580 ],
428 'tc' => '', 581 'tc' => '',
429 'ra' => 1, 582 'ra' => 1,
430 'qr' => 1, 583 'qr' => 1,
… …
496 649
497=back 650=back
498 651
499=head2 THE AnyEvent::DNS RESOLVER CLASS 652=head2 THE AnyEvent::DNS RESOLVER CLASS
500 653
501This is the class which deos the actual protocol work. 654This is the class which does the actual protocol work.
502 655
503=over 4 656=over 4
504 657
505=cut 658=cut
506 659
… …
526our $RESOLVER; 679our $RESOLVER;
527 680
528sub resolver() { 681sub resolver() {
529 $RESOLVER || do { 682 $RESOLVER || do {
530 $RESOLVER = new AnyEvent::DNS; 683 $RESOLVER = new AnyEvent::DNS;
531 $RESOLVER->load_resolv_conf; 684 $RESOLVER->os_config;
532 $RESOLVER 685 $RESOLVER
533 } 686 }
534} 687}
535 688
536=item $resolver = new AnyEvent::DNS key => value... 689=item $resolver = new AnyEvent::DNS key => value...
… …
541 694
542=over 4 695=over 4
543 696
544=item server => [...] 697=item server => [...]
545 698
546A list of server addressses (default C<v127.0.0.1>) in network format (4 699A list of server addresses (default: C<v127.0.0.1>) in network format (4
547octets for IPv4, 16 octets for IPv6 - not yet supported). 700octets for IPv4, 16 octets for IPv6 - not yet supported).
548 701
549=item timeout => [...] 702=item timeout => [...]
550 703
551A list of timeouts to use (also determines the number of retries). To make 704A list of timeouts to use (also determines the number of retries). To make
… …
562tries to resolve the name without any suffixes first. 715tries to resolve the name without any suffixes first.
563 716
564=item max_outstanding => $integer 717=item max_outstanding => $integer
565 718
566Most name servers do not handle many parallel requests very well. This option 719Most name servers do not handle many parallel requests very well. This option
567limits the numbe rof outstanding requests to C<$n> (default: C<10>), that means 720limits the number of outstanding requests to C<$n> (default: C<10>), that means
568if you request more than this many requests, then the additional requests will be queued 721if you request more than this many requests, then the additional requests will be queued
569until some other requests have been resolved. 722until some other requests have been resolved.
723
724=item reuse => $seconds
725
726The number of seconds (default: C<300>) that a query id cannot be re-used
727after a timeout. If there as no time-out then query id's can be reused
728immediately.
570 729
571=back 730=back
572 731
573=cut 732=cut
574 733
… …
603 $self 762 $self
604} 763}
605 764
606=item $resolver->parse_resolv_conv ($string) 765=item $resolver->parse_resolv_conv ($string)
607 766
608Parses the given string a sif it were a F<resolv.conf> file. The following 767Parses the given string as if it were a F<resolv.conf> file. The following
609directives are supported: 768directives are supported (but not necessarily implemented).
610 769
611C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>, 770C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
612C<options> (C<timeout>, C<attempts>, C<ndots>). 771C<options> (C<timeout>, C<attempts>, C<ndots>).
613 772
614Everything else is silently ignored. 773Everything else is silently ignored.
… …
658 if $attempts; 817 if $attempts;
659 818
660 $self->_compile; 819 $self->_compile;
661} 820}
662 821
663=item $resolver->load_resolv_conf 822=item $resolver->os_config
664 823
665Tries to load and parse F</etc/resolv.conf>. If there will ever be windows 824Tries so load and parse F</etc/resolv.conf> on portable operating systems. Tries various
666support, then this function will do the right thing under windows, too. 825egregious hacks on windows to force the DNS servers and searchlist out of the system.
667 826
668=cut 827=cut
669 828
670sub load_resolv_conf { 829sub os_config {
671 my ($self) = @_; 830 my ($self) = @_;
672 831
832 if ($^O =~ /mswin32|cygwin/i) {
833 # yeah, it suxx... lets hope DNS is DNS in all locales
834
835 if (open my $fh, "ipconfig /all |") {
836 delete $self->{server};
837 delete $self->{search};
838
839 while (<$fh>) {
840 # first DNS.* is suffix list
841 if (/^\s*DNS/) {
842 while (/\s+([[:alnum:].\-]+)\s*$/) {
843 push @{ $self->{search} }, $1;
844 $_ = <$fh>;
845 }
846 last;
847 }
848 }
849
850 while (<$fh>) {
851 # second DNS.* is server address list
852 if (/^\s*DNS/) {
853 while (/\s+(\d+\.\d+\.\d+\.\d+)\s*$/) {
854 my $ip = $1;
855 push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip
856 if AnyEvent::Util::dotted_quad $ip;
857 $_ = <$fh>;
858 }
859 last;
860 }
861 }
862
863 $self->_compile;
864 }
865 } else {
866 # try resolv.conf everywhere
867
673 open my $fh, "</etc/resolv.conf" 868 if (open my $fh, "</etc/resolv.conf") {
674 or return;
675
676 local $/; 869 local $/;
677 $self->parse_resolv_conf (<$fh>); 870 $self->parse_resolv_conf (<$fh>);
871 }
872 }
678} 873}
679 874
680sub _compile { 875sub _compile {
681 my $self = shift; 876 my $self = shift;
682 877
… …
707 902
708sub _recv { 903sub _recv {
709 my ($self) = @_; 904 my ($self) = @_;
710 905
711 while (my $peer = recv $self->{fh}, my $res, 4096, 0) { 906 while (my $peer = recv $self->{fh}, my $res, 4096, 0) {
712 my ($port, $host) = Socket::unpack_sockaddr_in $peer; 907 my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
713 908
714 return unless $port == 53 && grep $_ eq $host, @{ $self->{server} }; 909 return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
715 910
716 $self->_feed ($res); 911 $self->_feed ($res);
717 } 912 }
718} 913}
719 914
915sub _free_id {
916 my ($self, $id, $timeout) = @_;
917
918 if ($timeout) {
919 # we need to block the id for a while
920 $self->{id}{$id} = 1;
921 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $id];
922 } else {
923 # we can quickly recycle the id
924 delete $self->{id}{$id};
925 }
926
927 --$self->{outstanding};
928 $self->_scheduler;
929}
930
931# execute a single request, involves sending it with timeouts to multiple servers
720sub _exec { 932sub _exec {
721 my ($self, $req, $retry) = @_; 933 my ($self, $req) = @_;
722 934
935 my $retry; # of retries
936 my $do_retry;
937
938 $do_retry = sub {
723 if (my $retry_cfg = $self->{retry}[$retry]) { 939 my $retry_cfg = $self->{retry}[$retry++]
940 or do {
941 # failure
942 $self->_free_id ($req->[2], $retry > 1);
943 undef $do_retry; return $req->[1]->();
944 };
945
724 my ($server, $timeout) = @$retry_cfg; 946 my ($server, $timeout) = @$retry_cfg;
725 947
726 $self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub { 948 $self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
727 $NOW = time; 949 $NOW = time;
728 950
729 # timeout, try next 951 # timeout, try next
730 $self->_exec ($req, $retry + 1); 952 &$do_retry;
731 }), sub { 953 }), sub {
732 my ($res) = @_; 954 my ($res) = @_;
733 955
734 if ($res->{tc}) { 956 if ($res->{tc}) {
735 # success, but truncated, so use tcp 957 # success, but truncated, so use tcp
736 AnyEvent::Util::tcp_connect +(Socket::inet_ntoa $server), 53, sub { 958 AnyEvent::Socket::tcp_connect ((Socket::inet_ntoa $server), 53, sub {
737 my ($fh) = @_ 959 my ($fh) = @_
738 or return $self->_exec ($req, $retry + 1); 960 or return &$do_retry;
739 961
740 my $handle = new AnyEvent::Handle 962 my $handle = new AnyEvent::Handle
741 fh => $fh, 963 fh => $fh,
742 on_error => sub { 964 on_error => sub {
743 # failure, try next 965 # failure, try next
744 $self->_exec ($req, $retry + 1); 966 &$do_retry;
745 }; 967 };
746 968
747 $handle->push_write (pack "n/a", $req->[0]); 969 $handle->push_write (pack "n/a", $req->[0]);
748 $handle->push_read_chunk (2, sub { 970 $handle->push_read_chunk (2, sub {
749 $handle->unshift_read_chunk ((unpack "n", $_[1]), sub { 971 $handle->unshift_read_chunk ((unpack "n", $_[1]), sub {
750 $self->_feed ($_[1]); 972 $self->_feed ($_[1]);
751 }); 973 });
752 }); 974 });
753 shutdown $fh, 1; 975 shutdown $fh, 1;
754 976
755 }, sub { $timeout }; 977 }, sub { $timeout });
756 978
757 } else { 979 } else {
758 # success 980 # success
759 $self->{id}{$req->[2]} = 1; 981 $self->_free_id ($req->[2], $retry > 1);
760 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]]; 982 undef $do_retry; return $req->[1]->($res);
761 --$self->{outstanding};
762 $self->_scheduler;
763
764 $req->[1]->($res);
765 } 983 }
766 }]; 984 }];
767 985
768 send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server; 986 send $self->{fh}, $req->[0], 0, AnyEvent::Socket::pack_sockaddr (53, $server);
769 } else {
770 # failure
771 $self->{id}{$req->[2]} = 1;
772 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
773 --$self->{outstanding};
774 $self->_scheduler;
775
776 $req->[1]->();
777 } 987 };
988
989 &$do_retry;
778} 990}
779 991
780sub _scheduler { 992sub _scheduler {
781 my ($self) = @_; 993 my ($self) = @_;
782 994
783 $NOW = time; 995 $NOW = time;
784 996
785 # first clear id reuse queue 997 # first clear id reuse queue
786 delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] } 998 delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
787 while @{ $self->{reuse_q} } && $self->{reuse_q}[0] <= $NOW; 999 while @{ $self->{reuse_q} } && $self->{reuse_q}[0][0] <= $NOW;
788 1000
789 while ($self->{outstanding} < $self->{max_outstanding}) { 1001 while ($self->{outstanding} < $self->{max_outstanding}) {
1002
1003 if (@{ $self->{reuse_q} } >= 30000) {
1004 # we ran out of ID's, wait a bit
1005 $self->{reuse_to} ||= AnyEvent->timer (after => $self->{reuse_q}[0][0] - $NOW, cb => sub {
1006 delete $self->{reuse_to};
1007 $self->_scheduler;
1008 });
1009 last;
1010 }
1011
790 my $req = shift @{ $self->{queue} } 1012 my $req = shift @{ $self->{queue} }
791 or last; 1013 or last;
792 1014
793 while () { 1015 while () {
794 $req->[2] = int rand 65536; 1016 $req->[2] = int rand 65536;
795 last unless exists $self->{id}{$req->[2]}; 1017 last unless exists $self->{id}{$req->[2]};
796 } 1018 }
797 1019
1020 ++$self->{outstanding};
798 $self->{id}{$req->[2]} = 1; 1021 $self->{id}{$req->[2]} = 1;
799 substr $req->[0], 0, 2, pack "n", $req->[2]; 1022 substr $req->[0], 0, 2, pack "n", $req->[2];
800 1023
801 ++$self->{outstanding};
802 $self->_exec ($req, 0); 1024 $self->_exec ($req);
803 } 1025 }
804} 1026}
805 1027
806=item $resolver->request ($req, $cb->($res)) 1028=item $resolver->request ($req, $cb->($res))
807 1029
… …
827The callback will be invoked with a list of matching result records or 1049The callback will be invoked with a list of matching result records or
828none on any error or if the name could not be found. 1050none on any error or if the name could not be found.
829 1051
830CNAME chains (although illegal) are followed up to a length of 8. 1052CNAME chains (although illegal) are followed up to a length of 8.
831 1053
832Note that this resolver is just a stub resolver: it requires a nameserver 1054Note that this resolver is just a stub resolver: it requires a name server
833supporting recursive queries, will not do any recursive queries itself and 1055supporting recursive queries, will not do any recursive queries itself and
834is not secure when used against an untrusted name server. 1056is not secure when used against an untrusted name server.
835 1057
836The following options are supported: 1058The following options are supported:
837 1059
… …
913 my %atype = $opt{accept} 1135 my %atype = $opt{accept}
914 ? map +($_ => 1), @{ $opt{accept} } 1136 ? map +($_ => 1), @{ $opt{accept} }
915 : ($qtype => 1); 1137 : ($qtype => 1);
916 1138
917 # advance in searchlist 1139 # advance in searchlist
918 my $do_search; $do_search = sub { 1140 my ($do_search, $do_req);
1141
1142 $do_search = sub {
919 @search 1143 @search
920 or return $cb->(); 1144 or (undef $do_search), (undef $do_req), return $cb->();
921 1145
922 (my $name = lc "$qname." . shift @search) =~ s/\.$//; 1146 (my $name = lc "$qname." . shift @search) =~ s/\.$//;
923 my $depth = 2; 1147 my $depth = 2;
924 1148
925 # advance in cname-chain 1149 # advance in cname-chain
926 my $do_req; $do_req = sub { 1150 $do_req = sub {
927 $self->request ({ 1151 $self->request ({
928 rd => 1, 1152 rd => 1,
929 qd => [[$name, $qtype, $class]], 1153 qd => [[$name, $qtype, $class]],
930 }, sub { 1154 }, sub {
931 my ($res) = @_ 1155 my ($res) = @_
… …
935 1159
936 while () { 1160 while () {
937 # results found? 1161 # results found?
938 my @rr = grep $name eq lc $_->[0] && ($atype{"*"} || $atype{$_->[1]}), @{ $res->{an} }; 1162 my @rr = grep $name eq lc $_->[0] && ($atype{"*"} || $atype{$_->[1]}), @{ $res->{an} };
939 1163
940 return $cb->(@rr) 1164 (undef $do_search), (undef $do_req), return $cb->(@rr)
941 if @rr; 1165 if @rr;
942 1166
943 # see if there is a cname we can follow 1167 # see if there is a cname we can follow
944 my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} }; 1168 my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };
945 1169
… …
966 }; 1190 };
967 1191
968 $do_search->(); 1192 $do_search->();
969} 1193}
970 1194
1195use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
1196
9711; 11971;
972 1198
973=back 1199=back
974 1200
975=head1 AUTHOR 1201=head1 AUTHOR

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines