home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / Base.pm < prev    next >
Encoding:
Perl POD Document  |  2004-02-21  |  28.0 KB  |  1,207 lines
  1. package Net::DNS::Resolver::Base;
  2. #
  3. # $Id: Base.pm,v 2.107 2004/02/21 12:40:29 ctriv Exp $
  4. #
  5.  
  6. use strict;
  7.  
  8. use vars qw(
  9.     $VERSION
  10.     $AUTOLOAD
  11. );
  12.  
  13. use Carp;
  14. use Config ();
  15. use Socket;
  16. use IO::Socket;
  17. use IO::Select;
  18.  
  19. use Net::DNS;
  20. use Net::DNS::Packet;
  21.  
  22. $VERSION = (qw$Revision: 2.107 $)[1];
  23.  
  24. #
  25. # Set up a closure to be our class data.
  26. #
  27. {
  28.     my %defaults = (
  29.         nameservers       => ['127.0.0.1'],
  30.         port           => 53,
  31.         srcaddr        => '0.0.0.0',
  32.         srcport        => 0,
  33.         domain           => '',
  34.         searchlist       => [],
  35.         retrans           => 5,
  36.         retry           => 4,
  37.         usevc           => 0,
  38.         stayopen       => 0,
  39.         igntc          => 0,
  40.         recurse        => 1,
  41.         defnames       => 1,
  42.         dnsrch         => 1,
  43.         debug          => 0,
  44.         errorstring       => 'unknown error or no error',
  45.         tsig_rr        => undef,
  46.         answerfrom     => '',
  47.         answersize     => 0,
  48.         querytime      => undef,
  49.         tcp_timeout    => 120,
  50.         udp_timeout    => undef,
  51.         axfr_sel       => undef,
  52.         axfr_rr        => [],
  53.         axfr_soa_count => 0,
  54.         persistent_tcp => 0,
  55.         persistent_udp => 0,
  56.         dnssec         => 0,
  57.         udppacketsize  => 0,  # The actual default is lower bound by Net::DNS::PACKETSZ
  58.         cdflag         => 1,  # this is only used when {dnssec} == 1
  59.     );
  60.     
  61.     # If we're running under a SOCKSified Perl, use TCP instead of UDP
  62.     # and keep the sockets open.
  63.     if ($Config::Config{'usesocks'}) {
  64.         $defaults{'usevc'} = 1;
  65.         $defaults{'persistent_tcp'} = 1;
  66.     }
  67.     
  68.     sub defaults { \%defaults }
  69. }
  70.  
  71. # These are the attributes that we let the user specify in the new().
  72. # We also deprecate access to these with AUTOLOAD (some may be useful).
  73. my %public_attr = map { $_ => 1 } qw(
  74.     nameservers
  75.     port
  76.     srcaddr
  77.     srcport
  78.     domain
  79.     searchlist
  80.     retrans
  81.     retry
  82.     usevc
  83.     stayopen
  84.     igntc
  85.     recurse
  86.     defnames
  87.     dnsrch
  88.     debug
  89.     tcp_timeout
  90.     udp_timeout
  91.     persistent_tcp
  92.     persistent_udp
  93.     dnssec
  94. );
  95.  
  96.  
  97. sub new {
  98.     my $class = shift;
  99.  
  100.     my $self = bless({ %{$class->defaults} }, $class);
  101.  
  102.     $self->_process_args(@_) if @_ and @_ % 2 == 0;
  103.             
  104.     return $self;
  105. }
  106.  
  107. sub _process_args {
  108.     my ($self, %args) = @_;
  109.     
  110.     if ($args{'config_file'}) {
  111.         $self->read_config_file($args{'config_file'});
  112.     }
  113.     
  114.     foreach my $attr (keys %args) {
  115.         next unless $public_attr{$attr};
  116.     
  117.         if ($attr eq 'nameservers' || $attr eq 'searchlist') {
  118.             die "Net::DNS::Resolver->new(): $attr must be an arrayref\n" unless
  119.                 UNIVERSAL::isa($args{$attr}, 'ARRAY');
  120.         }
  121.         
  122.         if ($attr eq 'nameservers') {
  123.             $self->nameservers(@{$args{$attr}});
  124.         } else {
  125.             $self->{$attr} = $args{$attr};
  126.         }
  127.     }
  128. }
  129.             
  130.             
  131.             
  132.  
  133.  
  134. #
  135. # Some people have reported that Net::DNS dies because AUTOLOAD picks up
  136. # calls to DESTROY.
  137. #
  138. sub DESTROY {}
  139.  
  140.  
  141. sub read_env {
  142.     my ($invocant) = @_;
  143.     my $config     = ref $invocant ? $invocant : $invocant->defaults;
  144.         
  145.     $config->{'nameservers'} = [ $ENV{'RES_NAMESERVERS'} =~ m/(\S+)/g ]
  146.         if exists $ENV{'RES_NAMESERVERS'};
  147.  
  148.     $config->{'searchlist'}  = [ split(' ', $ENV{'RES_SEARCHLIST'})  ]
  149.         if exists $ENV{'RES_SEARCHLIST'};
  150.     
  151.     $config->{'domain'} = $ENV{'LOCALDOMAIN'}
  152.         if exists $ENV{'LOCALDOMAIN'};
  153.  
  154.     if (exists $ENV{'RES_OPTIONS'}) {
  155.         foreach ($ENV{'RES_OPTIONS'} =~ m/(\S+)/g) {
  156.             my ($name, $val) = split(m/:/);
  157.             $val = 1 unless defined $val;
  158.             $config->{$name} = $val if exists $config->{$name};
  159.         }
  160.     }
  161. }
  162.  
  163. #
  164. # $class->read_config_file($filename) or $self->read_config_file($file)
  165. #
  166. sub read_config_file {
  167.     my ($invocant, $file) = @_;
  168.     my $config            = ref $invocant ? $invocant : $invocant->defaults;
  169.  
  170.     
  171.     my @ns;
  172.     my @searchlist;
  173.     
  174.     local *FILE;
  175.  
  176.     open(FILE, "< $file") or croak "Could not open $file: $!";
  177.     local $/ = "\n";
  178.     local $_;
  179.     
  180.     while (<FILE>) {
  181.         s/\s*[;#].*//;
  182.         
  183.         # Skip ahead unless there's non-whitespace characters 
  184.         next unless m/\S/;
  185.  
  186.         SWITCH: {
  187.             /^\s*domain\s+(\S+)/ && do {
  188.                 $config->{'domain'} = $1;
  189.                 last SWITCH;
  190.             };
  191.  
  192.             /^\s*search\s+(.*)/ && do {
  193.                 push(@searchlist, split(' ', $1));
  194.                 last SWITCH;
  195.             };
  196.  
  197.             /^\s*nameserver\s+(.*)/ && do {
  198.                 foreach my $ns (split(' ', $1)) {
  199.                     $ns = '0.0.0.0' if $ns eq '0';
  200.                     next if $ns =~ m/:/;  # skip IPv6 nameservers
  201.                     push @ns, $ns;
  202.                 }
  203.                 last SWITCH;
  204.             };
  205.         }
  206.     }
  207.     close FILE || croak "Could not close $file: $!";
  208.  
  209.     $config->{'nameservers'} = [ @ns ]         if @ns;
  210.     $config->{'searchlist'}  = [ @searchlist ] if @searchlist;
  211. }
  212.  
  213.  
  214. sub print { print $_[0]->string }
  215.  
  216. sub string {
  217.     my $self = shift;
  218.  
  219.     my $timeout = defined $self->{'tcp_timeout'} ? $self->{'tcp_timeout'} : 'indefinite';
  220.     
  221.     return <<END;
  222. ;; RESOLVER state:
  223. ;;  domain       = $self->{domain}
  224. ;;  searchlist   = @{$self->{searchlist}}
  225. ;;  nameservers  = @{$self->{nameservers}}
  226. ;;  port         = $self->{port}
  227. ;;  srcport      = $self->{srcport}
  228. ;;  srcaddr      = $self->{srcaddr}
  229. ;;  tcp_timeout  = $timeout
  230. ;;  retrans  = $self->{retrans}  retry    = $self->{retry}
  231. ;;  usevc    = $self->{usevc}  stayopen = $self->{stayopen}    igntc = $self->{igntc}
  232. ;;  defnames = $self->{defnames}  dnsrch   = $self->{dnsrch}
  233. ;;  recurse  = $self->{recurse}  debug    = $self->{debug}
  234. END
  235. }
  236.  
  237.  
  238. sub searchlist {
  239.     my $self = shift;
  240.     $self->{'searchlist'} = [ @_ ] if @_;
  241.     return @{$self->{'searchlist'}};
  242. }
  243.  
  244. sub nameservers {
  245.     my $self   = shift;
  246.     my $defres = Net::DNS::Resolver->new;
  247.  
  248.     if (@_) {
  249.         my @a;
  250.         foreach my $ns (@_) {
  251.             if ($ns =~ /^(\d+(:?\.\d+){0,3})$/) {
  252.                 push @a, ($1 eq '0') ? '0.0.0.0' : $1;
  253.             } else {
  254.                 my @names;
  255.  
  256.                 if ($ns !~ /\./) {
  257.                     if (defined $defres->searchlist) {
  258.                         @names = map { $ns . '.' . $_ }
  259.                                 $defres->searchlist;
  260.                     } elsif (defined $defres->domain) {
  261.                         @names = ($ns . '.' . $defres->domain);
  262.                     }
  263.                 }
  264.                 else {
  265.                     @names = ($ns);
  266.                 }
  267.  
  268.                 my $packet = $defres->search($ns);
  269.                 $self->errorstring($defres->errorstring);
  270.                 if (defined($packet)) {
  271.                     push @a, cname_addr([@names], $packet);
  272.                 }
  273.             }
  274.         }
  275.  
  276.         $self->{'nameservers'} = [ @a ];
  277.     }
  278.  
  279.     return @{$self->{'nameservers'}};
  280. }
  281.  
  282. sub nameserver { &nameservers }
  283.  
  284. sub cname_addr {
  285.     my $names  = shift;
  286.     my $packet = shift;
  287.     my @addr;
  288.     my @names = @{$names};
  289.  
  290.     my $oct2 = '(?:2[0-4]\d|25[0-5]|[0-1]?\d\d|\d)';
  291.  
  292.     RR: foreach my $rr ($packet->answer) {
  293.         next RR unless grep {$rr->name} @names;
  294.                 
  295.         if ($rr->type eq 'CNAME') {
  296.             push(@names, $rr->cname);
  297.         } elsif ($rr->type eq 'A') {
  298.             # Run a basic taint check.
  299.             next RR unless $rr->address =~ m/^($oct2\.$oct2\.$oct2\.$oct2)$/o;
  300.             
  301.             push(@addr, $1)
  302.         }
  303.     }
  304.     
  305.     
  306.     return @addr;
  307. }
  308.  
  309.  
  310. # if ($self->{"udppacketsize"}  > &Net::DNS::PACKETSZ 
  311. # then we use EDNS and $self->{"udppacketsize"} 
  312. # should be taken as the maximum packet_data length
  313. sub _packetsz {
  314.     my ($self) = @_;
  315.  
  316.     return $self->{"udppacketsize"} > &Net::DNS::PACKETSZ ? 
  317.            $self->{"udppacketsize"} : &Net::DNS::PACKETSZ; 
  318. }
  319.  
  320. sub _reset_errorstring {
  321.     my ($self) = @_;
  322.     
  323.     $self->errorstring($self->defaults->{'errorstring'});
  324. }
  325.  
  326.  
  327. sub search {
  328.     my $self = shift;
  329.     my ($name, $type, $class) = @_;
  330.     my $ans;
  331.  
  332.     $type  ||= 'A';
  333.     $class ||= 'IN';
  334.  
  335.     # If the name looks like an IP address then do an appropriate
  336.     # PTR query.
  337.     if ($name =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) {
  338.         $name = "$4.$3.$2.$1.in-addr.arpa.";
  339.         $type = 'PTR';
  340.     }
  341.     
  342.     # pass IPv6 addresses right to query()
  343.     if (index($name, ':') > 0 and index($name, '.') < 0) {
  344.         return $self->query($name);
  345.     }
  346.  
  347.     # If the name contains at least one dot then try it as is first.
  348.     if (index($name, '.') >= 0) {
  349.         print ";; search($name, $type, $class)\n" if $self->{'debug'};
  350.         $ans = $self->query($name, $type, $class);
  351.         return $ans if $ans and $ans->header->ancount;
  352.     }
  353.  
  354.     # If the name doesn't end in a dot then apply the search list.
  355.     if (($name !~ /\.$/) && $self->{'dnsrch'}) {
  356.         foreach my $domain (@{$self->{'searchlist'}}) {
  357.             my $newname = "$name.$domain";
  358.             print ";; search($newname, $type, $class)\n"
  359.                 if $self->{'debug'};
  360.             $ans = $self->query($newname, $type, $class);
  361.             return $ans if $ans and $ans->header->ancount;
  362.         }
  363.     }
  364.  
  365.     # Finally, if the name has no dots then try it as is.
  366.     if (index($name, '.') < 0) {
  367.         print ";; search($name, $type, $class)\n" if $self->{'debug'};
  368.         $ans = $self->query("$name.", $type, $class);
  369.         return $ans if $ans and $ans->header->ancount;
  370.     }
  371.  
  372.     # No answer was found.
  373.     return undef;
  374. }
  375.  
  376.  
  377. sub query {
  378.     my ($self, $name, $type, $class) = @_;
  379.  
  380.     $type  ||= 'A';
  381.     $class ||= 'IN';
  382.  
  383.     # If the name doesn't contain any dots then append the default domain.
  384.     if ((index($name, '.') < 0) && (index($name, ':') < 0) && $self->{'defnames'}) {
  385.         $name .= ".$self->{domain}";
  386.     }
  387.  
  388.     # If the name looks like an IP address then do an appropriate
  389.     # PTR query.
  390.     if ($name =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) {
  391.         $name = "$4.$3.$2.$1.in-addr.arpa";
  392.         $type = 'PTR';
  393.     }
  394.  
  395.     # IPv4 address in IPv6 format (very lax regex)
  396.     if ($name =~ /^[0:]*:ffff:(\d+)\.(\d+)\.(\d+)\.(\d+)$/i) {
  397.         $name = "$4.$3.$2.$1.in-addr.arpa";
  398.         $type = 'PTR';
  399.     }
  400.     
  401.     # if the name looks like an IPv6 0-compressed IP address then expand
  402.     # PTR query. (eg 2001:5c0:0:1::2)
  403.     if ($name =~ /::/) {
  404.         # avoid stupid "Use of implicit split to @_ is deprecated" warning
  405.         while (scalar(my @parts = split (/:/, $name)) < 8) {
  406.             $name =~ s/::/:0::/;
  407.         }
  408.         $name =~ s/::/:0:/;
  409.     }    
  410.     
  411.     # if the name looks like an IPv6 address then do appropriate
  412.     # PTR query. (eg 2001:5c0:0:1:0:0:0:2)
  413.     if ($name =~ /:/) {
  414.         my (@stuff) = split (/:/, $name);
  415.         if (@stuff == 8) {
  416.             $name = 'ip6.arpa.';
  417.             $type = 'PTR';
  418.             foreach my $segment (@stuff) {
  419.                 $segment = sprintf ("%04s", $segment);
  420.                 $segment =~ m/(.)(.)(.)(.)/;
  421.                 $name = "$4.$3.$2.$1.$name";
  422.             }
  423.         } else {
  424.             # no idea what this is
  425.         }
  426.     }
  427.  
  428.     print ";; query($name, $type, $class)\n" if $self->{'debug'};
  429.     my $packet = Net::DNS::Packet->new($name, $type, $class);
  430.  
  431.     my $ans = $self->send($packet);
  432.  
  433.     return $ans && $ans->header->ancount   ? $ans : undef;
  434. }
  435.  
  436.  
  437. sub send {
  438.     my $self = shift;
  439.     my $packet = $self->make_query_packet(@_);
  440.     my $packet_data = $packet->data;
  441.  
  442.     my $ans;
  443.  
  444.     if ($self->{'usevc'} || length $packet_data > $self->_packetsz) {
  445.       
  446.         $ans = $self->send_tcp($packet, $packet_data);
  447.         
  448.     } else {
  449.         $ans = $self->send_udp($packet, $packet_data);
  450.         
  451.         if ($ans && $ans->header->tc && !$self->{'igntc'}) {
  452.             print ";;\n;; packet truncated: retrying using TCP\n" if $self->{'debug'};
  453.             $ans = $self->send_tcp($packet, $packet_data);
  454.         }
  455.     }
  456.     
  457.     return $ans;
  458. }
  459.  
  460.  
  461.  
  462. sub send_tcp {
  463.     my ($self, $packet, $packet_data) = @_;
  464.  
  465.     unless (@{$self->{'nameservers'}}) {
  466.         $self->errorstring('no nameservers');
  467.         print ";; ERROR: send_tcp: no nameservers\n" if $self->{'debug'};
  468.         return;
  469.     }
  470.  
  471.     $self->_reset_errorstring;
  472.     my $timeout = $self->{'tcp_timeout'};
  473.  
  474.     foreach my $ns (@{$self->{'nameservers'}}) {
  475.         my $srcport = $self->{'srcport'};
  476.         my $srcaddr = $self->{'srcaddr'};
  477.         my $dstport = $self->{'port'};
  478.  
  479.         print ";; send_tcp($ns:$dstport) (src port = $srcport)\n"
  480.             if $self->{'debug'};
  481.  
  482.         my $sock;
  483.         my $sock_key = "$ns:$dstport";
  484.  
  485.         if ($self->persistent_tcp && $self->{'sockets'}{$sock_key}) {
  486.             $sock = $self->{'sockets'}{$sock_key};
  487.             print ";; using persistent socket\n"
  488.                 if $self->{'debug'};
  489.         } else {
  490.  
  491.             # IO::Socket carps on errors if Perl's -w flag is
  492.             # turned on.  Uncomment the next two lines and the
  493.             # line following the "new" call to turn off these
  494.             # messages.
  495.  
  496.             #my $old_wflag = $^W;
  497.             #$^W = 0;
  498.  
  499.             $sock = IO::Socket::INET->new(
  500.                 PeerAddr  => $ns,
  501.                 PeerPort  => $dstport,
  502.                 LocalAddr => $srcaddr,
  503.                 LocalPort => ($srcport || undef),
  504.                 Proto     => 'tcp',
  505.                 Timeout   => $timeout
  506.             );
  507.  
  508.             #$^W = $old_wflag;
  509.  
  510.             unless ($sock) {
  511.                 $self->errorstring('connection failed');
  512.                 print ';; ERROR: send_tcp: connection ',
  513.                       "failed: $!\n" if $self->{'debug'};
  514.                 next;
  515.             }
  516.  
  517.             $self->{'sockets'}{$sock_key} = $sock;
  518.         }
  519.  
  520.         my $lenmsg = pack('n', length($packet_data));
  521.         print ';; sending ', length($packet_data), " bytes\n"
  522.             if $self->{'debug'};
  523.  
  524.         # note that we send the length and packet data in a single call
  525.         # as this produces a single TCP packet rather than two. This
  526.         # is more efficient and also makes things much nicer for sniffers.
  527.         # (ethereal doesn't seem to reassemble DNS over TCP correctly)
  528.         unless ($sock->send($lenmsg . $packet_data)) {
  529.             $self->errorstring($!);
  530.             print ";; ERROR: send_tcp: data send failed: $!\n"
  531.                 if $self->{'debug'};
  532.             next;
  533.         }
  534.  
  535.         my $sel = IO::Select->new($sock);
  536.  
  537.         if ($sel->can_read($timeout)) {
  538.             my $buf = read_tcp($sock, &Net::DNS::INT16SZ, $self->{'debug'});
  539.             next unless length($buf);
  540.             my ($len) = unpack('n', $buf);
  541.             next unless $len;
  542.  
  543.             unless ($sel->can_read($timeout)) {
  544.                 $self->errorstring('timeout');
  545.                 print ";; TIMEOUT\n" if $self->{'debug'};
  546.                 next;
  547.             }
  548.  
  549.             $buf = read_tcp($sock, $len, $self->{'debug'});
  550.  
  551.             $self->answerfrom($sock->peerhost);
  552.             $self->answersize(length $buf);
  553.  
  554.             print ';; received ', length($buf), " bytes\n"
  555.                 if $self->{'debug'};
  556.  
  557.             unless (length($buf) == $len) {
  558.                 $self->errorstring("expected $len bytes, " .
  559.                            'received ' . length($buf));
  560.                 next;
  561.             }
  562.  
  563.             my ($ans, $err) = Net::DNS::Packet->new(\$buf, $self->{'debug'});
  564.             if (defined $ans) {
  565.                 $self->errorstring($ans->header->rcode);
  566.                 $ans->answerfrom($self->answerfrom);
  567.                 $ans->answersize($self->answersize);
  568.             }
  569.             elsif (defined $err) {
  570.                 $self->errorstring($err);
  571.             }
  572.  
  573.             return $ans;
  574.         }
  575.         else {
  576.             $self->errorstring('timeout');
  577.             next;
  578.         }
  579.     }
  580.  
  581.     return;
  582. }
  583.  
  584. sub send_udp {
  585.     my ($self, $packet, $packet_data) = @_;
  586.     my $retrans = $self->{'retrans'};
  587.     my $timeout = $retrans;
  588.  
  589.     my $stop_time = time + $self->{'udp_timeout'} if $self->{'udp_timeout'};
  590.  
  591.     $self->_reset_errorstring;
  592.  
  593.     my $dstport = $self->{'port'};
  594.     my $srcport = $self->{'srcport'};
  595.     my $srcaddr = $self->{'srcaddr'};
  596.  
  597.     my $sock;
  598.  
  599.     if ($self->persistent_udp && $self->{'sockets'}{'UDP'}) {
  600.         $sock = $self->{'sockets'}{'UDP'};
  601.         print ";; using persistent socket\n"
  602.             if $self->{'debug'};
  603.     } else {
  604.         # IO::Socket carps on errors if Perl's -w flag is turned on.
  605.         # Uncomment the next two lines and the line following the "new"
  606.         # call to turn off these messages.
  607.  
  608.         #my $old_wflag = $^W;
  609.         #$^W = 0;
  610.  
  611.         $sock = IO::Socket::INET->new(
  612.                     LocalAddr => $srcaddr,
  613.                     LocalPort => ($srcport || undef),
  614.                     Proto     => 'udp',
  615.         );
  616.  
  617.         #$^W = $old_wflag;
  618.  
  619.         unless ($sock) {
  620.             $self->errorstring("couldn't create socket: $!");
  621.             return;
  622.         }
  623.         $self->{'sockets'}{'UDP'} = $sock if ($self->persistent_udp);
  624.     }
  625.  
  626.     my @ns = grep { $_->[0] && $_->[1] }
  627.              map  { [ $_, scalar(sockaddr_in($dstport, inet_aton($_))) ] }
  628.              @{$self->{'nameservers'}};
  629.  
  630.     unless (@ns) {
  631.         $self->errorstring('no nameservers');
  632.         return;
  633.     }
  634.  
  635.     my $sel = IO::Select->new($sock);
  636.  
  637.     # Perform each round of retries.
  638.     for (my $i = 0;
  639.          $i < $self->{'retry'};
  640.          ++$i, $retrans *= 2, $timeout = int($retrans / (@ns || 1))) {
  641.  
  642.         $timeout = 1 if ($timeout < 1);
  643.  
  644.         # Try each nameserver.
  645.         foreach my $ns (@ns) {
  646.             if ($stop_time) {
  647.                 my $now = time;
  648.                 if ($stop_time < $now) {
  649.                     $self->errorstring('query timed out');
  650.                     return;
  651.                 }
  652.                 if ($timeout > 1 && $timeout > ($stop_time-$now)) {
  653.                     $timeout = $stop_time-$now;
  654.                 }
  655.             }
  656.             my $nsname = $ns->[0];
  657.             my $nsaddr = $ns->[1];
  658.  
  659.             print ";; send_udp($nsname:$dstport)\n"
  660.                 if $self->{'debug'};
  661.  
  662.             unless ($sock->send($packet_data, 0, $nsaddr)) {
  663.                 print ";; send error: $!\n" if $self->{'debug'};
  664.                 @ns = grep { $_->[0] ne $nsname } @ns;
  665.                 next;
  666.             }
  667.  
  668.             my @ready = $sel->can_read($timeout);
  669.  
  670.             foreach my $ready (@ready) {
  671.                 my $buf = '';
  672.  
  673.                 if ($ready->recv($buf, $self->_packetsz)) {
  674.                 
  675.                     $self->answerfrom($ready->peerhost);
  676.                     $self->answersize(length $buf);
  677.                 
  678.                     print ';; answer from ',
  679.                           $ready->peerhost, ':',
  680.                           $ready->peerport, ' : ',
  681.                           length($buf), " bytes\n"
  682.                         if $self->{'debug'};
  683.                 
  684.                     my ($ans, $err) = Net::DNS::Packet->new(\$buf, $self->{'debug'});
  685.                 
  686.                     if (defined $ans) {
  687.                         next unless $ans->header->qr;
  688.                         next unless $ans->header->id == $packet->header->id;
  689.                         $self->errorstring($ans->header->rcode);
  690.                         $ans->answerfrom($self->answerfrom);
  691.                         $ans->answersize($self->answersize);
  692.                     } elsif (defined $err) {
  693.                         $self->errorstring($err);
  694.                     }
  695.                     
  696.                     return $ans;
  697.                 } else {
  698.                     $self->errorstring($!);
  699.                     
  700.                     print ';; recv ERROR(',
  701.                           $ready->peerhost, ':',
  702.                           $ready->peerport, '): ',
  703.                           $self->errorstring, "\n"
  704.                         if $self->{'debug'};
  705.  
  706.                     @ns = grep { $_->[0] ne $ready->peerhost } @ns;
  707.                     
  708.                     return unless @ns;
  709.                 }
  710.             }
  711.         }
  712.     }
  713.  
  714.     if ($sel->handles) {
  715.         $self->errorstring('query timed out');
  716.     }
  717.     else {
  718.         $self->errorstring('all nameservers failed');
  719.     }
  720.     return;
  721. }
  722.  
  723.  
  724. sub bgsend {
  725.     my $self = shift;
  726.  
  727.     unless (@{$self->{'nameservers'}}) {
  728.         $self->errorstring('no nameservers');
  729.         return;
  730.     }
  731.  
  732.     $self->_reset_errorstring;
  733.  
  734.     my $packet = $self->make_query_packet(@_);
  735.     my $packet_data = $packet->data;
  736.  
  737.     my $srcaddr = $self->{'srcaddr'};
  738.     my $srcport = $self->{'srcport'};
  739.  
  740.     my $dstaddr = $self->{'nameservers'}->[0];
  741.     my $dstport = $self->{'port'};
  742.  
  743.     my $sock = IO::Socket::INET->new(
  744.         Proto => 'udp',
  745.         LocalAddr => $srcaddr,
  746.         LocalPort => ($srcport || undef),
  747.     );
  748.  
  749.     unless ($sock) {
  750.         $self->errorstring(q|couldn't get socket|);   #'
  751.         return;
  752.     }
  753.     
  754.     my $dst_sockaddr = sockaddr_in($dstport, inet_aton($dstaddr));
  755.  
  756.     print ";; bgsend($dstaddr:$dstport)\n" if $self->{'debug'};
  757.  
  758.     unless ($sock->send($packet_data, 0, $dst_sockaddr)) {
  759.         my $err = $!;
  760.         print ";; send ERROR($dstaddr): $err\n" if $self->{'debug'};
  761.         $self->errorstring($err);
  762.         return;
  763.     }
  764.  
  765.     return $sock;
  766. }
  767.  
  768.  
  769. sub bgread {
  770.     my ($self, $sock) = @_;
  771.  
  772.     my $buf = '';
  773.  
  774.     my $peeraddr = $sock->recv($buf, $self->_packetsz);
  775.     
  776.     if ($peeraddr) {
  777.         print ';; answer from ', $sock->peerhost, ':',
  778.               $sock->peerport, ' : ', length($buf), " bytes\n"
  779.             if $self->{'debug'};
  780.  
  781.         my ($ans, $err) = Net::DNS::Packet->new(\$buf, $self->{'debug'});
  782.         
  783.         if (defined $ans) {
  784.             $self->errorstring($ans->header->rcode);
  785.         } elsif (defined $err) {
  786.             $self->errorstring($err);
  787.         }
  788.         
  789.         return $ans;
  790.     } else {
  791.         $self->errorstring($!);
  792.         return;
  793.     }
  794. }
  795.  
  796. sub bgisready {
  797.     my $self = shift;
  798.     my $sel = IO::Select->new(@_);
  799.     my @ready = $sel->can_read(0.0);
  800.     return @ready > 0;
  801. }
  802.  
  803. sub make_query_packet {
  804.     my $self = shift;
  805.     my $packet;
  806.  
  807.     if (ref($_[0]) and $_[0]->isa('Net::DNS::Packet')) {
  808.         $packet = shift;
  809.     } else {
  810.         my ($name, $type, $class) = @_;
  811.  
  812.         $name  ||= '';
  813.         $type  ||= 'A';
  814.         $class ||= 'IN';
  815.  
  816.         # If the name looks like an IP address then do an appropriate
  817.         # PTR query.
  818.         if ($name =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) {
  819.             $name = "$4.$3.$2.$1.in-addr.arpa.";
  820.             $type = 'PTR';
  821.         }
  822.  
  823.         $packet = Net::DNS::Packet->new($name, $type, $class);
  824.     }
  825.  
  826.     if ($packet->header->opcode eq 'QUERY') {
  827.         $packet->header->rd($self->{'recurse'});
  828.     }
  829.  
  830.     if ($self->{'dnssec'}) {
  831.         # RFC 3225
  832.         print ";; Adding EDNS extention with UDP packetsize $self->{'udppacketsize'} and DNS OK bit set\n" 
  833.             if $self->{'debug'};
  834.         
  835.         my $optrr = Net::DNS::RR->new(
  836.                         Type         => 'OPT',
  837.                         Name         => '',
  838.                         Class        => $self->{'udppacketsize'},  # Decimal UDPpayload
  839.                         ednsflags    => 0x8000, # first bit set see RFC 3225 
  840.                    );
  841.                  
  842.         $packet->push('additional', $optrr);
  843.         
  844.     } elsif ($self->{'udppacketsize'} > &Net::DNS::PACKETSZ) {
  845.         print ";; Adding EDNS extention with UDP packetsize  $self->{'udppacketsize'}.\n" if $self->{'debug'};
  846.         # RFC 3225
  847.         my $optrr = Net::DNS::RR->new( 
  848.                         Type         => 'OPT',
  849.                         Name         => '',
  850.                         Class        => $self->{'udppacketsize'},  # Decimal UDPpayload
  851.                         TTL          => 0x0000 # RCODE 32bit Hex
  852.                     );
  853.                     
  854.         $packet->push('additional', $optrr);
  855.     }
  856.     
  857.  
  858.     if ($self->{'tsig_rr'}) {
  859.         if (!grep { $_->type eq 'TSIG' } $packet->additional) {
  860.             $packet->push('additional', $self->{'tsig_rr'});
  861.         }
  862.     }
  863.  
  864.     return $packet;
  865. }
  866.  
  867. sub axfr {
  868.     my $self = shift;
  869.     my @zone;
  870.  
  871.     if ($self->axfr_start(@_)) {
  872.         my ($rr, $err);
  873.         while (($rr, $err) = $self->axfr_next, $rr && !$err) {
  874.             push @zone, $rr;
  875.         }
  876.         @zone = () if $err;
  877.     }
  878.  
  879.     return @zone;
  880. }
  881.  
  882. sub axfr_old {
  883.     croak "Use of Net::DNS::Resolver::axfr_old() is deprecated, use axfr() or axfr_start().";
  884. }
  885.  
  886. sub axfr_start {
  887.     my $self = shift;
  888.     my ($dname, $class) = @_;
  889.     $dname ||= $self->{'searchlist'}->[0];
  890.     $class ||= 'IN';
  891.  
  892.     unless ($dname) {
  893.         print ";; ERROR: axfr: no zone specified\n" if $self->{'debug'};
  894.         $self->errorstring('no zone');
  895.         return;
  896.     }
  897.  
  898.     print ";; axfr_start($dname, $class)\n" if $self->{'debug'};
  899.  
  900.     unless (@{$self->{'nameservers'}}) {
  901.         $self->errorstring('no nameservers');
  902.         print ";; ERROR: no nameservers\n" if $self->{'debug'};
  903.         return;
  904.     }
  905.  
  906.     my $packet = $self->make_query_packet($dname, 'AXFR', $class);
  907.     my $packet_data = $packet->data;
  908.  
  909.     my $ns = $self->{'nameservers'}->[0];
  910.  
  911.     print ";; axfr_start nameserver = $ns\n" if $self->{'debug'};
  912.  
  913.     my $srcport = $self->{'srcport'};
  914.  
  915.     my $sock;
  916.     my $sock_key = "$ns:$self->{'port'}";
  917.  
  918.     if ($self->{'persistent_tcp'} && $self->{'sockets'}->{$sock_key}) {
  919.         $sock = $self->{'sockets'}->{$sock_key};
  920.         print ";; using persistent socket\n" if $self->{'debug'};
  921.         
  922.     } else {
  923.  
  924.         # IO::Socket carps on errors if Perl's -w flag is turned on.
  925.         # Uncomment the next two lines and the line following the "new"
  926.         # call to turn off these messages.
  927.  
  928.         #my $old_wflag = $^W;
  929.         #$^W = 0;
  930.  
  931.         $sock = IO::Socket::INET->new(
  932.             PeerAddr  => $ns,
  933.             PeerPort  => $self->{'port'},
  934.             LocalAddr => $self->{'srcaddr'},
  935.             LocalPort => ($srcport || undef),
  936.             Proto     => 'tcp',
  937.             Timeout   => $self->{'tcp_timeout'}
  938.          );
  939.  
  940.         #$^W = $old_wflag;
  941.  
  942.         unless ($sock) {
  943.             $self->errorstring(q|couldn't connect|);
  944.             return;
  945.         }
  946.  
  947.         $self->{'sockets'}->{$sock_key} = $sock;
  948.     }
  949.  
  950.     my $lenmsg = pack('n', length($packet_data));
  951.  
  952.     unless ($sock->send($lenmsg)) {
  953.         $self->errorstring($!);
  954.         return;
  955.     }
  956.  
  957.     unless ($sock->send($packet_data)) {
  958.         $self->errorstring($!);
  959.         return;
  960.     }
  961.  
  962.     my $sel = IO::Select->new($sock);
  963.  
  964.     $self->{'axfr_sel'}       = $sel;
  965.     $self->{'axfr_rr'}        = [];
  966.     $self->{'axfr_soa_count'} = 0;
  967.  
  968.     return $sock;
  969. }
  970.  
  971.  
  972. sub axfr_next {
  973.     my $self = shift;
  974.     my $err  = '';
  975.     
  976.     unless (@{$self->{'axfr_rr'}}) {
  977.         unless ($self->{'axfr_sel'}) {
  978.             my $err = 'no zone transfer in progress';
  979.             
  980.             print ";; $err\n" if $self->{'debug'};
  981.             $self->errorstring($err);
  982.                     
  983.             return wantarray ? (undef, $err) : undef;
  984.         }
  985.  
  986.         my $sel = $self->{'axfr_sel'};
  987.         my $timeout = $self->{'tcp_timeout'};
  988.  
  989.         #--------------------------------------------------------------
  990.         # Read the length of the response packet.
  991.         #--------------------------------------------------------------
  992.  
  993.         my @ready = $sel->can_read($timeout);
  994.         unless (@ready) {
  995.             $err = 'timeout';
  996.             $self->errorstring($err);
  997.             return wantarray ? (undef, $err) : undef;
  998.         }
  999.  
  1000.         my $buf = read_tcp($ready[0], &Net::DNS::INT16SZ, $self->{'debug'});
  1001.         unless (length $buf) {
  1002.             $err = 'truncated zone transfer';
  1003.             $self->errorstring($err);
  1004.             return wantarray ? (undef, $err) : undef;
  1005.         }
  1006.  
  1007.         my ($len) = unpack('n', $buf);
  1008.         unless ($len) {
  1009.             $err = 'truncated zone transfer';
  1010.             $self->errorstring($err);
  1011.             return wantarray ? (undef, $err) : undef;
  1012.         }
  1013.  
  1014.         #--------------------------------------------------------------
  1015.         # Read the response packet.
  1016.         #--------------------------------------------------------------
  1017.  
  1018.         @ready = $sel->can_read($timeout);
  1019.         unless (@ready) {
  1020.             $err = 'timeout';
  1021.             $self->errorstring($err);
  1022.             return wantarray ? (undef, $err) : undef;
  1023.         }
  1024.  
  1025.         $buf = read_tcp($ready[0], $len, $self->{'debug'});
  1026.  
  1027.         print ';; received ', length($buf), " bytes\n"
  1028.             if $self->{'debug'};
  1029.  
  1030.         unless (length($buf) == $len) {
  1031.             $err = "expected $len bytes, received " . length($buf);
  1032.             $self->errorstring($err);
  1033.             print ";; $err\n" if $self->{'debug'};
  1034.             return wantarray ? (undef, $err) : undef;
  1035.         }
  1036.  
  1037.         my $ans;
  1038.         ($ans, $err) = Net::DNS::Packet->new(\$buf, $self->{'debug'});
  1039.  
  1040.         if ($ans) {
  1041.             if ($ans->header->rcode ne 'NOERROR') {    
  1042.                 $self->errorstring('Response code from server: ' . $ans->header->rcode);
  1043.                 print ';; Response code from server: ' . $ans->header->rcode . "\n" if $self->{'debug'};
  1044.                 return wantarray ? (undef, $err) : undef;
  1045.             }
  1046.             if ($ans->header->ancount < 1) {
  1047.                 $err = 'truncated zone transfer';
  1048.                 $self->errorstring($err);
  1049.                 print ";; $err\n" if $self->{'debug'};
  1050.                 return wantarray ? (undef, $err) : undef;
  1051.             }
  1052.         }
  1053.         else {
  1054.             $err ||= 'unknown error during packet parsing';
  1055.             $self->errorstring($err);
  1056.             print ";; $err\n" if $self->{'debug'};
  1057.             return wantarray ? (undef, $err) : undef;
  1058.         }
  1059.  
  1060.         foreach my $rr ($ans->answer) {
  1061.             if ($rr->type eq 'SOA') {
  1062.                 if (++$self->{'axfr_soa_count'} < 2) {
  1063.                     push @{$self->{'axfr_rr'}}, $rr;
  1064.                 }
  1065.             }
  1066.             else {
  1067.                 push @{$self->{'axfr_rr'}}, $rr;
  1068.             }
  1069.         }
  1070.  
  1071.         if ($self->{'axfr_soa_count'} >= 2) {
  1072.             $self->{'axfr_sel'} = undef;
  1073.             # we need to mark the transfer as over if the responce was in 
  1074.             # many answers.  Otherwise, the user will call axfr_next again
  1075.             # and that will cause a 'no transfer in progress' error.
  1076.             push(@{$self->{'axfr_rr'}}, undef);
  1077.         }
  1078.     }
  1079.  
  1080.     my $rr = shift @{$self->{'axfr_rr'}};
  1081.  
  1082.     return wantarray ? ($rr, undef) : $rr;
  1083. }
  1084.  
  1085.  
  1086. sub tsig {
  1087.     my $self = shift;
  1088.  
  1089.     if (@_ == 1) {
  1090.         if ($_[0] && ref($_[0])) {
  1091.             $self->{'tsig_rr'} = $_[0];
  1092.         }
  1093.         else {
  1094.             $self->{'tsig_rr'} = undef;
  1095.         }
  1096.     }
  1097.     elsif (@_ == 2) {
  1098.         my ($key_name, $key) = @_;
  1099.         $self->{'tsig_rr'} = Net::DNS::RR->new("$key_name TSIG $key");
  1100.     }
  1101.  
  1102.     return $self->{'tsig_rr'};
  1103. }
  1104.  
  1105. #
  1106. # Usage:  $data = read_tcp($socket, $nbytes, $debug);
  1107. #
  1108. sub read_tcp {
  1109.     my ($sock, $nbytes, $debug) = @_;
  1110.     my $buf = '';
  1111.  
  1112.     while (length($buf) < $nbytes) {
  1113.         my $nread = $nbytes - length($buf);
  1114.         my $read_buf = '';
  1115.  
  1116.         print ";; read_tcp: expecting $nread bytes\n" if $debug;
  1117.  
  1118.         # During some of my tests recv() returned undef even
  1119.         # though there wasn't an error.  Checking for the amount
  1120.         # of data read appears to work around that problem.
  1121.  
  1122.         unless ($sock->recv($read_buf, $nread)) {
  1123.             if (length($read_buf) < 1) {
  1124.                 my $errstr = $!;
  1125.  
  1126.                 print ";; ERROR: read_tcp: recv failed: $!\n"
  1127.                     if $debug;
  1128.  
  1129.                 if ($errstr eq 'Resource temporarily unavailable') {
  1130.                     warn "ERROR: read_tcp: recv failed: $errstr\n";
  1131.                     warn "ERROR: try setting \$res->timeout(undef)\n";
  1132.                 }
  1133.  
  1134.                 last;
  1135.             }
  1136.         }
  1137.  
  1138.         print ';; read_tcp: received ', length($read_buf), " bytes\n"
  1139.             if $debug;
  1140.  
  1141.         last unless length($read_buf);
  1142.         $buf .= $read_buf;
  1143.     }
  1144.  
  1145.     return $buf;
  1146. }
  1147.  
  1148. sub AUTOLOAD {
  1149.     my ($self) = @_;
  1150.  
  1151.     my $name = $AUTOLOAD;
  1152.     $name =~ s/.*://;
  1153.  
  1154.     Carp::croak "$name: no such method" unless exists $self->{$name};
  1155.     
  1156.     no strict q/refs/;
  1157.     
  1158.     
  1159.     *{$AUTOLOAD} = sub {
  1160.         my ($self, $new_val) = @_;
  1161.         
  1162.         if (defined $new_val) {
  1163.             $self->{"$name"} = $new_val;
  1164.         }
  1165.         
  1166.         return $self->{"$name"};
  1167.     };
  1168.  
  1169.     
  1170.     goto &{$AUTOLOAD};    
  1171. }
  1172.  
  1173. 1;
  1174.  
  1175. __END__
  1176.  
  1177. =head1 NAME
  1178.  
  1179. Net::DNS::Resolver::Base - Common Resolver Class
  1180.  
  1181. =head1 SYNOPSIS
  1182.  
  1183.  use base qw/Net::DNS::Resolver::Base/;
  1184.  
  1185. =head1 DESCRIPTION
  1186.  
  1187. This class is the common base class for the different platform
  1188. sub-classes of L<Net::DNS::Resolver|Net::DNS::Resolver>.  
  1189.  
  1190. No user serviceable parts inside, see L<Net::DNS::Resolver|Net::DNS::Resolver>
  1191. for all your resolving needs.
  1192.  
  1193. =head1 COPYRIGHT
  1194.  
  1195. Copyright (c) 1997-2002 Michael Fuhr. 
  1196.  
  1197. Portions Copyright (c) 2002-2003 Chris Reinhardt.
  1198.  
  1199. All rights reserved.  This program is free software; you may redistribute
  1200. it and/or modify it under the same terms as Perl itself.
  1201.  
  1202. =head1 SEE ALSO
  1203.  
  1204. L<perl(1)>, L<Net::DNS>, L<Net::DNS::Resolver>
  1205.  
  1206. =cut
  1207.