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.92 by root, Sun Jun 7 16:48:38 2009 UTC vs.
Revision 1.106 by root, Fri Jul 17 18:08:35 2009 UTC

… …
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 = 4.411; 40our $VERSION = 4.83;
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
… …
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,
… …
379 379
380sub _enc_name($) { 380sub _enc_name($) {
381 pack "(C/a*)*", (split /\./, shift), "" 381 pack "(C/a*)*", (split /\./, shift), ""
382} 382}
383 383
384if ($[ < 5.008) {
385 # special slower 5.6 version
386 *_enc_name = sub {
387 join "", map +(pack "C/a*", $_), (split /\./, shift), ""
388 };
389}
390
384sub _enc_qd() { 391sub _enc_qd() {
385 (_enc_name $_->[0]) . pack "nn", 392 (_enc_name $_->[0]) . pack "nn",
386 ($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}), 393 ($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),
387 ($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] || "in"}) 394 ($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] || "in"})
388} 395}
… …
504 11 => sub { ((join ".", unpack "C4", $_), unpack "C a*", substr $_, 4) }, # wks 511 11 => sub { ((join ".", unpack "C4", $_), unpack "C a*", substr $_, 4) }, # wks
505 12 => sub { local $ofs = $ofs - length; _dec_name }, # ptr 512 12 => sub { local $ofs = $ofs - length; _dec_name }, # ptr
506 13 => sub { unpack "C/a* C/a*", $_ }, # hinfo 513 13 => sub { unpack "C/a* C/a*", $_ }, # hinfo
507 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_name) }, # mx 514 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_name) }, # mx
508 16 => sub { unpack "(C/a*)*", $_ }, # txt 515 16 => sub { unpack "(C/a*)*", $_ }, # txt
509 28 => sub { AnyEvent::Socket::format_address ($_) }, # aaaa 516 28 => sub { AnyEvent::Socket::format_ipv6 ($_) }, # aaaa
510 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_name) }, # srv 517 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_name) }, # srv
511 35 => sub { # naptr 518 35 => sub { # naptr
512 # requires perl 5.10, sorry 519 # requires perl 5.10, sorry
513 my ($order, $preference, $flags, $service, $regexp, $offset) = unpack "nn C/a* C/a* C/a* .", $_; 520 my ($order, $preference, $flags, $service, $regexp, $offset) = unpack "nn C/a* C/a* C/a* .", $_;
514 local $ofs = $ofs + $offset - length; 521 local $ofs = $ofs + $offset - length;
… …
649calls. 656calls.
650 657
651Unless you have special needs, prefer this function over creating your own 658Unless you have special needs, prefer this function over creating your own
652resolver object. 659resolver object.
653 660
661The resolver is created with the following parameters:
662
663 untaint enabled
664 max_outstanding $ENV{PERL_ANYEVENT_MAX_OUTSTANDING_DNS}
665
666C<os_config> will be used for OS-specific configuration, unless
667C<$ENV{PERL_ANYEVENT_RESOLV_CONF}> is specified, in which case that file
668gets parsed.
669
654=cut 670=cut
655 671
656our $RESOLVER; 672our $RESOLVER;
657 673
658sub resolver() { 674sub resolver() {
659 $RESOLVER || do { 675 $RESOLVER || do {
660 $RESOLVER = new AnyEvent::DNS; 676 $RESOLVER = new AnyEvent::DNS
677 untaint => 1,
678 exists $ENV{PERL_ANYEVENT_MAX_OUTSTANDING_DNS}
679 ? (max_outstanding => $ENV{PERL_ANYEVENT_MAX_OUTSTANDING_DNS}*1 || 1) : (),
680 ;
681
682 exists $ENV{PERL_ANYEVENT_RESOLV_CONF}
683 ? length $ENV{PERL_ANYEVENT_RESOLV_CONF} && $RESOLVER->_parse_resolv_conf_file ($ENV{PERL_ANYEVENT_RESOLV_CONF})
661 $RESOLVER->os_config; 684 : $RESOLVER->os_config;
685
662 $RESOLVER 686 $RESOLVER
663 } 687 }
664} 688}
665 689
666=item $resolver = new AnyEvent::DNS key => value... 690=item $resolver = new AnyEvent::DNS key => value...
… …
703=item reuse => $seconds 727=item reuse => $seconds
704 728
705The number of seconds (default: C<300>) that a query id cannot be re-used 729The number of seconds (default: C<300>) that a query id cannot be re-used
706after a timeout. If there was no time-out then query ids can be reused 730after a timeout. If there was no time-out then query ids can be reused
707immediately. 731immediately.
732
733=item untaint => $boolean
734
735When true, then the resolver will automatically untaint results, and might
736also ignore certain environment variables.
708 737
709=back 738=back
710 739
711=cut 740=cut
712 741
… …
763 $self->_compile; 792 $self->_compile;
764 793
765 $self 794 $self
766} 795}
767 796
768=item $resolver->parse_resolv_conv ($string) 797=item $resolver->parse_resolv_conf ($string)
769 798
770Parses the given string as if it were a F<resolv.conf> file. The following 799Parses the given string as if it were a F<resolv.conf> file. The following
771directives are supported (but not necessarily implemented). 800directives are supported (but not necessarily implemented).
772 801
773C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>, 802C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
… …
820 if $attempts; 849 if $attempts;
821 850
822 $self->_compile; 851 $self->_compile;
823} 852}
824 853
854sub _parse_resolv_conf_file {
855 my ($self, $resolv_conf) = @_;
856
857 open my $fh, "<", $resolv_conf
858 or Carp::croak "$resolv_conf: $!";
859
860 local $/;
861 $self->parse_resolv_conf (<$fh>);
862}
863
825=item $resolver->os_config 864=item $resolver->os_config
826 865
827Tries so load and parse F</etc/resolv.conf> on portable operating systems. Tries various 866Tries so load and parse F</etc/resolv.conf> on portable operating
828egregious hacks on windows to force the DNS servers and searchlist out of the system. 867systems. Tries various egregious hacks on windows to force the DNS servers
868and searchlist out of the system.
829 869
830=cut 870=cut
831 871
832sub os_config { 872sub os_config {
833 my ($self) = @_; 873 my ($self) = @_;
834 874
835 $self->{server} = []; 875 $self->{server} = [];
836 $self->{search} = []; 876 $self->{search} = [];
837 877
838 if (AnyEvent::WIN32 || $^O =~ /cygwin/i) { 878 if ((AnyEvent::WIN32 || $^O =~ /cygwin/i)) {
839 no strict 'refs'; 879 no strict 'refs';
840 880
841 # there are many options to find the current nameservers etc. on windows 881 # there are many options to find the current nameservers etc. on windows
842 # all of them don't work consistently: 882 # all of them don't work consistently:
843 # - the registry thing needs separate code on win32 native vs. cygwin 883 # - the registry thing needs separate code on win32 native vs. cygwin
… …
877 push @{ $self->{server} }, $DNS_FALLBACK[rand @DNS_FALLBACK]; 917 push @{ $self->{server} }, $DNS_FALLBACK[rand @DNS_FALLBACK];
878 918
879 $self->_compile; 919 $self->_compile;
880 } 920 }
881 } else { 921 } else {
882 # try resolv.conf everywhere 922 # try resolv.conf everywhere else
883 923
884 if (open my $fh, "</etc/resolv.conf") { 924 $self->_parse_resolv_conf_file ("/etc/resolv.conf")
885 local $/; 925 if -e "/etc/resolv.conf";
886 $self->parse_resolv_conf (<$fh>);
887 }
888 } 926 }
889} 927}
890 928
891=item $resolver->timeout ($timeout, ...) 929=item $resolver->timeout ($timeout, ...)
892 930
… …
938 $self->{retry} = \@retry; 976 $self->{retry} = \@retry;
939} 977}
940 978
941sub _feed { 979sub _feed {
942 my ($self, $res) = @_; 980 my ($self, $res) = @_;
981
982 ($res) = $res =~ /^(.*)$/s
983 if AnyEvent::TAINT && $self->{untaint};
943 984
944 $res = dns_unpack $res 985 $res = dns_unpack $res
945 or return; 986 or return;
946 987
947 my $id = $self->{id}{$res->{id}}; 988 my $id = $self->{id}{$res->{id}};
… …
1011 AnyEvent::Socket::tcp_connect (AnyEvent::Socket::format_address ($server), DOMAIN_PORT, sub { 1052 AnyEvent::Socket::tcp_connect (AnyEvent::Socket::format_address ($server), DOMAIN_PORT, sub {
1012 return unless $do_retry; # some other request could have invalidated us already 1053 return unless $do_retry; # some other request could have invalidated us already
1013 1054
1014 my ($fh) = @_ 1055 my ($fh) = @_
1015 or return &$do_retry; 1056 or return &$do_retry;
1057
1058 require AnyEvent::Handle;
1016 1059
1017 my $handle; $handle = new AnyEvent::Handle 1060 my $handle; $handle = new AnyEvent::Handle
1018 fh => $fh, 1061 fh => $fh,
1019 timeout => $timeout, 1062 timeout => $timeout,
1020 on_error => sub { 1063 on_error => sub {
… …
1041 } 1084 }
1042 }]; 1085 }];
1043 1086
1044 my $sa = AnyEvent::Socket::pack_sockaddr (DOMAIN_PORT, $server); 1087 my $sa = AnyEvent::Socket::pack_sockaddr (DOMAIN_PORT, $server);
1045 1088
1046 my $fh = AF_INET == Socket::sockaddr_family ($sa) 1089 my $fh = AF_INET == AnyEvent::Socket::sockaddr_family ($sa)
1047 ? $self->{fh4} : $self->{fh6} 1090 ? $self->{fh4} : $self->{fh6}
1048 or return &$do_retry; 1091 or return &$do_retry;
1049 1092
1050 send $fh, $req->[0], 0, $sa; 1093 send $fh, $req->[0], 0, $sa;
1051 }; 1094 };
… …
1274 if (@rr) { 1317 if (@rr) {
1275 $depth-- 1318 $depth--
1276 or return $do_search->(); # cname chain too long 1319 or return $do_search->(); # cname chain too long
1277 1320
1278 $cname = 1; 1321 $cname = 1;
1279 $name = $rr[0][3]; 1322 $name = lc $rr[0][3];
1280 1323
1281 } elsif ($cname) { 1324 } elsif ($cname) {
1282 # follow the cname 1325 # follow the cname
1283 return $do_req->(); 1326 return $do_req->();
1284 1327

Diff Legend

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