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.51 by root, Fri May 30 05:56:20 2008 UTC vs.
Revision 1.103 by root, Thu Jul 9 08:31:16 2009 UTC

… …
2 2
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 8
9 my $cv = AnyEvent->condvar; 9 my $cv = AnyEvent->condvar;
10 AnyEvent::DNS::a "www.google.de", $cv; 10 AnyEvent::DNS::a "www.google.de", $cv;
11 # ... later 11 # ... later
12 my @addrs = $cv->recv; 12 my @addrs = $cv->recv;
13 13
14=head1 DESCRIPTION 14=head1 DESCRIPTION
15 15
16This module offers both a number of DNS convenience functions as well 16This module offers both a number of DNS convenience functions as well
17as a fully asynchronous and high-performance pure-perl stub resolver. 17as a fully asynchronous and high-performance pure-perl stub resolver.
… …
29package AnyEvent::DNS; 29package AnyEvent::DNS;
30 30
31no warnings; 31no warnings;
32use strict; 32use strict;
33 33
34use Carp ();
34use Socket qw(AF_INET SOCK_DGRAM SOCK_STREAM); 35use Socket qw(AF_INET SOCK_DGRAM SOCK_STREAM);
35 36
36use AnyEvent (); 37use AnyEvent ();
37use AnyEvent::Handle ();
38use AnyEvent::Util qw(AF_INET6); 38use AnyEvent::Util qw(AF_INET6);
39 39
40our $VERSION = '1.0'; 40our $VERSION = 4.81;
41 41
42our @DNS_FALLBACK = (v208.67.220.220, v208.67.222.222); 42our @DNS_FALLBACK = (v208.67.220.220, v208.67.222.222);
43 43
44=item AnyEvent::DNS::a $domain, $cb->(@addrs) 44=item AnyEvent::DNS::a $domain, $cb->(@addrs)
45 45
… …
65=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr) 65=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
66 66
67Tries to resolve the given service, protocol and domain name into a list 67Tries to resolve the given service, protocol and domain name into a list
68of service records. 68of service records.
69 69
70Each srv_rr is an array reference with the following contents: 70Each C<$srv_rr> is an array reference with the following contents:
71C<[$priority, $weight, $transport, $target]>. 71C<[$priority, $weight, $transport, $target]>.
72 72
73They will be sorted with lowest priority first, then randomly 73They will be sorted with lowest priority first, then randomly
74distributed by weight as per RFC 2782. 74distributed by weight as per RFC 2782.
75 75
… …
170 my %pri; 170 my %pri;
171 push @{ $pri{$_->[3]} }, [ @$_[3,4,5,6] ] 171 push @{ $pri{$_->[3]} }, [ @$_[3,4,5,6] ]
172 for @_; 172 for @_;
173 173
174 # order by priority 174 # order by priority
175 for my $pri (sort { $a->[0] <=> $b->[0] } keys %pri) { 175 for my $pri (sort { $a <=> $b } keys %pri) {
176 # order by weight 176 # order by weight
177 my @rr = sort { $a->[1] <=> $b->[1] } @{ delete $pri{$pri} }; 177 my @rr = sort { $a->[1] <=> $b->[1] } @{ delete $pri{$pri} };
178 178
179 my $sum; $sum += $_->[1] for @rr; 179 my $sum; $sum += $_->[1] for @rr;
180 180
… …
265 ptr $ptr, sub { 265 ptr $ptr, sub {
266 for my $name (@_) { 266 for my $name (@_) {
267 ++$cnt; 267 ++$cnt;
268 268
269 # () around AF_INET to work around bug in 5.8 269 # () around AF_INET to work around bug in 5.8
270 resolver->resolve ($name => ($af == (AF_INET) ? "a" : "aaaa"), sub { 270 resolver->resolve ("$name." => ($af == (AF_INET) ? "a" : "aaaa"), sub {
271 for (@_) { 271 for (@_) {
272 push @res, $name 272 push @res, $name
273 if $_->[3] eq $ip; 273 if $_->[3] eq $ip;
274 } 274 }
275 $cb->(@res) unless --$cnt; 275 $cb->(@res) unless --$cnt;
… …
295C<$ENV{PERL_ANYEVENT_EDNS0}>, but when set to C<1>, AnyEvent::DNS will use 295C<$ENV{PERL_ANYEVENT_EDNS0}>, but when set to C<1>, AnyEvent::DNS will use
296EDNS0 in all requests. 296EDNS0 in all requests.
297 297
298=cut 298=cut
299 299
300our $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0} * 1; # set to 1 to enable (partial) edns0 300our $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0}*1; # set to 1 to enable (partial) edns0
301 301
302our %opcode_id = ( 302our %opcode_id = (
303 query => 0, 303 query => 0,
304 iquery => 1, 304 iquery => 1,
305 status => 2, 305 status => 2,
… …
352 mx => 15, 352 mx => 15,
353 txt => 16, 353 txt => 16,
354 aaaa => 28, 354 aaaa => 28,
355 srv => 33, 355 srv => 33,
356 naptr => 35, # rfc2915 356 naptr => 35, # rfc2915
357 dname => 39, # rfc2672
357 opt => 41, 358 opt => 41,
358 spf => 99, 359 spf => 99,
359 tkey => 249, 360 tkey => 249,
360 tsig => 250, 361 tsig => 250,
361 ixfr => 251, 362 ixfr => 251,
… …
397 398
398Resource records are not yet encodable. 399Resource records are not yet encodable.
399 400
400Examples: 401Examples:
401 402
402 # very simple request, using lots of default values: 403 # very simple request, using lots of default values:
403 { rd => 1, qd => [ [ "host.domain", "a"] ] } 404 { rd => 1, qd => [ [ "host.domain", "a"] ] }
404 405
405 # more complex example, showing how flags etc. are named: 406 # more complex example, showing how flags etc. are named:
406 407
407 { 408 {
408 id => 10000, 409 id => 10000,
409 op => "query", 410 op => "query",
410 rc => "nxdomain", 411 rc => "nxdomain",
411 412
412 # flags 413 # flags
413 qr => 1, 414 qr => 1,
414 aa => 0, 415 aa => 0,
415 tc => 0, 416 tc => 0,
416 rd => 0, 417 rd => 0,
417 ra => 0, 418 ra => 0,
418 ad => 0, 419 ad => 0,
419 cd => 0, 420 cd => 0,
420 421
421 qd => [@rr], # query section 422 qd => [@rr], # query section
422 an => [@rr], # answer section 423 an => [@rr], # answer section
423 ns => [@rr], # authority section 424 ns => [@rr], # authority section
424 ar => [@rr], # additional records section 425 ar => [@rr], # additional records section
425 } 426 }
426 427
427=cut 428=cut
428 429
429sub dns_pack($) { 430sub dns_pack($) {
430 my ($req) = @_; 431 my ($req) = @_;
… …
503 11 => sub { ((join ".", unpack "C4", $_), unpack "C a*", substr $_, 4) }, # wks 504 11 => sub { ((join ".", unpack "C4", $_), unpack "C a*", substr $_, 4) }, # wks
504 12 => sub { local $ofs = $ofs - length; _dec_name }, # ptr 505 12 => sub { local $ofs = $ofs - length; _dec_name }, # ptr
505 13 => sub { unpack "C/a* C/a*", $_ }, # hinfo 506 13 => sub { unpack "C/a* C/a*", $_ }, # hinfo
506 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_name) }, # mx 507 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_name) }, # mx
507 16 => sub { unpack "(C/a*)*", $_ }, # txt 508 16 => sub { unpack "(C/a*)*", $_ }, # txt
508 28 => sub { AnyEvent::Socket::format_address ($_) }, # aaaa 509 28 => sub { AnyEvent::Socket::format_ipv6 ($_) }, # aaaa
509 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_name) }, # srv 510 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_name) }, # srv
510 35 => sub { # naptr 511 35 => sub { # naptr
512 # requires perl 5.10, sorry
511 my ($order, $preference, $flags, $service, $regexp, $offset) = unpack "nn C/a* C/a* C/a* .", $_; 513 my ($order, $preference, $flags, $service, $regexp, $offset) = unpack "nn C/a* C/a* C/a* .", $_;
512 local $ofs = $ofs + $offset - length; 514 local $ofs = $ofs + $offset - length;
513 ($order, $preference, $flags, $service, $regexp, _dec_name) 515 ($order, $preference, $flags, $service, $regexp, _dec_name)
514 }, 516 },
517 39 => sub { local $ofs = $ofs - length; _dec_name }, # dname
515 99 => sub { unpack "(C/a*)*", $_ }, # spf 518 99 => sub { unpack "(C/a*)*", $_ }, # spf
516); 519);
517 520
518sub _dec_rr { 521sub _dec_rr {
519 my $name = _dec_name; 522 my $name = _dec_name;
… …
533 536
534Unpacks a DNS packet into a perl data structure. 537Unpacks a DNS packet into a perl data structure.
535 538
536Examples: 539Examples:
537 540
538 # an unsuccessful reply 541 # an unsuccessful reply
539 { 542 {
540 'qd' => [ 543 'qd' => [
541 [ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ] 544 [ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
542 ], 545 ],
543 'rc' => 'nxdomain', 546 'rc' => 'nxdomain',
544 'ar' => [], 547 'ar' => [],
545 'ns' => [ 548 'ns' => [
546 [ 549 [
547 'uni-karlsruhe.de', 550 'uni-karlsruhe.de',
548 'soa', 551 'soa',
549 'in', 552 'in',
550 'netserv.rz.uni-karlsruhe.de', 553 'netserv.rz.uni-karlsruhe.de',
551 'hostmaster.rz.uni-karlsruhe.de', 554 'hostmaster.rz.uni-karlsruhe.de',
552 2008052201, 10800, 1800, 2592000, 86400 555 2008052201, 10800, 1800, 2592000, 86400
553 ] 556 ]
554 ], 557 ],
555 'tc' => '', 558 'tc' => '',
556 'ra' => 1, 559 'ra' => 1,
557 'qr' => 1, 560 'qr' => 1,
558 'id' => 45915, 561 'id' => 45915,
559 'aa' => '', 562 'aa' => '',
560 'an' => [], 563 'an' => [],
561 'rd' => 1, 564 'rd' => 1,
562 'op' => 'query' 565 'op' => 'query'
563 } 566 }
564 567
565 # a successful reply 568 # a successful reply
566 569
567 { 570 {
568 'qd' => [ [ 'www.google.de', 'a', 'in' ] ], 571 'qd' => [ [ 'www.google.de', 'a', 'in' ] ],
569 'rc' => 0, 572 'rc' => 0,
570 'ar' => [ 573 'ar' => [
571 [ 'a.l.google.com', 'a', 'in', '209.85.139.9' ], 574 [ 'a.l.google.com', 'a', 'in', '209.85.139.9' ],
572 [ 'b.l.google.com', 'a', 'in', '64.233.179.9' ], 575 [ 'b.l.google.com', 'a', 'in', '64.233.179.9' ],
573 [ 'c.l.google.com', 'a', 'in', '64.233.161.9' ], 576 [ 'c.l.google.com', 'a', 'in', '64.233.161.9' ],
574 ], 577 ],
575 'ns' => [ 578 'ns' => [
576 [ 'l.google.com', 'ns', 'in', 'a.l.google.com' ], 579 [ 'l.google.com', 'ns', 'in', 'a.l.google.com' ],
577 [ 'l.google.com', 'ns', 'in', 'b.l.google.com' ], 580 [ 'l.google.com', 'ns', 'in', 'b.l.google.com' ],
578 ], 581 ],
579 'tc' => '', 582 'tc' => '',
580 'ra' => 1, 583 'ra' => 1,
581 'qr' => 1, 584 'qr' => 1,
582 'id' => 64265, 585 'id' => 64265,
583 'aa' => '', 586 'aa' => '',
584 'an' => [ 587 'an' => [
585 [ 'www.google.de', 'cname', 'in', 'www.google.com' ], 588 [ 'www.google.de', 'cname', 'in', 'www.google.com' ],
586 [ 'www.google.com', 'cname', 'in', 'www.l.google.com' ], 589 [ 'www.google.com', 'cname', 'in', 'www.l.google.com' ],
587 [ 'www.l.google.com', 'a', 'in', '66.249.93.104' ], 590 [ 'www.l.google.com', 'a', 'in', '66.249.93.104' ],
588 [ 'www.l.google.com', 'a', 'in', '66.249.93.147' ], 591 [ 'www.l.google.com', 'a', 'in', '66.249.93.147' ],
589 ], 592 ],
590 'rd' => 1, 593 'rd' => 1,
591 'op' => 0 594 'op' => 0
592 } 595 }
593 596
594=cut 597=cut
595 598
596sub dns_unpack($) { 599sub dns_unpack($) {
597 local $pkt = shift; 600 local $pkt = shift;
… …
646calls. 649calls.
647 650
648Unless you have special needs, prefer this function over creating your own 651Unless you have special needs, prefer this function over creating your own
649resolver object. 652resolver object.
650 653
654The resolver is created with the following parameters:
655
656 untaint enabled
657 max_outstanding $ENV{PERL_ANYEVENT_MAX_OUTSTANDING_DNS}
658
659C<os_config> will be used for OS-specific configuration, unless
660C<$ENV{PERL_ANYEVENT_RESOLV_CONF}> is specified, in which case that file
661gets parsed.
662
651=cut 663=cut
652 664
653our $RESOLVER; 665our $RESOLVER;
654 666
655sub resolver() { 667sub resolver() {
656 $RESOLVER || do { 668 $RESOLVER || do {
657 $RESOLVER = new AnyEvent::DNS; 669 $RESOLVER = new AnyEvent::DNS
670 untaint => 1,
671 exists $ENV{PERL_ANYEVENT_MAX_OUTSTANDING_DNS}
672 ? (max_outstanding => $ENV{PERL_ANYEVENT_MAX_OUTSTANDING_DNS}*1 || 1) : (),
673 ;
674
675 exists $ENV{PERL_ANYEVENT_RESOLV_CONF}
676 ? length $ENV{PERL_ANYEVENT_RESOLV_CONF} && $RESOLVER->_parse_resolv_conf_file ($ENV{PERL_ANYEVENT_RESOLV_CONF})
658 $RESOLVER->os_config; 677 : $RESOLVER->os_config;
678
659 $RESOLVER 679 $RESOLVER
660 } 680 }
661} 681}
662 682
663=item $resolver = new AnyEvent::DNS key => value... 683=item $resolver = new AnyEvent::DNS key => value...
… …
698been resolved. 718been resolved.
699 719
700=item reuse => $seconds 720=item reuse => $seconds
701 721
702The number of seconds (default: C<300>) that a query id cannot be re-used 722The number of seconds (default: C<300>) that a query id cannot be re-used
703after a timeout. If there as no time-out then query id's can be reused 723after a timeout. If there was no time-out then query ids can be reused
704immediately. 724immediately.
725
726=item untaint => $boolean
727
728When true, then the resolver will automatically untaint results, and might
729also ignore certain environment variables.
705 730
706=back 731=back
707 732
708=cut 733=cut
709 734
710sub new { 735sub new {
711 my ($class, %arg) = @_; 736 my ($class, %arg) = @_;
712
713 # try to create a ipv4 and an ipv6 socket
714 # only fail when we cnanot create either
715
716 socket my $fh4, AF_INET , &Socket::SOCK_DGRAM, 0;
717 socket my $fh6, AF_INET6, &Socket::SOCK_DGRAM, 0;
718
719 $fh4 || $fh6
720 or Carp::croak "unable to create either an IPv6 or an IPv4 socket";
721 737
722 my $self = bless { 738 my $self = bless {
723 server => [], 739 server => [],
724 timeout => [2, 5, 5], 740 timeout => [2, 5, 5],
725 search => [], 741 search => [],
726 ndots => 1, 742 ndots => 1,
727 max_outstanding => 10, 743 max_outstanding => 10,
728 reuse => 300, # reuse id's after 5 minutes only, if possible 744 reuse => 300,
729 %arg, 745 %arg,
730 reuse_q => [], 746 reuse_q => [],
731 }, $class; 747 }, $class;
732 748
733 # search should default to gethostname's domain 749 # search should default to gethostname's domain
734 # but perl lacks a good posix module 750 # but perl lacks a good posix module
735 751
752 # try to create an ipv4 and an ipv6 socket
753 # only fail when we cannot create either
754 my $got_socket;
755
736 Scalar::Util::weaken (my $wself = $self); 756 Scalar::Util::weaken (my $wself = $self);
737 757
738 if ($fh4) { 758 if (socket my $fh4, AF_INET , &Socket::SOCK_DGRAM, 0) {
759 ++$got_socket;
760
739 AnyEvent::Util::fh_nonblocking $fh4, 1; 761 AnyEvent::Util::fh_nonblocking $fh4, 1;
740 $self->{fh4} = $fh4; 762 $self->{fh4} = $fh4;
741 $self->{rw4} = AnyEvent->io (fh => $fh4, poll => "r", cb => sub { 763 $self->{rw4} = AnyEvent->io (fh => $fh4, poll => "r", cb => sub {
742 if (my $peer = recv $fh4, my $pkt, MAX_PKT, 0) { 764 if (my $peer = recv $fh4, my $pkt, MAX_PKT, 0) {
743 $wself->_recv ($pkt, $peer); 765 $wself->_recv ($pkt, $peer);
744 } 766 }
745 }); 767 });
746 } 768 }
747 769
748 if ($fh6) { 770 if (AF_INET6 && socket my $fh6, AF_INET6, &Socket::SOCK_DGRAM, 0) {
771 ++$got_socket;
772
749 $self->{fh6} = $fh6; 773 $self->{fh6} = $fh6;
750 AnyEvent::Util::fh_nonblocking $fh6, 1; 774 AnyEvent::Util::fh_nonblocking $fh6, 1;
751 $self->{rw6} = AnyEvent->io (fh => $fh6, poll => "r", cb => sub { 775 $self->{rw6} = AnyEvent->io (fh => $fh6, poll => "r", cb => sub {
752 if (my $peer = recv $fh6, my $pkt, MAX_PKT, 0) { 776 if (my $peer = recv $fh6, my $pkt, MAX_PKT, 0) {
753 $wself->_recv ($pkt, $peer); 777 $wself->_recv ($pkt, $peer);
754 } 778 }
755 }); 779 });
756 } 780 }
757 781
782 $got_socket
783 or Carp::croak "unable to create either an IPv4 or an IPv6 socket";
784
758 $self->_compile; 785 $self->_compile;
759 786
760 $self 787 $self
761} 788}
762 789
763=item $resolver->parse_resolv_conv ($string) 790=item $resolver->parse_resolv_conf ($string)
764 791
765Parses the given string as if it were a F<resolv.conf> file. The following 792Parses the given string as if it were a F<resolv.conf> file. The following
766directives are supported (but not necessarily implemented). 793directives are supported (but not necessarily implemented).
767 794
768C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>, 795C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
… …
815 if $attempts; 842 if $attempts;
816 843
817 $self->_compile; 844 $self->_compile;
818} 845}
819 846
847sub _parse_resolv_conf_file {
848 my ($self, $resolv_conf) = @_;
849
850 open my $fh, "<:perlio", $resolv_conf
851 or Carp::croak "$resolv_conf: $!";
852
853 local $/;
854 $self->parse_resolv_conf (<$fh>);
855}
856
820=item $resolver->os_config 857=item $resolver->os_config
821 858
822Tries so load and parse F</etc/resolv.conf> on portable operating systems. Tries various 859Tries so load and parse F</etc/resolv.conf> on portable operating
823egregious hacks on windows to force the DNS servers and searchlist out of the system. 860systems. Tries various egregious hacks on windows to force the DNS servers
861and searchlist out of the system.
824 862
825=cut 863=cut
826 864
827sub os_config { 865sub os_config {
828 my ($self) = @_; 866 my ($self) = @_;
829 867
830 $self->{server} = []; 868 $self->{server} = [];
831 $self->{search} = []; 869 $self->{search} = [];
832 870
833 if (AnyEvent::WIN32 || $^O =~ /cygwin/i) { 871 if ((AnyEvent::WIN32 || $^O =~ /cygwin/i)) {
834 no strict 'refs'; 872 no strict 'refs';
835 873
836 # there are many options to find the current nameservers etc. on windows 874 # there are many options to find the current nameservers etc. on windows
837 # all of them don't work consistently: 875 # all of them don't work consistently:
838 # - the registry thing needs separate code on win32 native vs. cygwin 876 # - the registry thing needs separate code on win32 native vs. cygwin
839 # - the registry layout differs between windows versions 877 # - the registry layout differs between windows versions
840 # - calling windows api functions doesn't work on cygwin 878 # - calling windows api functions doesn't work on cygwin
841 # - ipconfig uses locale-specific messages 879 # - ipconfig uses locale-specific messages
842 880
843 # we use ipconfig parsing because, despite all it's brokenness, 881 # we use ipconfig parsing because, despite all its brokenness,
844 # it seems most stable in practise. 882 # it seems most stable in practise.
845 # for good measure, we append a fallback nameserver to our list. 883 # for good measure, we append a fallback nameserver to our list.
846 884
847 if (open my $fh, "ipconfig /all |") { 885 if (open my $fh, "ipconfig /all |") {
848 # parsing strategy: we go through the output and look for 886 # parsing strategy: we go through the output and look for
… …
857 } elsif (/^\S/ || /^\s[^:]{16,}: /) { 895 } elsif (/^\S/ || /^\s[^:]{16,}: /) {
858 $dns = 0; 896 $dns = 0;
859 } 897 }
860 if ($dns && /^\s*(\S+)\s*$/) { 898 if ($dns && /^\s*(\S+)\s*$/) {
861 my $s = $1; 899 my $s = $1;
862 $s =~ s/%\d+(?!\S)//; # get rid of scope id 900 $s =~ s/%\d+(?!\S)//; # get rid of ipv6 scope id
863 if (my $ipn = AnyEvent::Socket::parse_address ($s)) { 901 if (my $ipn = AnyEvent::Socket::parse_address ($s)) {
864 push @{ $self->{server} }, $ipn; 902 push @{ $self->{server} }, $ipn;
865 } else { 903 } else {
866 push @{ $self->{search} }, $s; 904 push @{ $self->{search} }, $s;
867 } 905 }
… …
872 push @{ $self->{server} }, $DNS_FALLBACK[rand @DNS_FALLBACK]; 910 push @{ $self->{server} }, $DNS_FALLBACK[rand @DNS_FALLBACK];
873 911
874 $self->_compile; 912 $self->_compile;
875 } 913 }
876 } else { 914 } else {
877 # try resolv.conf everywhere 915 # try resolv.conf everywhere else
878 916
879 if (open my $fh, "</etc/resolv.conf") { 917 $self->_parse_resolv_conf_file ("/etc/resolv.conf")
880 local $/; 918 if -e "/etc/resolv.conf";
881 $self->parse_resolv_conf (<$fh>);
882 }
883 } 919 }
920}
921
922=item $resolver->timeout ($timeout, ...)
923
924Sets the timeout values. See the C<timeout> constructor argument (and note
925that this method uses the values itself, not an array-reference).
926
927=cut
928
929sub timeout {
930 my ($self, @timeout) = @_;
931
932 $self->{timeout} = \@timeout;
933 $self->_compile;
934}
935
936=item $resolver->max_outstanding ($nrequests)
937
938Sets the maximum number of outstanding requests to C<$nrequests>. See the
939C<max_outstanding> constructor argument.
940
941=cut
942
943sub max_outstanding {
944 my ($self, $max) = @_;
945
946 $self->{max_outstanding} = $max;
947 $self->_scheduler;
884} 948}
885 949
886sub _compile { 950sub _compile {
887 my $self = shift; 951 my $self = shift;
888 952
… …
905 $self->{retry} = \@retry; 969 $self->{retry} = \@retry;
906} 970}
907 971
908sub _feed { 972sub _feed {
909 my ($self, $res) = @_; 973 my ($self, $res) = @_;
974
975 ($res) = $res =~ /^(.*)$/s
976 if AnyEvent::TAINT && $self->{untaint};
910 977
911 $res = dns_unpack $res 978 $res = dns_unpack $res
912 or return; 979 or return;
913 980
914 my $id = $self->{id}{$res->{id}}; 981 my $id = $self->{id}{$res->{id}};
… …
967 1034
968 $self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub { 1035 $self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
969 $NOW = time; 1036 $NOW = time;
970 1037
971 # timeout, try next 1038 # timeout, try next
972 &$do_retry; 1039 &$do_retry if $do_retry;
973 }), sub { 1040 }), sub {
974 my ($res) = @_; 1041 my ($res) = @_;
975 1042
976 if ($res->{tc}) { 1043 if ($res->{tc}) {
977 # success, but truncated, so use tcp 1044 # success, but truncated, so use tcp
978 AnyEvent::Socket::tcp_connect (AnyEvent::Socket::format_address ($server), DOMAIN_PORT, sub { 1045 AnyEvent::Socket::tcp_connect (AnyEvent::Socket::format_address ($server), DOMAIN_PORT, sub {
1046 return unless $do_retry; # some other request could have invalidated us already
1047
979 my ($fh) = @_ 1048 my ($fh) = @_
980 or return &$do_retry; 1049 or return &$do_retry;
981 1050
1051 require AnyEvent::Handle;
1052
982 my $handle = new AnyEvent::Handle 1053 my $handle; $handle = new AnyEvent::Handle
983 fh => $fh, 1054 fh => $fh,
1055 timeout => $timeout,
984 on_error => sub { 1056 on_error => sub {
1057 undef $handle;
1058 return unless $do_retry; # some other request could have invalidated us already
985 # failure, try next 1059 # failure, try next
986 &$do_retry; 1060 &$do_retry;
987 }; 1061 };
988 1062
989 $handle->push_write (pack "n/a", $req->[0]); 1063 $handle->push_write (pack "n/a", $req->[0]);
990 $handle->push_read (chunk => 2, sub { 1064 $handle->push_read (chunk => 2, sub {
991 $handle->unshift_read (chunk => (unpack "n", $_[1]), sub { 1065 $handle->unshift_read (chunk => (unpack "n", $_[1]), sub {
1066 undef $handle;
992 $self->_feed ($_[1]); 1067 $self->_feed ($_[1]);
993 }); 1068 });
994 }); 1069 });
995 shutdown $fh, 1;
996 1070
997 }, sub { $timeout }); 1071 }, sub { $timeout });
998 1072
999 } else { 1073 } else {
1000 # success 1074 # success
… …
1061 } 1135 }
1062} 1136}
1063 1137
1064=item $resolver->request ($req, $cb->($res)) 1138=item $resolver->request ($req, $cb->($res))
1065 1139
1140This is the main low-level workhorse for sending DNS requests.
1141
1066Sends a single request (a hash-ref formated as specified for 1142This function sends a single request (a hash-ref formated as specified
1067C<dns_pack>) to the configured nameservers including 1143for C<dns_pack>) to the configured nameservers in turn until it gets a
1144response. It handles timeouts, retries and automatically falls back to
1145virtual circuit mode (TCP) when it receives a truncated reply.
1146
1068retries. Calls the callback with the decoded response packet if a reply 1147Calls the callback with the decoded response packet if a reply was
1069was received, or no arguments on timeout. 1148received, or no arguments in case none of the servers answered.
1070 1149
1071=cut 1150=cut
1072 1151
1073sub request($$) { 1152sub request($$) {
1074 my ($self, $req, $cb) = @_; 1153 my ($self, $req, $cb) = @_;
1075 1154
1076 push @{ $self->{queue} }, [dns_pack $req, $cb]; 1155 push @{ $self->{queue} }, [dns_pack $req, $cb];
1077 $self->_scheduler; 1156 $self->_scheduler;
1078} 1157}
1079 1158
1080=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr)) 1159=item $resolver->resolve ($qname, $qtype, %options, $cb->(@rr))
1081 1160
1082Queries the DNS for the given domain name C<$qname> of type C<$qtype>. 1161Queries the DNS for the given domain name C<$qname> of type C<$qtype>.
1083 1162
1084A C<$qtype> is either a numerical query type (e.g. C<1> for A recods) or 1163A C<$qtype> is either a numerical query type (e.g. C<1> for A records) or
1085a lowercase name (you have to look at the source to see which aliases are 1164a lowercase name (you have to look at the source to see which aliases are
1086supported, but all types from RFC 1035, C<aaaa>, C<srv>, C<spf> and a few 1165supported, but all types from RFC 1035, C<aaaa>, C<srv>, C<spf> and a few
1087more are known to this module). A qtype of "*" is supported and means 1166more are known to this module). A C<$qtype> of "*" is supported and means
1088"any" record type. 1167"any" record type.
1089 1168
1090The callback will be invoked with a list of matching result records or 1169The callback will be invoked with a list of matching result records or
1091none on any error or if the name could not be found. 1170none on any error or if the name could not be found.
1092 1171
1093CNAME chains (although illegal) are followed up to a length of 8. 1172CNAME chains (although illegal) are followed up to a length of 10.
1094 1173
1095The callback will be invoked with an result code in string form (noerror, 1174The callback will be invoked with arraryefs of the form C<[$name, $type,
1096formerr, servfail, nxdomain, notimp, refused and so on), or numerical 1175$class, @data>], where C<$name> is the domain name, C<$type> a type string
1097form if the result code is not supported. The remaining arguments are 1176or number, C<$class> a class name and @data is resource-record-dependent
1098arraryefs of the form C<[$name, $type, $class, @data>], where C<$name> is 1177data. For C<a> records, this will be the textual IPv4 addresses, for C<ns>
1099the domain name, C<$type> a type string or number, C<$class> a class name 1178or C<cname> records this will be a domain name, for C<txt> records these
1100and @data is resource-record-dependent data. For C<a> records, this will 1179are all the strings and so on.
1101be the textual IPv4 addresses, for C<ns> or C<cname> records this will be
1102a domain name, for C<txt> records these are all the strings and so on.
1103 1180
1104All types mentioned in RFC 1035, C<aaaa>, C<srv> and C<spf> are 1181All types mentioned in RFC 1035, C<aaaa>, C<srv>, C<naptr> and C<spf> are
1105decoded. All resource records not known to this module will just return 1182decoded. All resource records not known to this module will have
1106the raw C<rdata> field as fourth entry. 1183the raw C<rdata> field as fourth entry.
1107 1184
1108Note that this resolver is just a stub resolver: it requires a name server 1185Note that this resolver is just a stub resolver: it requires a name server
1109supporting recursive queries, will not do any recursive queries itself and 1186supporting recursive queries, will not do any recursive queries itself and
1110is not secure when used against an untrusted name server. 1187is not secure when used against an untrusted name server.
… …
1115 1192
1116=item search => [$suffix...] 1193=item search => [$suffix...]
1117 1194
1118Use the given search list (which might be empty), by appending each one 1195Use the given search list (which might be empty), by appending each one
1119in turn to the C<$qname>. If this option is missing then the configured 1196in turn to the C<$qname>. If this option is missing then the configured
1120C<ndots> and C<search> define its value. If the C<$qname> ends in a dot, 1197C<ndots> and C<search> values define its value (depending on C<ndots>, the
1121then the searchlist will be ignored. 1198empty suffix will be prepended or appended to that C<search> value). If
1199the C<$qname> ends in a dot, then the searchlist will be ignored.
1122 1200
1123=item accept => [$type...] 1201=item accept => [$type...]
1124 1202
1125Lists the acceptable result types: only result types in this set will be 1203Lists the acceptable result types: only result types in this set will be
1126accepted and returned. The default includes the C<$qtype> and nothing 1204accepted and returned. The default includes the C<$qtype> and nothing
… …
1204 $do_search = sub { 1282 $do_search = sub {
1205 @search 1283 @search
1206 or (undef $do_search), (undef $do_req), return $cb->(); 1284 or (undef $do_search), (undef $do_req), return $cb->();
1207 1285
1208 (my $name = lc "$qname." . shift @search) =~ s/\.$//; 1286 (my $name = lc "$qname." . shift @search) =~ s/\.$//;
1209 my $depth = 2; 1287 my $depth = 10;
1210 1288
1211 # advance in cname-chain 1289 # advance in cname-chain
1212 $do_req = sub { 1290 $do_req = sub {
1213 $self->request ({ 1291 $self->request ({
1214 rd => 1, 1292 rd => 1,
… …
1232 if (@rr) { 1310 if (@rr) {
1233 $depth-- 1311 $depth--
1234 or return $do_search->(); # cname chain too long 1312 or return $do_search->(); # cname chain too long
1235 1313
1236 $cname = 1; 1314 $cname = 1;
1237 $name = $rr[0][3]; 1315 $name = lc $rr[0][3];
1238 1316
1239 } elsif ($cname) { 1317 } elsif ($cname) {
1240 # follow the cname 1318 # follow the cname
1241 return $do_req->(); 1319 return $do_req->();
1242 1320
… …
1291 1369
1292=back 1370=back
1293 1371
1294=head1 AUTHOR 1372=head1 AUTHOR
1295 1373
1296 Marc Lehmann <schmorp@schmorp.de> 1374 Marc Lehmann <schmorp@schmorp.de>
1297 http://home.schmorp.de/ 1375 http://home.schmorp.de/
1298 1376
1299=cut 1377=cut
1300 1378

Diff Legend

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