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.19 by root, Fri May 23 23:37:13 2008 UTC vs.
Revision 1.29 by root, Sun May 25 03:11:38 2008 UTC

… …
3AnyEvent::DNS - fully asynchronous DNS resolution 3AnyEvent::DNS - fully asynchronous DNS resolution
4 4
5=head1 SYNOPSIS 5=head1 SYNOPSIS
6 6
7 use AnyEvent::DNS; 7 use AnyEvent::DNS;
8
9 my $cv = AnyEvent->condvar;
10 AnyEvent::DNS::a "www.google.de", sub { $cv->send (@_) };
11 # ... later
12 my @addrs = $cv->recv;
8 13
9=head1 DESCRIPTION 14=head1 DESCRIPTION
10 15
11This module offers both a number of DNS convenience functions as well 16This module offers both a number of DNS convenience functions as well
12as a fully asynchronous and high-performance pure-perl stub resolver. 17as a fully asynchronous and high-performance pure-perl stub resolver.
… …
24package AnyEvent::DNS; 29package AnyEvent::DNS;
25 30
26no warnings; 31no warnings;
27use strict; 32use strict;
28 33
34use Socket qw(AF_INET SOCK_DGRAM SOCK_STREAM);
35
29use AnyEvent::Handle (); 36use AnyEvent::Handle ();
30 37
31=item AnyEvent::DNS::addr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...) 38=item AnyEvent::DNS::addr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)
32
33NOT YET IMPLEMENTED
34 39
35Tries to resolve the given nodename and service name into protocol families 40Tries to resolve the given nodename and service name into protocol families
36and sockaddr structures usable to connect to this node and service in a 41and sockaddr structures usable to connect to this node and service in a
37protocol-independent way. It works remotely similar to the getaddrinfo 42protocol-independent way. It works remotely similar to the getaddrinfo
38posix function. 43posix function.
… …
40C<$node> is either an IPv4 or IPv6 address or a hostname, C<$service> is 45C<$node> is either an IPv4 or IPv6 address or a hostname, C<$service> is
41either a service name (port name from F</etc/services>) or a numerical 46either a service name (port name from F</etc/services>) or a numerical
42port number. If both C<$node> and C<$service> are names, then SRV records 47port number. If both C<$node> and C<$service> are names, then SRV records
43will be consulted to find the real service, otherwise they will be 48will be consulted to find the real service, otherwise they will be
44used as-is. If you know that the service name is not in your services 49used as-is. If you know that the service name is not in your services
45database, then you cna specify the service in the format C<name=port> 50database, then you can specify the service in the format C<name=port>
46(e.g. C<http=80>). 51(e.g. C<http=80>).
47 52
48C<$proto> must be a protocol name, currently C<tcp>, C<udp> or 53C<$proto> must be a protocol name, currently C<tcp>, C<udp> or
49C<sctp>. The default is C<tcp>. 54C<sctp>. The default is C<tcp>.
50 55
51C<$family> must be either C<0> (meaning any protocol is ok), C<4> (use 56C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use
52only IPv4) or C<6> (use only IPv6). 57only IPv4) or C<6> (use only IPv6). This setting might be influenced by
58C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.
53 59
54C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or 60C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or
55C<undef> in which case it gets automatically chosen). 61C<undef> in which case it gets automatically chosen).
56 62
57The callback will receive zero or more array references that contain 63The callback will receive zero or more array references that contain
… …
88=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr) 94=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
89 95
90Tries to resolve the given service, protocol and domain name into a list 96Tries to resolve the given service, protocol and domain name into a list
91of service records. 97of service records.
92 98
93Each srv_rr is an arrayref with the following contents: 99Each srv_rr is an array reference with the following contents:
94C<[$priority, $weight, $transport, $target]>. 100C<[$priority, $weight, $transport, $target]>.
95 101
96They will be sorted with lowest priority, highest weight first (TODO: 102They will be sorted with lowest priority, highest weight first (TODO:
97should use the rfc algorithm to reorder same-priority records for weight). 103should use the RFC algorithm to reorder same-priority records for weight).
98 104
99Example: 105Example:
100 106
101 AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ... 107 AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
102 # @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] ) 108 # @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
… …
192 resolver->resolve ($domain => "*", $cb); 198 resolver->resolve ($domain => "*", $cb);
193} 199}
194 200
195############################################################################# 201#############################################################################
196 202
197#AnyEvent::DNS::addr $node, $service, $family, $type, $proto, $cb->([$family, $type, $protocol, $sockaddr], ...)
198
199# $port, $host
200sub pack_sockaddr_in6($$) {
201 pack "nnN a16 N",
202 Socket::AF_INET6,
203 $_[0], # port
204 0, # flowinfo
205 $_[1], # addr
206 0 # scope id
207}
208
209sub addr($$$$$$) { 203sub addr($$$$$$) {
210 my ($node, $service, $proto, $family, $type, $cb) = @_; 204 my ($node, $service, $proto, $family, $type, $cb) = @_;
211 205
212 unless (eval { &Socket::AF_INET6 }) { 206 unless (&AnyEvent::Util::AF_INET6) {
213 $family != 6 207 $family != 6
214 or return $cb->(); 208 or return $cb->();
215 209
216 $family ||= 4; 210 $family ||= 4;
217 } 211 }
218 212
213 $cb->() if $family == 4 && !$AnyEvent::PROTOCOL{ipv4};
214 $cb->() if $family == 6 && !$AnyEvent::PROTOCOL{ipv6};
215
216 $family ||=4 unless $AnyEvent::PROTOCOL{ipv6};
217 $family ||=6 unless $AnyEvent::PROTOCOL{ipv4};
218
219 $proto ||= "tcp"; 219 $proto ||= "tcp";
220 $type ||= $proto eq "udp" ? Socket::SOCK_DGRAM : Socket::SOCK_STREAM; 220 $type ||= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
221 221
222 my $proton = (getprotobyname $proto)[2] 222 my $proton = (getprotobyname $proto)[2]
223 or Carp::croak "$proto: protocol unknown"; 223 or Carp::croak "$proto: protocol unknown";
224 224
225 my $port; 225 my $port;
… …
237 237
238 # resolve a records / provide sockaddr structures 238 # resolve a records / provide sockaddr structures
239 my $resolve = sub { 239 my $resolve = sub {
240 my @res; 240 my @res;
241 my $cv = AnyEvent->condvar (cb => sub { 241 my $cv = AnyEvent->condvar (cb => sub {
242 $cb->(map $_->[1], sort { $a->[0] <=> $b->[0] } @res) 242 $cb->(
243 map $_->[2],
244 sort {
245 $AnyEvent::PROTOCOL{$a->[1]} <=> $AnyEvent::PROTOCOL{$b->[1]}
246 or $a->[0] <=> $b->[0]
247 }
248 @res
249 )
243 }); 250 });
244 251
245 $cv->begin; 252 $cv->begin;
246 for my $idx (0 .. $#target) { 253 for my $idx (0 .. $#target) {
247 my ($node, $port) = @{ $target[$idx] }; 254 my ($node, $port) = @{ $target[$idx] };
248 255
249 if (my $noden = AnyEvent::Socket::parse_ip ($node)) { 256 if (my $noden = AnyEvent::Socket::parse_ip ($node)) {
250 if (4 == length $noden && $family != 6) { 257 if (4 == length $noden && $family != 6) {
251 push @res, [$idx, [Socket::AF_INET, $type, $proton, 258 push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
252 Socket::pack_sockaddr_in $port, $noden]] 259 AnyEvent::Socket::pack_sockaddr ($port, $noden)]]
253 } 260 }
254 261
255 if (16 == length $noden && $family != 4) { 262 if (16 == length $noden && $family != 4) {
256 push @res, [$idx, [Socket::AF_INET6, $type, $proton, 263 push @res, [$idx, "ipv6", [&AnyEvent::Util::AF_INET6, $type, $proton,
257 pack_sockaddr_in6 $port, $noden]] 264 AnyEvent::Socket::pack_sockaddr ( $port, $noden)]]
258 } 265 }
259 } else { 266 } else {
260 # ipv4 267 # ipv4
261 if ($family != 6) { 268 if ($family != 6) {
262 $cv->begin; 269 $cv->begin;
263 a $node, sub { 270 a $node, sub {
264 push @res, [$idx, [Socket::AF_INET, $type, $proton, 271 push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
265 Socket::pack_sockaddr_in $port, AnyEvent::Socket::parse_ipv4 ($_)]] 272 AnyEvent::Socket::pack_sockaddr ($port, AnyEvent::Socket::parse_ipv4 ($_))]]
266 for @_; 273 for @_;
267 $cv->end; 274 $cv->end;
268 }; 275 };
269 } 276 }
270 277
271 my $idx = $idx + 0.5; # prefer ipv4 for now
272
273 # ipv6 278 # ipv6
274 if ($family != 4) { 279 if ($family != 4) {
275 $cv->begin; 280 $cv->begin;
276 aaaa $node, sub { 281 aaaa $node, sub {
277 push @res, [$idx, [Socket::AF_INET6, $type, $proton, 282 push @res, [$idx, "ipv6", [&AnyEvent::Socket::AF_INET6, $type, $proton,
278 pack_sockaddr_in6 $port, AnyEvent::Socket::parse_ipv6 ($_)]] 283 AnyEvent::Socket::pack_sockaddr ($port, AnyEvent::Socket::parse_ipv6 ($_))]]
279 for @_; 284 for @_;
280 $cv->end; 285 $cv->end;
281 }; 286 };
282 } 287 }
283 } 288 }
284 } 289 }
285 $cv->end; 290 $cv->end;
286 }; 291 };
287 292
288 # try srv records, if applicable 293 # try srv records, if applicable
294 if ($node eq "localhost") {
295 @target = (["127.0.0.1", $port], ["::1", $port]);
296 &$resolve;
289 if (defined $service && !AnyEvent::Socket::parse_ip ($node)) { 297 } elsif (defined $service && !AnyEvent::Socket::parse_ip ($node)) {
290 srv $service, $proto, $node, sub { 298 srv $service, $proto, $node, sub {
291 my (@srv) = @_; 299 my (@srv) = @_;
292 300
293 # no srv records, continue traditionally 301 # no srv records, continue traditionally
294 @srv 302 @srv
… …
297 # only srv record has "." => abort 305 # only srv record has "." => abort
298 $srv[0][2] ne "." || $#srv 306 $srv[0][2] ne "." || $#srv
299 or return $cb->(); 307 or return $cb->();
300 308
301 # use srv records then 309 # use srv records then
302 @target = map [$_->[3], $_->[2]], 310 @target = map ["$_->[3].", $_->[2]],
303 grep $_->[3] ne ".", 311 grep $_->[3] ne ".",
304 @srv; 312 @srv;
305 313
306 &$resolve; 314 &$resolve;
307 }; 315 };
… …
319=over 4 327=over 4
320 328
321=item $AnyEvent::DNS::EDNS0 329=item $AnyEvent::DNS::EDNS0
322 330
323This variable decides whether dns_pack automatically enables EDNS0 331This variable decides whether dns_pack automatically enables EDNS0
324support. By default, this is disabled (C<0>), but when set to C<1>, 332support. By default, this is disabled (C<0>), unless overridden by
325AnyEvent::DNS will use EDNS0 in all requests. 333C<$ENV{PERL_ANYEVENT_EDNS0>), but when set to C<1>, AnyEvent::DNS will use
334EDNS0 in all requests.
326 335
327=cut 336=cut
328 337
329our $EDNS0 = 0; # set to 1 to enable (partial) edns0 338our $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0} * 1; # set to 1 to enable (partial) edns0
330 339
331our %opcode_id = ( 340our %opcode_id = (
332 query => 0, 341 query => 0,
333 iquery => 1, 342 iquery => 1,
334 status => 2, 343 status => 2,
… …
404 413
405our %class_str = reverse %class_id; 414our %class_str = reverse %class_id;
406 415
407# names MUST have a trailing dot 416# names MUST have a trailing dot
408sub _enc_qname($) { 417sub _enc_qname($) {
409 pack "(C/a)*", (split /\./, shift), "" 418 pack "(C/a*)*", (split /\./, shift), ""
410} 419}
411 420
412sub _enc_qd() { 421sub _enc_qd() {
413 (_enc_qname $_->[0]) . pack "nn", 422 (_enc_qname $_->[0]) . pack "nn",
414 ($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}), 423 ($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),
… …
518 my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4; 527 my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;
519 [$qname, $type_str{$qt} || $qt, $class_str{$qc} || $qc] 528 [$qname, $type_str{$qt} || $qt, $class_str{$qc} || $qc]
520} 529}
521 530
522our %dec_rr = ( 531our %dec_rr = (
523 1 => sub { join ".", unpack "C4" }, # a 532 1 => sub { join ".", unpack "C4", $_ }, # a
524 2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns 533 2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns
525 5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname 534 5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname
526 6 => sub { 535 6 => sub {
527 local $ofs = $ofs - length; 536 local $ofs = $ofs - length;
528 my $mname = _dec_qname; 537 my $mname = _dec_qname;
529 my $rname = _dec_qname; 538 my $rname = _dec_qname;
530 ($mname, $rname, unpack "NNNNN", substr $pkt, $ofs) 539 ($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
531 }, # soa 540 }, # soa
532 11 => sub { ((join ".", unpack "C4"), unpack "C a*", substr $_, 4) }, # wks 541 11 => sub { ((join ".", unpack "C4", $_), unpack "C a*", substr $_, 4) }, # wks
533 12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr 542 12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr
534 13 => sub { unpack "C/a C/a", $_ }, # hinfo 543 13 => sub { unpack "C/a* C/a*", $_ }, # hinfo
535 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx 544 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx
536 16 => sub { unpack "(C/a)*", $_ }, # txt 545 16 => sub { unpack "(C/a*)*", $_ }, # txt
537 28 => sub { AnyEvent::Socket::format_ip ($_) }, # aaaa 546 28 => sub { AnyEvent::Socket::format_ip ($_) }, # aaaa
538 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv 547 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv
539 99 => sub { unpack "(C/a)*", $_ }, # spf 548 99 => sub { unpack "(C/a*)*", $_ }, # spf
540); 549);
541 550
542sub _dec_rr { 551sub _dec_rr {
543 my $qname = _dec_qname; 552 my $qname = _dec_qname;
544 553
… …
692 701
693=over 4 702=over 4
694 703
695=item server => [...] 704=item server => [...]
696 705
697A list of server addressses (default: C<v127.0.0.1>) in network format (4 706A list of server addresses (default: C<v127.0.0.1>) in network format (4
698octets for IPv4, 16 octets for IPv6 - not yet supported). 707octets for IPv4, 16 octets for IPv6 - not yet supported).
699 708
700=item timeout => [...] 709=item timeout => [...]
701 710
702A list of timeouts to use (also determines the number of retries). To make 711A list of timeouts to use (also determines the number of retries). To make
… …
713tries to resolve the name without any suffixes first. 722tries to resolve the name without any suffixes first.
714 723
715=item max_outstanding => $integer 724=item max_outstanding => $integer
716 725
717Most name servers do not handle many parallel requests very well. This option 726Most name servers do not handle many parallel requests very well. This option
718limits the numbe rof outstanding requests to C<$n> (default: C<10>), that means 727limits the number of outstanding requests to C<$n> (default: C<10>), that means
719if you request more than this many requests, then the additional requests will be queued 728if you request more than this many requests, then the additional requests will be queued
720until some other requests have been resolved. 729until some other requests have been resolved.
721 730
722=item reuse => $seconds 731=item reuse => $seconds
723 732
724The number of seconds (default: C<60>) that a query id cannot be re-used 733The number of seconds (default: C<300>) that a query id cannot be re-used
725after a request. Since AnyEvent::DNS will only allocate up to 30000 ID's 734after a timeout. If there as no time-out then query id's can be reused
726at the same time, the long-term maximum number of requests per second is 735immediately.
727C<30000 / $seconds> (and thus C<500> requests/s by default).
728 736
729=back 737=back
730 738
731=cut 739=cut
732 740
733sub new { 741sub new {
734 my ($class, %arg) = @_; 742 my ($class, %arg) = @_;
735 743
736 socket my $fh, &Socket::AF_INET, &Socket::SOCK_DGRAM, 0 744 socket my $fh, AF_INET, &Socket::SOCK_DGRAM, 0
737 or Carp::croak "socket: $!"; 745 or Carp::croak "socket: $!";
738 746
739 AnyEvent::Util::fh_nonblocking $fh, 1; 747 AnyEvent::Util::fh_nonblocking $fh, 1;
740 748
741 my $self = bless { 749 my $self = bless {
742 server => [v127.0.0.1], 750 server => [v127.0.0.1],
743 timeout => [2, 5, 5], 751 timeout => [2, 5, 5],
744 search => [], 752 search => [],
745 ndots => 1, 753 ndots => 1,
746 max_outstanding => 10, 754 max_outstanding => 10,
747 reuse => 60, # reuse id's after 5 minutes only, if possible 755 reuse => 300, # reuse id's after 5 minutes only, if possible
748 %arg, 756 %arg,
749 fh => $fh, 757 fh => $fh,
750 reuse_q => [], 758 reuse_q => [],
751 }, $class; 759 }, $class;
752 760
… …
761 $self 769 $self
762} 770}
763 771
764=item $resolver->parse_resolv_conv ($string) 772=item $resolver->parse_resolv_conv ($string)
765 773
766Parses the given string a sif it were a F<resolv.conf> file. The following 774Parses the given string as if it were a F<resolv.conf> file. The following
767directives are supported (but not neecssarily implemented). 775directives are supported (but not necessarily implemented).
768 776
769C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>, 777C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
770C<options> (C<timeout>, C<attempts>, C<ndots>). 778C<options> (C<timeout>, C<attempts>, C<ndots>).
771 779
772Everything else is silently ignored. 780Everything else is silently ignored.
… …
784 for (split /\n/, $resolvconf) { 792 for (split /\n/, $resolvconf) {
785 if (/^\s*#/) { 793 if (/^\s*#/) {
786 # comment 794 # comment
787 } elsif (/^\s*nameserver\s+(\S+)\s*$/i) { 795 } elsif (/^\s*nameserver\s+(\S+)\s*$/i) {
788 my $ip = $1; 796 my $ip = $1;
789 if (AnyEvent::Util::dotted_quad $ip) { 797 if (my $ipn = AnyEvent::Socket::parse_ip ($ip)) {
790 push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip; 798 push @{ $self->{server} }, $ipn;
791 } else { 799 } else {
792 warn "nameserver $ip invalid and ignored\n"; 800 warn "nameserver $ip invalid and ignored\n";
793 } 801 }
794 } elsif (/^\s*domain\s+(\S*)\s+$/i) { 802 } elsif (/^\s*domain\s+(\S*)\s+$/i) {
795 $self->{search} = [$1]; 803 $self->{search} = [$1];
… …
818 $self->_compile; 826 $self->_compile;
819} 827}
820 828
821=item $resolver->os_config 829=item $resolver->os_config
822 830
823Tries so load and parse F</etc/resolv.conf> on portable opertaing systems. Tries various 831Tries so load and parse F</etc/resolv.conf> on portable operating systems. Tries various
824egregious hacks on windows to force the dns servers and searchlist out of the config. 832egregious hacks on windows to force the DNS servers and searchlist out of the system.
825 833
826=cut 834=cut
827 835
828sub os_config { 836sub os_config {
829 my ($self) = @_; 837 my ($self) = @_;
… …
848 856
849 while (<$fh>) { 857 while (<$fh>) {
850 # second DNS.* is server address list 858 # second DNS.* is server address list
851 if (/^\s*DNS/) { 859 if (/^\s*DNS/) {
852 while (/\s+(\d+\.\d+\.\d+\.\d+)\s*$/) { 860 while (/\s+(\d+\.\d+\.\d+\.\d+)\s*$/) {
861 my $ipn = AnyEvent::Socket::parse_ip ("$1"); # "" is necessary here, apparently
862 push @{ $self->{server} }, $ipn
853 my $ip = $1; 863 if $ipn;
854 push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip
855 if AnyEvent::Util::dotted_quad $ip;
856 $_ = <$fh>; 864 $_ = <$fh>;
857 } 865 }
858 last; 866 last;
859 } 867 }
860 } 868 }
… …
901 909
902sub _recv { 910sub _recv {
903 my ($self) = @_; 911 my ($self) = @_;
904 912
905 while (my $peer = recv $self->{fh}, my $res, 4096, 0) { 913 while (my $peer = recv $self->{fh}, my $res, 4096, 0) {
906 my ($port, $host) = Socket::unpack_sockaddr_in $peer; 914 my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
907 915
908 return unless $port == 53 && grep $_ eq $host, @{ $self->{server} }; 916 return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
909 917
910 $self->_feed ($res); 918 $self->_feed ($res);
911 } 919 }
912} 920}
913 921
922sub _free_id {
923 my ($self, $id, $timeout) = @_;
924
925 if ($timeout) {
926 # we need to block the id for a while
927 $self->{id}{$id} = 1;
928 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $id];
929 } else {
930 # we can quickly recycle the id
931 delete $self->{id}{$id};
932 }
933
934 --$self->{outstanding};
935 $self->_scheduler;
936}
937
938# execute a single request, involves sending it with timeouts to multiple servers
914sub _exec { 939sub _exec {
915 my ($self, $req, $retry) = @_; 940 my ($self, $req) = @_;
916 941
942 my $retry; # of retries
943 my $do_retry;
944
945 $do_retry = sub {
917 if (my $retry_cfg = $self->{retry}[$retry]) { 946 my $retry_cfg = $self->{retry}[$retry++]
947 or do {
948 # failure
949 $self->_free_id ($req->[2], $retry > 1);
950 undef $do_retry; return $req->[1]->();
951 };
952
918 my ($server, $timeout) = @$retry_cfg; 953 my ($server, $timeout) = @$retry_cfg;
919 954
920 $self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub { 955 $self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
921 $NOW = time; 956 $NOW = time;
922 957
923 # timeout, try next 958 # timeout, try next
924 $self->_exec ($req, $retry + 1); 959 &$do_retry;
925 }), sub { 960 }), sub {
926 my ($res) = @_; 961 my ($res) = @_;
927 962
928 if ($res->{tc}) { 963 if ($res->{tc}) {
929 # success, but truncated, so use tcp 964 # success, but truncated, so use tcp
930 AnyEvent::Socket::tcp_connect ((Socket::inet_ntoa $server), 53, sub { 965 AnyEvent::Socket::tcp_connect ((Socket::inet_ntoa $server), 53, sub {
931 my ($fh) = @_ 966 my ($fh) = @_
932 or return $self->_exec ($req, $retry + 1); 967 or return &$do_retry;
933 968
934 my $handle = new AnyEvent::Handle 969 my $handle = new AnyEvent::Handle
935 fh => $fh, 970 fh => $fh,
936 on_error => sub { 971 on_error => sub {
937 # failure, try next 972 # failure, try next
938 $self->_exec ($req, $retry + 1); 973 &$do_retry;
939 }; 974 };
940 975
941 $handle->push_write (pack "n/a", $req->[0]); 976 $handle->push_write (pack "n/a", $req->[0]);
942 $handle->push_read_chunk (2, sub { 977 $handle->push_read (chunk => 2, sub {
943 $handle->unshift_read_chunk ((unpack "n", $_[1]), sub { 978 $handle->unshift_read (chunk => (unpack "n", $_[1]), sub {
944 $self->_feed ($_[1]); 979 $self->_feed ($_[1]);
945 }); 980 });
946 }); 981 });
947 shutdown $fh, 1; 982 shutdown $fh, 1;
948 983
949 }, sub { $timeout }); 984 }, sub { $timeout });
950 985
951 } else { 986 } else {
952 # success 987 # success
953 $self->{id}{$req->[2]} = 1; 988 $self->_free_id ($req->[2], $retry > 1);
954 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]]; 989 undef $do_retry; return $req->[1]->($res);
955 --$self->{outstanding};
956 $self->_scheduler;
957
958 $req->[1]->($res);
959 } 990 }
960 }]; 991 }];
961 992
962 send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server; 993 send $self->{fh}, $req->[0], 0, AnyEvent::Socket::pack_sockaddr (53, $server);
963 } else {
964 # failure
965 $self->{id}{$req->[2]} = 1;
966 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
967 --$self->{outstanding};
968 $self->_scheduler;
969
970 $req->[1]->();
971 } 994 };
995
996 &$do_retry;
972} 997}
973 998
974sub _scheduler { 999sub _scheduler {
975 my ($self) = @_; 1000 my ($self) = @_;
976 1001
… …
997 while () { 1022 while () {
998 $req->[2] = int rand 65536; 1023 $req->[2] = int rand 65536;
999 last unless exists $self->{id}{$req->[2]}; 1024 last unless exists $self->{id}{$req->[2]};
1000 } 1025 }
1001 1026
1027 ++$self->{outstanding};
1002 $self->{id}{$req->[2]} = 1; 1028 $self->{id}{$req->[2]} = 1;
1003 substr $req->[0], 0, 2, pack "n", $req->[2]; 1029 substr $req->[0], 0, 2, pack "n", $req->[2];
1004 1030
1005 ++$self->{outstanding};
1006 $self->_exec ($req, 0); 1031 $self->_exec ($req);
1007 } 1032 }
1008} 1033}
1009 1034
1010=item $resolver->request ($req, $cb->($res)) 1035=item $resolver->request ($req, $cb->($res))
1011 1036
… …
1031The callback will be invoked with a list of matching result records or 1056The callback will be invoked with a list of matching result records or
1032none on any error or if the name could not be found. 1057none on any error or if the name could not be found.
1033 1058
1034CNAME chains (although illegal) are followed up to a length of 8. 1059CNAME chains (although illegal) are followed up to a length of 8.
1035 1060
1036Note that this resolver is just a stub resolver: it requires a nameserver 1061Note that this resolver is just a stub resolver: it requires a name server
1037supporting recursive queries, will not do any recursive queries itself and 1062supporting recursive queries, will not do any recursive queries itself and
1038is not secure when used against an untrusted name server. 1063is not secure when used against an untrusted name server.
1039 1064
1040The following options are supported: 1065The following options are supported:
1041 1066
… …
1117 my %atype = $opt{accept} 1142 my %atype = $opt{accept}
1118 ? map +($_ => 1), @{ $opt{accept} } 1143 ? map +($_ => 1), @{ $opt{accept} }
1119 : ($qtype => 1); 1144 : ($qtype => 1);
1120 1145
1121 # advance in searchlist 1146 # advance in searchlist
1122 my $do_search; $do_search = sub { 1147 my ($do_search, $do_req);
1148
1149 $do_search = sub {
1123 @search 1150 @search
1124 or return $cb->(); 1151 or (undef $do_search), (undef $do_req), return $cb->();
1125 1152
1126 (my $name = lc "$qname." . shift @search) =~ s/\.$//; 1153 (my $name = lc "$qname." . shift @search) =~ s/\.$//;
1127 my $depth = 2; 1154 my $depth = 2;
1128 1155
1129 # advance in cname-chain 1156 # advance in cname-chain
1130 my $do_req; $do_req = sub { 1157 $do_req = sub {
1131 $self->request ({ 1158 $self->request ({
1132 rd => 1, 1159 rd => 1,
1133 qd => [[$name, $qtype, $class]], 1160 qd => [[$name, $qtype, $class]],
1134 }, sub { 1161 }, sub {
1135 my ($res) = @_ 1162 my ($res) = @_
… …
1139 1166
1140 while () { 1167 while () {
1141 # results found? 1168 # results found?
1142 my @rr = grep $name eq lc $_->[0] && ($atype{"*"} || $atype{$_->[1]}), @{ $res->{an} }; 1169 my @rr = grep $name eq lc $_->[0] && ($atype{"*"} || $atype{$_->[1]}), @{ $res->{an} };
1143 1170
1144 return $cb->(@rr) 1171 (undef $do_search), (undef $do_req), return $cb->(@rr)
1145 if @rr; 1172 if @rr;
1146 1173
1147 # see if there is a cname we can follow 1174 # see if there is a cname we can follow
1148 my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} }; 1175 my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };
1149 1176

Diff Legend

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