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.3 by root, Fri May 23 03:20:53 2008 UTC vs.
Revision 1.17 by root, Fri May 23 20:21:50 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
16# none yet
17 19
18=over 4 20=over 4
19 21
20=cut 22=cut
21 23
22package AnyEvent::DNS; 24package AnyEvent::DNS;
23 25
24no warnings; 26no warnings;
25use strict; 27use strict;
26 28
27use AnyEvent::Util (); 29use AnyEvent::Handle ();
30
31=item AnyEvent::DNS::addr $node, $service, $family, $type, $cb->(@addrs)
32
33NOT YET IMPLEMENTED
34
35Tries to resolve the given nodename and service name into sockaddr
36structures usable to connect to this node and service in a
37protocol-independent way. It works similarly to the getaddrinfo posix
38function.
39
40Example:
41
42 AnyEvent::DNS::addr "google.com", "http", AF_UNSPEC, SOCK_STREAM, sub { ... };
43
44=item AnyEvent::DNS::a $domain, $cb->(@addrs)
45
46Tries to resolve the given domain to IPv4 address(es).
47
48=item AnyEvent::DNS::aaaa $domain, $cb->(@addrs)
49
50Tries to resolve the given domain to IPv6 address(es).
51
52=item AnyEvent::DNS::mx $domain, $cb->(@hostnames)
53
54Tries to resolve the given domain into a sorted (lower preference value
55first) list of domain names.
56
57=item AnyEvent::DNS::ns $domain, $cb->(@hostnames)
58
59Tries to resolve the given domain name into a list of name servers.
60
61=item AnyEvent::DNS::txt $domain, $cb->(@hostnames)
62
63Tries to resolve the given domain name into a list of text records.
64
65=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
66
67Tries to resolve the given service, protocol and domain name into a list
68of service records.
69
70Each srv_rr is an arrayref with the following contents:
71C<[$priority, $weight, $transport, $target]>.
72
73They will be sorted with lowest priority, highest weight first (TODO:
74should use the rfc algorithm to reorder same-priority records for weight).
75
76Example:
77
78 AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
79 # @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
80
81=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames)
82
83Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form)
84into it's hostname(s).
85
86Example:
87
88 AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
89 # => f.root-servers.net
90
91=item AnyEvent::DNS::any $domain, $cb->(@rrs)
92
93Tries to resolve the given domain and passes all resource records found to
94the callback.
95
96=cut
97
98sub resolver;
99
100sub a($$) {
101 my ($domain, $cb) = @_;
102
103 resolver->resolve ($domain => "a", sub {
104 $cb->(map $_->[3], @_);
105 });
106}
107
108sub aaaa($$) {
109 my ($domain, $cb) = @_;
110
111 resolver->resolve ($domain => "aaaa", sub {
112 $cb->(map $_->[3], @_);
113 });
114}
115
116sub mx($$) {
117 my ($domain, $cb) = @_;
118
119 resolver->resolve ($domain => "mx", sub {
120 $cb->(map $_->[4], sort { $a->[3] <=> $b->[3] } @_);
121 });
122}
123
124sub ns($$) {
125 my ($domain, $cb) = @_;
126
127 resolver->resolve ($domain => "ns", sub {
128 $cb->(map $_->[3], @_);
129 });
130}
131
132sub txt($$) {
133 my ($domain, $cb) = @_;
134
135 resolver->resolve ($domain => "txt", sub {
136 $cb->(map $_->[3], @_);
137 });
138}
139
140sub srv($$$$) {
141 my ($service, $proto, $domain, $cb) = @_;
142
143 # todo, ask for any and check glue records
144 resolver->resolve ("_$service._$proto.$domain" => "srv", sub {
145 $cb->(map [@$_[3,4,5,6]], sort { $a->[3] <=> $b->[3] || $b->[4] <=> $a->[4] } @_);
146 });
147}
148
149sub ptr($$) {
150 my ($ip, $cb) = @_;
151
152 $ip = AnyEvent::Socket::parse_ip ($ip)
153 or return $cb->();
154
155 if (4 == length $ip) {
156 $ip = join ".", (reverse split /\./, $ip), "in-addr.arpa.";
157 } else {
158 $ip = join ".", (reverse split //, unpack "H*", $ip), "ip6.arpa.";
159 }
160
161 resolver->resolve ($ip => "ptr", sub {
162 $cb->(map $_->[3], @_);
163 });
164}
165
166sub any($$) {
167 my ($domain, $cb) = @_;
168
169 resolver->resolve ($domain => "*", $cb);
170}
28 171
29=back 172=back
30 173
31=head2 DNS EN-/DECODING FUNCTIONS 174=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS
32 175
33=over 4 176=over 4
34 177
178=item $AnyEvent::DNS::EDNS0
179
180This variable decides whether dns_pack automatically enables EDNS0
181support. By default, this is disabled (C<0>), but when set to C<1>,
182AnyEvent::DNS will use EDNS0 in all requests.
183
35=cut 184=cut
185
186our $EDNS0 = 0; # set to 1 to enable (partial) edns0
36 187
37our %opcode_id = ( 188our %opcode_id = (
38 query => 0, 189 query => 0,
39 iquery => 1, 190 iquery => 1,
40 status => 2, 191 status => 2,
192 notify => 4,
193 update => 5,
41 map +($_ => $_), 3..15 194 map +($_ => $_), 3, 6..15
42); 195);
43 196
44our %opcode_str = reverse %opcode_id; 197our %opcode_str = reverse %opcode_id;
45 198
46our %rcode_id = ( 199our %rcode_id = (
47 ok => 0, 200 noerror => 0,
48 formerr => 1, 201 formerr => 1,
49 servfail => 2, 202 servfail => 2,
50 nxdomain => 3, 203 nxdomain => 3,
51 notimp => 4, 204 notimp => 4,
52 refused => 5, 205 refused => 5,
206 yxdomain => 6, # Name Exists when it should not [RFC 2136]
207 yxrrset => 7, # RR Set Exists when it should not [RFC 2136]
208 nxrrset => 8, # RR Set that should exist does not [RFC 2136]
209 notauth => 9, # Server Not Authoritative for zone [RFC 2136]
210 notzone => 10, # Name not contained in zone [RFC 2136]
211# EDNS0 16 BADVERS Bad OPT Version [RFC 2671]
212# EDNS0 16 BADSIG TSIG Signature Failure [RFC 2845]
213# EDNS0 17 BADKEY Key not recognized [RFC 2845]
214# EDNS0 18 BADTIME Signature out of time window [RFC 2845]
215# EDNS0 19 BADMODE Bad TKEY Mode [RFC 2930]
216# EDNS0 20 BADNAME Duplicate key name [RFC 2930]
217# EDNS0 21 BADALG Algorithm not supported [RFC 2930]
53 map +($_ => $_), 6..15 218 map +($_ => $_), 11..15
54); 219);
55 220
56our %rcode_str = reverse %rcode_id; 221our %rcode_str = reverse %rcode_id;
57 222
58our %type_id = ( 223our %type_id = (
… …
72 minfo => 14, 237 minfo => 14,
73 mx => 15, 238 mx => 15,
74 txt => 16, 239 txt => 16,
75 aaaa => 28, 240 aaaa => 28,
76 srv => 33, 241 srv => 33,
242 opt => 41,
243 spf => 99,
244 tkey => 249,
245 tsig => 250,
246 ixfr => 251,
77 axfr => 252, 247 axfr => 252,
78 mailb => 253, 248 mailb => 253,
79 "*" => 255, 249 "*" => 255,
80); 250);
81 251
82our %type_str = reverse %type_id; 252our %type_str = reverse %type_id;
83 253
84our %class_id = ( 254our %class_id = (
85 in => 1, 255 in => 1,
86 ch => 3, 256 ch => 3,
87 hs => 4, 257 hs => 4,
258 none => 254,
88 "*" => 255, 259 "*" => 255,
89); 260);
90 261
91our %class_str = reverse %class_id; 262our %class_str = reverse %class_id;
92 263
93# names MUST have a trailing dot 264# names MUST have a trailing dot
… …
128 qr => 1, 299 qr => 1,
129 aa => 0, 300 aa => 0,
130 tc => 0, 301 tc => 0,
131 rd => 0, 302 rd => 0,
132 ra => 0, 303 ra => 0,
304 ad => 0,
305 cd => 0,
133 306
134 qd => [@rr], # query section 307 qd => [@rr], # query section
135 an => [@rr], # answer section 308 an => [@rr], # answer section
136 ns => [@rr], # authority section 309 ns => [@rr], # authority section
137 ar => [@rr], # additional records section 310 ar => [@rr], # additional records section
… …
140=cut 313=cut
141 314
142sub dns_pack($) { 315sub dns_pack($) {
143 my ($req) = @_; 316 my ($req) = @_;
144 317
145 pack "nn nnnn a* a* a* a*", 318 pack "nn nnnn a* a* a* a* a*",
146 $req->{id}, 319 $req->{id},
147 320
148 ! !$req->{qr} * 0x8000 321 ! !$req->{qr} * 0x8000
149 + $opcode_id{$req->{op}} * 0x0800 322 + $opcode_id{$req->{op}} * 0x0800
150 + ! !$req->{aa} * 0x0400 323 + ! !$req->{aa} * 0x0400
151 + ! !$req->{tc} * 0x0200 324 + ! !$req->{tc} * 0x0200
152 + ! !$req->{rd} * 0x0100 325 + ! !$req->{rd} * 0x0100
153 + ! !$req->{ra} * 0x0080 326 + ! !$req->{ra} * 0x0080
327 + ! !$req->{ad} * 0x0020
328 + ! !$req->{cd} * 0x0010
154 + $rcode_id{$req->{rc}} * 0x0001, 329 + $rcode_id{$req->{rc}} * 0x0001,
155 330
156 scalar @{ $req->{qd} || [] }, 331 scalar @{ $req->{qd} || [] },
157 scalar @{ $req->{an} || [] }, 332 scalar @{ $req->{an} || [] },
158 scalar @{ $req->{ns} || [] }, 333 scalar @{ $req->{ns} || [] },
159 scalar @{ $req->{ar} || [] }, 334 $EDNS0 + scalar @{ $req->{ar} || [] }, # include EDNS0 option here
160 335
161 (join "", map _enc_qd, @{ $req->{qd} || [] }), 336 (join "", map _enc_qd, @{ $req->{qd} || [] }),
162 (join "", map _enc_rr, @{ $req->{an} || [] }), 337 (join "", map _enc_rr, @{ $req->{an} || [] }),
163 (join "", map _enc_rr, @{ $req->{ns} || [] }), 338 (join "", map _enc_rr, @{ $req->{ns} || [] }),
164 (join "", map _enc_rr, @{ $req->{ar} || [] }); 339 (join "", map _enc_rr, @{ $req->{ar} || [] }),
340
341 ($EDNS0 ? pack "C nnNn", 0, 41, 4096, 0, 0 : "") # EDNS0, 4kiB udp payload size
165} 342}
166 343
167our $ofs; 344our $ofs;
168our $pkt; 345our $pkt;
169 346
… …
198 my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4; 375 my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;
199 [$qname, $type_str{$qt} || $qt, $class_str{$qc} || $qc] 376 [$qname, $type_str{$qt} || $qt, $class_str{$qc} || $qc]
200} 377}
201 378
202our %dec_rr = ( 379our %dec_rr = (
203 1 => sub { Socket::inet_ntoa $_ }, # a 380 1 => sub { join ".", unpack "C4" }, # a
204 2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns 381 2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns
205 5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname 382 5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname
206 6 => sub { 383 6 => sub {
207 local $ofs = $ofs - length; 384 local $ofs = $ofs - length;
208 my $mname = _dec_qname; 385 my $mname = _dec_qname;
209 my $rname = _dec_qname; 386 my $rname = _dec_qname;
210 ($mname, $rname, unpack "NNNNN", substr $pkt, $ofs) 387 ($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
211 }, # soa 388 }, # soa
212 11 => sub { ((Socket::inet_aton substr $_, 0, 4), unpack "C a*", substr $_, 4) }, # wks 389 11 => sub { ((join ".", unpack "C4"), unpack "C a*", substr $_, 4) }, # wks
213 12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr 390 12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr
214 13 => sub { unpack "C/a C/a", $_ }, 391 13 => sub { unpack "C/a C/a", $_ }, # hinfo
215 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx 392 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx
216 16 => sub { unpack "C/a", $_ }, # txt 393 16 => sub { unpack "(C/a)*", $_ }, # txt
217 28 => sub { sprintf "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x", unpack "n8" }, # aaaa 394 28 => sub { AnyEvent::Socket::format_ip ($_) }, # aaaa
218 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv 395 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv
396 99 => sub { unpack "(C/a)*", $_ }, # spf
219); 397);
220 398
221sub _dec_rr { 399sub _dec_rr {
222 my $qname = _dec_qname; 400 my $qname = _dec_qname;
223 401
… …
236 414
237Unpacks a DNS packet into a perl data structure. 415Unpacks a DNS packet into a perl data structure.
238 416
239Examples: 417Examples:
240 418
241 # a non-successful reply 419 # an unsuccessful reply
242 { 420 {
243 'qd' => [ 421 'qd' => [
244 [ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ] 422 [ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
245 ], 423 ],
246 'rc' => 'nxdomain', 424 'rc' => 'nxdomain',
… …
250 'uni-karlsruhe.de', 428 'uni-karlsruhe.de',
251 'soa', 429 'soa',
252 'in', 430 'in',
253 'netserv.rz.uni-karlsruhe.de', 431 'netserv.rz.uni-karlsruhe.de',
254 'hostmaster.rz.uni-karlsruhe.de', 432 'hostmaster.rz.uni-karlsruhe.de',
255 2008052201, 433 2008052201, 10800, 1800, 2592000, 86400
256 10800,
257 1800,
258 2592000,
259 86400
260 ] 434 ]
261 ], 435 ],
262 'tc' => '', 436 'tc' => '',
263 'ra' => 1, 437 'ra' => 1,
264 'qr' => 1, 438 'qr' => 1,
… …
312 qr => ! ! ($flags & 0x8000), 486 qr => ! ! ($flags & 0x8000),
313 aa => ! ! ($flags & 0x0400), 487 aa => ! ! ($flags & 0x0400),
314 tc => ! ! ($flags & 0x0200), 488 tc => ! ! ($flags & 0x0200),
315 rd => ! ! ($flags & 0x0100), 489 rd => ! ! ($flags & 0x0100),
316 ra => ! ! ($flags & 0x0080), 490 ra => ! ! ($flags & 0x0080),
491 ad => ! ! ($flags & 0x0020),
492 cd => ! ! ($flags & 0x0010),
317 op => $opcode_str{($flags & 0x001e) >> 11}, 493 op => $opcode_str{($flags & 0x001e) >> 11},
318 rc => $rcode_str{($flags & 0x000f)}, 494 rc => $rcode_str{($flags & 0x000f)},
319 495
320 qd => [map _dec_qd, 1 .. $qd], 496 qd => [map _dec_qd, 1 .. $qd],
321 an => [map _dec_rr, 1 .. $an], 497 an => [map _dec_rr, 1 .. $an],
… …
328 504
329=back 505=back
330 506
331=head2 THE AnyEvent::DNS RESOLVER CLASS 507=head2 THE AnyEvent::DNS RESOLVER CLASS
332 508
333This is the class which deos the actual protocol work. 509This is the class which does the actual protocol work.
334 510
335=over 4 511=over 4
336 512
337=cut 513=cut
338 514
… …
358our $RESOLVER; 534our $RESOLVER;
359 535
360sub resolver() { 536sub resolver() {
361 $RESOLVER || do { 537 $RESOLVER || do {
362 $RESOLVER = new AnyEvent::DNS; 538 $RESOLVER = new AnyEvent::DNS;
363 $RESOLVER->load_resolv_conf; 539 $RESOLVER->os_config;
364 $RESOLVER 540 $RESOLVER
365 } 541 }
366} 542}
367 543
368=item $resolver = new AnyEvent::DNS key => value... 544=item $resolver = new AnyEvent::DNS key => value...
369 545
370Creates and returns a new resolver. It only supports UDP, so make sure 546Creates and returns a new resolver.
371your answer sections fit into a DNS packet.
372 547
373The following options are supported: 548The following options are supported:
374 549
375=over 4 550=over 4
376 551
377=item server => [...] 552=item server => [...]
378 553
379A list of server addressses (default C<v127.0.0.1>) in network format (4 554A list of server addressses (default: C<v127.0.0.1>) in network format (4
380octets for IPv4, 16 octets for IPv6 - not yet supported). 555octets for IPv4, 16 octets for IPv6 - not yet supported).
381 556
382=item timeout => [...] 557=item timeout => [...]
383 558
384A list of timeouts to use (also determines the number of retries). To make 559A list of timeouts to use (also determines the number of retries). To make
… …
398 573
399Most name servers do not handle many parallel requests very well. This option 574Most name servers do not handle many parallel requests very well. This option
400limits the numbe rof outstanding requests to C<$n> (default: C<10>), that means 575limits the numbe rof outstanding requests to C<$n> (default: C<10>), that means
401if you request more than this many requests, then the additional requests will be queued 576if you request more than this many requests, then the additional requests will be queued
402until some other requests have been resolved. 577until some other requests have been resolved.
578
579=item reuse => $seconds
580
581The number of seconds (default: C<60>) that a query id cannot be re-used
582after a request. Since AnyEvent::DNS will only allocate up to 30000 ID's
583at the same time, the long-term maximum number of requests per second is
584C<30000 / $seconds> (and thus C<500> requests/s by default).
403 585
404=back 586=back
405 587
406=cut 588=cut
407 589
… …
417 server => [v127.0.0.1], 599 server => [v127.0.0.1],
418 timeout => [2, 5, 5], 600 timeout => [2, 5, 5],
419 search => [], 601 search => [],
420 ndots => 1, 602 ndots => 1,
421 max_outstanding => 10, 603 max_outstanding => 10,
422 reuse => 300, # reuse id's after 5 minutes only, if possible 604 reuse => 60, # reuse id's after 5 minutes only, if possible
423 %arg, 605 %arg,
424 fh => $fh, 606 fh => $fh,
425 reuse_q => [], 607 reuse_q => [],
426 }, $class; 608 }, $class;
427 609
… …
437} 619}
438 620
439=item $resolver->parse_resolv_conv ($string) 621=item $resolver->parse_resolv_conv ($string)
440 622
441Parses the given string a sif it were a F<resolv.conf> file. The following 623Parses the given string a sif it were a F<resolv.conf> file. The following
442directives are supported: 624directives are supported (but not neecssarily implemented).
443 625
444C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>, 626C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
445C<options> (C<timeout>, C<attempts>, C<ndots>). 627C<options> (C<timeout>, C<attempts>, C<ndots>).
446 628
447Everything else is silently ignored. 629Everything else is silently ignored.
… …
491 if $attempts; 673 if $attempts;
492 674
493 $self->_compile; 675 $self->_compile;
494} 676}
495 677
496=item $resolver->load_resolv_conf 678=item $resolver->os_config
497 679
498Tries to load and parse F</etc/resolv.conf>. If there will ever be windows 680Tries so load and parse F</etc/resolv.conf> on portable opertaing systems. Tries various
499support, then this function will do the right thing under windows, too. 681egregious hacks on windows to force the dns servers and searchlist out of the config.
500 682
501=cut 683=cut
502 684
503sub load_resolv_conf { 685sub os_config {
504 my ($self) = @_; 686 my ($self) = @_;
505 687
688 if ($^O =~ /mswin32|cygwin/i) {
689 # yeah, it suxx... lets hope DNS is DNS in all locales
690
691 if (open my $fh, "ipconfig /all |") {
692 delete $self->{server};
693 delete $self->{search};
694
695 while (<$fh>) {
696 # first DNS.* is suffix list
697 if (/^\s*DNS/) {
698 while (/\s+([[:alnum:].\-]+)\s*$/) {
699 push @{ $self->{search} }, $1;
700 $_ = <$fh>;
701 }
702 last;
703 }
704 }
705
706 while (<$fh>) {
707 # second DNS.* is server address list
708 if (/^\s*DNS/) {
709 while (/\s+(\d+\.\d+\.\d+\.\d+)\s*$/) {
710 my $ip = $1;
711 push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip
712 if AnyEvent::Util::dotted_quad $ip;
713 $_ = <$fh>;
714 }
715 last;
716 }
717 }
718
719 $self->_compile;
720 }
721 } else {
722 # try resolv.conf everywhere
723
506 open my $fh, "</etc/resolv.conf" 724 if (open my $fh, "</etc/resolv.conf") {
507 or return;
508
509 local $/; 725 local $/;
510 $self->parse_resolv_conf (<$fh>); 726 $self->parse_resolv_conf (<$fh>);
727 }
728 }
511} 729}
512 730
513sub _compile { 731sub _compile {
514 my $self = shift; 732 my $self = shift;
515 733
… …
522 } 740 }
523 741
524 $self->{retry} = \@retry; 742 $self->{retry} = \@retry;
525} 743}
526 744
745sub _feed {
746 my ($self, $res) = @_;
747
748 $res = dns_unpack $res
749 or return;
750
751 my $id = $self->{id}{$res->{id}};
752
753 return unless ref $id;
754
755 $NOW = time;
756 $id->[1]->($res);
757}
758
527sub _recv { 759sub _recv {
528 my ($self) = @_; 760 my ($self) = @_;
529 761
530 while (my $peer = recv $self->{fh}, my $res, 1024, 0) { 762 while (my $peer = recv $self->{fh}, my $res, 4096, 0) {
531 my ($port, $host) = Socket::unpack_sockaddr_in $peer; 763 my ($port, $host) = Socket::unpack_sockaddr_in $peer;
532 764
533 return unless $port == 53 && grep $_ eq $host, @{ $self->{server} }; 765 return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
534 766
535 $res = dns_unpack $res 767 $self->_feed ($res);
536 or return;
537
538 my $id = $self->{id}{$res->{id}};
539
540 return unless ref $id;
541
542 $NOW = time;
543 $id->[1]->($res);
544 } 768 }
545} 769}
546 770
547sub _exec { 771sub _exec {
548 my ($self, $req, $retry) = @_; 772 my ($self, $req, $retry) = @_;
… …
556 # timeout, try next 780 # timeout, try next
557 $self->_exec ($req, $retry + 1); 781 $self->_exec ($req, $retry + 1);
558 }), sub { 782 }), sub {
559 my ($res) = @_; 783 my ($res) = @_;
560 784
785 if ($res->{tc}) {
786 # success, but truncated, so use tcp
787 AnyEvent::Socket::tcp_connect ((Socket::inet_ntoa $server), 53, sub {
788 my ($fh) = @_
789 or return $self->_exec ($req, $retry + 1);
790
791 my $handle = new AnyEvent::Handle
792 fh => $fh,
793 on_error => sub {
794 # failure, try next
795 $self->_exec ($req, $retry + 1);
796 };
797
798 $handle->push_write (pack "n/a", $req->[0]);
799 $handle->push_read_chunk (2, sub {
800 $handle->unshift_read_chunk ((unpack "n", $_[1]), sub {
801 $self->_feed ($_[1]);
802 });
803 });
804 shutdown $fh, 1;
805
806 }, sub { $timeout });
807
808 } else {
561 # success 809 # success
562 $self->{id}{$req->[2]} = 1; 810 $self->{id}{$req->[2]} = 1;
563 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]]; 811 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
564 --$self->{outstanding}; 812 --$self->{outstanding};
565 $self->_scheduler; 813 $self->_scheduler;
566 814
567 $req->[1]->($res); 815 $req->[1]->($res);
816 }
568 }]; 817 }];
569 818
570 send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server; 819 send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server;
571 } else { 820 } else {
572 # failure 821 # failure
… …
584 833
585 $NOW = time; 834 $NOW = time;
586 835
587 # first clear id reuse queue 836 # first clear id reuse queue
588 delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] } 837 delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
589 while @{ $self->{reuse_q} } && $self->{reuse_q}[0] <= $NOW; 838 while @{ $self->{reuse_q} } && $self->{reuse_q}[0][0] <= $NOW;
590 839
591 while ($self->{outstanding} < $self->{max_outstanding}) { 840 while ($self->{outstanding} < $self->{max_outstanding}) {
841
842 if (@{ $self->{reuse_q} } >= 30000) {
843 # we ran out of ID's, wait a bit
844 $self->{reuse_to} ||= AnyEvent->timer (after => $self->{reuse_q}[0][0] - $NOW, cb => sub {
845 delete $self->{reuse_to};
846 $self->_scheduler;
847 });
848 last;
849 }
850
592 my $req = shift @{ $self->{queue} } 851 my $req = shift @{ $self->{queue} }
593 or last; 852 or last;
594 853
595 while () { 854 while () {
596 $req->[2] = int rand 65536; 855 $req->[2] = int rand 65536;
… …
719 # advance in searchlist 978 # advance in searchlist
720 my $do_search; $do_search = sub { 979 my $do_search; $do_search = sub {
721 @search 980 @search
722 or return $cb->(); 981 or return $cb->();
723 982
724 (my $name = "$qname." . shift @search) =~ s/\.$//; 983 (my $name = lc "$qname." . shift @search) =~ s/\.$//;
725 my $depth = 2; 984 my $depth = 2;
726 985
727 # advance in cname-chain 986 # advance in cname-chain
728 my $do_req; $do_req = sub { 987 my $do_req; $do_req = sub {
729 $self->request ({ 988 $self->request ({
… …
735 994
736 my $cname; 995 my $cname;
737 996
738 while () { 997 while () {
739 # results found? 998 # results found?
740 my @rr = grep $_->[0] eq $name && ($atype{"*"} || $atype{$_->[1]}), @{ $res->{an} }; 999 my @rr = grep $name eq lc $_->[0] && ($atype{"*"} || $atype{$_->[1]}), @{ $res->{an} };
741 1000
742 return $cb->(@rr) 1001 return $cb->(@rr)
743 if @rr; 1002 if @rr;
744 1003
745 # see if there is a cname we can follow 1004 # see if there is a cname we can follow
746 my @rr = grep $_->[0] eq $name && $_->[1] eq "cname", @{ $res->{an} }; 1005 my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };
747 1006
748 if (@rr) { 1007 if (@rr) {
749 $depth-- 1008 $depth--
750 or return $do_search->(); # cname chain too long 1009 or return $do_search->(); # cname chain too long
751 1010
… …
768 }; 1027 };
769 1028
770 $do_search->(); 1029 $do_search->();
771} 1030}
772 1031
1032use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
1033
7731; 10341;
774 1035
775=back 1036=back
776 1037
777=head1 AUTHOR 1038=head1 AUTHOR

Diff Legend

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