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

Diff Legend

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