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 / Recurse.pm < prev    next >
Encoding:
Perl POD Document  |  2003-12-13  |  14.9 KB  |  403 lines
  1. package Net::DNS::Resolver::Recurse;
  2. #
  3. # $Id: Recurse.pm,v 2.100 2003/12/13 01:37:06 ctriv Exp $
  4. #
  5. use strict;
  6. use Net::DNS::Resolver;
  7.  
  8. use vars qw($VERSION @ISA);
  9.  
  10. $VERSION = (qw$Revision: 2.100 $)[1];
  11. @ISA = qw(Net::DNS::Resolver);
  12.  
  13. sub hints {
  14.   my $self = shift;
  15.   my @hints = @_;
  16.   print ";; hints(@hints)\n" if $self->{'debug'};
  17.   if (!@hints && $self->nameservers) {
  18.     $self->hints($self->nameservers);
  19.   } else {
  20.     $self->nameservers(@hints);
  21.   }
  22.   print ";; verifying (root) zone...\n" if $self->{'debug'};
  23.   # bind always asks one of the hint servers
  24.   # for who it thinks is authoritative for
  25.   # the (root) zone as a sanity check.
  26.   # Nice idea.
  27.   my $packet = $self->query(".", "NS", "IN");
  28.   my %hints = ();
  29.   if ($packet) {
  30.     if (my @ans = $packet->answer) {
  31.       foreach my $rr (@ans) {
  32.         if ($rr->name =~ /^\.?$/ and
  33.             $rr->type eq "NS") {
  34.           # Found root authority
  35.           my $server = lc $rr->rdatastr;
  36.           $server =~ s/\.$//;
  37.           print ";; FOUND HINT: $server\n" if $self->{'debug'};
  38.           $hints{$server} = [];
  39.         }
  40.       }
  41.       foreach my $rr ($packet->additional) {
  42.         print ";; ADDITIONAL: ",$rr->string,"\n" if $self->{'debug'};
  43.         if (my $server = lc $rr->name and
  44.             $rr->type eq "A") {
  45.           #print ";; ADDITIONAL HELP: $server -> [".$rr->rdatastr."]\n" if $self->{'debug'};
  46.           if ($hints{$server}) {
  47.             print ";; STORING IP: $server IN A ",$rr->rdatastr,"\n" if $self->{'debug'};
  48.             push @{ $hints{$server} }, $rr->rdatastr;
  49.           }
  50.         }
  51.       }
  52.     }
  53.     foreach my $server (keys %hints) {
  54.       if (!@{ $hints{$server} }) {
  55.         # Wipe the servers without lookups
  56.         delete $hints{$server};
  57.       }
  58.     }
  59.     $self->{'hints'} = \%hints;
  60.   } else {
  61.     $self->{'hints'} = {};
  62.   } 
  63.   if (%{ $self->{'hints'} }) {
  64.     if ($self->{'debug'}) {
  65.       print ";; USING THE FOLLOWING HINT IPS:\n";
  66.       foreach my $ips (values %{ $self->{'hints'} }) {
  67.         foreach my $server (@{ $ips }) {
  68.           print ";;  $server\n";
  69.         }
  70.       }
  71.     }
  72.   } else {
  73.     warn "Server [".($self->nameservers)[0]."] did not give answers";
  74.   }
  75.  
  76.   # Disable recursion flag.
  77.   $self->recurse(0);
  78.  
  79.   return $self->nameservers( map { @{ $_ } } values %{ $self->{'hints'} } );
  80. }
  81.  
  82. # $res->query_dorecursion( args );
  83. # Takes same args as Net::DNS::Resolver->query
  84. # Purpose: Do that "hot pototo dance" on args.
  85. sub query_dorecursion {
  86.   my $self = shift;
  87.   my @query = @_;
  88.  
  89.   # Make sure the hint servers are initialized.
  90.   $self->hints unless $self->{'hints'};
  91.  
  92.   # Make sure the authority cache is clean.
  93.   # It is only used to store A records of
  94.   # authoritative name servers.
  95.   $self->{'authority_cache'} = {};
  96.  
  97.   # Obtain real question Net::DNS::Packet
  98.   my $query_packet = $self->make_query_packet(@query);
  99.  
  100.   # Seed name servers with hints
  101.   return $self->_dorecursion( $query_packet, ".", $self->{'hints'}, 0);
  102. }
  103.  
  104. sub _dorecursion {
  105.   my $self = shift;
  106.   my $query_packet = shift;
  107.   my $known_zone = shift;
  108.   my $known_authorities = shift;
  109.   my $depth = shift;
  110.   my $cache = $self->{'authority_cache'};
  111.  
  112.   print ";; _dorecursion() depth=[$depth] known_zone=[$known_zone]\n" if $self->{'debug'};
  113.   die "Recursion too deep, aborting..." if $depth > 255;
  114.  
  115.   $known_zone =~ s/\.*$/./;
  116.  
  117.   # Get IPs from authorities
  118.   my @ns = ();
  119.   foreach my $ns (keys %{ $known_authorities }) {
  120.     if (scalar @{ $known_authorities->{$ns} }) {
  121.       $cache->{$ns} = $known_authorities->{$ns};
  122.       push (@ns, @{ $cache->{$ns} });
  123.     } elsif ($cache->{$ns}) {
  124.       $known_authorities->{$ns} = $cache->{$ns};
  125.       push (@ns, @{ $cache->{$ns} });
  126.     }
  127.   }
  128.  
  129.   if (!@ns) {
  130.     my $found_auth = 0;
  131.     if ($self->{'debug'}) {
  132.       require Data::Dumper;
  133.       print ";; _dorecursion() Failed to extract nameserver IPs:\n";
  134.       print Data::Dumper::Dumper([$known_authorities,$cache]);
  135.     }
  136.     foreach my $ns (keys %{ $known_authorities }) {
  137.       if (!@{ $known_authorities->{$ns} }) {
  138.         print ";; _dorecursion() Manual lookup for authority [$ns]\n" if $self->{'debug'};
  139.         my $auth_packet =
  140.           $self->_dorecursion
  141.           ($self->make_query_packet($ns,"A"),  # packet
  142.            ".",               # known_zone
  143.            $self->{'hints'},  # known_authorities
  144.            $depth+1);         # depth
  145.  
  146.         if ($auth_packet and my @ans = $auth_packet->answer) {
  147.           print ";; _dorecursion() Answers found for [$ns]\n" if $self->{'debug'};
  148.           foreach my $rr (@ans) {
  149.             if ($rr->type eq "CNAME") {
  150.               # Follow CNAME
  151.               if (my $server = lc $rr->name) {
  152.                 $server =~ s/\.*$/./;
  153.                 if ($server eq $ns) {
  154.                   my $cname = lc $rr->rdatastr;
  155.                   $cname =~ s/\.*$/./;
  156.                   print ";; _dorecursion() Following CNAME ns [$ns] -> [$cname]\n" if $self->{'debug'};
  157.                   $known_authorities->{$cname} ||= [];
  158.                   delete $known_authorities->{$ns};
  159.                   next;
  160.                 }
  161.               }
  162.             } elsif ($rr->type eq "A") {
  163.               if (my $server = lc $rr->name) {
  164.                 $server =~ s/\.*$/./;
  165.                 if ($known_authorities->{$server}) {
  166.                   my $ip = $rr->rdatastr;
  167.                   print ";; _dorecursion() Found ns: $server IN A $ip\n" if $self->{'debug'};
  168.                   $cache->{$server} = $known_authorities->{$server};
  169.                   push (@{ $cache->{$ns} }, $ip);
  170.                   $found_auth++;
  171.                   next;
  172.                 }
  173.               }
  174.             }
  175.             print ";; _dorecursion() Ignoring useless answer: ",$rr->string,"\n" if $self->{'debug'};
  176.           }
  177.         } else {
  178.           print ";; _dorecursion() Could not find A records for [$ns]\n" if $self->{'debug'};
  179.         }
  180.       }
  181.     }
  182.     if ($found_auth) {
  183.       print ";; _dorecursion() Found $found_auth new NS authorities...\n" if $self->{'debug'};
  184.       return $self->_dorecursion( $query_packet, $known_zone, $known_authorities, $depth+1);
  185.     }
  186.     print ";; _dorecursion() No authority information could be obtained.\n" if $self->{'debug'};
  187.     return undef;
  188.   }
  189.  
  190.   # Cut the deck of IPs in a random place.
  191.   print ";; _dorecursion() cutting deck of (".scalar(@ns).") authorities...\n" if $self->{'debug'};
  192.   splice(@ns, 0, 0, splice(@ns, int(rand @ns)));
  193.  
  194.   print ";; _dorecursion() First nameserver [$ns[0]]\n" if $self->{'debug'};
  195.   $self->nameservers(@ns);
  196.  
  197.   if (my $packet = $self->send( $query_packet )) {
  198.     my $of = undef;
  199.     print ";; _dorecursion() Response received from [",$self->answerfrom,"]\n" if $self->{'debug'};
  200.     if (my $status = $packet->header->rcode) {
  201.       if ($status eq "NXDOMAIN") {
  202.         # I guess NXDOMAIN is the best we'll ever get
  203.         print ";; _dorecursion() returning NXDOMAIN\n" if $self->{'debug'};
  204.         return $packet;
  205.       } elsif (my @ans = $packet->answer) {
  206.         print ";; _dorecursion() Answers were found.\n" if $self->{'debug'};
  207.         return $packet;
  208.       } elsif (my @authority = $packet->authority) {
  209.         my %auth = ();
  210.         foreach my $rr (@authority) {
  211.           if ($rr->type =~ /^(NS|SOA)$/) {
  212.             my $server = lc ($1 eq "NS" ? $rr->nsdname : $rr->mname);
  213.             $server =~ s/\.*$/./;
  214.             $of = lc $rr->name;
  215.             $of =~ s/\.*$/./;
  216.             print ";; _dorecursion() Received authority [$of] [",$rr->type(),"] [$server]\n" if $self->{'debug'};
  217.             if (length $of <= length $known_zone) {
  218.               print ";; _dorecursion() Deadbeat name server did not provide new information.\n" if $self->{'debug'};
  219.             } elsif ($of =~ /$known_zone$/) {
  220.               print ";; _dorecursion() FOUND closer authority for [$of] at [$server].\n" if $self->{'debug'};
  221.               $auth{$server} ||= [];
  222.             } else {
  223.               print ";; _dorecursion() Confused name server [",$self->answerfrom,"] thinks [$of] is closer than [$known_zone]?\n" if $self->{'debug'};
  224.               last;
  225.             }
  226.           } else {
  227.             print ";; _dorecursion() Ignoring NON NS entry found in authority section: ",$rr->string,"\n" if $self->{'debug'};
  228.           }
  229.         }
  230.         foreach my $rr ($packet->additional) {
  231.           if ($rr->type eq "CNAME") {
  232.             # Store this CNAME into %auth too
  233.             if (my $server = lc $rr->name) {
  234.               $server =~ s/\.*$/./;
  235.               if ($auth{$server}) {
  236.                 my $cname = lc $rr->rdatastr;
  237.                 $cname =~ s/\.*$/./;
  238.                 print ";; _dorecursion() FOUND CNAME authority: ",$rr->string,"\n" if $self->{'debug'};
  239.                 $auth{$cname} ||= [];
  240.                 $auth{$server} = $auth{$cname};
  241.                 next;
  242.               }
  243.             }
  244.           } elsif ($rr->type eq "A") {
  245.             if (my $server = lc $rr->name) {
  246.               $server =~ s/\.*$/./;
  247.               if ($auth{$server}) {
  248.                 print ";; _dorecursion() STORING: $server IN A ",$rr->rdatastr,"\n" if $self->{'debug'};
  249.                 push @{ $auth{$server} }, $rr->rdatastr;
  250.                 next;
  251.               }
  252.             }
  253.           }
  254.           print ";; _dorecursion() Ignoring useless: ",$rr->string,"\n" if $self->{'debug'};
  255.         }
  256.         if ($of =~ /$known_zone$/) {
  257.           return $self->_dorecursion( $query_packet, $of, \%auth, $depth+1 );
  258.         } else {
  259.           return $self->_dorecursion( $query_packet, $known_zone, $known_authorities, $depth+1 );
  260.         }
  261.       }
  262.     }
  263.   }
  264.   return undef;
  265. }
  266.  
  267. 1;
  268.  
  269. __END__
  270.  
  271.  
  272. =head1 NAME
  273.  
  274. Net::DNS::Resolver::Recurse - Perform recursive dns lookups
  275.  
  276. =head1 SYNOPSIS
  277.  
  278.   use Net::DNS::Resolver::Recurse;
  279.   my $res = Net::DNS::Resolver::Recurse->new;
  280.  
  281. =head1 DESCRIPTION
  282.  
  283. This module is a super class of Net::DNS::Resolver.
  284. So the methods for Net::DNS::Resolver still work
  285. for this module as well.  There are just a couple
  286. methods added:
  287.  
  288. =head2 hints
  289.  
  290. Initialize the hint servers.  Recursive queries
  291. need a starting name server to work off of.
  292. This method takes a list of IP addresses to
  293. use as the starting servers.  These name servers
  294. should be authoritative for the root (.) zone.
  295.  
  296.   $res->hints( @ips );
  297.  
  298. If no hints are passed, the default nameserver
  299. is asked for the hints.  Normally these IPs can
  300. be obtained from the following location:
  301.  
  302.   ftp://ftp.internic.net/domain/named.root
  303.  
  304. =head2 query_dorecursion
  305.  
  306. This method is much like the normal query() method
  307. except it disables the recurse flag in the packet
  308. and explicitly performs the recursion.
  309.  
  310.   $packet = $res->query_dorecursion( "www.netscape.com.", "A");
  311.  
  312. =head1 AUTHOR
  313.  
  314. Rob Brown, bbb@cpan.org
  315.  
  316. =head1 SEE ALSO
  317.  
  318. L<Net::DNS::Resolver>,
  319.  
  320. =head1 COPYRIGHT
  321.  
  322. Copyright (c) 2002, Rob Brown.  All rights reserved.
  323.  
  324. This module is free software; you can redistribute
  325. it and/or modify it under the same terms as Perl itself.
  326.  
  327. $Id: Recurse.pm,v 2.100 2003/12/13 01:37:06 ctriv Exp $
  328.  
  329. =cut
  330.  
  331. Example lookup process:
  332.  
  333. [root@box root]# dig +trace www.rob.com.au.
  334.  
  335. ; <<>> DiG 9.2.0 <<>> +trace www.rob.com.au.
  336. ;; global options:  printcmd
  337. .                       507343  IN      NS      C.ROOT-SERVERS.NET.
  338. .                       507343  IN      NS      D.ROOT-SERVERS.NET.
  339. .                       507343  IN      NS      E.ROOT-SERVERS.NET.
  340. .                       507343  IN      NS      F.ROOT-SERVERS.NET.
  341. .                       507343  IN      NS      G.ROOT-SERVERS.NET.
  342. .                       507343  IN      NS      H.ROOT-SERVERS.NET.
  343. .                       507343  IN      NS      I.ROOT-SERVERS.NET.
  344. .                       507343  IN      NS      J.ROOT-SERVERS.NET.
  345. .                       507343  IN      NS      K.ROOT-SERVERS.NET.
  346. .                       507343  IN      NS      L.ROOT-SERVERS.NET.
  347. .                       507343  IN      NS      M.ROOT-SERVERS.NET.
  348. .                       507343  IN      NS      A.ROOT-SERVERS.NET.
  349. .                       507343  IN      NS      B.ROOT-SERVERS.NET.
  350. ;; Received 436 bytes from 127.0.0.1#53(127.0.0.1) in 9 ms
  351.   ;;; But these should be hard coded as the hints
  352.  
  353.   ;;; Ask H.ROOT-SERVERS.NET gave:
  354. au.                     172800  IN      NS      NS2.BERKELEY.EDU.
  355. au.                     172800  IN      NS      NS1.BERKELEY.EDU.
  356. au.                     172800  IN      NS      NS.UU.NET.
  357. au.                     172800  IN      NS      BOX2.AUNIC.NET.
  358. au.                     172800  IN      NS      SEC1.APNIC.NET.
  359. au.                     172800  IN      NS      SEC3.APNIC.NET.
  360. ;; Received 300 bytes from 128.63.2.53#53(H.ROOT-SERVERS.NET) in 322 ms
  361.   ;;; A little closer than before
  362.  
  363.   ;;; Ask NS2.BERKELEY.EDU gave:
  364. com.au.                 259200  IN      NS      ns4.ausregistry.net.
  365. com.au.                 259200  IN      NS      dns1.telstra.net.
  366. com.au.                 259200  IN      NS      au2ld.CSIRO.au.
  367. com.au.                 259200  IN      NS      audns01.syd.optus.net.
  368. com.au.                 259200  IN      NS      ns.ripe.net.
  369. com.au.                 259200  IN      NS      ns1.ausregistry.net.
  370. com.au.                 259200  IN      NS      ns2.ausregistry.net.
  371. com.au.                 259200  IN      NS      ns3.ausregistry.net.
  372. com.au.                 259200  IN      NS      ns3.melbourneit.com.
  373. ;; Received 387 bytes from 128.32.206.12#53(NS2.BERKELEY.EDU) in 10312 ms
  374.   ;;; A little closer than before
  375.  
  376.   ;;; Ask ns4.ausregistry.net gave:
  377. com.au.                 259200  IN      NS      ns1.ausregistry.net.
  378. com.au.                 259200  IN      NS      ns2.ausregistry.net.
  379. com.au.                 259200  IN      NS      ns3.ausregistry.net.
  380. com.au.                 259200  IN      NS      ns4.ausregistry.net.
  381. com.au.                 259200  IN      NS      ns3.melbourneit.com.
  382. com.au.                 259200  IN      NS      dns1.telstra.net.
  383. com.au.                 259200  IN      NS      au2ld.CSIRO.au.
  384. com.au.                 259200  IN      NS      ns.ripe.net.
  385. com.au.                 259200  IN      NS      audns01.syd.optus.net.
  386. ;; Received 259 bytes from 137.39.1.3#53(ns4.ausregistry.net) in 606 ms
  387.   ;;; Uh... yeah... I already knew this
  388.   ;;; from what NS2.BERKELEY.EDU told me.
  389.   ;;; ns4.ausregistry.net must have brain damage
  390.  
  391.   ;;; Ask ns1.ausregistry.net gave:
  392. rob.com.au.             86400   IN      NS      sy-dns02.tmns.net.au.
  393. rob.com.au.             86400   IN      NS      sy-dns01.tmns.net.au.
  394. ;; Received 87 bytes from 203.18.56.41#53(ns1.ausregistry.net) in 372 ms
  395.   ;;; Ah, much better.  Something more useful.
  396.  
  397.   ;;; Ask sy-dns02.tmns.net.au gave:
  398. www.rob.com.au.         7200    IN      A       139.134.5.123
  399. rob.com.au.             7200    IN      NS      sy-dns01.tmns.net.au.
  400. rob.com.au.             7200    IN      NS      sy-dns02.tmns.net.au.
  401. ;; Received 135 bytes from 139.134.2.18#53(sy-dns02.tmns.net.au) in 525 ms
  402.   ;;; FINALLY, THE ANSWER!
  403.