Net-DNS-0.68/0000755000175000017500000000000011711344242012162 5ustar willemwillemNet-DNS-0.68/contrib/0000755000175000017500000000000011711344242013622 5ustar willemwillemNet-DNS-0.68/contrib/loc2earth.fcgi0000755000175000017500000001347011710626412016350 0ustar willemwillem#!/usr/local/bin/perl -T # loc2earth.cgi - generates a redirect to Earth Viewer based on LOC record # [ see or RFC 1876 ] # by Christopher Davis # $Id: loc2earth.fcgi 264 2005-04-06 09:16:15Z olaf $ die "I want 5.004 and I want it now" if $] < 5.004; # if you don't have FastCGI support, comment out this line and the two lines # later in the script with "NO FCGI" comments use CGI::Fast qw(:standard); # and uncomment the following instead. #use CGI qw(:standard); use Net::DNS '0.08'; # LOC support in 0.08 and later $res = new Net::DNS::Resolver; @samplehosts= ('www.kei.com', 'www.ndg.com.au', 'gw.alink.net', 'quasar.inexo.com.br', 'hubert.fukt.hk-r.se', 'sargent.cms.dmu.ac.uk', 'thales.mathematik.uni-ulm.de'); while (new CGI::Fast) { # NO FCGI -- comment out this line print header(-Title => "RFC 1876 Resources: Earth Viewer Demo"); # reinitialize these since FastCGI would keep them around otherwise @addrs = @netnames = (); $foundloc = 0; print ' RFC 1876 Resources: Earth Viewer Demo

RFC 1876 Resources

loc2earth: The Earth Viewer Demo


'; print p("This is a quick & dirty demonstration of the use of the", a({-href => 'http://www.dimensional.com/~mfuhr/perldns/'}, 'Net::DNS module'),"and the", a({-href => 'http://www-genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html'}, 'CGI.pm library'), "to write LOC-aware Web applications."); print startform("GET"); print p(strong("Hostname"),textfield(-name => host, -size => 50)); print p(submit, reset), endform; if (param('host')) { ($host = param('host')) =~ s/\s//g; # strip out spaces # check for numeric IPs and do reverse lookup to get name if ($host =~ m/^\d+\.\d+\.\d+\.\d+$/) { $query = $res->query($host); if (defined ($query)) { foreach $ans ($query->answer) { if ($ans->type eq "PTR") { $host = $ans->ptrdname; } } } } $query = $res->query($host,"LOC"); if (defined ($query)) { # then we got an answer of some sort foreach $ans ($query->answer) { if ($ans->type eq "LOC") { &print_loc($ans->rdatastr); $foundloc++; } elsif ($ans->type eq "CNAME") { # XXX should follow CNAME chains here } } } if (!$foundloc) { # try the RFC 1101 search bit $query = $res->query($host,"A"); if (defined ($query)) { foreach $ans ($query->answer) { if ($ans->type eq "A") { push(@addrs,$ans->address); } } } if (@addrs) { checkaddrs: foreach $ipstr (@addrs) { $ipnum = unpack("N",pack("CCCC",split(/\./,$ipstr,4))); ($ip1) = split(/\./,$ipstr); if ($ip1 >= 224) { # class D/E, treat as host addr $mask = 0xFFFFFFFF; } elsif ($ip1 >= 192) { # "class C" $mask = 0xFFFFFF00; } elsif ($ip1 >= 128) { # "class B" $mask = 0xFFFF0000; } else { # class A $mask = 0xFF000000; } $oldmask = 0; while ($oldmask != $mask) { $oldmask = $mask; $querystr = join(".", reverse (unpack("CCCC",pack("N",$ipnum & $mask)))) . ".in-addr.arpa"; $query = $res->query($querystr,"PTR"); if (defined ($query)) { foreach $ans ($query->answer) { if ($ans->type eq "PTR") { # we want the list in LIFO order unshift(@netnames,$ans->ptrdname); } } $query = $res->query($querystr,"A"); if (defined ($query)) { foreach $ans ($query->answer) { if ($ans->type eq "A") { $mask = unpack("L",pack("CCCC", split(/\./,$ans->address,4))); } } } } } if (@netnames) { foreach $network (@netnames) { $query = $res->query($network,"LOC"); if (defined ($query)) { foreach $ans ($query->answer) { if ($ans->type eq "LOC") { &print_loc($ans->rdatastr); $foundloc++; last checkaddrs; } elsif ($ans->type eq "CNAME") { # XXX should follow CNAME chains here } } } } } } } } if (!$foundloc) { print hr,p("Sorry, there appear to be no LOC records for the", "host $host in the DNS."); } } print hr,p("Some hosts with LOC records you may want to try:"), ""; print '
RFC 1876 Now
Christopher Davis <ckd@kei.com>
'; } # NO FCGI -- comment out this line sub print_loc { local($rdata) = @_; ($latdeg,$latmin,$latsec,$lathem, $londeg,$lonmin,$lonsec,$lonhem) = split (/ /,$rdata); print hr,p("The host $host appears to be at", "${latdeg}°${latmin}'${latsec}\" ${lathem}", "latitude and ${londeg}°${lonmin}'${lonsec}\"", "${lonhem} longitude according to the DNS."); $evurl = ("http://www.fourmilab.ch/cgi-bin/uncgi/Earth?" . "lat=${latdeg}d${latmin}m${latsec}s&ns=" . (($lathem eq "S")?"lSouth":"lNorth") . "&lon=${londeg}d${lonmin}m${lonsec}s&ew=" . (($lonhem eq "W")?"West":"East") . "&alt="); print "

Generate an Earth Viewer image from "; foreach $alt (49, 204, 958, 35875) { print ('', $alt,'km '); } print " above this point

"; } Net-DNS-0.68/contrib/dnswalk.README0000644000175000017500000000024311710626412016144 0ustar willemwillem$Id: dnswalk.README 739 2008-12-17 13:48:03Z olaf $ Dave Barr's dnswalk now uses Net::DNS. You can get a copy from: http://sourceforge.net/projects/dnswalk/ Net-DNS-0.68/contrib/check_zone0000755000175000017500000004526511710626412015675 0ustar willemwillem#!/usr/local/bin/perl -w # $Id: check_zone 638 2007-05-15 18:59:26Z olaf $ =head1 NAME check_zone - Check a DNS zone for errors =head1 SYNOPSIS C [ C<-r> ][ C<-v> ] I [ I ] =head1 DESCRIPTION Checks a DNS zone for errors. Current checks are: =over 4 =item * Checks the domain's SOA from each of the domain's name servers. The SOA serial numbers should match. This program's output cannot be trusted if they do not. =item * Tries to perform an AXFR from each of the domain's name servers. This test helps to detect whether the name server is blocking AXFR. =item * Checks that all A records have corresponding PTR records. For each A record its PTR's name is match checked. =item * Checks that all PTR records match an A record (sometimes they match a CNAME). Check the PTR's name against the A record. =item * Checks that hosts listed in NS, MX, and CNAME records have A records. Checks for NS and CNAME records not pointing to another CNAME (i.e., they must directly resolve to an A record). That test may be somewhat controversial because, in many cases, a MX to a CNAME or a CNAME to another CNAME will resolve; however, in DNS circles it isn't a recommended practise. =item * Check each record processed for being with the class requested. This is an internal integrity check. =back =head1 OPTIONS =over 4 =back =item C<-r> Perform a recursive check on subdomains. =item C<-v> Verbose. =item C<-a alternate_domain> Treat as equal to . This is useful when supporting a change of domain names (eg from myolddomain.example.net to mynewdomain.example.net) where the PTR records can point to only one of the two supported domains (which are otherwise identical). =item C<-e exception_file> Ignore exceptions in file . File format can be space-separated domain pairs, one pair per line, or it can be straight output from this program itself (for simple cut-and-paste functionality). This allows for skipping entries that are odd or unusual, but not causing problems. Note: this only works with A - PTR checks. =head1 AUTHORS Originally developed by Michael Fuhr (mfuhr@dimensional.com) and hacked--with furor--by Dennis Glatting (dennis.glatting@software-munitions.com). "-a" and "-e" options added by Paul Archer =head1 COPYRIGHT =head1 SEE ALSO L, L, L, L, L, L =head1 BUGS A query for an A RR against a name that is a CNAME may not follow the CNAME to an A RR. There isn't a mechanism to insure records are returned from an authoritative source. There appears to be a bug in the resolver AXFR routine where, if one server cannot be contacted, the routine doesn't try another in its list. =cut require 'assert.pl'; use strict; use vars qw($opt_r); use vars qw($opt_v); use vars qw($opt_a); use vars qw($opt_e); use Getopt::Std; use File::Basename; use IO::Socket; use Net::DNS; getopts("rva:e:"); die "Usage: ", basename($0), " [ -r -v ] [ -a alternate_domain] [ -e eqivalent_domains_file ] domain [ class ]\n" unless (@ARGV >= 1) && (@ARGV <= 2); our $exit_status = 0; $SIG{__WARN__} = sub {$exit_status=1 ; print STDERR @_ }; $opt_r = 1; our $main_domain=$ARGV[0]; our %exceptions = parse_exceptions_file(); foreach my $key (sort keys %exceptions) { print "$key:\t"; foreach my $val (@{$exceptions{$key}}) { print "$val "; } print "\n"; } check_domain(@ARGV); exit $exit_status; sub parse_exceptions_file { my %exceptions; my $file = $opt_e || ""; return %exceptions unless ( -r $file); open FH, $file or warn "Couldn't read $file: $!"; my $line; while ( defined ($line = ) ) { chomp $line; #print " raw line: $line\n"; next if $line =~ /^\s*#/; $line =~ s/#.*$//; $line =~ s/^\s*//; $line =~ s/\s*$//; $line =~ s/'//g; my ($left, $right) = (split /[\s:]+/, $line)[0, -1]; push @{$exceptions{$left}}, $right; #print "processed line: $line\n"; } return %exceptions; } sub check_domain { my ( $domain, $class ) = @_; my $ns; my @zone; $class ||= "IN"; print "-" x 70, "\n"; print "$domain (class $class)\n"; print "\n"; my $res = new Net::DNS::Resolver; $res->defnames( 0 ); $res->retry( 2 ); my( $nspack, $ns_rr, @nsl ); # Get a list of name servers for the domain. # Error-out if the query isn't satisfied. # $nspack = $res->query( $domain, 'NS', $class ); unless( defined( $nspack )) { warn "Couldn't find nameservers for $domain: ", $res->errorstring, "\n"; return; } printf( "List of name servers returned from '%s'\n", $res->answerfrom ); foreach $ns_rr ( $nspack->answer ) { $ns_rr->print if( $opt_v ); assert( $class eq $ns_rr->class ); assert( 'NS' eq $ns_rr->type ); if( $ns_rr->name eq $domain ) { print "\t", $ns_rr->rdatastr, "\n"; push @nsl, $ns_rr->rdatastr; } else { warn( "asked for '$domain', got '%s'\n", $ns_rr->rdatastr ); } } print "\n"; warn( "\tZone has no NS records\n" ) if( scalar( @nsl ) == 0 ); # Transfer the zone from each of the name servers. # The zone is transferred for several reasons. # First, so the check routines won't (an efficiency # issue) and second, to see if we can. # $res->nameservers( @nsl ); foreach $ns ( @nsl ) { $res->nameservers( $ns ); my @local_zone = $res->axfr( $domain, $class ); unless( @local_zone ) { warn "Zone transfer from '", $ns, "' failed: ", $res->errorstring, "\n"; } @zone = @local_zone if( ! @zone ); } # Query each name server for the zone # and check the zone's SOA serial number. # print "checking SOA records\n"; check_soa( $domain, $class, \@nsl ); print "\n"; # Check specific record types. # print "checking NS records\n"; check_ns( $domain, $class, \@nsl, \@zone ); print "\n"; print "checking A records\n"; check_a( $domain, $class, \@nsl, \@zone ); print "\n"; print "checking PTR records\n"; check_ptr( $domain, $class, \@nsl, \@zone ); print "\n"; print "checking MX records\n"; check_mx( $domain, $class, \@nsl, \@zone ); print "\n"; print "checking CNAME records\n"; check_cname( $domain, $class, \@nsl, \@zone ); print "\n"; # Recurse? # if( $opt_r ) { my %subdomains; print "checking subdomains\n\n"; # Get a list of NS records from the zone that # are not for the zone (i.e., they're subdomains). # foreach ( grep { $_->type eq 'NS' and $_->name ne $domain } @zone ) { $subdomains{$_->name} = 1; } # For each subdomain, check it. # foreach ( sort keys %subdomains ) { check_domain($_, $class); } } } sub check_soa { my( $domain, $class, $nsl ) = @_; my( $soa_sn, $soa_diff ) = ( 0, 0 ); my( $ns, $soa_rr ); my $rr_count = 0; my $res = new Net::DNS::Resolver; $res->defnames( 0 ); $res->retry( 2 ); $res->recurse( 0 ); # Contact each name server and get the # SOA for the somain. # foreach $ns ( @$nsl ) { my $soa = 0; my $nspack; # Query the name server and test # for a result. # $res->nameservers( $ns ); $nspack = $res->query( $domain, "SOA", $class ); unless( defined( $nspack )) { warn "Couldn't get SOA from '$ns'\n"; next; } # Look at each SOA for the domain from the # name server. Specifically, look to see if # its serial number is different across # the name servers. # foreach $soa_rr ( $nspack->answer ) { $soa_rr->print if( $opt_v ); assert( $class eq $soa_rr->class ); assert( 'SOA' eq $soa_rr->type ); print "\t$ns:\t", $soa_rr->serial, "\n"; # If soa_sn is zero then an SOA serial number # hasn't been recorded. In that case record # the serial number. If the serial number # doesn't match a previously recorded one then # indicate they are different. # # If the serial numbers are different then you # cannot really trust the remainder of the test. # if( $soa_sn ) { $soa_diff = 1 if ( $soa_sn != $soa_rr->serial ); } else { $soa_sn = $soa_rr->serial; } } ++$rr_count; } print "\t*** SOAs are different!\n" if( $soa_diff ); print "$rr_count SOA RRs checked.\n"; } sub check_ptr { my( $domain, $class, $nsl, $zone ) = @_; my $res = new Net::DNS::Resolver; my $ptr_rr; my $rr_count = 0; $res->defnames( 0 ); $res->retry( 2 ); $res->nameservers( @$nsl ); foreach $ptr_rr ( grep { $_->type eq 'PTR' } @$zone ) { my @types; $ptr_rr->print if( $opt_v ); assert( $class eq $ptr_rr->class ); assert( 'PTR' eq $ptr_rr->type ); print "\tchecking PTR rr '$ptr_rr' to PTR\n" if( $opt_v ); @types = types4name( $ptr_rr->ptrdname, $domain, $class, $nsl ); if( grep { $_ eq 'A' } @types ) { xcheck_ptr2a( $ptr_rr, $domain, $class, $nsl ); } else { warn "\t'", $ptr_rr->ptrdname, "' doesn't resolve to an A RR (RRs are '", join( ', ', @types ), "')\n"; } ++$rr_count; } print "$rr_count PTR RRs checked.\n"; } sub check_ns { my( $domain, $class, $nsl, $zone ) = @_; my $res = new Net::DNS::Resolver; my $ns_rr; my $rr_count = 0; $res->defnames( 0 ); $res->retry( 2 ); $res->nameservers( @$nsl ); # Go through the zone data and process # all NS RRs for the zone (delegation # NS RRs are ignored). Specifically, # check to see if the indicate name server # is a CNAME RR and the name resolves to an A # RR. Check to insure the address resolved # against the name has an associated PTR RR. # foreach $ns_rr ( grep { $_->type eq 'NS' } @$zone ) { my @types; $ns_rr->print if( $opt_v ); assert( $class eq $ns_rr->class ); assert( 'NS' eq $ns_rr->type ); next if( $ns_rr->name ne $domain ); printf( "rr nsdname: %s\n", $ns_rr->nsdname ) if $opt_v; @types = types4name( $ns_rr->nsdname, $domain, $class, $nsl ); if( grep { $_ eq 'A' } @types ) { xcheck_name( $ns_rr->nsdname, $domain, $class, $nsl ); } else { warn "\t'", $ns_rr->nsdname, "' doesn't resolve to an A RR (RRs are '", join( ', ', @types ), "')\n"; } ++$rr_count; } print "$rr_count NS RRs checked.\n"; } sub check_a { my( $domain, $class, $nsl, $zone ) = @_; my $res = new Net::DNS::Resolver; my $a_rr; my $rr_count = 0; $res->defnames( 0 ); $res->retry( 2 ); $res->nameservers( @$nsl ); # Go through the zone data and process # all A RRs. Specifically, check to insure # each A RR matches a PTR RR and the PTR RR # matches the A RR. # foreach $a_rr ( grep { $_->type eq 'A' } @$zone ) { $a_rr->print if( $opt_v ); assert( $class eq $a_rr->class ); assert( 'A' eq $a_rr->type ); print "\tchecking A RR '", $a_rr->address, "' to PTR\n" if( $opt_v ); xcheck_a2ptr( $a_rr, $domain, $class, $nsl ); ++$rr_count; } print "$rr_count A RRs checked.\n"; } sub check_mx { my( $domain, $class, $nsl, $zone ) = @_; my $res = new Net::DNS::Resolver; my $mx_rr; my $rr_count = 0; $res->defnames( 0 ); $res->retry( 2 ); $res->nameservers( @$nsl ); # Go through the zone data and process # all MX RRs. Specifically, check to insure # each MX RR resolves to an A RR and the # A RR has a matching PTR RR. # foreach $mx_rr ( grep { $_->type eq 'MX' } @$zone ) { $mx_rr->print if( $opt_v ); assert( $class eq $mx_rr->class ); assert( 'MX' eq $mx_rr->type ); print "\tchecking MX RR '", $mx_rr->exchange, "' to A\n" if( $opt_v ); xcheck_name( $mx_rr->exchange, $domain, $class, $nsl ); ++$rr_count; } print "$rr_count MX RRs checked.\n"; } sub check_cname { my( $domain, $class, $nsl, $zone ) = @_; my $res = new Net::DNS::Resolver; my $cname_rr; my $rr_count = 0; $res->defnames( 0 ); $res->retry( 2 ); $res->nameservers( @$nsl ); # Go through the zone data and process # all CNAME RRs. Specifically, check to insure # each CNAME RR resolves to an A RR and the # A RR has a matching PTR RR. # foreach $cname_rr ( grep { $_->type eq 'CNAME' } @$zone ) { my @types; $cname_rr->print if( $opt_v ); assert( $class eq $cname_rr->class ); assert( 'CNAME' eq $cname_rr->type ); print "\tchecking CNAME RR '", $cname_rr->cname, "' to A\n" if( $opt_v ); @types = types4name( $cname_rr->cname, $domain, $class, $nsl ); if( grep { $_ eq 'A' } @types ) { xcheck_name( $cname_rr->cname, $domain, $class, $nsl ); } else { warn "\t'", $cname_rr->cname, "' doesn't resolve to an A RR (RRs are '", join( ', ', @types ), "')\n"; } ++$rr_count; } print "$rr_count CNAME RRs checked.\n"; } sub check_w_equivs_and_exceptions { my ($left, $comp, $right) = @_; if (defined $exceptions{$left}) { foreach my $rval (@{$exceptions{$left}}) { $left = $right if ($rval eq $right); } } if ($opt_a){ $left =~ s/\.?$opt_a$//; $left =~ s/\.?$main_domain$//; $right =~ s/\.?$opt_a$//; $right =~ s/\.?$main_domain$//; } return (eval ("\"$left\" $comp \"$right\"") ); } sub xcheck_a2ptr { my( $a_rr, $domain, $class, $nsl ) = @_; my $res = new Net::DNS::Resolver; $res->defnames( 0 ); $res->retry( 2 ); $res->nameservers( @$nsl ); assert( $class eq $a_rr->class ); assert( 'A' eq $a_rr->type ); # Request a PTR RR against the A RR. # A missing PTR RR is an error. # my $ans = $res->query( $a_rr->address, 'PTR', $class ); if( defined( $ans )) { my $ptr_rr; foreach $ptr_rr ( $ans->answer ) { $ptr_rr->print if( $opt_v ); assert( $class eq $ptr_rr->class ); assert( 'PTR' eq $ptr_rr->type ); warn( "\t'", $a_rr->name, "' has address '", $a_rr->address, "' but PTR is '", $ptr_rr->ptrdname, "'\n" ) if( check_w_equivs_and_exceptions($a_rr->name, "ne", $ptr_rr->ptrdname) ); warn( "\t'", $a_rr->name, "' has address '", $a_rr->address, "' but PTR is '", ip_ptr2a_str( $ptr_rr->name ), "'\n" ) if( $a_rr->address ne ip_ptr2a_str( $ptr_rr->name )); } } else { warn( "\tNO PTR RR for '", $a_rr->name, "' at address '", $a_rr->address,"'\n" ); } } sub xcheck_ptr2a { my( $ptr_rr, $domain, $class, $nsl ) = @_; my $res = new Net::DNS::Resolver; $res->defnames( 0 ); $res->retry( 2 ); $res->nameservers( @$nsl ); assert( $class eq $ptr_rr->class ); assert( 'PTR' eq $ptr_rr->type ); # Request an A RR against the PTR RR. # A missing A RR is an error. # my $ans = $res->query( $ptr_rr->ptrdname, 'A', $class ); if( defined( $ans )) { my $a_rr; foreach $a_rr ( $ans->answer ) { $a_rr->print if( $opt_v ); assert( $class eq $a_rr->class ); assert( 'A' eq $a_rr->type ); warn( "\tPTR RR '", $ptr_rr->name, "' has name '", $ptr_rr->ptrdname, "' but A query returned '", $a_rr->name, "'\n" ) if( check_w_equivs_and_exceptions($ptr_rr->ptrdname, "ne", $a_rr->name) ); warn( "\tPTR RR '", $ptr_rr->name, "' has address '", ip_ptr2a_str( $ptr_rr->name ), "' but A query returned '", $a_rr->address, "'\n" ) if( ip_ptr2a_str( $ptr_rr->name ) ne $a_rr->address ); } } else { warn( "\tNO A RR for '", $ptr_rr->ptrdname, "' at address '", ip_ptr2a_str( $ptr_rr->address ), "'\n" ); } } sub xcheck_name { my( $name, $domain, $class, $nsl ) = @_; my $res = new Net::DNS::Resolver; $res->defnames( 0 ); $res->retry( 2 ); $res->nameservers( @$nsl ); # Get the A RR for the name. # my $ans = $res->query( $name, 'A', $class ); if( defined( $ans )) { # There is one or more A RRs. # For each A RR do a reverse look-up # and verify the PTR matches the A. # my $a_rr; foreach $a_rr ( $ans->answer ) { $a_rr->print if( $opt_v ); assert( $class eq $a_rr->class ); assert( 'A' eq $a_rr->type ); warn( "\tQuery for '$name' returned A RR name '", $a_rr->name, "'\n" ) if( check_w_equivs_and_exceptions($name, "ne", $a_rr->name) ); xcheck_a2ptr( $a_rr, $domain, $class, $nsl ); } } else { warn( "\t", $name, " has no A RR\n" ); } } sub types4name { my( $name, $domain, $class, $nsl ) = @_; my $res = new Net::DNS::Resolver; my @rr_types; $res->defnames( 0 ); $res->retry( 2 ); $res->nameservers( @$nsl ); # Get the RRs for the name. # my $ans = $res->query( $name, 'ANY', $class ); if( defined( $ans )) { my $any_rr; foreach $any_rr ( $ans->answer ) { $any_rr->print if( $opt_v ); assert( $class eq $any_rr->class ); push @rr_types, ( $any_rr->type ); } } else { warn( "\t'", $name, "' doesn't resolve.\n" ); } # If there were no RRs for the name then # return the RR types of ??? # push @rr_types, ( '???' ) if( ! @rr_types ); return @rr_types; } sub ip_ptr2a_str { my( $d, $c, $b, $a ) = ip_parts( $_[0]); return "$a.$b.$c.$d"; } sub ip_parts { my $ip = $_[0]; assert( $ip ne '' ); if( $ip =~ /(\d+)\.(\d+)\.(\d+)\.(\d+)/oi ) { return ( $1, $2, $3, $4 ); } else { warn "Unable to parse '$ip'\n"; } assert( 0 ); } Net-DNS-0.68/contrib/loclist.pl0000755000175000017500000000611711710626412015641 0ustar willemwillem#!/usr/bin/perl # loclist.pl -- check a list of hostnames for LOC records # -v -- verbose output (include NO results). used to be the default # -n -- try looking for network LOC records as well (slower) # -r -- try doing reverse-resolution on IP-appearing hosts # -d -- debugging output # egrep 'loc2earth.*host' /serv/www/logs/wn.log | # perl -pe 's/^.*host=//; s/([a-zA-Z0-9.-]+).*/$1/' | # sort -u | ~/loclist.pl > loc.sites use Net::DNS '0.08'; use Getopt::Std; getopts('vnrd'); $res = new Net::DNS::Resolver; line: foreach $_ (<>) { chomp; $foundloc = $namefound = 0; next line if m/^$/; next line if m/[^\w.-\/+_]/; # /, +, _ not actually valid in hostnames print STDERR "$_ DEBUG looking up...\n" if $opt_d; if (m/^\d+\.\d+\.\d+\.\d+$/) { if ($opt_r) { $query = $res->query($_); if (defined ($query)) { foreach $ans ($query->answer) { if ($ans->type eq "PTR") { $_ = $ans->ptrdname; $namefound++; } } } } next line unless $namefound; } $query = $res->query($_,"LOC"); if (defined ($query)) { # then we got an answer of some sort foreach $ans ($query->answer) { if ($ans->type eq "LOC") { print "$_ YES ",$ans->rdatastr,"\n"; $foundloc++; } } } if ($opt_n && !$foundloc) { # try the RFC 1101 search bit @addrs = @netnames = (); $query = $res->query($_,"A"); if (defined ($query)) { foreach $ans ($query->answer) { if ($ans->type eq "A") { push(@addrs,$ans->address); } } } if (@addrs) { checkaddrs: foreach $ipstr (@addrs) { $ipnum = unpack("N",pack("CCCC",split(/\./,$ipstr,4))); ($ip1) = split(/\./,$ipstr); if ($ip1 >= 224) { # class D/E, treat as host addr $mask = 0xFFFFFFFF; } elsif ($ip1 >= 192) { # "class C" $mask = 0xFFFFFF00; } elsif ($ip1 >= 128) { # "class B" $mask = 0xFFFF0000; } else { # class A $mask = 0xFF000000; } $oldmask = 0; while ($oldmask != $mask) { $oldmask = $mask; $querystr = join(".", reverse (unpack("CCCC",pack("N",$ipnum & $mask)))) . ".in-addr.arpa"; $query = $res->query($querystr,"PTR"); if (defined ($query)) { foreach $ans ($query->answer) { if ($ans->type eq "PTR") { # we want the list in LIFO order unshift(@netnames,$ans->ptrdname); } } $query = $res->query($querystr,"A"); if (defined ($query)) { foreach $ans ($query->answer) { if ($ans->type eq "A") { $mask = unpack("L",pack("CCCC", split(/\./,$ans->address,4))); } } } } } if (@netnames) { foreach $network (@netnames) { $query = $res->query($network,"LOC"); if (defined ($query)) { foreach $ans ($query->answer) { if ($ans->type eq "LOC") { print "$_ YES ",$ans->rdatastr,"\n"; $foundloc++; last checkaddrs; } elsif ($ans->type eq "CNAME") { # XXX should follow CNAME chains here } } } } } } } } if ($opt_v && !$foundloc) { print "$_ NO\n"; } } Net-DNS-0.68/contrib/README0000644000175000017500000000111511710626412014501 0ustar willemwillemThis directory contains contributed scripts and modules that use Net::DNS. The Net::DNS author assumes no responsibility for them -- if you have problems or questions, please contact the contributor. File Contributor ------ ----------- check_soa Dick Franks check_zone Dennis Glatting dnswalk Dave Barr loc2earth.fcgi Christopher Davis loclist.pl Christopher Davis --- $Id: README 607 2006-09-17 18:20:28Z olaf $ Net-DNS-0.68/contrib/check_soa0000755000175000017500000004011611710626412015472 0ustar willemwillem#!/usr/bin/perl $VERSION = (qw$LastChangedRevision: 912 $)[1] || 0.34; =head1 NAME check_soa - Check nameservers for a domain =head1 SYNOPSIS check_soa [-d] [-n] [-t] [-v] domain [nameserver] =head1 DESCRIPTION B builds a list of nameservers for the zone which contains the specified domain name. The program queries each nameserver for the relevant SOA record and reports the zone serial number. Error reports are generated for nameservers which reply with incorrect, non-authoritative or outdated information. =over 8 =item I Fully qualified domain name to be tested. Domains within ip6.arpa or in-addr.arpa namespaces may be specified using the appropriate IP address or prefix notation. =item I Optional name or list of IP addresses of specific nameserver to be tested. Addresses are used in the sequence they appear in the argument list. =back SOA query packets are sent to the nameservers as rapidly as the underlying hardware will allow. The program waits for a response only when it is needed for analysis. Execution time is determined by the slowest nameserver. This perldoc(1) documentation page is displayed if the I argument is omitted. The program is based on the B idea described by Albitz and Liu. =head1 OPTIONS =over 8 =item B<-d> Turn on resolver diagnostics. =item B<-n> Report negative cache TTL. =item B<-t> Ignore UDP datagram truncation. =item B<-v> Verbose output including address records for each nameserver. =back =head1 EXAMPLES =over 8 =item check_soa example.com Query all nameservers for the specified domain. =item check_soa 192.0.2.1 Query nameservers for the corresponding in-addr.arpa subdomain. =item check_soa 2001:DB8::8:800:200C:417A Query nameservers for the corresponding ip6.arpa subdomain. =item check_soa 2001:DB8:0:CD30::/60 As above, for IPv6 address prefix of specified length. =item check_soa 192.0.2.1 z.arin.net Query specific nameserver as above. =back =head1 BUGS The program can become confused by zones which originate, or appear to originate, from more than one primary server. The timeout code uses the perl 4 argument select() function. This is not guaranteed to work in non-Unix environments. =head1 COPYRIGHT (c) 2003-2011 Dick Franks Erwfranks[...]acm.orgE All rights reserved. This program is free software; you may use or redistribute it under the same terms as Perl itself. =head1 SEE ALSO Paul Albitz, Cricket Liu. DNS and BIND, 5th Edition. O'Reilly, 2006. Andrews, M., Locally Served DNS Zones, RFC6303, IETF, 2011. Andrews, M., Negative Caching of DNS Queries, RFC2308, IETF Network Working Group, 1998. Elz, R., Bush, R., Clarifications to the DNS Specification, RFC2181, IETF Network Working Group, 1997. Mockapetris, P., Domain Names - Implementation and Specification, RFC 1035, USC/ISI, 1987. Larry Wall, Tom Christiansen, Jon Orwant. Programming Perl, 3rd Edition. O'Reilly, 2000. =cut use strict; my $self = $0; # script my $options = 'dntv'; # options my %option; eval { require Getopt::Std; Getopt::Std::getopts( $options, \%option ) }; warn "Can't locate Getopt::Std\n" if $@; my @arg = qw( domain [nameserver] ); # arguments my ( $domain, @nameserver ) = @ARGV; my @flag = map {"[-$_]"} split( //, $options ); # documentation die eval { system("perldoc -F $self"); "" }, < ( $option{d} || 0 ), # -d enable diagnostics igntc => ( $option{t} || 0 ) # -t ignore truncation ); my $negtest = $option{n}; # -n report NCACHE TTL my $verbose = $option{v}; # -v verbose my $neg_min = 300; # NCACHE TTL reporting threshold my $neg_max = 86400; # NCACHE TTL reporting threshold my $udp_timeout = 5; # timeout for concurrent queries my $udp_wait = 0.020; # minimum polling interval my $resolver = new Net::DNS::Resolver(@conf); # create resolver object $resolver->nameservers(@nameserver) or die $resolver->string; my ($question) = new Net::DNS::Packet($domain)->question; # invert IP address/prefix my $name = lc $question->qname; my $NetDNSrev = &Net::DNS::version; die "\tFeature not supported by Net::DNS $NetDNSrev\n" if $name =~ m#[:/\s]|\.\d+$#; my @ns = NS($name); # find NS serving name unless (@ns) { displayRR( $name, 'ANY' ); # show any RR for name displayRR( $name, 'NS' ); # show failed NS query die $resolver->string; # game over } my ($zone) = map { $_->name } @ns; # extract zone name my @nsname = grep { $_ ne $zone } map { $_->nsdname } @ns; # extract server names from NS records my @server = @nameserver ? (@nameserver) : ( sort @nsname ); my @soa = displayRR( $zone, 'SOA' ); foreach my $soa (@soa) { # simple sanity check my $owner = lc $soa->name; # zone name my $mname = lc $soa->mname; # primary server my $rname = lc $soa->rname; # responsible person my $resolved; # check MNAME resolvable foreach my $rrtype (qw( A AAAA )) { my $probe = $resolver->send( $mname, $rrtype ); last if ( $resolved = scalar $probe->answer ); } for ($mname) { # locally served zone insanity last unless $_ eq $owner; # RFC6303 displayRR( $zone, 'NS' ) unless @nameserver; # ensure NS always listed displayRR( $zone, 'ANY' ) unless $_ eq $name; # ensure other RRs listed last unless /(in-addr|ip6)\.arpa/i; report('unexpected address record in locally served zone [RFC6303]') if $resolved; } last unless @nsname; # suppress remaining tests report( 'unresolved MNAME', $mname ) unless $resolved; unless ( $rname =~ /(@|[^\\]\.)([^@]+)$/ ) { # parse RNAME report( 'incomplete RNAME', $rname ) unless $rname eq '<>'; } elsif ( $2 ne $mname ) { my $resolved; # check RNAME resolvable foreach my $rrtype (qw( MX A AAAA CNAME )) { my $probe = $resolver->send( $2, $rrtype ); last if ( $resolved = scalar $probe->answer ); } report( 'unresolved RNAME', $rname ) unless $resolved; } unless ( $soa->expire > $soa->refresh ) { # check refresh/retry timing report('slave expires zone data before scheduled refresh'); } else { my $window = $soa->expire - $soa->refresh - 1; # zone transfer window my $retry = $soa->retry || 1; # retry interval my $n = 1 + int( $window / $retry ); # number of transfer attempts my $s = $n > 1 ? 's' : ''; report("slave expires zone data after $n transfer failure$s") unless $n > 3; } my ($min) = sort { $a <=> $b } ( $soa->minimum, $soa->ttl ); # force NCACHE test for extreme TTLs $negtest++ if $min < $neg_min or $soa->minimum > $neg_max; } my @ncache = NCACHE($zone) if $negtest; # report observed NCACHE TTL displayRR( $name, 'ANY' ) if @soa; # show RR for user-specified name displayRR( $zone, 'NS' ) if @nameserver; # show NS if testing specific nameserver print "----\n"; my ( $bad, $seq, $iphash ) = checkNS( $zone, @server ); # report status print "\n"; my $s = $bad != 1 ? 's' : ''; print "Unsatisfactory response from $bad nameserver$s\n\n" if $bad and @server > 1; my %mname = reverse %$iphash; # invert address hash my $mcount = keys %mname; # number of distinct MNAMEs if ( $mcount > 1 ) { report("unable to identify unique primary nameserver"); # RFC1034, 4.3.5 foreach ( sort keys %mname ) { report( '', $_, $mname{$_} ? '' : "\tserial\t$seq" ) } } exit; sub checkNS0 { ## initial status vector for checkNS my $serial = 0; my $hash = {}; my $res = new Net::DNS::Resolver(@conf); foreach my $soa ( @soa, @ncache ) { my $mname = lc $soa->mname; # populate hash with name/IP of primary foreach my $id ( $mname, $res->nameservers($mname) ) { $hash->{$id} = $mname; } $serial = $soa->serial; } return ( 0, $serial, $hash ); } sub checkNS { ## query nameservers (concurrently) and report status my $zone = shift; my $index = @_; # index last element my $element = pop @_ or return checkNS0; # pop element, terminate if undef my ( $ns, $if ) = split / /, lc $element; # name + optional interface IP my $res = new Net::DNS::Resolver(@conf); # use clean resolver for each test my @xip = sort $res->nameservers( $if || $ns ); # point at nameserver @xip = $res->nameservers("$ns.") unless @xip; # retry as absolute name (eg. localhost.) my $ip = pop @xip; # last (or only) interface $res->nameservers($ip) if @xip; $res->recurse(0); # send non-recursive query to nameserver my ( $socket, $sent ) = ( $res->bgsend( $zone, 'SOA' ), time ) if $ip; my ( $fail, $latest, $hash ) = checkNS( $zone, @_ ); # recurse to query others concurrently # pick up response as recursion unwinds my $packet; if ($socket) { until ( $res->bgisready($socket) ) { # timed wait on socket last if time > ( $sent + $udp_timeout ); delay($udp_wait); # snatch a few milliseconds sleep } $packet = $res->bgread($socket) if $res->bgisready($socket); # get response } elsif ($ip) { $packet = $res->send( $zone, 'SOA' ); # use sequential query model } my @pass = ( $fail, $latest, $hash ); # use prebuilt return values my @fail = ( $fail + 1, $latest, $hash ); my %nsaddr = ( $ip => 1 ) if $ip; # special handling for multihomed server foreach my $xip (@xip) { # iterate over remaining interfaces next if $nsaddr{$xip}++; # silently ignore duplicate address record my ( $f, $x, $h ) = checkNS( $zone, (undef) x @_, "$ns $xip" ); %$hash = ( %$hash, %$h ); # merge address hashes @pass = @fail if $f; # propagate failure to caller } my $rcode; my @soa; unless ($packet) { # ... is no more! It has ceased to be! $rcode = 'no response'; } elsif ( $packet->header->rcode ne 'NOERROR' ) { $rcode = $packet->header->rcode; # NXDOMAIN or fault at nameserver } else { @soa = grep { $_->type eq 'SOA' } $packet->answer; foreach my $soa (@soa) { my $mname = lc $soa->mname; # hash MNAME by IP my @ip = $res->nameservers($mname) unless $hash->{$mname}; foreach ( $mname, @ip ) { $hash->{$_} = $mname } } } my $primary = $hash->{$ip || $ns} ? '*' : ''; # flag zone primary unless ($ip) { # identify nameserver print "\n[$index]$primary\t$ns\n"; # name only $rcode = 'unresolved server name'; } elsif ( $ns eq $ip ) { print "\n[$index]$primary\t$ip\n"; # ip only } else { print "\n[$index]$primary\t$ns ($ip)\n"; # name and ip } if ($verbose) { # show PTR record my @ptr = grep { $_->type eq 'PTR' } displayRR($ip) if $ip; my @fwd = sort map { lc $_->ptrdname } @ptr; foreach my $name ( @fwd ? @fwd : ($ns) ) { # show address records displayRR( $name, 'A' ); displayRR( $name, 'AAAA' ); } } if ($rcode) { return @pass if $ns eq lc $zone; # local zone report($rcode); # abject failure return @fail; } my @result = @fail; # analyse response my @auth = $packet->authority unless @soa; my @ncache = grep { $_->type eq 'SOA' } @auth; my @refer = grep { $_->type eq 'NS' } @auth; if (@soa) { if ( @soa > 1 ) { report('multiple SOA records'); # RFC2181, 6.1 } elsif ( $packet->header->aa ) { @result = @pass; # RFC1034, 6.2.1(1) } else { my $ttl = $soa[0]->ttl; # RFC1034, 6.2.1(2) report( 'non-authoritative answer', ttl($ttl) ); } } elsif (@ncache) { my ($ttl) = map { $_->ttl } @soa = @ncache; # RFC2308, 2.2(1)(2) report( 'NODATA response', ttl($ttl) ); return @fail unless grep { $_->name =~ /^$zone$/i } @ncache; report('requested SOA in authority section; violates RFC2308'); } elsif (@refer) { my @n = grep { $_->nsdname =~ /$ns/i } @refer; # RFC2308, 2.2(4) report('authoritative data expired') if @n; # self referral report('not configured for zone') unless @n; return @fail; } else { report('NODATA response from nameserver'); # RFC2308, 2.2(3) return @fail; } report('truncated response from nameserver') if $packet->header->tc; my ($serial) = map { $_->serial } @soa; # check serial number if ( $primary && ordered( $serial, $latest ) ) { # primary should have latest data my $retest = $res->send( $zone, 'SOA' ); # retest before pointing finger ($serial) = map { $_->serial } $retest->answer if $retest; } print "\t\t\tzone serial\t", $serial, "\n"; if ( ordered( $serial, $latest ) ) { report('serial number not current'); return @fail unless $primary; report('discredited as unique primary nameserver'); $hash->{0} = ''; return @fail; } return @result if $serial == $latest; my $x = $if ? 0 : ( $index - 1 ) - $fail; # all previous out of date my $s = $x > 1 ? 's' : ''; # pedants really are revolting! report("at least $x previously unreported stale serial number$s") if $x; return ( $result[0] + $x, $serial, $hash ); # restate partial result } sub delay { ## short duration sleep my $duration = shift; # seconds sleep( 1 + $duration ) unless eval { defined select( undef, undef, undef, $duration ) }; } sub displayRR { ## print specified RRs or error code my $packet = $resolver->send(@_) or return (); # get specified RRs my $header = $packet->header; my $rcode = $header->rcode; # response code my ($question) = $packet->question; my $qtype = $question->qtype; my @answer = $packet->answer; my @authority = $packet->authority; my @ncache = grep { $_->type eq 'SOA' } @authority; # per RFC2308 my @workaround = @ncache if $qtype eq 'SOA'; # SOA misplaced/withheld? my @remark = qw(unexpected) if @workaround; $rcode = 'NODATA' if @ncache && $rcode eq 'NOERROR'; # no matching data at (non-empty) node foreach my $rr ( @answer, @workaround ) { # print RRs unless shown elsewhere next if $qtype eq 'ANY' && $rr->type =~ /^(SOA|NS)$/; for ( $rr->string ) { my $l = $verbose ? length($_) : 108; # abbreviate long RR my $name = $rr->name; print ";\t$name\n" unless /^$name/; # annotate IDN substr( $_, $l ) = ' ...' if length($_) > $l && $rr->type ne 'SOA'; print "$_\n"; } } report( @remark, "$rcode:", $question->string ) if $rcode ne 'NOERROR'; return @answer; } sub NCACHE { ## report observed NCACHE TTL for domain my $domain = shift || ''; my $seq = time; my $nxdomain = "_nx_$seq.$domain"; # intentionally perverse query my $reply = $resolver->send( $nxdomain, 'PTR' ) or return (); for ( $reply->answer ) { report( 'wildcard invalidates NCACHE test:', $_->string ); return (); } my @ncache = grep { $_->type eq 'SOA' } $reply->authority; for (@ncache) { report( 'negative cache data', ttl( $_->ttl ) ); } return @ncache; } sub NS { ## find NS records for domain my $domain = lc shift; my $packet = $resolver->send( $domain, 'NS' ) or die $resolver->string; my @answer = grep { $_->type eq 'NS' } $packet->answer; return @answer if @answer; if ( my ($ncache) = grep { $_->type eq 'SOA' } $packet->authority ) { my $apex = lc $ncache->name; return () unless $apex =~ /[^.]/; # protect root servers return NS($apex) if $apex ne $domain; } my @referral = grep { $_->type eq 'NS' } $packet->authority; return @referral if grep { $domain eq lc $_->name } @referral; my ( undef, $parent ) = split /\./, $domain, 2; return NS( $parent || return () ); } sub ordered { ## irreflexive 32-bit partial ordering use integer; my ( $a, $b ) = @_; return defined $b unless defined $a; # ( undef, any ) return 0 unless defined $b; # ( any, undef ) # unwise to assume 32-bit arithmetic, or that integer overflow goes unpunished if ( $a < 0 ) { # translate $a<0 region $a = ( $a ^ 0x80000000 ) & 0xFFFFFFFF; # 0 <= $a < 2**31 $b = ( $b ^ 0x80000000 ) & 0xFFFFFFFF; # -2**31 <= $b < 2**32 } return $a < $b ? ( $a > ( $b - 0x80000000 ) ) : ( $b < ( $a - 0x80000000 ) ); } sub report { ## concatenate strings into fault report print '### ', join( "\t", @_ ), "\n"; } sub ttl { ## human-friendly TTL my $t = shift; my ( $s, $m, $h, $y, $d ) = ( gmtime($t) )[0 .. 2, 5, 7]; unless ( $y == 70 ) { return sprintf 'TTL %u (%uy%ud)', $t, $y - 70, $d; } elsif ($h) { return sprintf 'TTL %u (%ud%0.2uh)', $t, $d, $h if $d; return sprintf 'TTL %u (%uh%0.2um)', $t, $h, $m if $m; return sprintf 'TTL %u (%uh)', $t, $h; } else { return sprintf 'TTL %u (%ud)', $t, $d if $d; return sprintf 'TTL %u (%um%0.2us)', $t, $m, $s if $s; return sprintf 'TTL %u (%um)', $t, $m; } } __END__ Net-DNS-0.68/TODO0000644000175000017500000000634611710626412012664 0ustar willemwillemTo Do list for Net::DNS ======================= ( While taking over Net::DNS maintenance I've also inhereted this TODO list. I have not yet "updated" the TODO list to reflect my feeling of priority with these items. Olaf March 2005 ) * Work on Resolver.pm: - Show more info about the query when $res->debug(1). - Work on a way to use the same socket for background queries. - Document $res->errorstring messages. - Work on efficiency of IO::Socket handling. - Implement AA ONLY queries. Here's a code fragment to set the nameserver list to the hosts returned in the authority section: $res->nameservers(map { $_->nsdname } grep { $_->type eq "NS" } $ans->authority); - Need more tests - Proper identification of the set of nameservers to query in Cygwin.pm and Win32.pm. Using the registy is highly unreliable. Also see rt.cpan.org ticket 11931. * Get rid of .* in AAAA.pm; write more tests for AAAA.pm. * Allow Net::DNS::RR::LOC->latlon to set the lat/lon. * Work on the dynamic update code. Some things remaining to do: - Append the default zone in update packets if the name doesn't contain a dot. Does this break people's code? - Do sanity checking on user-created RR objects. Update the BUGS section in RR.pm when this is complete. - Allow yxrrset & friends to take an RR object as an argument. - Do more sanity checking on yxrrset & friends. - Add an "update" method to the resolver class to send the update packet to the zone's authoritative nameservers (see also RFC 2136, Section 4). * Improve the error handling and reporting. Some things to do: - Make sure empty RDATA sections don't cause the program to print the obnoxious "no such method" warning. - Set a more descriptive error if a zone transfer fails, especially if the nameserver isn't authoritative (current code returns NOERROR if the nameserver answered but wasn't authoritative). - Consider documenting the use of "eval" to avoid a fatal error in certain places. Idea by Dirk Herr-Hoyman. * Restructure some of the code. Some things to look at: - Net::DNS::Resolver->send (needs to be broken into smaller pieces). * Add more RR types. Currently unimplemented are: MD RFC 1035 (obsolete) MF RFC 1035 (obsolete) WKS RFC 1035 NSAP_PTR RFC 1348 (deprecated) GPOS RFC 1712 (withdrawn) ATMA ??? * Check the EID, NIMLOC, and NULL RR handling. * Add test cases for NULL, EID, and NIMLOC to private zone data. NULL isn't allowed in master files per RFC 1035, Section 3.3.10; BIND 8.1-REL doesn't appear to implement EID or NIMLOC (perhaps via dynamic update?). * Write some front-end methods to do CNAME translations automagically. * Do more study of resolver behavior as recommended in RFCs 1035, 1123, and 2136. * Check code for conformance to the guidelines listed in The Perl 5 Module List. Check style & efficiency according to the perlstyle manpage and the Camel. * Consider rewriting the packet-parsing code in C for increased speed, or possibly going back to using Dave Shield's resparse library. * And a number of things listed on the request tracker rt.cpan.org. --- $Id: TODO 519 2005-12-07 12:30:16Z olaf $ Net-DNS-0.68/demo/0000755000175000017500000000000011711344242013106 5ustar willemwillemNet-DNS-0.68/demo/example_recurse.pl0000755000175000017500000000052311710626412016632 0ustar willemwillem#!/usr/local/bin/perl -w # Example usage for Net::DNS::Resolver::Recurse # Performs recursion for a query. use Net::DNS::Resolver::Recurse; my $res = Net::DNS::Resolver::Recurse->new; $res->debug(1); $res->hints("198.41.0.4"); # A.ROOT-SERVER.NET. my $packet = $res->query_dorecursion("www.rob.com.au.", "A"); $packet && $packet->print; Net-DNS-0.68/demo/check_zone0000755000175000017500000000662011710626412015151 0ustar willemwillem#!/usr/local/bin/perl -w # $Id: check_zone 264 2005-04-06 09:16:15Z olaf $ =head1 NAME check_zone - Check a DNS zone for errors =head1 SYNOPSIS C [ C<-r> ] I [ I ] =head1 DESCRIPTION Checks a DNS zone for errors. Current checks are: =over 4 =item * Checks that all A records have corresponding PTR records. =item * Checks that hosts listed in NS, MX, and CNAME records have A records. =back =head1 OPTIONS =over 4 =item C<-r> Perform a recursive check on subdomains. =back =head1 AUTHOR Michael Fuhr =head1 SEE ALSO L, L, L, L, L, L, L =cut use strict; use vars qw($opt_r); use Getopt::Std; use File::Basename; use IO::Socket; use Net::DNS; getopts("r"); die "Usage: ", basename($0), " [ -r ] domain [ class ]\n" unless (@ARGV >= 1) && (@ARGV <= 2); check_domain(@ARGV); exit; sub check_domain { my ($domain, $class) = @_; $class ||= "IN"; print "-" x 70, "\n"; print "$domain (class $class)\n"; print "\n"; my $res = Net::DNS::Resolver->new; $res->defnames(0); $res->retry(2); my $nspack = $res->query($domain, "NS", $class); unless (defined($nspack)) { warn "Couldn't find nameservers for $domain: ", $res->errorstring, "\n"; return; } print "nameservers (will request zone from first available):\n"; my $ns; foreach $ns (grep { $_->type eq "NS" } $nspack->answer) { print "\t", $ns->nsdname, "\n"; } print "\n"; $res->nameservers(map { $_->nsdname } grep { $_->type eq "NS" } $nspack->answer); my @zone = $res->axfr($domain, $class); unless (@zone) { warn "Zone transfer failed: ", $res->errorstring, "\n"; return; } print "checking PTR records\n"; check_ptr($domain, $class, @zone); print "\n"; print "checking NS records\n"; check_ns($domain, $class, @zone); print "\n"; print "checking MX records\n"; check_mx($domain, $class, @zone); print "\n"; print "checking CNAME records\n"; check_cname($domain, $class, @zone); print "\n"; if ($opt_r) { print "checking subdomains\n\n"; my %subdomains; foreach (grep { $_->type eq "NS" and $_->name ne $domain } @zone) { $subdomains{$_->name} = 1; } foreach (sort keys %subdomains) { check_domain($_, $class); } } } sub check_ptr { my ($domain, $class, @zone) = @_; my $res = Net::DNS::Resolver->new; my $rr; foreach $rr (grep { $_->type eq "A" } @zone) { my $host = $rr->name; my $addr = $rr->address; my $ans = $res->send($addr, "A", $class); print "\t$host ($addr) has no PTR record\n" if ($ans->header->ancount < 1); } } sub check_ns { my ($domain, $class, @zone) = @_; my $res = Net::DNS::Resolver->new; my $rr; foreach $rr (grep { $_->type eq "NS" } @zone) { my $ans = $res->send($rr->nsdname, "A", $class); print "\t", $rr->nsdname, " has no A record\n" if ($ans->header->ancount < 1); } } sub check_mx { my ($domain, $class, @zone) = @_; my $res = Net::DNS::Resolver->new; my $rr; foreach $rr (grep { $_->type eq "MX" } @zone) { my $ans = $res->send($rr->exchange, "A", $class); print "\t", $rr->exchange, " has no A record\n" if ($ans->header->ancount < 1); } } sub check_cname { my ($domain, $class, @zone) = @_; my $res = Net::DNS::Resolver->new; my $rr; foreach $rr (grep { $_->type eq "CNAME" } @zone) { my $ans = $res->send($rr->cname, "A", $class); print "\t", $rr->cname, " has no A record\n" if ($ans->header->ancount < 1); } } Net-DNS-0.68/demo/trace_dns.pl0000755000175000017500000000055111710626412015412 0ustar willemwillem#!/usr/local/bin/perl use strict; use warnings; use Net::DNS; use Net::DNS::Resolver::Recurse; my $res = Net::DNS::Resolver::Recurse->new; $res->recursion_callback(sub { my $packet = shift; $_->print for $packet->additional; printf(";; Received %d bytes from %s\n\n", $packet->answersize, $packet->answerfrom); }); $res->query_dorecursion(@ARGV); Net-DNS-0.68/demo/perldig0000755000175000017500000000235711710626412014472 0ustar willemwillem#!/usr/local/bin/perl -w # $Id: perldig 264 2005-04-06 09:16:15Z olaf $ =head1 NAME perldig - Perl script to perform DNS queries =head1 SYNOPSIS C [ C<@>I ] I [ I [ I ] ] =head1 DESCRIPTION Performs a DNS query on the given name. The record type and class can also be specified; if left blank they default to A and IN. =head1 AUTHOR Michael Fuhr =head1 SEE ALSO L, L, L, L, L, L, L =cut use strict; use File::Basename; use Net::DNS; my $res = Net::DNS::Resolver->new; if (@ARGV && ($ARGV[0] =~ /^@/)) { my $nameserver = shift; $nameserver =~ s/^@//; $res->nameservers($nameserver); } die "Usage: ", basename($0), " [ \@nameserver ] name [ type [ class ] ]\n" unless (@ARGV >= 1) && (@ARGV <= 3); my ($name, $type, $class) = @ARGV; $type ||= "A"; $class ||= "IN"; if (uc($type) eq "AXFR") { my @rrs = $res->axfr($name, $class); if (@rrs) { foreach my $rr (@rrs) { $rr->print; } } else { die "zone transfer failed: ", $res->errorstring, "\n"; } } else { my $answer = $res->send($name, $type, $class); if ($answer) { $answer->print; } else { die "query failed: ", $res->errorstring, "\n"; } } Net-DNS-0.68/demo/README0000644000175000017500000000166711710626412014001 0ustar willemwillemThis directory contains demonstration scripts for the Net::DNS module. To read the manual page for a particular program, run the command "perldoc program-name". axfr Performs a zone transfer and stores the zone in a file. If a zone file already exists, axfr reads the file instead of performing a zone transfer. Requires the Storable module (available on CPAN). check_soa Perl version of the check_soa program presented in _DNS and BIND_ by Paul Albitz & Cricket Liu. Also see the check_soa version in the Contrib directory which is an fires off the queries in parallel. check_zone Checks a zone for errors like missing PTR records. Can recurse into subdomains. See also a hacked version in contrib/check_zone. mresolv Performs multiple DNS queries in parallel. mx Prints a domain's MX records sorted by preference. perldig Performs DNS queries and print the results. --- $Id: README 607 2006-09-17 18:20:28Z olaf $ Net-DNS-0.68/demo/mresolv0000755000175000017500000000656211710626412014535 0ustar willemwillem#!/usr/local/bin/perl -w # $Id: mresolv 264 2005-04-06 09:16:15Z olaf $ =head1 NAME mresolv - Perform multiple DNS lookups in parallel =head1 SYNOPSIS B S<[ B<-d> ]> S<[ B<-n> I ]> S<[ B<-t> I ]> S<[ I... ]> =head1 DESCRIPTION B performs multiple DNS lookups in parallel. Names to query are read from the list of files given on the command line, or from the standard input. =head1 OPTIONS =over 4 =item B<-d> Turn on debugging output. =item B<-n> I Set the number of queries to have outstanding at any time. =item B<-t> I Set the timeout in seconds. If no replies are received for this amount of time, all outstanding queries will be flushed and new names will be read from the input stream. =back =head1 COPYRIGHT Copyright (c) 1997-2000 Michael Fuhr. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L, L, L, L, L =cut use Net::DNS; use IO::Select; use Getopt::Std; use strict; use vars qw($opt_d $opt_n $opt_t); $| = 1; $opt_n = 32; # number of requests to have outstanding at any time $opt_t = 15; # timeout (seconds) getopts("dn:t:"); my $res = Net::DNS::Resolver->new; my $sel = IO::Select->new; my $eof = 0; while (1) { my $name; my $sock; #---------------------------------------------------------------------- # Read names until we've filled our quota of outstanding requests. #---------------------------------------------------------------------- while (!$eof && $sel->count < $opt_n) { print "DEBUG: reading..." if defined $opt_d; $name = <>; unless ($name) { print "EOF.\n" if defined $opt_d; $eof = 1; last; } chomp $name; $sock = $res->bgsend($name); $sel->add($sock); print "name = $name, outstanding = ", $sel->count, "\n" if defined $opt_d; } #---------------------------------------------------------------------- # Wait for any replies. Remove any replies from the outstanding pool. #---------------------------------------------------------------------- my @ready; my $timed_out = 1; print "DEBUG: waiting for replies\n" if defined $opt_d; for (@ready = $sel->can_read($opt_t); @ready; @ready = $sel->can_read(0)) { $timed_out = 0; print "DEBUG: replies received: ", scalar @ready, "\n" if defined $opt_d; foreach $sock (@ready) { print "DEBUG: handling a reply\n" if defined $opt_d; $sel->remove($sock); my $ans = $res->bgread($sock); next unless $ans; my $rr; foreach $rr ($ans->answer) { $rr->print; } } } #---------------------------------------------------------------------- # If we timed out waiting for replies, remove all entries from the # outstanding pool. #---------------------------------------------------------------------- if ($timed_out) { print "DEBUG: timeout: clearing the outstanding pool.\n" if defined $opt_d; my $sock; foreach $sock ($sel->handles) { $sel->remove($sock); } } print "DEBUG: outstanding = ", $sel->count, ", eof = $eof\n" if defined $opt_d; #---------------------------------------------------------------------- # We're done if there are no outstanding queries and we've read EOF. #---------------------------------------------------------------------- last if ($sel->count == 0) && $eof; } Net-DNS-0.68/demo/mx0000755000175000017500000000136011710626412013461 0ustar willemwillem#!/usr/local/bin/perl -w # $Id: mx 264 2005-04-06 09:16:15Z olaf $ =head1 NAME mx - Print a domain's MX records =head1 SYNOPSIS C I =head1 DESCRIPTION C prints a domain's MX records, sorted by preference. =head1 AUTHOR Michael Fuhr =head1 SEE ALSO L, L, L, L, L, L, L =cut use strict; use File::Basename; use Net::DNS; die "Usage: ", basename($0), " domain\n" unless (@ARGV == 1); my $dname = $ARGV[0]; my $res = Net::DNS::Resolver->new; my @mx = mx($res, $dname); if (@mx) { foreach my $rr (@mx) { print $rr->preference, "\t", $rr->exchange, "\n"; } } else { print "Can't find MX hosts for $dname: ", $res->errorstring, "\n"; } Net-DNS-0.68/demo/check_soa0000755000175000017500000001016211710626412014754 0ustar willemwillem#!/usr/local/bin/perl -w # $Id: check_soa 264 2005-04-06 09:16:15Z olaf $ =head1 NAME check_soa - Check a domain's nameservers =head1 SYNOPSIS B I =head1 DESCRIPTION B queries each of a domain's nameservers for the Start of Authority (SOA) record and prints the serial number. Errors are printed for nameservers that couldn't be reached or didn't answer authoritatively. =head1 AUTHOR The original Bourne Shell and C versions were printed in I by Paul Albitz & Cricket Liu. This Perl version was written by Michael Fuhr . =head1 SEE ALSO L, L, L, L, L, L, L =cut use File::Basename; use Net::DNS; use strict; #------------------------------------------------------------------------------ # Get the domain from the command line. #------------------------------------------------------------------------------ die "Usage: ", basename($0), " domain\n" unless @ARGV == 1; my ($domain) = @ARGV; #------------------------------------------------------------------------------ # Find all the nameservers for the domain. #------------------------------------------------------------------------------ my $res = Net::DNS::Resolver->new(); $res->defnames(0); $res->retry(2); my $ns_req = $res->query($domain, "NS"); die "No nameservers found for $domain: ", $res->errorstring, "\n" unless defined($ns_req) and ($ns_req->header->ancount > 0); # Send out non-recursive queries $res->recurse(0); # Do not buffer standard out $| = 1; #------------------------------------------------------------------------------ # Check the SOA record on each nameserver. #------------------------------------------------------------------------------ foreach my $nsrr (grep {$_->type eq "NS" } $ns_req->answer) { #---------------------------------------------------------------------- # Set the resolver to query this nameserver. #---------------------------------------------------------------------- my $ns = $nsrr->nsdname; # In order to lookup the IP(s) of the nameserver, we need a Resolver # object that is set to our local, recursive nameserver. So we create # a new object just to do that. my $local_res = Net::DNS::Resolver->new(); my $a_req = $local_res->query($ns, 'A'); unless ($a_req) { warn "Can not find address for $ns: ", $res->errorstring, "\n"; next; } foreach my $ip (map { $_->address } grep { $_->type eq 'A' } $a_req->answer) { #---------------------------------------------------------------------- # Ask this IP. #---------------------------------------------------------------------- $res->nameservers($ip); print "$ns ($ip): "; #---------------------------------------------------------------------- # Get the SOA record. #---------------------------------------------------------------------- my $soa_req = $res->send($domain, 'SOA', 'IN'); unless (defined($soa_req)) { warn $res->errorstring, "\n"; next; } #---------------------------------------------------------------------- # Is this nameserver authoritative for the domain? #---------------------------------------------------------------------- unless ($soa_req->header->aa) { warn "isn't authoritative for $domain\n"; next; } #---------------------------------------------------------------------- # We should have received exactly one answer. #---------------------------------------------------------------------- unless ($soa_req->header->ancount == 1) { warn "expected 1 answer, got ", $soa_req->header->ancount, "\n"; next; } #---------------------------------------------------------------------- # Did we receive an SOA record? #---------------------------------------------------------------------- unless (($soa_req->answer)[0]->type eq "SOA") { warn "expected SOA, got ", ($soa_req->answer)[0]->type, "\n"; next; } #---------------------------------------------------------------------- # Print the serial number. #---------------------------------------------------------------------- print "has serial number ", ($soa_req->answer)[0]->serial, "\n"; } } 0; Net-DNS-0.68/demo/axfr0000755000175000017500000001062711710626412014003 0ustar willemwillem#!/usr/local/bin/perl -w # $Id: axfr 264 2005-04-06 09:16:15Z olaf $ use strict; use vars qw($opt_f $opt_q $opt_s $opt_D); use File::Basename; use Getopt::Std; use Net::DNS; use Storable; #------------------------------------------------------------------------------ # Read any command-line options and check syntax. #------------------------------------------------------------------------------ getopts("fqsD:"); die "Usage: ", basename($0), " [ -fqs ] [ -D directory ] [ \@nameserver ] zone\n" unless (@ARGV >= 1) && (@ARGV <= 2); #------------------------------------------------------------------------------ # Get the nameserver (if specified) and set up the zone transfer directory # hierarchy. #------------------------------------------------------------------------------ my $nameserver = ($ARGV[0] =~ /^@/) ? shift @ARGV : ""; $nameserver =~ s/^@//; my $zone = shift @ARGV; my $basedir = defined $opt_D ? $opt_D : $ENV{"HOME"} . "/.dns-zones"; my $zonedir = join("/", reverse(split(/\./, $zone))); my $zonefile = $basedir . "/" . $zonedir . "/axfr"; # Don't worry about the 0777 permissions here - the current umask setting # will be applied. unless (-d $basedir) { mkdir($basedir, 0777) or die "can't mkdir $basedir: $!\n"; } my $dir = $basedir; my $subdir; foreach $subdir (split(m#/#, $zonedir)) { $dir .= "/" . $subdir; unless (-d $dir) { mkdir($dir, 0777) or die "can't mkdir $dir: $!\n"; } } #------------------------------------------------------------------------------ # Get the zone. #------------------------------------------------------------------------------ my $res = Net::DNS::Resolver->new; $res->nameservers($nameserver) if $nameserver; my (@zone, $zoneref); if (-e $zonefile && !defined $opt_f) { $zoneref = retrieve($zonefile) || die "couldn't retrieve zone from $zonefile: $!\n"; #---------------------------------------------------------------------- # Check the SOA serial number if desired. #---------------------------------------------------------------------- if (defined $opt_s) { my($serial_file, $serial_zone); my $rr; foreach $rr (@$zoneref) { if ($rr->type eq "SOA") { $serial_file = $rr->serial; last; } } die "no SOA in $zonefile\n" unless defined $serial_file; my $soa = $res->query($zone, "SOA"); die "couldn't get SOA for $zone: ", $res->errorstring, "\n" unless defined $soa; foreach $rr ($soa->answer) { if ($rr->type eq "SOA") { $serial_zone = $rr->serial; last; } } if ($serial_zone != $serial_file) { $opt_f = 1; } } } else { $opt_f = 1; } if (defined $opt_f) { @zone = $res->axfr($zone); die "couldn't transfer zone: ", $res->errorstring, "\n" unless @zone; store \@zone, $zonefile or die "couldn't store zone to $zonefile: $!\n"; $zoneref = \@zone; } #------------------------------------------------------------------------------ # Print the records in the zone. #------------------------------------------------------------------------------ unless ($opt_q) { $_->print for @$zoneref } __END__ =head1 NAME axfr - Perform a DNS zone transfer =head1 SYNOPSIS B S<[ B<-fqs> ]> S<[ B<-D> I ]> S<[ B<@>I ]> I =head1 DESCRIPTION B performs a DNS zone transfer, prints each record to the standard output, and stores the zone to a file. If the zone has already been stored in a file, B will read the file instead of performing a zone transfer. Zones will be stored in a directory hierarchy. For example, the zone transfer for foo.bar.com will be stored in the file $HOME/.dns-zones/com/bar/foo/axfr. The directory can be changed with the B<-D> option. This programs requires that the Storable module be installed. =head1 OPTIONS =over 4 =item B<-f> Force a zone transfer, even if the zone has already been stored in a file. =item B<-q> Be quiet -- don't print the records from the zone. =item B<-s> Perform a zone transfer if the SOA serial number on the nameserver is different than the serial number in the zone file. =item B<-D> I Store zone files under I instead of the default directory (see L<"FILES">). =item B<@>I Query I instead of the default nameserver. =back =head1 FILES =over 4 =item B<$HOME/.dns-zones> Default directory for storing zone files. =back =head1 AUTHOR Michael Fuhr =head1 SEE ALSO L, L, L, L, L, L, L, L =cut Net-DNS-0.68/Makefile.PL0000644000175000017500000002077711710626412014152 0ustar willemwillem # $Id: Makefile.PL 957 2011-11-04 14:23:13Z willem $ -*-perl-*- use strict; $^W = 1; use ExtUtils::MakeMaker qw(WriteMakefile prompt); use IO::Socket (); use Config qw(%Config); use Getopt::Long qw(GetOptions); sub DEBUG { 0; } # An existing makefile can confuse the CC test. unlink('Makefile'); # clean up the online testing flag file. unlink("t/online.enabled"); unlink("t/online.disabled"); # clean up the IPv6 testing flag file. unlink("t/IPv6.enabled"); unlink("t/IPv6.disabled"); warn < \$use_xs, 'pm' => sub { warn qq/\n\tWARNING: Use of "--pm" is deprecated. Use "--noxs" instead.\n\n/; $use_xs = 0; }, 'online-tests!' => \$online_tests, 'non-fatal-online-tests' => sub { $online_tests = 2; }, 'IPv6-tests!' => \$IPv6_tests, 'help|?' => \$help, ); push @options, ( 'iphelper!' => \$iphelper ) if ( $^O eq 'cygwin' ); unless ( GetOptions(@options) ) { print "Error: Unrecognized option.\n"; print "Try perl Makefile.PL --help for more information\n"; exit 1; } if ($help) { print < 'Net::DNS', VERSION_FROM => 'lib/Net/DNS.pm', ABSTRACT => 'Perl DNS resolver module', AUTHOR => 'Olaf Kolkman ', LICENSE => 'perl', PREREQ_PM => { 'Test::More' => 0.18, 'IO::Socket' => 0, 'MIME::Base64' => 2.11, 'Digest::MD5' => 2.12, 'Digest::SHA' => 5.23, 'Digest::HMAC_MD5' => 1.00, }, XS => {}, C => [], clean => { FILES => 't/IPv6.enabled t/online.enabled t/online.nonfatal compile.* DNS.o DNS.c DNS.bs lib/Net/DNS/Resolver/Win32' }, ); if ( $^O eq 'MSWin32' || $^O eq "cygwin" && $iphelper ) { unless (eval { local $SIG{__WARN__} = sub { }; require WIN32::API; } ) { warn <{'enum'} = 1.0; # Dependency for Win32::IPHelper $Makefile{'PREREQ_PM'}->{'Win32::IPHelper'} = 0.07; $Makefile{'PREREQ_PM'}->{'Win32::API'} = 0.55; $Makefile{'PREREQ_PM'}->{'Win32::TieRegistry'} = 0; } # # Check if we have a C compiler unless ( defined $use_xs ) { if ( test_cc() ) { print "You have a working compiler.\n"; $use_xs = 1; $Makefile{'MYEXTLIB'} = 'netdns$(LIB_EXT)'; } else { $use_xs = 0; $Makefile{'MYEXTLIB'} = ''; print <new( PeerAddr => "www.google.com:80", Timeout => 10, ); unless ($s) { $online_tests = 0; print <t/online.enabled" ) || die "Can't touch ./t/online.enabled $!"; close(ENABLED) || die "Can't touch ./t/online.enabled $!"; if ( $online_tests == 2 ) { open( NONFATAL, ">t/online.nonfatal" ) || die "Can't touch ./t/online.nonfatal $!"; close(NONFATAL) || die "Can't touch ./t/online.nonfatal $!"; } } # # Test to see if IPv6 is available, unless IPv6 testing has been declined. # if ( !defined $IPv6_tests || $IPv6_tests == 1 ) { unless ( eval { require IO::Socket::INET6; IO::Socket::INET6->VERSION("2.01"); } ) { print <t/IPv6.enabled' ) || die "Can't touch ./t/IPv6.enabled $!"; close(ENABLED) || die "Can't touch ./t/IPv6.enabled $!"; } } WriteMakefile(%Makefile); sub test_cc { # # The perl/C checking voodoo is stolen from Graham Barr's # Scalar-List-Utils distribution. # print "Testing if you have a C compiler and the needed header files....\n"; unless ( open( F, ">compile.c" ) ) { warn "Cannot write compile.c, skipping test compilation and installing pure Perl version.\n"; return; } print F <<'EOF'; #include "netdns.h" int main() { return 0; } EOF close(F) or return; my $ret = system("$Config{'cc'} -c compile.c -o compile$Config{obj_ext}"); my $ar = exists $Config{'full_ar'} ? $Config{'full_ar'} : $Config{'ar'}; my $cr = ( $^O eq 'MSWin32' && $Config{'cc'} eq 'cl' ? '/OUT:' : 'cr ' ); # ar action $ret = system( "$ar $cr compile$Config{lib_ext} compile$Config{obj_ext}" ) unless $ret; foreach my $file ( glob('compile*') ) { unlink($file) || warn "Could not delete $file: $!\n"; } return ( $ret == 0 ); } package MY; use Config qw(%Config); sub postamble { my $cr = ( $^O eq 'MSWin32' && $Config{'cc'} eq 'cl' ? '/OUT:' : 'cr ' ); # ar action my $content = ' test_cover : pure_all cover -delete HARNESS_PERL_SWITCHES=-MDevel::Cover $(MAKE) test cover netdns$(LIB_EXT): netdns$(OBJ_EXT) $(FULL_AR) ' . $cr . '$@ netdns$(OBJ_EXT) $(RANLIB) $@ '; return $content; } sub MY::libscan { my $path = $_[1]; return '' if $path =~ /\B\.svn\b/; return '' if $^O eq 'cygwin' && !$iphelper && $path =~ /Resolver[^\w]Win32\.pm$/; return $path; } Net-DNS-0.68/META.yml0000664000175000017500000000124511711344242013437 0ustar willemwillem--- #YAML:1.0 name: Net-DNS version: 0.68 abstract: Perl DNS resolver module author: - Olaf Kolkman license: perl distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: Digest::HMAC_MD5: 1 Digest::MD5: 2.12 Digest::SHA: 5.23 IO::Socket: 0 MIME::Base64: 2.11 Test::More: 0.18 no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.56 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 Net-DNS-0.68/DNS.xs0000644000175000017500000000335011710626412013164 0ustar willemwillem/* * $Id: DNS.xs 639 2007-05-25 12:00:15Z olaf $ * * * Copyright (c) 2005 Olaf Kolkman * Copyright (c) 2002-2003 Chris Reinhardt. * * All rights reserved. This program is free software; you may redistribute * it and/or modify it under the same terms as Perl itself. * * */ #ifdef _HPUX_SOURCE #define _SYS_MAGIC_INCLUDED #endif #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "netdns.h" /* * int netdns_dn_expand( char *msg, char *eomorig, * char *comp_dn, char *exp_dn, * int length); * * * netdns_dn_expand * netdns_dn_expand() expands the compressed domain name given by the * pointer comp _dn into a full domain name. * * The compressed name is contained in * a query or reply message; msg is a pointer to the beginning * of that message. Expanded names are stored in the buffer * referenced by the exp_dn buffer of size length , which should * be large enough to hold the expanded result. * * netdns_dn_expand() returns the size of the compressed name, or -1 * if there was an error. */ MODULE = Net::DNS PACKAGE = Net::DNS::Packet PROTOTYPES: DISABLE void dn_expand_XS(sv_buf, offset) SV * sv_buf int offset PPCODE: STRLEN len; u_char * buf; u_char name[MAXDNAME]; int pos; if (SvROK(sv_buf)) sv_buf = SvRV(sv_buf); buf = (u_char *) SvPV(sv_buf, len); /* This is where we do the actual uncompressing magic. */ pos = netdns_dn_expand(buf, buf+len , buf+offset, &name[0], MAXDNAME); EXTEND(SP, 2); if (pos < 0) { PUSHs(sv_2mortal(newSVsv(&PL_sv_undef))); PUSHs(sv_2mortal(newSVsv(&PL_sv_undef))); } else { PUSHs(sv_2mortal(newSVpv((const char *)name, 0))); PUSHs(sv_2mortal(newSViv(pos + offset))); } XSRETURN(2); Net-DNS-0.68/MANIFEST0000644000175000017500000000434711710461502013321 0ustar willemwillemChanges contrib/check_soa contrib/check_zone contrib/dnswalk.README contrib/loc2earth.fcgi contrib/loclist.pl contrib/README demo/axfr demo/check_soa demo/check_zone demo/example_recurse.pl demo/mresolv demo/mx demo/perldig demo/README demo/trace_dns.pl DNS.xs lib/Net/DNS.pm lib/Net/DNS/Domain.pm lib/Net/DNS/DomainName.pm lib/Net/DNS/FAQ.pod lib/Net/DNS/Header.pm lib/Net/DNS/Mailbox.pm lib/Net/DNS/Nameserver.pm lib/Net/DNS/Packet.pm lib/Net/DNS/Question.pm lib/Net/DNS/Resolver.pm lib/Net/DNS/Resolver/Base.pm lib/Net/DNS/Resolver/Cygwin.pm lib/Net/DNS/Resolver/Recurse.pm lib/Net/DNS/Resolver/UNIX.pm lib/Net/DNS/Resolver/Win32.pm lib/Net/DNS/RR.pm lib/Net/DNS/RR/A.pm lib/Net/DNS/RR/AAAA.pm lib/Net/DNS/RR/APL.pm lib/Net/DNS/RR/APL/ApItem.pm lib/Net/DNS/RR/AFSDB.pm lib/Net/DNS/RR/CERT.pm lib/Net/DNS/RR/CNAME.pm lib/Net/DNS/RR/DHCID.pm lib/Net/DNS/RR/DNAME.pm lib/Net/DNS/RR/EID.pm lib/Net/DNS/RR/HINFO.pm lib/Net/DNS/RR/HIP.pm lib/Net/DNS/RR/IPSECKEY.pm lib/Net/DNS/RR/ISDN.pm lib/Net/DNS/RR/KX.pm lib/Net/DNS/RR/LOC.pm lib/Net/DNS/RR/MB.pm lib/Net/DNS/RR/MG.pm lib/Net/DNS/RR/MINFO.pm lib/Net/DNS/RR/MR.pm lib/Net/DNS/RR/MX.pm lib/Net/DNS/RR/NAPTR.pm lib/Net/DNS/RR/NIMLOC.pm lib/Net/DNS/RR/NS.pm lib/Net/DNS/RR/NSAP.pm lib/Net/DNS/RR/NULL.pm lib/Net/DNS/RR/OPT.pm lib/Net/DNS/RR/PTR.pm lib/Net/DNS/RR/PX.pm lib/Net/DNS/RR/RP.pm lib/Net/DNS/RR/RT.pm lib/Net/DNS/RR/SOA.pm lib/Net/DNS/RR/SPF.pm lib/Net/DNS/RR/SRV.pm lib/Net/DNS/RR/SSHFP.pm lib/Net/DNS/RR/TKEY.pm lib/Net/DNS/RR/TSIG.pm lib/Net/DNS/RR/TXT.pm lib/Net/DNS/RR/Unknown.pm lib/Net/DNS/RR/X25.pm lib/Net/DNS/Text.pm lib/Net/DNS/Update.pm Makefile.PL MANIFEST This list of files META.yml netdns.c netdns.h README t/.resolv.conf t/00-load.t t/00-pod.t t/00-version.t t/01-resolver-env.t t/01-resolver-file.t t/01-resolver-flags.t t/01-resolver-opt.t t/01-resolver.t t/02-domain.t t/02-domainname.t t/02-mailbox.t t/02-text.t t/03-header.t t/03-question.t t/04-packet.t t/05-apl.t t/05-rr-opt.t t/05-rr-rrsort.t t/05-rr-sshfp.t t/05-rr-txt.t t/05-rr-unknown.t t/05-rr.t t/05-rr-various.t t/06-packet-unique-push.t t/06-update.t t/07-misc.t t/08-online.t t/09-tkey.t t/10-recurse.t t/11-escapedchars.t t/11-inet6.t t/12-compression.t t/13-udp-trunc.t t/99-cleanup.t t/NonFatal.pm t/TestData.pm t/custom.txt TODO Net-DNS-0.68/t/0000755000175000017500000000000011711344242012425 5ustar willemwillemNet-DNS-0.68/t/05-apl.t0000644000175000017500000000676311710626412013625 0ustar willemwillem# $Id: 05-apl.t 886 2011-05-20 08:10:20Z willem $ -*-perl-*- use Test::More tests => 18; use strict; use Data::Dumper; #### ## ## Some APL routines. use Net::DNS; use Net::DNS::RR::APL; foreach my $apitem ( qw( 1:192.168.32.0/21 !1:192.168.32.0/21 2:FF00:0:0:0:0:0:0:0/8) ) { my $object=Net::DNS::RR::APL::ApItem->new($apitem); is ( $object->string, $apitem, "String read/write correct for $apitem"); } foreach my $apitem ( qw( 1:192.168.32.0.3/21 !1:192.168.32.0+21 4:FF00:0:0:0:0:0:0:0/8) ) { my $object=Net::DNS::RR::APL::ApItem->new($apitem); diag ($object->string) unless( ok ( !defined ($object), "Incorrect format not parsed")); } my $UUencodedData=' 00 01 1a 03 c0 a8 2a 00 01 1a 04 c0 a8 2a 40 00 01 19 84 c0 a8 2a 80 00 01 04 01 e0 00 02 08 01 ff '; $UUencodedData =~ s/\s*//g; my $datadata = pack('H*',$UUencodedData); my $dummy; my ($apitem,$offset)=Net::DNS::RR::APL::ApItem->new_from_wire($datadata, 0); is(lc $apitem->string,lc "1:192.168.42.0/26","1:192.168.42.0/26 compares"); # diag(unpack("H*",$apitem->rdata)); ($apitem,$dummy)=Net::DNS::RR::APL::ApItem->new_from_wire($apitem->rdata(), 0); is(lc $apitem->string,lc "1:192.168.42.0/26","1:192.168.42.0/26 compares"); ($apitem,$offset)=Net::DNS::RR::APL::ApItem->new_from_wire($datadata, $offset); is(lc $apitem->string,lc "1:192.168.42.64/26","1:192.168.42.64/26 compares"); # diag(unpack("H*",$apitem->rdata)); ($apitem,$dummy)=Net::DNS::RR::APL::ApItem->new_from_wire($apitem->rdata(), 0); is(lc $apitem->string,lc "1:192.168.42.64/26","1:192.168.42.64/26 compares"); ($apitem,$offset)=Net::DNS::RR::APL::ApItem->new_from_wire($datadata, $offset); is(lc $apitem->string,lc "!1:192.168.42.128/25","1:192.168.42.128/25 compares"); # diag(unpack("H*",$apitem->rdata)); ($apitem,$dummy)=Net::DNS::RR::APL::ApItem->new_from_wire($apitem->rdata(), 0); is(lc $apitem->string,lc "!1:192.168.42.128/25","1:192.168.42.128/25 compares"); ($apitem,$offset)=Net::DNS::RR::APL::ApItem->new_from_wire($datadata, $offset); is(lc $apitem->string,lc "1:224.0.0.0/4","1:224.0.0.0/4 compares"); # diag(unpack("H*",$apitem->rdata)); ($apitem,$dummy)=Net::DNS::RR::APL::ApItem->new_from_wire($apitem->rdata(), 0); is(lc $apitem->string,lc "1:224.0.0.0/4","1:224.0.0.0/4 compares"); ($apitem,$offset)=Net::DNS::RR::APL::ApItem->new_from_wire($datadata, $offset); is(lc $apitem->string,lc "2:FF00:0:0:0:0:0:0:0/8","2:FF00:0:0:0:0:0:0:0/8 compares"); # diag(unpack("H*",$apitem->rdata)); ($apitem,$dummy)=Net::DNS::RR::APL::ApItem->new_from_wire($apitem->rdata(), 0); is(lc $apitem->string,lc "2:FF00:0:0:0:0:0:0:0/8","2:FF00:0:0:0:0:0:0:0/8 compares"); my $UUencodedPacket=' 35 0b 81 80 00 01 00 01 00 00 00 00 03 61 70 6c 07 6e 65 74 2d 64 6e 73 03 6f 72 67 00 00 2a 00 01 c0 0c 00 2a 00 01 00 00 00 64 00 21 00 01 1a 03 c0 a8 2a 00 01 1a 04 c0 a8 2a 40 00 01 19 04 c0 a8 2a 80 00 01 04 01 e0 00 02 08 01 ff '; $UUencodedPacket =~ s/\s*//g; my $packetdata = pack('H*',$UUencodedPacket); my $packet = Net::DNS::Packet->new(\$packetdata); is(($packet->answer)[0]->rdatastr,"1:192.168.42.0/26 1:192.168.42.64/26 1:192.168.42.128/25 1:224.0.0.0/4 2:ff00:0:0:0:0:0:0:0/8","Packet content parsed"); my $apl= Net::DNS::RR->new("foo.example. IN APL 1:192.168.32.0/21 !1:192.168.38.0/28"); is($apl->rdatastr,"1:192.168.32.0/21 !1:192.168.38.0/28", "String parsing of APL RR"); foreach my $ap ($apl->aplist()){ print $ap->negation()?"!":""; print $ap->address(); print $ap->prefix(). " "; } Net-DNS-0.68/t/custom.txt0000644000175000017500000000021611710626412014500 0ustar willemwillem# $Id: custom.txt 264 2005-04-06 09:16:15Z olaf $ domain t2.net-dns.org search alt.net-dns.org ext.net-dns.org nameserver 10.0.1.42 10.0.2.42 Net-DNS-0.68/t/03-header.t0000644000175000017500000000305011710626412014261 0ustar willemwillem# $Id: 03-header.t 967 2011-12-08 21:47:41Z willem $ use Test::More tests => 19; use strict; BEGIN { use_ok('Net::DNS'); } my $packet = new Net::DNS::Packet(qw(. NS IN)); my $header = $packet->header; ok($header, 'packet->header returned something'); $header->id(41); $header->qr(1); $header->opcode('QUERY'); $header->aa(1); $header->tc(0); $header->rd(1); $header->cd(0); $header->ra(1); $header->rcode("NOERROR"); is($header->id, 41, 'id() works'); is($header->qr, 1, 'qr() works'); is($header->opcode, 'QUERY', 'opcode() works'); is($header->aa, 1, 'aa() works'); is($header->tc, 0, 'tc() works'); is($header->rd, 1, 'rd() works'); is($header->cd, 0, 'cd() works'); is($header->ra, 1, 'ra() works'); is($header->rcode, 'NOERROR', 'rcode() works'); my $data = $packet->data; my $packet2 = new Net::DNS::Packet(\$data); my $header2 = $packet2->header; is_deeply($header, $header2, 'encode/decode transparent'); # # Is $header->string remotely sane? # like($header->string, '/opcode = QUERY/', 'string() has opcode correct'); like($header->string, '/qdcount = 1/', 'string() has qdcount correct'); like($header->string, '/ancount = 0/', 'string() has ancount correct'); # # Check that the aliases work properly. # $header->zocount(0); $header->prcount(1); $header->upcount(2); $header->adcount(3); is($header->qdcount, 0, 'zocount works'); is($header->ancount, 1, 'prcount works'); is($header->nscount, 2, 'upcount works'); is($header->arcount, 3, 'adcount works'); Net-DNS-0.68/t/01-resolver-env.t0000644000175000017500000000326611710626412015467 0ustar willemwillem# $Id: 01-resolver-env.t 737 2008-12-17 11:32:10Z olaf $ -*-perl-*- use Test::More tests => 17; use strict; BEGIN { local $ENV{'RES_NAMESERVERS'} = '10.0.1.128 10.0.2.128'; local $ENV{'RES_SEARCHLIST'} = 'net-dns.org lib.net-dns.org'; local $ENV{'LOCALDOMAIN'} = 't.net-dns.org'; local $ENV{'RES_OPTIONS'} = 'retrans:3 retry:2 debug'; use_ok('Net::DNS'); } my $res = Net::DNS::Resolver->new; ok($res, "new() returned something"); ok(scalar $res->nameservers, "nameservers() works"); my @servers = $res->nameservers; is($servers[0], '10.0.1.128', 'Nameserver set correctly'); is($servers[1], '10.0.2.128', 'Nameserver set correctly'); my @search = $res->searchlist; is($search[0], 'net-dns.org', 'Search set correctly' ); is($search[1], 'lib.net-dns.org', 'Search set correctly' ); is($res->domain, 't.net-dns.org', 'Local domain works' ); is($res->retrans, 3, 'Retransmit works' ); is($res->retry, 2, 'Retry works' ); ok($res->debug, 'Debug works' ); eval { $Net::DNS::DNSSEC=0; is ($res->cdflag(),0,"absence dnssec() sets cdflag to 0"); is ($res->adflag(),1,"absence of dnssec() sets adflag to 0"); local $SIG{__WARN__}=sub { ok ($_[0]=~/You called the Net::DNS::Resolver::dnssec\(\)/, "Correct warning in absense of Net::DNS::SEC") }; $res->dnssec(1); }; { $Net::DNS::DNSSEC=1; local $SIG{__WARN__}=sub { diag "We are ignoring that Net::DNS::SEC not installed." }; $res->dnssec(1); is ($res->udppacketsize(),2048,"dnssec() sets udppacketsize to 2048"); is ($res->cdflag(),0,"dnssec() sets cdflag to 0"); is ($res->adflag(),1,"dnssec() sets adflag to 1"); };Net-DNS-0.68/t/05-rr-opt.t0000644000175000017500000000121611710626412014260 0ustar willemwillem# $Id: 05-rr-opt.t 616 2006-10-18 09:15:48Z olaf $ -*-perl-*- use Test::More tests => 7; use strict; BEGIN { use_ok('Net::DNS'); } my $size=2048; my $ednsflags=0x9e22; my $optrr= Net::DNS::RR->new( Type => 'OPT', Name => '', Class => $size, # Decimal UDPpayload ednsflags => $ednsflags, # first bit set see RFC 3225 ); ok($optrr->do,"DO bit set"); is($optrr->clear_do,0x1e22,"Clearing do, leaving the other bits "); ok(!$optrr->do,"DO bit cleared"); is($optrr->set_do,0x9e22,"Clearing do, leaving the other bits "); is($optrr->size(),2048,"Size read"); is($optrr->size(1498),1498,"Size set"); Net-DNS-0.68/t/TestData.pm0000644000175000017500000001464511710626412014507 0ustar willemwillem# t::Testdata # Stores some information for t/05-rr.t which is useful for reuse in other test modules that are not distributed. # $Id$ require Exporter; @ISA = qw(Exporter ); use vars qw( @rrs @EXPORT ); @EXPORT= qw ( @rrs ); @_rrs=( { #[0] type => 'SOA', mname => 'soa-mname.example.com.', rname => 'soa-rname.example.com.', serial => 12345, refresh => 7200, retry => 3600, expire => 2592000, minimum => 86400, }, { #[6] type => 'HINFO', cpu => 'test-cpu', os => 'test-os', }, ); @rrs=( { #[0] type => 'SOA', mname => 'soa-mname.example.com.', rname => 'soa-rname.example.com.', serial => 12345, refresh => 7200, retry => 3600, expire => 2592000, minimum => 86400, }, { #[1] type => 'A', address => '10.0.0.1', }, { #[2] type => 'AAAA', address => '123:45:6:7:890a:bcd:ef:123', }, { #[3] type => 'AFSDB', subtype => 1, hostname => 'afsdb-hostname.example.com', }, { #[4] type => 'CNAME', cname => 'cname-cname.example.com.', }, { #[5] type => 'DNAME', dname => 'dname.example.com.', }, { #[6] type => 'HINFO', cpu => 'test-cpu', os => 'test-os', }, { #[7] type => 'ISDN', address => '987654321', sa => '001', }, { #[8] type => 'MB', madname => 'mb-madname.example.com.', }, { #[9] type => 'MG', mgmname => 'mg-mgmname.example.com.', }, { #[10] type => 'MINFO', rmailbx => 'minfo-rmailbx.example.com.', emailbx => 'minfo-emailbx.example.com.', }, { #[11] type => 'MR', newname => 'mr-newname.example.com.', }, { #[12] type => 'MX', preference => 10, exchange => 'mx-exchange.example.com.', }, { #[13] type => 'NAPTR', order => 100, preference => 10, flags => 'U', service => 'BLA+FOO', regexp => '!^.*$!mailto:information@example.com!i', replacement => 'naptr-rEplacement.example.com.', }, { #[14] type => 'NS', nsdname => 'ns-nsdname.example.com.', }, { #[15] type => 'NSAP', afi => '47', idi => '0005', dfi => '80', aa => '005a00', rd => '1000', area => '0020', id => '00800a123456', sel => '00', }, { #[16] type => 'PTR', ptrdname => 'ptr-ptrdname.example.com.', }, { #[17] type => 'PX', preference => 10, map822 => 'px-map822.example.com.', mapx400 => 'px-mapx400.example.com.', }, { #[18] type => 'RP', mbox => 'rp-mbox.example.com.', txtdname => 'rp-txtdname.example.com.', }, { #[19] type => 'RT', preference => 10, intermediate => 'rt-intermediate.example.com.', }, { #[20] type => 'SRV', priority => 1, weight => 2, port => 3, target => 'srv-target.example.com.', }, { #[21] type => 'TXT', txtdata => 'txt-txtdata', }, { #[22] type => 'X25', psdn => 123456789, }, { #[23] type => 'LOC', version => 0, size => 3000, horiz_pre => 500000, vert_pre => 500, latitude => 2001683648, longitude => 1856783648, altitude => 9997600, }, #[24] { type => 'CERT', 'format' => 3, tag => 1, algorithm => 1, certificate => '123456789abcdefghijklmnopqrstuvwxyz', }, { #[25] type => 'SPF', txtdata => 'txt-txtdata', }, # 38.2.0.192.in-addr.arpa. 7200 IN IPSECKEY ( 10 1 2 # 192.0.2.38 # AQNRU3mG7TVTO2BkR47usntb102uFJtugbo6BSGvgqt4AQ== ) { #[26] type => 'IPSECKEY', precedence => 10, algorithm => 2, gatetype => 1, gateway => '192.0.2.38', pubkey => "AQNRU3mG7TVTO2BkR47usntb102uFJtugbo6BSGvgqt4AQ==", }, { #[27] type => 'IPSECKEY', precedence => 10, algorithm => 2, gatetype => 0, gateway => '.', pubkey => "AQNRU3mG7TVTO2BkR47usntb102uFJtugbo6BSGvgqt4AQ==", }, { #[28] type => 'IPSECKEY', precedence => 10, algorithm => 1, gatetype => 2, gateway => '2001:db8:0:8002:0:2000:1:0', pubkey => "AQNRU3mG7TVTO2BkR47usntb102uFJtugbo6BSGvgqt4AQ==", }, { #[28] type => 'IPSECKEY', precedence => 10, algorithm => 2, gatetype => 3, gateway => 'gateway.example.com.', pubkey => "AQNRU3mG7TVTO2BkR47usntb102uFJtugbo6BSGvgqt4AQ==", }, { #[29] type => 'HIP', pkalgorithm => 2, hit => "200100107b1a74df365639cc39f1d578", pubkey => "AwEAAbdxyhNuSutc5EMzxTs9LBPCIkOFH8cIvM4p9+LrV4e19WzK00+CI6zBCQTdtWsuxKbWIy87UOoJTwkUs7lBu+Upr1gsNrut79ryra+bSRGQb1slImA8YVJyuIDsj7kwzG7jnERNqnWxZ48AWkskmdHaVDP4BcelrTI3rMXdXF5D", rendezvousservers => [ qw|example.net example.com| ], }, { #[30] type => 'DHCID', identifiertype => 2, digesttype => 1, digest => 'Y2/AuCccgoJbsaxcQc9TUapptP69lOjxfNuVAA2kjEA=', }, { #[31] type => 'KX', preference => 10, exchange => 'kx-exchange.example.com.', }, ); 1; Net-DNS-0.68/t/07-misc.t0000644000175000017500000001204411710626412013773 0ustar willemwillem# $Id: 07-misc.t 625 2007-01-24 14:35:58Z olaf $ -*-perl-*- use Test::More tests => 37; use strict; BEGIN { use_ok('Net::DNS'); } # test to make sure that wildcarding works. # my $rr; eval { $rr = Net::DNS::RR->new('*.t.net-dns.org 60 IN A 10.0.0.1'); }; ok($rr, 'RR got made'); is($rr->name, '*.t.net-dns.org', 'Name is correct' ); is($rr->ttl, 60, 'TTL is correct' ); is($rr->class, 'IN', 'CLASS is correct' ); is($rr->type, 'A', 'TYPE is correct' ); is($rr->address, '10.0.0.1', 'Address is correct'); # # Make sure the underscore in SRV hostnames work. # my $srv; eval { $srv = Net::DNS::RR->new('_rvp._tcp.t.net-dns.org. 60 IN SRV 0 0 80 im.bastardsinc.biz'); }; ok(!$@, 'No errors'); ok($srv, 'SRV got made'); # # Test that the 5.005 Use of uninitialized value at # /usr/local/lib/perl5/site_perl/5.005/Net/DNS/RR.pm line 639. bug is gone # my $warning = 0; { local $^W = 1; local $SIG{__WARN__} = sub { $warning++ }; my $rr = Net::DNS::RR->new('mx.t.net-dns.org 60 IN MX 10 a.t.net-dns.org'); ok($rr, 'RR created'); is($rr->preference, 10, 'Preference works'); } is($warning, 0, 'No evil warning'); { my $mx = Net::DNS::RR->new('mx.t.net-dns.org 60 IN MX 0 mail.net-dns.org'); like($mx->string, '/0 mail.net-dns.org/'); is($mx->preference, 0); is($mx->exchange, 'mail.net-dns.org'); } { my $srv = Net::DNS::RR->new('srv.t.net-dns.org 60 IN SRV 0 2 3 target.net-dns.org'); like($srv->string, '/0 2 3 target.net-dns.org\./'); is($srv->rdatastr, '0 2 3 target.net-dns.org.'); } # # # Below are some thests that have to do with TXT RRs # # #;; QUESTION SECTION: #;txt2.t.net-dns.org. IN TXT #;; ANSWER SECTION: #txt2.t.net-dns.org. 60 IN TXT "Net-DNS\; complicated $tuff" "sort of \" text\; and binary \000 data" #;; AUTHORITY SECTION: #net-dns.org. 3600 IN NS ns1.net-dns.org. #net-dns.org. 3600 IN NS ns.ripe.net. #net-dns.org. 3600 IN NS ns.hactrn.net. #;; ADDITIONAL SECTION: #ns1.net-dns.org. 3600 IN A 193.0.4.49 #ns1.net-dns.org. 3600 IN AAAA my $UUencodedPacket=' 11 99 85 00 00 01 00 01 00 03 00 02 04 74 78 74 32 01 74 07 6e 65 74 2d 64 6e 73 03 6f 72 67 00 00 10 00 01 c0 0c 00 10 00 01 00 00 00 3c 00 3d 1a 4e 65 74 2d 44 4e 53 3b 20 63 6f 6d 70 6c 69 63 61 74 65 64 20 24 74 75 66 66 21 73 6f 72 74 20 6f 66 20 22 20 74 65 78 74 3b 20 61 6e 64 20 62 69 6e 61 72 79 20 00 20 64 61 74 61 c0 13 00 02 00 01 00 00 0e 10 00 06 03 6e 73 31 c0 13 c0 13 00 02 00 01 00 00 0e 10 00 0d 02 6e 73 04 72 69 70 65 03 6e 65 74 00 c0 13 00 02 00 01 00 00 0e 10 00 0c 02 6e 73 06 68 61 63 74 72 6e c0 93 c0 79 00 01 00 01 00 00 0e 10 00 04 c1 00 04 31 c0 79 00 1c 00 01 00 00 0e 10 00 10 20 01 06 10 02 40 00 03 00 00 12 34 be 21 e3 1e '; $UUencodedPacket =~ s/\s*//g; my $packetdata = pack('H*',$UUencodedPacket); my $packet = Net::DNS::Packet->new(\$packetdata); my $TXTrr=($packet->answer)[0]; is(($TXTrr->char_str_list())[0],'Net-DNS; complicated $tuff',"First Char string in TXT RR read from wireformat"); # Compare the second char_str this contains a NULL byte (space NULL # space=200020 in hex) is(unpack('H*',($TXTrr->char_str_list())[1]),"736f7274206f66202220746578743b20616e642062696e61727920002064617461", "Second Char string in TXT RR read from wireformat"); my $TXTrr2=Net::DNS::RR->new('txt2.t.net-dns.org. 60 IN TXT "Test1 \" \; more stuff" "Test2"'); is(($TXTrr2->char_str_list())[0],'Test1 " ; more stuff', "First arg string in TXT RR read from zonefileformat"); is(($TXTrr2->char_str_list())[1],'Test2',"Second Char string in TXT RR read from zonefileformat"); my $TXTrr3 = Net::DNS::RR->new("baz.example.com 3600 HS TXT '\"' 'Char Str2'"); is( ($TXTrr3->char_str_list())[0],'"',"Escaped \" between the single quotes"); ok(Net::DNS::Resolver::Base::_ip_is_ipv4("10.0.0.9"),"_ip_is_ipv4, test 1"); ok(Net::DNS::Resolver::Base::_ip_is_ipv4("1"),"_ip_is_ipv4, test 2"); # remember 1.1 expands to 1.0.0.1 and is legal. ok( Net::DNS::Resolver::Base::_ip_is_ipv4("1.1"),"_ip_is_ipv4, test 3"); ok( ! Net::DNS::Resolver::Base::_ip_is_ipv4("256.1.0.9"),"_ip_is_ipv4, test 4"); ok( ! Net::DNS::Resolver::Base::_ip_is_ipv4("10.11.12.13.14"),"_ip_is_ipv4, test 5"); ok(Net::DNS::Resolver::Base::_ip_is_ipv6("::1"),"_ip_is_ipv6, test 1"); ok(Net::DNS::Resolver::Base::_ip_is_ipv6("1::1"),"_ip_is_ipv6, test 2"); ok(Net::DNS::Resolver::Base::_ip_is_ipv6("1::1:1"),"_ip_is_ipv6, test 3"); ok(! Net::DNS::Resolver::Base::_ip_is_ipv6("1::1:1::1"),"_ip_is_ipv6, test 4"); ok(Net::DNS::Resolver::Base::_ip_is_ipv6("1:2:3:4:4:6:7:8"),"_ip_is_ipv6, test 5"); ok(! Net::DNS::Resolver::Base::_ip_is_ipv6("1:2:3:4:4:6:7:8:9"),"_ip_is_ipv6, test 6"); ok( Net::DNS::Resolver::Base::_ip_is_ipv6("0001:0002:0003:0004:0004:0006:0007:0008"),"_ip_is_ipv6, test 7"); ok( Net::DNS::Resolver::Base::_ip_is_ipv6("abcd:ef01:2345:6789::"),"_ip_is_ipv6, test 8"); ok(! Net::DNS::Resolver::Base::_ip_is_ipv6("abcd:efgh:2345:6789::"),"_ip_is_ipv6, test 9"); ok( Net::DNS::Resolver::Base::_ip_is_ipv6("0001:0002:0003:0004:0004:0006:0007:10.0.0.1"),"_ip_is_ipv6, test 10"); Net-DNS-0.68/t/99-cleanup.t0000644000175000017500000000036611710626412014506 0ustar willemwillem# $Id: 99-cleanup.t 795 2009-01-26 17:28:44Z olaf $ -*-perl-*- use Test::More; plan tests => 1; diag ("Cleaning"); unlink("t/online.disabled") if (-e "t/online.disabled"); unlink("t/IPv6.disabled") if (-e "t/IPv6.disabled"); ok(1,"Dummy"); Net-DNS-0.68/t/02-domain.t0000644000175000017500000001340311710626412014302 0ustar willemwillem# $Id: 02-domain.t 915 2011-10-10 14:25:06Z willem $ -*-perl-*- use strict; use diagnostics; use Test::More tests => 46; use constant UTF8 => eval { require Encode; Encode::decode_utf8( chr(91) ) eq '['; # specifically not UTF-EBCDIC }; use constant LIBIDN => eval { require Net::LibIDN; }; # optional IDN support use constant LIBIDNOK => eval { # tested and working LIBIDN && Net::LibIDN::idn_to_ascii( pack( 'U*', 20013, 22269 ), 'utf-8' ) eq 'xn--fiqs8s'; }; BEGIN { use_ok('Net::DNS::Domain'); } { my $domain = new Net::DNS::Domain('example.com'); isa_ok( $domain, 'Net::DNS::Domain', 'object returned by new() constructor' ); } { eval { my $domain = new Net::DNS::Domain(); }; my $exception = $1 if $@ =~ /^(.+)\n/; ok( $exception ||= '', "empty argument list\t[$exception]" ); } { eval { my $domain = new Net::DNS::Domain(undef); }; my $exception = $1 if $@ =~ /^(.+)\n/; ok( $exception ||= '', "argument undefined\t[$exception]" ); } t5: { my $domain = new Net::DNS::Domain('example.com'); my $labels = $domain->label; is( $labels, 2, 'domain labels separated by dots' ); } use constant ESC => '\\'; { my $case = ESC . '.'; my $domain = new Net::DNS::Domain("example${case}com"); my $labels = $domain->label; is( $labels, 1, "$case devoid of special meaning" ); } { my $case = ESC . ESC; my $domain = new Net::DNS::Domain("example${case}.com"); my $labels = $domain->label; is( $labels, 2, "$case devoid of special meaning" ); } { my $case = ESC . ESC . ESC . '.'; my $domain = new Net::DNS::Domain("example${case}com"); my $labels = $domain->label; is( $labels, 1, "$case devoid of special meaning" ); } { my $case = '\092'; my $domain = new Net::DNS::Domain("example${case}.com"); my $labels = $domain->label; is( $labels, 2, "$case devoid of special meaning" ); } t10: { my $name = 'example.com'; my $domain = new Net::DNS::Domain("$name..."); is( $domain->name, $name, 'ignore gratuitous trailing dots' ); } { my $left = 'example'; my $right = 'com'; my $domain = new Net::DNS::Domain("$left..$right"); is( $domain->name, "$left.$right", 'ignore interior null label' ); } { my $domain = new Net::DNS::Domain(''); is( $domain->name, '.', 'DNS root represented as single dot' ); } { my $name = 'simple-name'; my $suffix = 'example.com'; my $domain = new Net::DNS::Domain($name); is( $domain->name, $name, "$name absolute by default" ); my $create = origin Net::DNS::Domain($suffix); my $result = &$create( sub{ new Net::DNS::Domain($name); } ); my $expect = new Net::DNS::Domain("$name.$suffix"); is( $result->name, $expect->name, "suffix appended to $name" ); } t15: { foreach my $char ( qw($ ' " ; @) ) { my $string = $char . 'example.com.'; my $domain = new Net::DNS::Domain($string); is( $domain->string, ESC . $string, "escape leading $char in string" ); } } t20: { eval { my $domain = new Net::DNS::Domain('.example.com') }; my $exception = $1 if $@ =~ /^(.+)\n/; ok( $exception ||= '', "null domain label\t[$exception]" ); } { my @warnings; local $SIG{__WARN__} = sub { push( @warnings, "@_" ); }; my $name = 'LO-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-NG!'; my $domain = new Net::DNS::Domain("$name"); my ($warning) = @warnings; chomp $warning; ok( $warning, "long domain label\t[$warning]" ); } { my $ldh = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz-0123456789'; my $domain = new Net::DNS::Domain($ldh); is( $domain->name, $ldh, '63 octet LDH character label' ); } SKIP: { skip( 'IDN test - Unicode/UTF-8 not supported', 8 ) unless UTF8; skip( 'IDN test - Net::LibIDN not installed', 8 ) unless LIBIDN; skip( 'IDN test - Net::LibIDN not working', 8 ) unless LIBIDNOK; my $a_label = 'xn--fiqs8s'; my $u_label = eval{ pack( 'U*', 20013, 22269 ); }; is( new Net::DNS::Domain($a_label)->identifier, $a_label, 'IDN A-label domain->identifier' ); is( new Net::DNS::Domain($a_label)->string, "$a_label.", 'IDN A-label domain->string' ); is( new Net::DNS::Domain($a_label)->name, $u_label, 'IDN A-label domain->name' ); is( new Net::DNS::Domain($a_label)->fqdn, "$u_label.", 'IDN A-label domain->fqdn' ); is( new Net::DNS::Domain($u_label)->identifier, $a_label, 'IDN U-label domain->identifier' ); is( new Net::DNS::Domain($u_label)->string, "$a_label.", 'IDN U-label domain->string' ); is( new Net::DNS::Domain($u_label)->name, $u_label, 'IDN U-label domain->name' ); is( new Net::DNS::Domain($u_label)->fqdn, "$u_label.", 'IDN U-label domain->fqdn' ); } t31:{ foreach my $case ( '\000\001\002\003\004\005\006\007\008\009\010\011\012\013\014\015', '\016\017\018\019\020\021\022\023\024\025\026\027\028\029\030\031' ) { my $domain = new Net::DNS::Domain($case); is( $domain->name, $case, "C0 controls:\t$case" ); } } { foreach my $case ( '\032!"#$%&\'()*+,-\./', # 32 .. 47 '0123456789:;<=>?', # 48 .. '@ABCDEFGHIJKLMNO', # 64 .. 'PQRSTUVWXYZ[\\\\]^_', # 80 .. '`abcdefghijklmno', # 96 .. 'pqrstuvwxyz{|}~\127' # 112 .. ) { my $domain = new Net::DNS::Domain($case); is( $domain->name, $case, "G0 graphics:\t$case" ); } } t39: { foreach my $case ( '\128\129\130\131\132\133\134\135\136\137\138\139\140\141\142\143', '\144\145\146\147\148\149\150\151\152\153\154\155\156\157\158\159', '\160\161\162\163\164\165\166\167\168\169\170\171\172\173\174\175', '\176\177\178\179\180\181\182\183\184\185\186\187\188\189\190\191', '\192\193\194\195\196\197\198\199\200\201\202\203\204\205\206\207', '\208\209\210\211\212\213\214\215\216\217\218\219\220\221\222\223', '\224\225\226\227\228\229\230\231\232\233\234\235\236\237\238\239', '\240\241\242\243\244\245\246\247\248\249\250\251\252\253\254\255' ) { my $domain = new Net::DNS::Domain($case); is( $domain->name, $case, "8-bit codes:\t$case" ); } } exit; Net-DNS-0.68/t/00-version.t0000644000175000017500000000123411710626412014515 0ustar willemwillem# $Id: 00-version.t 953 2011-11-02 21:15:28Z willem $ -*-perl-*- use Test::More; use File::Spec; use File::Find; use ExtUtils::MakeMaker; use strict; my @files; my $blib = File::Spec->catfile(qw(blib lib)); find( sub { push(@files, $File::Find::name) if /\.pm$/}, $blib); plan skip_all => 'No versions from git checkouts' if -e '.git'; plan skip_all => ' Not sure how to parse versions.' unless eval { MM->can('parse_version') }; plan tests => scalar @files; foreach my $file ( sort @files ) { my $version = MM->parse_version($file); diag("$file\t=>\t$version") if $ENV{'NET_DNS_DEBUG'}; ok( $version =~ /[\d.]{3}/, "file version: $version\t$file" ); } Net-DNS-0.68/t/10-recurse.t0000644000175000017500000000520411710626412014502 0ustar willemwillem# $Id: 10-recurse.t 897 2011-09-20 12:44:28Z willem $ -*-perl-*- use Test::More; use strict; use t::NonFatal; BEGIN { if (-e 't/online.enabled' && ! -e 't/online.disabled' ) { # # Some people try to run these on private address space." use IO::Socket::INET; my $sock = IO::Socket::INET->new(PeerAddr => '193.0.14.129', # k.root-servers.net. PeerPort => '53', Proto => 'udp'); unless($sock){ plan skip_all => "Cannot bind to socket:\n\t".$!."\n"; diag "This is an indication you do have network problems"; exit; }else{ my $ip = inet_ntoa($sock->sockaddr); if ( $ip =~ /^(10|172\.(1[6-9]|2.|30|31)|192.168)\./ ) { plan skip_all => "Cannot run these tests from this IP: $ip"; exit; }else{ plan tests => 12; NonFatalBegin(); } } } else { plan skip_all => 'Online tests disabled.'; } } BEGIN { use_ok('Net::DNS::Resolver::Recurse'); } { my $res = Net::DNS::Resolver::Recurse->new; isa_ok($res, 'Net::DNS::Resolver::Recurse'); $res->debug(1); $res->udp_timeout(20); # Hard code A and K.ROOT-SERVERS.NET hint ok($res->hints("193.0.14.129", "198.41.0.4" ), "hints() set"); ok(%{ $res->{'hints'} }, 'sanity check worked'); my $packet; # Try a domain that is a CNAME $packet = $res->query_dorecursion("www.google.com.","A"); ok($packet, 'got a packet'); ok(scalar $packet->answer, 'answer has RRs'); # Try a big hairy one undef $packet; $packet = $res->query_dorecursion("www.rob.com.au.","A"); ok($packet, 'got a packet'); ok(scalar $packet->answer, 'anwer section had RRs'); } # test the callback my @HINTS= qw( 192.33.4.12 128.8.10.90 192.203.230.10 192.5.5.241 192.112.36.4 128.63.2.53 192.36.148.17 192.58.128.30 193.0.14.129 199.7.83.42 202.12.27.33 198.41.0.4 192.228.79.201 ); my $res2 = Net::DNS::Resolver::Recurse->new ; $res2->nameservers( @HINTS ); my $ans_at=$res2->send("a.t.", "A"); if ($ans_at->header->ancount == 1 ){ diag "We are going to skip a bunch of checks."; diag "There seems to be a middle box in the path that modifies your packets"; } SKIP: { skip "Modifying middlebox detected ",4 if ($ans_at->header->ancount == 1 ); { my $res = Net::DNS::Resolver::Recurse->new ; my $count; $res->debug(1); # Hard code root hints, there are some environments that will fail # the test otherwise $res->hints( @HINTS ); $res->recursion_callback(sub { my $packet = shift; isa_ok($packet, 'Net::DNS::Packet'); $count++; }); $res->query_dorecursion('a.t.net-dns.org', 'A'); is($count, 3); } } NonFatalEnd(); Net-DNS-0.68/t/01-resolver-file.t0000644000175000017500000000167711710626412015622 0ustar willemwillem# $Id: 01-resolver-file.t 616 2006-10-18 09:15:48Z olaf $ use Test::More tests => 8; use strict; BEGIN { chdir 't/' || die "Couldn't chdir to t/\n"; unshift(@INC, '../blib/lib', '../blib/arch'); use_ok('Net::DNS'); } SKIP: { skip 'File parsing only supported on unix.', 7 unless $Net::DNS::Resolver::ISA[0] eq 'Net::DNS::Resolver::UNIX'; skip 'Could not read configuration file', 7 unless -r '.resolv.conf' && -o _; my $res = Net::DNS::Resolver->new; ok($res, "new() returned something"); ok($res->nameservers, "nameservers() works"); my @servers = $res->nameservers; is($servers[0], '10.0.1.128', 'Nameserver set correctly'); is($servers[1], '10.0.2.128', 'Nameserver set correctly'); my @search = $res->searchlist; is($search[0], 'net-dns.org', 'Search set correctly' ); is($search[1], 'lib.net-dns.org', 'Search set correctly' ); is($res->domain, 't.net-dns.org', 'Local domain works' ); } Net-DNS-0.68/t/02-text.t0000644000175000017500000001075111710626412014022 0ustar willemwillem# $Id: 02-text.t 965 2011-12-02 22:04:30Z willem $ -*-perl-*- use strict; use diagnostics; use Test::More tests => 27; BEGIN { my $codeword = unpack 'H*', '[|'; my %codename = ( '5b7c' => 'ASCII superset', 'ba4f' => 'EBCDIC cp37', '4abb' => 'EBCDIC cp500', '4a6a' => 'EBCDIC cp875', '68bb' => 'EBCDIC cp1026', 'ad4f' => 'EBCDIC cp1047', 'bb4f' => 'EBCDIC posix-bc' ); my $encoding = $codename{lc $codeword} || "unknown codeset [$codeword]"; diag $encoding unless $encoding =~ /ASCII/; use_ok('Net::DNS::Text'); } { my $object = new Net::DNS::Text('example'); isa_ok( $object, 'Net::DNS::Text', 'object returned by new() constructor' ); } { eval { my $object = new Net::DNS::Text(); }; my $exception = $1 if $@ =~ /^(.+)\n/; ok( $exception ||= '', "empty argument list\t[$exception]" ); } { eval { my $object = new Net::DNS::Text(undef); }; my $exception = $1 if $@ =~ /^(.+)\n/; ok( $exception ||= '', "argument undefined\t[$exception]" ); } { my $sample = ''; my $expect = '""'; my $result = new Net::DNS::Text($sample)->string; is( $result, $expect, 'null argument' ); } { my $sample = 'example'; my $escape = '\e\x\a\m\p\l\e'; my $result = new Net::DNS::Text($escape)->string; is( $result, $sample, 'character escape' ); } { my $sample = 'A'; my $escape = '\065'; my $result = new Net::DNS::Text($escape)->string; is( $result, $sample, 'numeric escape' ); } { my $sample = 'x\000x\031x\127x\128x\159\160\255x'; my $expect = '7800781f787f7880789fa0ff78'; my $length = sprintf '%02x', length pack( 'H*', $expect ); my $object = new Net::DNS::Text($sample); my $buffer = $object->encode; is( unpack( 'H*', $buffer ), $length . $expect, 'encode() returns expected data' ); } { my $sample = 'example'; my $buffer = new Net::DNS::Text($sample)->encode; my $object = decode Net::DNS::Text( \$buffer ); isa_ok( $object, 'Net::DNS::Text', 'object returned by decode() constructor' ); is( $object->string, $sample, 'object matches original data' ); my ( $x, $next ) = decode Net::DNS::Text( \$buffer ); is( $next, length $buffer, 'expected offset returned by decode()' ); } { my %testcase = ( '000102030405060708090a0b0c0d0e0f' => '"\000\001\002\003\004\005\006\007\008 \010\011\012\013\014\015"', '101112131415161718191a1b1c1d1e1f' => '\016\017\018\019\020\021\022\023\024\025\026\027\028\029\030\031', ); foreach my $hexcode ( sort keys %testcase ) { my $string = $testcase{$hexcode}; my $content = pack 'H*', $hexcode; my $buffer = pack 'C a*', length $content, $content; my $decoded = decode Net::DNS::Text( \$buffer ); my $compare = $decoded->string; is( $compare, qq($string), "C0 controls:\t$string" ); } } { my %testcase = ( '202122232425262728292a2b2c2d2e2f' => '" !\"#$%&\'()*+,-./"', '303132333435363738393a3b3c3d3e3f' => '"0123456789:;<=>?"', '404142434445464748494a4b4c4d4e4f' => '"@ABCDEFGHIJKLMNO"', '505152535455565758595a5b5c5d5e5f' => 'PQRSTUVWXYZ[\\\\]^_', '606162636465666768696a6b6c6d6e6f' => '"`abcdefghijklmno"', '707172737475767778797a7b7c7d7e7f' => 'pqrstuvwxyz{|}~\127' ); foreach my $hexcode ( sort keys %testcase ) { my $string = $testcase{$hexcode}; my $content = pack 'H*', $hexcode; my $buffer = pack 'C a*', length $content, $content; my $decoded = decode Net::DNS::Text( \$buffer ); my $compare = $decoded->string; is( $compare, qq($string), "G0 graphics:\t$string" ); } } { my %testcase = ( '808182838485868788898a8b8c8d8e8f' => '\128\129\130\131\132\133\134\135\136\137\138\139\140\141\142\143', '909192939495969798999a9b9c9d9e9f' => '\144\145\146\147\148\149\150\151\152\153\154\155\156\157\158\159', 'a0a1a2a3a4a5a6a7a8a9aaabacadaeaf' => '\160\161\162\163\164\165\166\167\168\169\170\171\172\173\174\175', 'b0b1b2b3b4b5b6b7b8b9babbbcbdbebf' => '\176\177\178\179\180\181\182\183\184\185\186\187\188\189\190\191', 'c0c1c2c3c4c5c6c7c8c9cacbcccdcecf' => '\192\193\194\195\196\197\198\199\200\201\202\203\204\205\206\207', 'd0d1d2d3d4d5d6d7d8d9dadbdcdddedf' => '\208\209\210\211\212\213\214\215\216\217\218\219\220\221\222\223', 'e0e1e2e3e4e5e6e7e8e9eaebecedeeef' => '\224\225\226\227\228\229\230\231\232\233\234\235\236\237\238\239', 'f0f1f2f3f4f5f6f7f8f9fafbfcfdfeff' => '\240\241\242\243\244\245\246\247\248\249\250\251\252\253\254\255' ); foreach my $hexcode ( sort keys %testcase ) { my $string = $testcase{$hexcode}; my $encoded = new Net::DNS::Text( $string )->encode; is( unpack( 'xH*', $encoded ), $hexcode, qq(8-bit codes:\t$string) ); } } Net-DNS-0.68/t/NonFatal.pm0000644000175000017500000000254011710626412014467 0ustar willemwillem# $Id: NonFatal.pm 895 2011-09-19 14:48:24Z willem $ -*-perl-*- # Test::More calls functions from Test::Builder. Those functions all eventually # call Test::Builder::ok (on a builder instance) for reporting the status. # Here we define a new builder inherited from Test::Builder, with a overloaded # oks method that always reports the test to have completed successful. # # The functions NonFatalBegin and NonFatalEnd re-bless the builder in use by # Test::More (Test::More->builder) to be of type Test::NonFatal and # Test::Builder respectively. Tests that are between those functions will thus # appear to always succeed, however, failure is reported. # # Note that the builder is only re-blessed when the file 't/online.nonfatal' # exists. # # This is just a quick hack to allow for non-fatal unit tests. It has many # problems such as for example that blocks marked by the NonFatalBegin and # NonFatalEnd subroutines may not be nested. # { package Test::NonFatal; use base 'Test::Builder'; sub ok { my ($self, $test, $name) = @_; $name = "NOT OK, but tolerating failure, $name" unless $test; $self->SUPER::ok(1, $name); return $test ? 1 : 0; } } use Test::More; sub NonFatalBegin { bless Test::More->builder, Test::NonFatal if -e 't/online.nonfatal'; } sub NonFatalEnd { bless Test::More->builder, Test::Builder if -e 't/online.nonfatal'; } 1; Net-DNS-0.68/t/00-pod.t0000644000175000017500000000072011710626412013611 0ustar willemwillem# $Id: 00-pod.t 616 2006-10-18 09:15:48Z olaf $ use Test::More; use File::Spec; use File::Find; use strict; eval "use Test::Pod 0.95"; if ($@) { plan skip_all => "Test::Pod v0.95 required for testing POD"; } else { Test::Pod->import; my @files; my $blib = File::Spec->catfile(qw(blib lib)); find( sub { push(@files, $File::Find::name) if /\.p(l|m|od)$/}, $blib); plan tests => scalar @files; foreach my $file (@files) { pod_file_ok($file); } } Net-DNS-0.68/t/02-mailbox.t0000644000175000017500000000715311710626412014473 0ustar willemwillem# $Id: 02-mailbox.t 965 2011-12-02 22:04:30Z willem $ -*-perl-*- use strict; use diagnostics; use Test::More tests => 35; BEGIN { use_ok('Net::DNS::Mailbox'); } { my %testcase = ( '.' => '<>', 'a' => 'a', 'a.b' => 'a@b', 'a.b.c' => 'a@b.c', 'a.b.c.d' => 'a@b.c.d', 'a@b' => 'a@b', 'a@b.c' => 'a@b.c', 'a@b.c.d' => 'a@b.c.d', 'a\.b.c.d' => 'a.b@c.d', 'a\.b@c.d' => 'a.b@c.d', 'a\@b.c.d' => 'a\@b@c.d', 'a\@b@c.d' => 'a\@b@c.d', 'empty <>' => '<>', 'fore aft' => 'a.b@c.d', 'nested <
>' => 'address', 'obscure <<<>>>' => 'right', ); foreach my $test ( sort keys %testcase ) { my $expect = $testcase{$test}; my $mailbox = new Net::DNS::Mailbox($test); my $data = $mailbox->encode; my $decoded = decode Net::DNS::Mailbox( \$data ); is( $decoded->address, $expect, "encode/decode mailbox $test" ); } } { my $domain = new Net::DNS::Mailbox( uc 'MBOX.EXAMPLE.COM' ); my $hash = {}; my $data = $domain->encode( 1, $hash ); my $compress = $domain->encode( length $data, $hash ); my $canonical = $domain->encode( length $data ); my $decoded = decode Net::DNS::Mailbox( \$data ); my $downcased = new Net::DNS::Mailbox( lc $domain->name )->encode( 0, {} ); isa_ok( $domain, 'Net::DNS::Mailbox', 'object returned by new() constructor' ); isa_ok( $decoded, 'Net::DNS::Mailbox', 'object returned by decode() constructor' ); is( length $compress, length $data, 'Net::DNS::Mailbox encoding is uncompressed' ); isnt( $data, $downcased, 'Net::DNS::Mailbox encoding preserves case' ); is( length $canonical, length $data, 'Net::DNS::Mailbox canonical form is uncompressed' ); isnt( $canonical, $downcased, 'Net::DNS::Mailbox canonical form preserves case' ); } { my $domain = new Net::DNS::Mailbox1035( uc 'MBOX.EXAMPLE.COM' ); my $hash = {}; my $data = $domain->encode( 1, $hash ); my $compress = $domain->encode( length $data, $hash ); my $canonical = $domain->encode( length $data ); my $decoded = decode Net::DNS::Mailbox1035( \$data ); my $downcased = new Net::DNS::Mailbox1035( lc $domain->name )->encode( 0, {} ); isa_ok( $domain, 'Net::DNS::Mailbox1035', 'object returned by new() constructor' ); isa_ok( $decoded, 'Net::DNS::Mailbox1035', 'object returned by decode() constructor' ); isnt( length $compress, length $data, 'Net::DNS::Mailbox1035 encoding is compressible' ); isnt( $data, $downcased, 'Net::DNS::Mailbox1035 encoding preserves case' ); is( length $canonical, length $data, 'Net::DNS::Mailbox1035 canonical form is uncompressed' ); is( $canonical, $downcased, 'Net::DNS::Mailbox1035 canonical form is lower case' ); } { my $domain = new Net::DNS::Mailbox2535( uc 'MBOX.EXAMPLE.COM' ); my $hash = {}; my $data = $domain->encode( 1, $hash ); my $compress = $domain->encode( length $data, $hash ); my $canonical = $domain->encode( length $data ); my $decoded = decode Net::DNS::Mailbox2535( \$data ); my $downcased = new Net::DNS::Mailbox2535( lc $domain->name )->encode( 0, {} ); isa_ok( $domain, 'Net::DNS::Mailbox2535', 'object returned by new() constructor' ); isa_ok( $decoded, 'Net::DNS::Mailbox2535', 'object returned by decode() constructor' ); is( length $compress, length $data, 'Net::DNS::Mailbox2535 encoding is uncompressed' ); isnt( $data, $downcased, 'Net::DNS::Mailbox2535 encoding preserves case' ); is( length $canonical, length $data, 'Net::DNS::Mailbox2535 canonical form is uncompressed' ); is( $canonical, $downcased, 'Net::DNS::Mailbox2535 canonical form is lower case' ); } exit; Net-DNS-0.68/t/12-compression.t0000644000175000017500000000370411710626412015400 0ustar willemwillem# $Id: 12-compression.t 704 2008-02-06 21:30:59Z olaf $ -*-perl-*- # build DNS packet which has an endless loop in compression # check it against XS and PP implementation of dn_expand # both should return (undef,undef) as a sign that the packet # is invalid # use Test::More tests => 5; use strict; use Net::DNS; # simple query packet my $pkt = Net::DNS::Packet->new( 'www.example.com','a' )->data; # replace 'com' with pointer to 'example', thus causing # endless loop for compressed string: # www.example.example.example.example... my $pos = pack( 'C', index( $pkt,"\007example" )); $pkt =~s{\003com}{\xc0$pos\001x}; # start at 'www' my $start_offset = index( $pkt,"\003www" ); # fail in case the implementation is buggy and loops forever $SIG{ ALRM } = sub { BAIL_OUT( "endless loop?" ) }; alarm(15); my ($name,$offset); # XS implementation SKIP: { skip("No dn_expand_xs available",1) if ! $Net::DNS::HAVE_XS; my ($name,$offset) = eval { Net::DNS::Packet::dn_expand( \$pkt,$start_offset ) }; ok( !defined($name) && !defined($offset), 'XS detected invalid packet' ); } $Net::DNS::HAVE_XS = 0; undef $name; undef $offset; ($name,$offset) = eval { Net::DNS::Packet::dn_expand( \$pkt,$start_offset ) }; ok( !defined($name) && !defined($offset), 'PP detected invalid packet' ); # rt.cpan.org 27391 my $packet = Net::DNS::Packet->new("bad..example.com"); my $corrupt = $packet->data; my $result = Net::DNS::Packet->new(\$corrupt); is (($result->question)[0]->qtype(),"A","Type correct"); is (($result->question)[0]->qclass(),"IN","Type correct"); #rt.cpan.org #26957 undef $packet; $packet = Net::DNS::Packet->new(); my $input= "123456789112345678921234567893123456789412345678951234567896123456789.example.com"; # We truncate labels: my $compressed="123456789112345678921234567893123456789412345678951234567896123.example.com"; my $compname=$packet->dn_comp($input,0); is((Net::DNS::Packet::dn_expand(\$compname,0))[0],$compressed,"Long labels chopped") Net-DNS-0.68/t/.resolv.conf0000644000175000017500000000021511710626412014663 0ustar willemwillem# $Id: .resolv.conf 264 2005-04-06 09:16:15Z olaf $ domain t.net-dns.org search net-dns.org lib.net-dns.org nameserver 10.0.1.128 10.0.2.128 Net-DNS-0.68/t/09-tkey.t0000644000175000017500000000552711710626412014026 0ustar willemwillem# $Id: 09-tkey.t 795 2009-01-26 17:28:44Z olaf $ -*-perl-*- use Test::More tests => 7; use strict; use Digest::HMAC_MD5; BEGIN { use_ok('Net::DNS'); } #1 sub is_empty { my ($string) = @_; return ($string eq "; no data" || $string eq "; rdlength = 0"); } #------------------------------------------------------------------------------ # Canned data. #------------------------------------------------------------------------------ my $zone = "example.com"; my $name = "123456789-test"; my $class = "IN"; my $type = "TKEY"; my $algorithm = "fake.algorithm.example.com"; my $key = "fake key"; my $inception = 100000; # use a strange fixed inception time to give a fixed # checksum my $expiration = $inception + 24*60*60; my $rr = undef; #------------------------------------------------------------------------------ # Packet creation. #------------------------------------------------------------------------------ $rr = Net::DNS::RR->new( Name => "$name", Type => "TKEY", TTL => 0, Class => "ANY", algorithm => $algorithm, inception => $inception, expiration => $expiration, mode => 3, # GSSAPI key => "fake key", other_data => "", ); my $packet = Net::DNS::Packet->new("$name", "TKEY", "IN"); $packet->push("answer", $rr); my $z = ($packet->zone)[0]; ok($packet, 'new() returned packet'); #2 is($packet->header->opcode, 'QUERY', 'header opcode correct'); #3 is($z->zname, $name, 'zname correct'); #4 is($z->zclass, "IN", 'zclass correct'); #5 is($z->ztype, 'TKEY', 'ztype correct'); #6 #------------------------------------------------------------------------------ # create a signed TKEY query packet using an external signing function # and compare it to a known good result. This effectively tests the # sign_func and sig_data methods of TSIG as well. #------------------------------------------------------------------------------ sub fake_sign { my ($key, $data) = @_; my $hmac = Digest::HMAC_MD5->new($key); $hmac->add($data); return $hmac->hexdigest; } my $tsig = Net::DNS::RR->new( Name => $name, Type => "TSIG", TTL => 0, Class => "ANY", Algorithm => $algorithm, Time_Signed => $inception + 1, Fudge => 36000, Mac_Size => 0, Mac => "", Key => $key, Sign_Func => \&fake_sign, Other_Len => 0, Other_Data => "", Error => 0, ); $packet->push("additional", $tsig); # use a fixed packet id so we get a known checksum $packet->header->id(1234); # create the packet - this will fill in the 'mac' field my $raw_packet = $packet->data; is(($packet->additional)[0]->mac, "6365643161343964663364643264656131306638303633626465366236643465", 'MAC correct'); Net-DNS-0.68/t/02-domainname.t0000644000175000017500000001576111710626412015154 0ustar willemwillem# $Id: 02-domainname.t 895 2011-09-19 14:48:24Z willem $ -*-perl-*- use strict; use diagnostics; use Test::More tests => 45; BEGIN { use_ok('Net::DNS::DomainName'); } { my $domain = new Net::DNS::DomainName(''); is( $domain->name, '.', 'DNS root represented as single dot' ); my $binary = unpack 'H*', $domain->encode; my $expect = '00'; is( $binary, $expect, 'DNS root wire-format representation' ); } { my $ldh = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz-0123456789'; my $domain = new Net::DNS::DomainName($ldh); my $subdomain = new Net::DNS::DomainName("sub.$ldh"); is( $domain->name, $ldh, '63 octet LDH character label' ); my $buffer = $domain->encode; my $hex = '3f' . '4142434445464748494a4b4c4d4e4f505152535455565758595a' . '6162636465666768696a6b6c6d6e6f707172737475767778797a' . '2d30313233343536373839' . '00'; is( lc unpack( 'H*', $buffer ), $hex, 'simple wire-format encoding' ); my ( $decoded, $offset ) = decode Net::DNS::DomainName( \$buffer ); is( $decoded->name, $domain->name, 'simple wire-format decoding' ); my $data = '03737562c000'; $buffer .= pack( 'H*', $data ); ( $decoded, $offset ) = decode Net::DNS::DomainName( \$buffer, $offset ); is( $decoded->name, $subdomain->name, 'compressed wire-format decoding' ); } { my $buffer = pack 'H*', 'c002'; eval { my $domain = decode Net::DNS::DomainName( \$buffer ); }; my $exception = $1 if $@ =~ /^(.+)\n/; ok( $exception ||= '', "bad compression pointer\t[$exception]" ); } { my $buffer = pack 'H*', 'c000'; eval { my $domain = decode Net::DNS::DomainName( \$buffer ); }; my $exception = $1 if $@ =~ /^(.+)\n/; ok( $exception ||= '', "name compression loop\t[$exception]" ); } t10: { my $hex = '40' . '4142434445464748494a4b4c4d4e4f505152535455565758595a' . '6162636465666768696a6b6c6d6e6f707172737475767778797a' . '2d30313233343536373839ff' . '00'; my $buffer = pack 'H*', $hex; eval { my $domain = decode Net::DNS::DomainName( \$buffer ); }; my $exception = $1 if $@ =~ /^(.+)\n/; ok( $exception ||= '', "unsupported wire-format\t[$exception]" ); } { my $hex = '80' . '4142434445464748494a4b4c4d4e4f505152535455565758595a' . '6162636465666768696a6b6c6d6e6f707172737475767778797a' . '2d30313233343536373839ff' . '4142434445464748494a4b4c4d4e4f505152535455565758595a' . '6162636465666768696a6b6c6d6e6f707172737475767778797a' . '2d30313233343536373839ff' . '00'; my $buffer = pack 'H*', $hex; eval { my $domain = decode Net::DNS::DomainName( \$buffer ); }; my $exception = $1 if $@ =~ /^(.+)\n/; ok( $exception ||= '', "unsupported wire-format\t[$exception]" ); } { foreach my $case ( '\000\001\002\003\004\005\006\007\008\009\010\011\012\013\014\015', '\016\017\018\019\020\021\022\023\024\025\026\027\028\029\030\031' ) { my $domain = new Net::DNS::DomainName($case); my $binary = $domain->encode; my $result = decode Net::DNS::DomainName( \$binary )->name; is( unpack( 'H*', $result ), unpack( 'H*', $case ), "C0 controls:\t$case" ); } } { foreach my $case ( '\032!"#$%&\'()*+,-\./', # 32 .. 47 '0123456789:;<=>?', # 48 .. '@ABCDEFGHIJKLMNO', # 64 .. 'PQRSTUVWXYZ[\\\\]^_', # 80 .. '`abcdefghijklmno', # 96 .. 'pqrstuvwxyz{|}~\127' # 112 .. ) { my $domain = new Net::DNS::DomainName($case); my $binary = $domain->encode; my $result = decode Net::DNS::DomainName( \$binary )->name; is( unpack( 'H*', $result ), unpack( 'H*', $case ), "G0 graphics:\t$case" ); } } t20: { foreach my $case ( '\128\129\130\131\132\133\134\135\136\137\138\139\140\141\142\143', '\144\145\146\147\148\149\150\151\152\153\154\155\156\157\158\159', '\160\161\162\163\164\165\166\167\168\169\170\171\172\173\174\175', '\176\177\178\179\180\181\182\183\184\185\186\187\188\189\190\191', '\192\193\194\195\196\197\198\199\200\201\202\203\204\205\206\207', '\208\209\210\211\212\213\214\215\216\217\218\219\220\221\222\223', '\224\225\226\227\228\229\230\231\232\233\234\235\236\237\238\239', '\240\241\242\243\244\245\246\247\248\249\250\251\252\253\254\255' ) { my $domain = new Net::DNS::DomainName($case); my $binary = $domain->encode; my $result = decode Net::DNS::DomainName( \$binary )->name; is( unpack( 'H*', $result ), unpack( 'H*', $case ), "8-bit codes:\t$case" ); } } t28: { my $domain = new Net::DNS::DomainName( uc 'EXAMPLE.COM' ); my $hash = {}; my $data = $domain->encode( 0, $hash ); my $compress = $domain->encode( length $data, $hash ); my $canonical = $domain->encode( length $data ); my $decoded = decode Net::DNS::DomainName( \$data ); my $downcased = new Net::DNS::DomainName( lc $domain->name )->encode( 0, {} ); isa_ok( $domain, 'Net::DNS::DomainName', 'object returned by new() constructor' ); isa_ok( $decoded, 'Net::DNS::DomainName', 'object returned by decode() constructor' ); is( length $compress, length $data, 'Net::DNS::DomainName wire encoding is uncompressed' ); isnt( $data, $downcased, 'Net::DNS::DomainName wire encoding preserves case' ); is( length $canonical, length $data, 'Net::DNS::DomainName canonical form is uncompressed' ); isnt( $canonical, $downcased, 'Net::DNS::DomainName canonical form preserves case' ); } t34: { my $domain = new Net::DNS::DomainName1035( uc 'EXAMPLE.COM' ); my $hash = {}; my $data = $domain->encode( 0, $hash ); my $compress = $domain->encode( length $data, $hash ); my $canonical = $domain->encode( length $data ); my $decoded = decode Net::DNS::DomainName1035( \$data ); my $downcased = new Net::DNS::DomainName1035( lc $domain->name )->encode( 0, {} ); isa_ok( $domain, 'Net::DNS::DomainName1035', 'object returned by new() constructor' ); isa_ok( $decoded, 'Net::DNS::DomainName1035', 'object returned by decode() constructor' ); isnt( length $compress, length $data, 'Net::DNS::DomainName1035 wire encoding is compressible' ); isnt( $data, $downcased, 'Net::DNS::DomainName1035 wire encoding preserves case' ); is( length $canonical, length $data, 'Net::DNS::DomainName1035 canonical form is uncompressed' ); is( $canonical, $downcased, 'Net::DNS::DomainName1035 canonical form is lower case' ); } t40: { my $domain = new Net::DNS::DomainName2535( uc 'EXAMPLE.COM' ); my $hash = {}; my $data = $domain->encode( 0, $hash ); my $compress = $domain->encode( length $data, $hash ); my $canonical = $domain->encode( length $data ); my $decoded = decode Net::DNS::DomainName2535( \$data ); my $downcased = new Net::DNS::DomainName2535( lc $domain->name )->encode( 0, {} ); isa_ok( $domain, 'Net::DNS::DomainName2535', 'object returned by new() constructor' ); isa_ok( $decoded, 'Net::DNS::DomainName2535', 'object returned by decode() constructor' ); is( length $compress, length $data, 'Net::DNS::DomainName2535 wire encoding is uncompressed' ); isnt( $data, $downcased, 'Net::DNS::DomainName2535 wire encoding preserves case' ); is( length $canonical, length $data, 'Net::DNS::DomainName2535 canonical form is uncompressed' ); is( $canonical, $downcased, 'Net::DNS::DomainName2535 canonical form is lower case' ); } exit; Net-DNS-0.68/t/05-rr-various.t0000644000175000017500000000406311710626412015151 0ustar willemwillem# $Id: 05-rr-various.t 901 2011-09-27 20:33:41Z willem $ -*-perl-*- # Contains a number of additional test for RR related functionality use Test::More; use strict; use Net::DNS; use vars qw( $HAS_DNSSEC $HAS_DLV $HAS_NSEC3 $HAS_NSEC3PARAM); plan tests => 7; is ( Net::DNS::stripdot ('foo\\\\\..'),'foo\\\\\.', "Stripdot does its magic in precense of escapes test 1"); is ( Net::DNS::stripdot ('foo\\\\\.'),'foo\\\\\.', "Stripdot does its magic in precense of escapes test 2"); is ( Net::DNS::stripdot(''),'',"Stripdot handles empty strings as it should"); my $rr_aaaa_v4compat = Net::DNS::RR->new("foo AAAA ::0.0.0.2"); is($rr_aaaa_v4compat->address, "0:0:0:0:0:0:0:2", "v4compat AAAA records parsed correctly"); # rt.cpan.org 41071 my $pkt1 = Net::DNS::Packet->new('e3.example.com','AAAA','IN'); $pkt1->push( answer => Net::DNS::RR->new( name => 'e3.example.com', type => 'AAAA', address => 'CAFE:BABE::1' )); my $pkt2 = Net::DNS::Packet->new( \$pkt1->data ); is(($pkt1->answer)[0]->string,($pkt2->answer)[0]->string,"New from string and new from hash creation "); is(($pkt1->answer)[0]->address,"cafe:babe:0:0:0:0:0:1","Lets have cafe:babe:0:0:0:0:0:1"); #rt 49035 my $string = '5.5.5.5 1200 IN NAPTR 100 100 "u" "E2U+X-ADDRESS" "!^(.*)$!data:,CN=East test;ST=CT;C=United States;uid=ast1;intrunk=dms500!" .'; my $newrr1 = Net::DNS::RR->new("$string"); my $newrr2 = Net::DNS::RR->new(name=> '5.5.5.5', ttl=> 1200, class=> 'IN', type => 'NAPTR', order => '100', preference => '100', flags => 'u', service => 'E2U+X-ADDRESS', regexp => '!^(.*)$!data:,CN=East test;ST=CT;C=United States;uid=ast1;intrunk=dms500!', replacement => '.', rdlength => 0, rdata => '', ); is($newrr1->string,$newrr2->string, "Failed to parse ". $string); Net-DNS-0.68/t/01-resolver.t0000644000175000017500000000607411710626412014701 0ustar willemwillem# $Id: 01-resolver.t 964 2011-12-02 10:23:51Z willem $ -*-perl-*- use strict; use Test::More tests => 47; use t::NonFatal; use Net::DNS; my $res = Net::DNS::Resolver->new(); for (qw[Cygwin Win32]) { diag $_ if eval { $res->SUPER::isa("Net::DNS::Resolver::$_") }; } isa_ok( $res, 'Net::DNS::Resolver', 'new() created object' ); ok( scalar $res->nameservers, 'nameservers() works' ); my $searchlist = [qw(t.net-dns.org t2.net-dns.org)]; is_deeply([$res->searchlist(@$searchlist)], $searchlist, 'setting searchlist returns correctly.'); is_deeply([$res->searchlist], $searchlist, 'setting searchlist sticks.'); my %good_input = ( port => 54, srcaddr => '10.1.0.1', srcport => 53, domain => 'net-dns.org', retrans => 6, retry => 5, usevc => 1, stayopen => 1, igntc => 1, recurse => 0, defnames => 0, dnsrch => 0, debug => 1, tcp_timeout => 60, udp_timeout => 60, persistent_tcp => 1, dnssec => 1, force_v4 => 1, cdflag => 0, adflag => 1, ); #diag "\n\nIf you do not have Net::DNS::SEC installed you will see a warning.\n"; #diag "It is safe to ignore this\n"; while (my ($param, $value) = each %good_input) { open (TMPFH,">/dev/null") or die "can't open /dev/null"; local *STDERR=*TMPFH; is_deeply($res->$param($value), $value, "setting $param returns correctly"); is_deeply($res->$param(), $value, "setting $param sticks"); close (TMPFH); } SKIP: { # Test first, if we want online tests at all. skip 'Online tests disabled.', 3 unless -e 't/online.enabled'; skip 'Online tests disabled.', 3 if -e 't/online.disabled'; # Some people try to run these on private address space - test for this case and skip. use IO::Socket::INET; my $sock = IO::Socket::INET->new(PeerAddr => '193.0.14.129', # k.root-servers.net. PeerPort => '53', Proto => 'udp'); my $ip = $sock ? inet_ntoa($sock->sockaddr) : undef; skip "Tests may not succeed from private IP: $ip", 3 if $ip && $ip =~ /^(10|172\.(1[6-9]|2.|30|31)|192.168)\./; NonFatalBegin(); my $res = Net::DNS::Resolver->new(udp_timeout => 3, tcp_timeout => 3); $res->nameservers('a.t.net-dns.org'); $ip = ($res->nameservers)[0]; is($ip, '10.0.1.128', 'Nameservers() looks up IP.') or diag ($res->errorstring . $res->print) ; $res->nameservers('cname.t.net-dns.org'); $ip = ($res->nameservers)[0]; is($ip, '10.0.1.128', 'Nameservers() looks up cname.') or diag ($res->errorstring . $res->print) ; # Test to trigger a bug in release 0.59 of Question.pm # (rt.cpan.org #28198) (modification of $_ value in various # places my $die = 0; undef ($res); # default values again $res = Net::DNS::Resolver->new(udp_timeout => 3, tcp_timeout => 3); eval{ local $^W = 1; local $SIG{__DIE__} = sub { $die++ }; for (0) # Sets $_ to 0 { my $q=$res->send("net-dns.org","SOA"); } }; is($die, 0, 'No deaths because of \$_'); NonFatalEnd(); } Net-DNS-0.68/t/08-online.t0000644000175000017500000001612111710626412014325 0ustar willemwillem# $Id: 08-online.t 924 2011-10-23 22:25:32Z willem $ -*-perl-*- use Test::More; use strict; use Socket; use Data::Dumper; use t::NonFatal; BEGIN { if (-e 't/online.enabled' && ! -e 't/online.disabled' ) { plan tests => 95; NonFatalBegin(); } else { plan skip_all => 'Online tests disabled.'; exit; } } BEGIN { use_ok('Net::DNS'); } sub timeoutres { return Net::DNS::Resolver->new( tcp_timeout => 3, udp_timeout => 3 ); } my $res = &timeoutres; #$res->debug(1); my @rrs = ( { type => 'A', name => 'a.t.net-dns.org', address => '10.0.1.128', }, { type => 'MX', name => 'mx.t.net-dns.org', exchange => 'a.t.net-dns.org', preference => 10, }, { type => 'CNAME', name => 'cname.t.net-dns.org', cname => 'a.t.net-dns.org', }, { type => 'TXT', name => 'txt.t.net-dns.org', txtdata => 'Net-DNS', }, ); foreach my $data (@rrs) { my $packet = $res->send($data->{'name'}, $data->{'type'}, 'IN'); if (ok($packet, "Got an answer for $data->{name} IN $data->{type}")) { is($packet->header->qdcount, 1, 'Only one question'); if (is($packet->header->ancount, 1, 'Got single answer')) { my $question = ($packet->question)[0]; my $answer = ($packet->answer)[0]; ok($question, 'Got question' ); is($question->qname, $data->{'name'}, 'Question has right name' ); is($question->qtype, $data->{'type'}, 'Question has right type' ); is($question->qclass, 'IN', 'Question has right class'); ok($answer, ); is($answer->class, 'IN', 'Class correct' ); foreach my $meth (keys %{$data}) { if ($meth eq "name"){ #names should be case insensitive is(lc($answer->$meth()),lc($data->{$meth}), "$meth correct ($data->{name})"); }else{ is($answer->$meth(), $data->{$meth}, "$meth correct ($data->{name})"); } } } else { foreach (1 .. 6) { ok(1, "skipping subtest $_"); } foreach (keys %{$data}) { ok(1, "skipping subtest for method $_"); } } } else { foreach (1 .. 8) { ok(0, "skipping subtest $_"); } foreach (keys %{$data}) { ok(1, "skipping subtest for method $_"); } } } # Does the mx() function work. my @mx = mx(&timeoutres, 'mx2.t.net-dns.org'); my $wanted_names = [qw(a.t.net-dns.org a2.t.net-dns.org)]; my $names = [ map { $_->exchange } @mx ]; is_deeply($names, $wanted_names, "mx() seems to be working"); # some people seem to use mx() in scalar context is(scalar mx(&timeoutres, 'mx2.t.net-dns.org'), 2, "mx() works in scalar context"); # # test that search() and query() DTRT with reverse lookups # { my @tests = ( { ip => '198.41.0.4', host => 'a.root-servers.net', }, { ip => '2001:500:1::803f:235', host => 'h.root-servers.net', }, ); foreach my $test (@tests) { foreach my $method (qw(search query)) { my $packet = $res->$method($test->{'ip'}); SKIP: { skip "Packet returned for $method is undefined, error returned: ".$res->errorstring, 2, if !defined ($packet); isa_ok($packet, 'Net::DNS::Packet'); is(lc(($packet->answer)[0]->ptrdname),lc($test->{'host'}), "$method($test->{'ip'}) works"); } } } } $res = Net::DNS::Resolver->new( domain => 't.net-dns.org', searchlist => ['t.net-dns.org', 'net-dns.org'], udp_timeout => 3, tcp_timeout => 3, ); my $ans_at=$res->send("a.t.", "A"); if ($ans_at && $ans_at->header && $ans_at->header->ancount >= 1 ){ diag "We are going to skip a bunch of checks."; diag "For unexplained reasons a query for 'a.t' resolves as "; diag "".($ans_at->answer)[0]->string ; diag "For users of 'dig' try 'dig a.t.' to test this hypothesis"; } SKIP: { skip "Query for a.t. resolves unexpectedly",35 if ($ans_at && $ans_at->header && $ans_at->header->ancount >= 1 ); #$res->debug(1); # # test the search() and query() append the default domain and # searchlist correctly. # { $res->defnames(1); $res->dnsrch(1); $res->persistent_udp(0); my @tests = ( { method => 'search', name => 'a', }, { method => 'search', name => 'a.t', }, { method => 'query', name => 'a', }, ); foreach my $test (@tests) { my $method = $test->{'method'}; my $ans = $res->$method($test->{'name'}); isa_ok($ans, 'Net::DNS::Packet'); is($ans && $ans->header && $ans->header->ancount, 1,"Correct answer count (with $method)"); my ($a) = $ans && $ans->answer; isa_ok($a, 'Net::DNS::RR::A'); is($a && lc($a->name), 'a.t.net-dns.org',"Correct name (with $method)"); } } # $res->debug(1); my $socket=$res->bgsend('a.t.net-dns.org','A'); ok(ref($socket)=~/^IO::Socket::INET(6?)$/,"Socket returned"); diag("Error condition: ".$res->errorstring ."Socket ref:".ref($socket)) unless ref($socket)=~/^IO::Socket::INET(6?)$/; my $loop=0; # burn a little CPU to get the socket ready. # I could off course used microsleep or something. while ($loop<200000){ $loop++; } $loop=0; while ($loop<6){ last if $res->bgisready($socket); sleep(1); # If burning CPU above was not sufficient. $loop++; } ok ($res->bgisready($socket),"Socket is ready"); SKIP: { skip "No socket to read from",5 unless $res->bgisready($socket); $res->debug(0); my $ans= $res->bgread($socket); ok(defined($ans->answerfrom),"Answerfrom defined" . (defined($ans->answerfrom)? "(".$ans->answerfrom .")":"") ); ok(defined($ans->answersize),"Answersize defined". (defined($ans->answersize)? "(".$ans->answersize .")":"") ); undef $socket; SKIP: { skip "Answerless packet (response from ".$ans->answerfrom. " had RCODE: ".$ans->header->rcode.")", 2 unless is ($ans->header->ancount, 1,"Correct answer count"); my ($a) = $ans->answer; isa_ok($a, 'Net::DNS::RR::A'); is(lc($a->name), 'a.t.net-dns.org',"Correct name"); } } # # test the search() and query() append the default domain and # searchlist correctly. # $res->defnames(1); $res->dnsrch(1); $res->persistent_udp(1); # $res->debug(1); my @tests = ( { method => 'search', name => 'a', }, { method => 'search', name => 'a.t', }, { method => 'query', name => 'a', }, ); $res->send("a.t.net-dns.org A"); my $sock_id= $res->{'sockets'}[AF_INET]{"UDP"}; ok($sock_id,"Persistend UDP socket identified"); foreach my $test (@tests) { my $method = $test->{'method'}; my $ans = $res->$method($test->{'name'}); is( $res->{'sockets'}[AF_INET]{"UDP"},$sock_id,"Persistent socket matches"); isa_ok($ans, 'Net::DNS::Packet'); is($ans && $ans->header && $ans->header->ancount, 1,"Correct answer count (with persistent socket and $method)"); my ($a) = $ans && $ans->answer; isa_ok($a, 'Net::DNS::RR::A'); is($a && lc($a->name), 'a.t.net-dns.org',"Correct name (with persistent socket and $method)"); } } NonFatalEnd(); Net-DNS-0.68/t/06-packet-unique-push.t0000644000175000017500000000554311710626412016575 0ustar willemwillem# $Id: 06-packet-unique-push.t 967 2011-12-08 21:47:41Z willem $ use Test::More tests => 77; use strict; BEGIN { use_ok('Net::DNS'); } #1 # Matching of RR name is not case sensitive my $packet=Net::DNS::Packet->new(); my $rr_1=Net::DNS::RR->new('bla.FOO 100 IN TXT "lower case"'); my $rr_2=Net::DNS::RR->new('bla.foo 100 IN TXT "lower case"'); my $rr_3=Net::DNS::RR->new('bla.foo 100 IN TXT "MIXED CASE"'); my $rr_4=Net::DNS::RR->new('bla.foo 100 IN TXT "mixed case"'); $packet->unique_push("answer",$rr_1); $packet->unique_push("answer",$rr_2); is($packet->header->ancount,1,"unique_push, case sensitivity test 1"); $packet->unique_push("answer",$rr_3); $packet->unique_push("answer",$rr_4); is($packet->header->ancount,3,"unique_push, case sensitivity test 2"); my $tests = sub { my ($method) = @_; my $domain = 'example.com'; my @tests = ( [ 1, Net::DNS::RR->new('foo.example.com 60 IN A 10.0.0.1'), Net::DNS::RR->new('foo.example.com 60 IN A 10.0.0.1'), ], [ 2, Net::DNS::RR->new('foo.example.com 60 IN A 10.0.0.1'), Net::DNS::RR->new('bar.example.com 60 IN A 10.0.0.1'), ], [ 1, Net::DNS::RR->new('foo.example.com 60 IN A 10.0.0.1'), Net::DNS::RR->new('foo.example.com 60 IN A 10.0.0.1'), Net::DNS::RR->new('foo.example.com 90 IN A 10.0.0.1'), ], [ 3, Net::DNS::RR->new('foo.example.com 60 IN A 10.0.0.1'), Net::DNS::RR->new('foo.example.com 60 IN A 10.0.0.2'), Net::DNS::RR->new('foo.example.com 60 IN A 10.0.0.3'), ], [ 3, Net::DNS::RR->new('foo.example.com 60 IN A 10.0.0.1'), Net::DNS::RR->new('foo.example.com 60 IN A 10.0.0.2'), Net::DNS::RR->new('foo.example.com 60 IN A 10.0.0.3'), Net::DNS::RR->new('foo.example.com 60 IN A 10.0.0.1'), ], [ 3, Net::DNS::RR->new('foo.example.com 60 IN A 10.0.0.1'), Net::DNS::RR->new('foo.example.com 60 IN A 10.0.0.2'), Net::DNS::RR->new('foo.example.com 60 IN A 10.0.0.1'), Net::DNS::RR->new('foo.example.com 60 IN A 10.0.0.4'), ], ); my %sections = ( answer => 'ancount', authority => 'nscount', additional => 'arcount', ); foreach my $try (@tests) { my ($count, @rrs) = @$try; while (my ($section, $count_meth) = each %sections) { my $packet = Net::DNS::Packet->new($domain); $packet->$method($section, @rrs); is($packet->header->$count_meth(), $count, "$section right"); } # # Now do it again calling safe_push() for each RR. # while (my ($section, $count_meth) = each %sections) { my $packet = Net::DNS::Packet->new($domain); foreach (@rrs) { $packet->$method($section, $_); } is($packet->header->$count_meth(), $count, "$section right"); } } }; $tests->('unique_push'); { my @warnings; local $SIG{__WARN__} = sub { push(@warnings, "@_"); }; $tests->('safe_push'); is(scalar @warnings, 72); ok(!grep { $_ !~ m/deprecated/ } @warnings); } Net-DNS-0.68/t/00-load.t0000644000175000017500000000301711710626412013750 0ustar willemwillem# $Id: 00-load.t 938 2011-10-28 13:27:31Z willem $ -*-perl-*- use strict; use diagnostics; use Test::More "no_plan"; BEGIN { use_ok('Net::DNS'); use_ok('Net::DNS::Resolver::Recurse'); use_ok('Net::DNS::Nameserver'); use_ok('Net::DNS::Resolver::Cygwin'); # can't test windows, has registry stuff } diag("\nThese tests were run using:\n"); diag("Net::DNS::VERSION:\t$Net::DNS::VERSION"); diag("Net::DNS::SEC seems to be available") if $Net::DNS::DNSSEC; diag("set environment variable NET_DNS_DEBUG to get all versions"); sub is_rr_loaded { my $rr = shift; return $INC{"Net/DNS/RR/$rr.pm"} ? 1 : 0; } # # Check on-demand loading using this list of RR packages my @rrs = qw( CNAME HINFO MB MG MINFO MR MX NULL NS PTR SOA TXT A AFSDB DNAME KX NAPTR PX RP RT SRV AAAA APL CERT DHCID EID HIP IPSECKEY ISDN LOC NIMLOC OPT SPF SSHFP TKEY TSIG X25 ); # # Make sure that we start with none of the RR packages loaded foreach my $rr (@rrs) { ok( !is_rr_loaded($rr), "not yet loaded Net::DNS::RR::$rr" ); } # # Check that each RR package is loaded on demand local $SIG{__WARN__} = sub { }; # suppress warnings foreach my $rr (@rrs) { my $object = eval { new Net::DNS::RR( name => '.', type => $rr ); }; diag($@) if $@; # report exceptions ok( is_rr_loaded($rr), "loaded package Net::DNS::RR::$rr" ); } # # Check that Net::DNS symbol table was imported correctly { no strict 'refs'; foreach my $sym (@Net::DNS::EXPORT) { ok( defined &{$sym}, "$sym is imported" ); } } ############## #done_testing() ############## Net-DNS-0.68/t/05-rr-txt.t0000644000175000017500000001024711710626412014301 0ustar willemwillem# $Id: 05-rr-txt.t 901 2011-09-27 20:33:41Z willem $ -*-perl-*- use Test::More tests => 38; use strict; use Data::Dumper; my $uut; BEGIN { use_ok('Net::DNS'); } #------------------------------------------------------------------------------ # Canned data. #------------------------------------------------------------------------------ my $name = 'foo.example.com'; my $class = 'IN'; my $type = 'TXT'; my $ttl = 43201; my $rr_base = join(' ', $name, $ttl, $class, $type, " " ); #Stimulus, expected response, and test name: my @Testlist = ( { # 2-5 stim => q|""|, rdatastr => q|""|, char_str_list_r => ['',], descr => 'Double-quoted null string', }, { # 6-9 stim => q|''|, rdatastr => q|""|, char_str_list_r => ['',], descr => 'Single-quoted null string', }, { # 10-13 stim => qq|" \t"|, rdatastr => qq|" \t"|, char_str_list_r => [ qq| \t|, ], descr => 'Double-quoted whitespace string', }, { # 14-17 stim => q|noquotes|, rdatastr => q|"noquotes"|, char_str_list_r => [ q|noquotes|, ], descr => 'unquoted single string', }, { # 18-21 stim => q|"yes_quotes"|, rdatastr => q|"yes_quotes"|, char_str_list_r => [ q|yes_quotes|, ], descr => 'Double-quoted single string', }, { # 22-25 stim => q|"escaped \" quote"|, rdatastr => q|"escaped \" quote"|, char_str_list_r => [ q|escaped " quote|, ], descr => 'Quoted, escaped double-quote', }, { # 26-29 stim => q|two tokens|, rdatastr => q|"two" "tokens"|, char_str_list_r => [ q|two|, q|tokens|, ], descr => 'Two unquoted strings', }, { # 30-33 stim => q|"missing quote|, rdatastr => q||, char_str_list_r => [], descr => 'Unbalanced quotes work', }, { # 31-34 stim => q|\;|, rdatastr => q|"\;"|, char_str_list_r => [ q|;|, ], descr => 'Semi Colon', }, ); #------------------------------------------------------------------------------ # Run the tests #------------------------------------------------------------------------------ foreach my $test_hr ( @Testlist ) { ok( $uut = Net::DNS::RR->new($rr_base . $test_hr->{'stim'}), $test_hr->{'descr'} . " -- Stimulus " ); is($uut->rdatastr(), $test_hr->{'rdatastr'}, $test_hr->{'descr'} . " -- Response ( rdatastr ) " ); my @list = $uut->char_str_list(); print "\n\n"; print $test_hr->{'stim'}; print "\n--------------\n"; print Dumper $uut; print "\n==============================\n"; is_deeply(\@list, $test_hr->{'char_str_list_r'}, $test_hr->{'descr'} . " -- char_str_list equality" ) ; } my $string1 = q|no|; my $string2 = q|quotes|; my $rdata = pack("C", length $string1) . $string1; $rdata .= pack("C", length $string2) . $string2; # RR->new_from_hash() drops stuff straight into the hash and # re-blesses it, breaking encapsulation. my %work_hash = ( Name => $name, TTL => $ttl, Class => $class, Type => $type, ); # Don't break RR->new_from_hash (e.i. "See the manual pages for each RR # type to see what fields the type requires."). $work_hash{'txtdata'} = q|no quotes|; ok( $uut = Net::DNS::RR->new(%work_hash), # 30 "RR->new_from_hash with txtdata -- Stimulus"); is( $uut->rdatastr(), q|"no" "quotes"|, # 31 "RR->new_from_hash with txtdata -- Response (rdatastr())"); is( $uut->rr_rdata(), $rdata , "TXT->rr_rdata" ); # 32 # And HINFO inherits its parsing from TXT and should therefore work OK as well my $rr = Net::DNS::RR->new("SRI-NIC.ARPA. HINFO 'DEC-2060 2006' TOPS20"); is($rr->cpu,"DEC-2060 2006","Character string in quotes 1"); is($rr->os,"TOPS20","Character string in quotes 2"); my $rr2 = eval{ Net::DNS::RR->new("SRI-NIC.ARPA. HINFO DEC-2060 2006 TOPS20") }; ok( !defined($rr2), "Failed parsing of to many HINFO strings"); my $rr3 = Net::DNS::RR->new("SRI-NIC.ARPA. HINFO DEC-2060 TOPS20"); is($rr3->cpu,"DEC-2060","Character string in quotes 3"); is($rr3->os,"TOPS20","Character string in quotes 4"); my $TXTrr=Net::DNS::RR->new('txt2.t.net-dns.org. 60 IN TXT "Test1 \" \; more stuff" "Test2"'); is ( ($TXTrr->char_str_list())[0], 'Test1 " ; more stuff', "char_str_list[0] returns unescaped ;"); is ( $TXTrr->rdatastr,'"Test1 \" \; more stuff" "Test2"', "string method returns escaped ;"); Net-DNS-0.68/t/06-update.t0000644000175000017500000002170111710626412014321 0ustar willemwillem# $Id: 06-update.t 966 2011-12-06 21:05:59Z willem $ -*-perl-*- use Test::More tests => 72; use strict; BEGIN { use_ok('Net::DNS'); } #1 sub is_empty { local $_ = shift; return 0 unless defined $_; return 1 unless length $_; return 1 if /\\# 0/; return 1 if /; no data/; return 1 if /; rdlength = 0/; return 0; } #------------------------------------------------------------------------------ # Canned data. #------------------------------------------------------------------------------ my $zone = "example.com"; my $name = "foo.example.com"; my $class = "HS"; my $class2 = "CH"; my $type = "A"; my $ttl = 43200; my $rdata = "10.1.2.3"; my $rr = undef; #------------------------------------------------------------------------------ # Packet creation. #------------------------------------------------------------------------------ my $packet = Net::DNS::Update->new($zone, $class); my $z = ($packet->zone)[0]; ok($packet, 'new() returned packet'); #2 is($packet->header->opcode, 'UPDATE', 'header opcode correct'); #3 is($z->zname, $zone, 'zname correct'); #4 is($z->zclass, $class, 'zclass correct'); #5 is($z->ztype, 'SOA', 'ztype correct'); #6 #------------------------------------------------------------------------------ # RRset exists (value-independent). #------------------------------------------------------------------------------ $rr = yxrrset("$name $class $type"); ok($rr, 'yxrrset() returned RR'); #7 is($rr->name, $name, 'yxrrset - right name'); #8 is($rr->ttl, 0, 'yxrrset - right TTL'); #9 is($rr->class, 'ANY', 'yxrrset - right class'); #10 is($rr->type, $type, 'yxrrset - right type'); #11 ok(is_empty($rr->rdatastr), 'yxrrset - data empty'); #12 undef $rr; #------------------------------------------------------------------------------ # RRset exists (value-dependent). #------------------------------------------------------------------------------ $rr = yxrrset("$name $class $type $rdata"); ok($rr, 'yxrrset() returned RR'); #13 is($rr->name, $name, 'yxrrset - right name'); #14 is($rr->ttl, 0, 'yxrrset - right TTL'); #15 is($rr->class, $class, 'yxrrset - right class'); #16 is($rr->type, $type, 'yxrrset - right type'); #17 is($rr->rdatastr, $rdata, 'yxrrset - right data'); #18 undef $rr; #------------------------------------------------------------------------------ # RRset does not exist. #------------------------------------------------------------------------------ $rr = nxrrset("$name $class $type"); ok($rr, 'nxrrset() returned RR'); #19 is($rr->name, $name, 'nxrrset - right name'); #20 is($rr->ttl, 0, 'nxrrset - right ttl'); #21 is($rr->class, 'NONE', 'nxrrset - right class'); #22 is($rr->type, $type, 'nxrrset - right type'); #23 ok(is_empty($rr->rdatastr), 'nxrrset - data empty'); #24 undef $rr; #------------------------------------------------------------------------------ # Name is in use. #------------------------------------------------------------------------------ $rr = yxdomain("$name $class"); ok($rr, 'yxdomain() returned RR'); #25 is($rr->name, $name, 'yxdomain - right name'); #26 is($rr->ttl, 0, 'yxdomain - right ttl'); #27 is($rr->class, 'ANY', 'yxdomain - right class'); #28 is($rr->type, 'ANY', 'yxdomain - right type'); #29 ok(is_empty($rr->rdatastr), 'yxdomain - data empty'); #30 undef $rr; #------------------------------------------------------------------------------ # Name is not in use. #------------------------------------------------------------------------------ $rr = nxdomain("$name $class"); ok($rr, 'nxdomain() returned RR'); #31 is($rr->name, $name, 'nxdomain - right name'); #32 is($rr->ttl, 0, 'nxdomain - right ttl'); #33 is($rr->class, 'NONE', 'nxdomain - right class'); #34 is($rr->type, 'ANY', 'nxdomain - right type'); #35 ok(is_empty($rr->rdatastr), 'nxdomain - data empty'); #36 undef $rr; #------------------------------------------------------------------------------ # Name is not in use. (No Class) #------------------------------------------------------------------------------ $rr = nxdomain("$name"); ok($rr, 'nxdomain() returned RR'); #31 is($rr->name, $name, 'nxdomain - right name'); #32 is($rr->ttl, 0, 'nxdomain - right ttl'); #33 is($rr->class, 'NONE', 'nxdomain - right class'); #34 is($rr->type, 'ANY', 'nxdomain - right type'); #35 ok(is_empty($rr->rdatastr), 'nxdomain - data empty'); #36 undef $rr; #------------------------------------------------------------------------------ # Add to an RRset. #------------------------------------------------------------------------------ $rr = rr_add("$name $ttl $class $type $rdata"); ok($rr, 'rr_add() returned RR'); #37 is($rr->name, $name, 'rr_add - right name'); #38 is($rr->ttl, $ttl, 'rr_add - right ttl'); #39 is($rr->class, $class, 'rr_add - right class'); #40 is($rr->type, $type, 'rr_add - right type'); #41 is($rr->rdatastr, $rdata, 'rr_add - right data'); #42 undef $rr; #------------------------------------------------------------------------------ # Delete an RRset. #------------------------------------------------------------------------------ $rr = rr_del("$name $class $type"); ok($rr, 'rr_del() returned RR'); #43 is($rr->name, $name, 'rr_del - right name'); #44 is($rr->ttl, 0, 'rr_del - right ttl'); #45 is($rr->class, 'ANY', 'rr_del - right class'); #46 is($rr->type, $type, 'rr_del - right type'); #47 ok(is_empty($rr->rdatastr), 'rr_del - data empty'); #48 undef $rr; #------------------------------------------------------------------------------ # Delete All RRsets From A Name. #------------------------------------------------------------------------------ $rr = rr_del("$name $class"); ok($rr, 'rr_del() returned RR'); #49 is($rr->name, $name, 'rr_del - right name'); #50 is($rr->ttl, 0, 'rr_del - right ttl'); #51 is($rr->class, 'ANY', 'rr_del - right class'); #52 is($rr->type, 'ANY', 'rr_del - right type'); #53 ok(is_empty($rr->rdatastr), 'rr_del - data empty'); #54 undef $rr; #------------------------------------------------------------------------------ # Delete An RR From An RRset. #------------------------------------------------------------------------------ $rr = rr_del("$name $class $type $rdata"); ok($rr, 'rr_del() returned RR'); #55 is($rr->name, $name, 'rr_del - right name'); #56 is($rr->ttl, 0, 'rr_del - right ttl'); #57 is($rr->class, 'NONE', 'rr_del - right class'); #58 is($rr->type, $type, 'rr_del - right type'); #59 is($rr->rdatastr, $rdata, 'rr_del - right data'); #60 undef $rr; #------------------------------------------------------------------------------ # Make sure RRs in an update packet have the same class as the zone, unless # the class is NONE or ANY. #------------------------------------------------------------------------------ $packet = Net::DNS::Update->new($zone, $class); ok($packet, 'packet created'); #61 $packet->push("pre", yxrrset("$name $class $type $rdata")); $packet->push("pre", yxrrset("$name $class2 $type $rdata")); $packet->push("pre", yxrrset("$name $class2 $type")); $packet->push("pre", nxrrset("$name $class2 $type")); my @pre = $packet->pre; is(scalar(@pre), 4, 'pushed inserted correctly'); #62 is($pre[0]->class, $class, 'first class right'); #63 is($pre[1]->class, $class, 'second class right'); #64 is($pre[2]->class, 'ANY', 'third class right'); #65 is($pre[3]->class, 'NONE', 'fourth class right'); #66 Net-DNS-0.68/t/05-rr-unknown.t0000644000175000017500000000632311710626412015161 0ustar willemwillem# $Id: 05-rr-unknown.t 896 2011-09-20 12:35:04Z willem $ -*-perl-*- # # RFC 3597 Unknown typecode implemntation test code. # O.M. Kolkman RIPE NCC. # use Test::More tests => 19; use strict; BEGIN { use_ok('Net::DNS'); } is(Net::DNS::typesbyname('TYPE10226'), 10226, 'typesbyname(TYPE10226) returns 10226'); is(Net::DNS::typesbyval(10226), 'TYPE10226','typesbyval(10226) returns TYPE10226'); is(Net::DNS::typesbyval(1), 'A',' typesbyval(1) returns A'); is(Net::DNS::typesbyval(Net::DNS::typesbyname('TYPE001')), 'A', 'typesbyval(typebyname(TYPE001)) returns A'); { ## check for exception if type number too large my $large = 65536; eval { Net::DNS::typesbyval($large); }; my $exception = $1 if $@ =~ /^(.+)\n/; ok( $exception ||= '', "Net::DNS::typesbyval($large)\t[$exception]" ); } is(Net::DNS::classesbyname('CLASS124'), 124, 'classesbyname(CLASS124) returns 124'); is(Net::DNS::classesbyval(125), 'CLASS125','classesbyval(125) returns CLASS125'); is(Net::DNS::classesbyval(1), 'IN', 'classesbyval(1) returns IN'); is(Net::DNS::classesbyval(Net::DNS::classesbyname('CLASS04')), 'HS', 'classesbyval(typebyname(CLASS04)) returns HS'); { ## check for exception if class number too large my $large = 65536; eval { Net::DNS::classesbyval($large); }; my $exception = $1 if $@ =~ /^(.+)\n/; ok( $exception ||= '', "Net::DNS::classesbyval($large)\t[$exception]" ); } { my $rr = Net::DNS::RR->new('e.example CLASS01 TYPE01 10.0.0.2'); is($rr->type, 'A', 'TYPE01 parsed OK'); is($rr->class,'IN', 'CLASS01 parsed OK'); } { my $rr = Net::DNS::RR->new('e.example IN A \# 4 0A0000 01 '); is($rr->address,'10.0.0.1', 'Unknown RR representation for A parsed OK'); } { ## check for exception if RFC3597 hexadecimal data too long eval { new Net::DNS::RR('e.example IN A \# 4 0A0000 01 11') }; my $exception = $1 if $@ =~ /^(.+)\n/; ok( $exception ||= '', "hexadecimal string not declared length:\t[$exception]" ); } { my $rr = Net::DNS::RR->new('e.example IN TYPE4555 \# 4 0A0000 01 '); is($rr->string, 'e.example. 0 IN TYPE4555 \# 4 0a000001', 'Fully unknown RR parsed correctly'); } { my $rr4 = Net::DNS::RR->new('e.example CLASS122 TYPE4555 \# 4 0A0000 01 '); is($rr4->string, 'e.example. 0 CLASS122 TYPE4555 \# 4 0a000001', 'Fully unknown RR in unknown CLASS parsed correctly'); } my $UUencodedPacket=' 02 79 85 00 00 01 00 01 00 01 00 01 04 54 45 53 54 07 65 78 61 6d 70 6c 65 03 63 6f 6d 00 00 ff 00 01 c0 0c 30 39 00 01 00 00 00 7b 00 0a 11 22 33 44 55 aa bb cc dd ee c0 11 00 02 00 01 00 00 03 84 00 05 02 6e 73 c0 11 c0 44 00 01 00 01 00 00 03 84 00 04 7f 00 00 01'; $UUencodedPacket =~ s/\s*//g; my $packetdata = pack('H*',$UUencodedPacket); my $packet = Net::DNS::Packet->new(\$packetdata); my $string_representation = ($packet->answer)[0]->string; $string_representation =~ s/\s+/ /g, is ( $string_representation, 'TEST.example.com. 123 IN TYPE12345 \# 10 1122334455aabbccddee', 'Packet read from a packet dumped by bind...' ); my $rr = Net::DNS::RR->new('atma.example IN TYPE34 \# 4 0A0000 01 '); is($rr->string,'atma.example. 0 IN ATMA \# 4 0a000001',"ATMA, is known but undefined"); Net-DNS-0.68/t/05-rr-rrsort.t0000644000175000017500000000754711710626412015026 0ustar willemwillem# $Id: 05-rr-rrsort.t 682 2007-09-27 07:50:27Z olaf $ -*-perl-*- use Test::More; use strict; use Net::DNS qw(rrsort); plan tests => 22; my $rr1=Net::DNS::RR->new("example.com. 600 IN SRV 0 0 5060 A.example.com."); is(ref($rr1),"Net::DNS::RR::SRV","SRV RR1 created"); my $rr2=Net::DNS::RR->new("example.com. 600 IN SRV 1 0 5060 A.example.com."); is(ref($rr2),"Net::DNS::RR::SRV","SRV RR2 created"); my $rr3=Net::DNS::RR->new("example.com. 600 IN SRV 2 0 5060 A.example.com."); is(ref($rr3),"Net::DNS::RR::SRV","SRV RR3 created"); my $rr4=Net::DNS::RR->new("example.com. 600 IN SRV 3 0 5060 A.example.com."); is(ref($rr4),"Net::DNS::RR::SRV","SRV RR4 created"); my $rr5=Net::DNS::RR->new("example.com. 600 IN SRV 3 1 5060 A.example.com."); is(ref($rr5),"Net::DNS::RR::SRV","SRV RR5 created"); my $rr6=Net::DNS::RR->new("example.com. 600 IN SRV 3 2 5060 A.example.com."); is(ref($rr6),"Net::DNS::RR::SRV","SRV RR6 created"); my $rr7=Net::DNS::RR->new("example.com. 600 IN SRV 1 3 5070 A.example.com."); is(ref($rr7),"Net::DNS::RR::SRV","SRV RR7 created"); my $rr8=Net::DNS::RR->new("example.com. 600 IN SRV 3 3 5070 A.example.com."); is(ref($rr8),"Net::DNS::RR::SRV","SRV RR8 created"); my $rr9=Net::DNS::RR->new("example.com. 600 IN A 192.168.0.1"); is(ref($rr9),"Net::DNS::RR::A","A RR9 created"); my @rrarray=($rr1, $rr2, $rr3, $rr4, $rr5, $rr6, $rr7, $rr8, $rr9); my @expectedrdata=($rr1, $rr2, $rr3, $rr7, $rr4, $rr5, $rr6, $rr8); my @expectedpriority=($rr1, $rr7, $rr2, $rr3, $rr8, $rr6, $rr5, $rr4); my @expectedweight=($rr7, $rr8, $rr6, $rr5, $rr1, $rr2, $rr3, $rr4); is (rrsort("SRV"),undef,"rrsort returns rrerly whith undefined arguments"); is (rrsort("SRV",@rrarray),8,"rrsort returns properly whith undefined attribute (1)"); is (rrsort("SRV",,@rrarray),8,"rrsort returns properly whith undefined attribute (2)"); is (rrsort("SRV","",@rrarray),8,"rrsort returns properly whith undefined attribute (3)"); my @prioritysorted= rrsort("SRV","priority",@rrarray); my @weightsorted= rrsort("SRV","weight",@rrarray); my @defaultsorted= rrsort("SRV",@rrarray); my @portsorted= rrsort("SRV","port",@rrarray); my @foosorted= rrsort("SRV","foo",@rrarray); is (@foosorted,8,"rrsort returns properly whith undefined attribute (3)"); is ( @prioritysorted,8,"rrsort correctly maintains RRs test 2"); ok (eq_array(\@expectedpriority, \@prioritysorted), "Sorting on SRV priority works"); ok (eq_array(\@expectedpriority, \@defaultsorted), "Default SRV sort works"); ok (eq_array(\@expectedweight, \@weightsorted), "Weight sorted SRV sort works"); is (rrsort("A","priority",@rrarray),1,"rrsort correctly maintains RRs test 1"); is (rrsort("MX","priority",@rrarray),undef,"rrsort correctly maintains RRs test 3"); # # Test with MX RRs. # my $mxrr1=Net::DNS::RR->new("example.com. 600 IN MX 10 mx1.example.com"); my $mxrr2=Net::DNS::RR->new("example.com. 600 IN MX 6 mx2.example.com"); my $mxrr3=Net::DNS::RR->new("example.com. 600 IN MX 66 mx3.example.com"); my $mxrr4=Net::DNS::RR->new("example.com. 600 IN RT 6 rt1.example.com"); my @mxrrarray=($mxrr1, $mxrr2, $mxrr3, $mxrr4); my @expectedmxarray=($mxrr2,$mxrr1,$mxrr3); my @sortedmxarray=rrsort("MX",@mxrrarray); ok (eq_array(\@expectedmxarray,\@sortedmxarray),"MX sorting"); my $nsrr1=Net::DNS::RR->new("example.com. 600 IN NS ns2.example.com"); my $nsrr2=Net::DNS::RR->new("example.com. 600 IN NS ns4.example.com"); my $nsrr3=Net::DNS::RR->new("example.com. 600 IN NS ns1.example.com"); my $nsrr4=Net::DNS::RR->new("example.com. 600 IN RT 6 rt1.example.com"); my @nsrrarray=($nsrr1, $nsrr2, $nsrr3, $nsrr4); my @expectednsarray=($nsrr3,$nsrr1,$nsrr2); my @sortednsarray=rrsort("NS",@nsrrarray); ok (eq_array(\@expectednsarray,\@sortednsarray),"NS sorting"); Net-DNS-0.68/t/13-udp-trunc.t0000644000175000017500000001620311710626412014757 0ustar willemwillem# $Id: 13-udp-trunc.t 961 2011-11-22 13:31:10Z willem $ -*-perl-*- # Bulk of this code is contributed by Aaron Crane in 2008 # via rt.cpan.org ticket 33547 # Portions (c) 2009 Olaf Kolkman use Test::More; use strict; use Data::Dumper; my $ZONE = 'example.com'; use_ok('Net::DNS::Nameserver'); use vars qw( $Address $TestPort $numberoftests ); BEGIN{ $TestPort = 5334; $Address = "127.0.0.1"; $numberoftests=100; if( eval {require IO::Socket;} ){ #Try binding to the test addresses .. diag ("Testing availability of $Address"); my $s = IO::Socket::INET->new(Proto => 'udp', LocalAddr => $Address, LocalPort => $TestPort ); unless ($s){ diag ("This test needs ".join (" ",$Address). " to be configured on your system, and port $TestPort needs to be available for binding"); plan skip_all => "$Address has not been configured"; exit; } close ($s); plan tests => $numberoftests; }else{ plan skip_all => 'Some modules required for this test are not available (dont\'t worry about this)'; exit; } } { my @full_response; my $ns = Net::DNS::Nameserver->new( LocalPort => $TestPort, LocalAddr => $Address, ReplyHandler => sub { NOERROR => @full_response }, ); for (trad_query(), edns_query(1024), edns_query(2048)) { my ($query, $size) = @$_; for my $n ( [1, 1, 1], [5, 1, 1], [10, 1, 1], [1, 1, 30], [40, 40, 40], [50, 1, 1], [1, 50, 1], [20, 20, 1], [20, 1, 50], [60, 60, 60], [60, 100, 60], ) { @full_response = make_response($n); my $notcomp=Net::DNS::Packet->new(); $notcomp->push("question", $query->question); my ($ans, $auth, $add)=@full_response; $notcomp->push("answer", @$ans) if $ans; $notcomp->push("authority", @$auth) if $auth; $notcomp->push("additional", @$add) if $add; #$notcomp->print; my $socket = Mock::UDP->new($query->data); $ns->udp_connection($socket); my $reply_data = $socket->output; my $reply = Net::DNS::Packet->new(\$reply_data); #$reply->print; cmp_ok(length $reply_data, '<=', $size, "UDP-$size reply for\t($n->[0] , $n->[1], $n->[2])\t records short enough ($size: ".length($notcomp->data) ."->". length ( $reply_data ) . ")") || $reply->print; ok($reply, "UDP-$size reply for\t($n->[0] , $n->[1], $n->[2])\t received answer"); my $got = reply_records($reply); my $expected = response_records($query, @full_response); ok(is_prefix($reply->header->tc, $got, $expected), "UDP-$size reply for\t($n->[0] , $n->[1], $n->[2])\t records complete or sanely truncated"); } } } sub trad_query { return [Net::DNS::Packet->new($ZONE), 512]; } sub edns_query { my $size = shift; my $edns_rr = Net::DNS::RR->new(type => 'OPT', class => $size, name => ''); my $query = Net::DNS::Packet->new($ZONE); $query->push(additional => $edns_rr); return [$query, $size]; } sub reply_records { my ($reply) = @_; my @records; for my $section (qw) { push @records, map { [$section => $_] } $reply->$section; } return \@records; } sub response_records { my ($query, @response) = @_; unshift @response, [$query->question]; my @records; for my $section (qw) { push @records, map { [$section => $_] } @{ shift @response }; } return \@records; } sub is_prefix { my ($truncated, $got_list, $expected_list) = @_; die 'TEST BUG: no records expected' if !@$expected_list; if (@$got_list > @$expected_list) { diag("Most peculiar: got too many records"); return 0; } my @seen; my $rr_got; my $rr_exp; # Start investigating the additonal section # if we find an RR with a certain (name,class,type) in the additonal section (in got) then # we expect all RRs from from that (name,class,type) from the expected array to be in the packet. # if a certain RR (name,class,type) from the expected array is not found in the packet than all # RRs from that set expect to be stripped. foreach my $tst ( @$expected_list ){ next unless $tst->[0] eq "additional"; $rr_exp->{$tst->[1]->name. "--". $tst->[1]->class. "--". $tst->[1]->type}{$tst->[1]->rdatastr} = 1; } foreach my $tst ( @$got_list ){ next unless $tst->[0] eq "additional"; $rr_got->{$tst->[1]->name. "--". $tst->[1]->class. "--". $tst->[1]->type}{$tst->[1]->rdatastr} = 1; } foreach my $a (keys %$rr_exp){ if (defined $rr_got->{$a}){ foreach my $b (keys %{$rr_got->{$a}}){ if (defined($rr_exp->{$a}->{$b})){ delete $rr_got->{$a}->{$b}; delete $rr_exp->{$a}->{$b}; } delete $rr_got->{$a} unless (keys %{$rr_got->{$a}}); delete $rr_exp->{$a} unless (keys %{$rr_exp->{$a}}); } }else{ delete $rr_exp->{ $a } } } if (my @a=keys %$rr_exp){ foreach my $a ( @a) { diag ("One RR of name-class-type $a got stripped from the packet while leaving others in the additional section"); } return 0; } if (my @b=keys %$rr_got){ foreach my $b ( @b) { diag ("One RR of name-class-type $b did not get stripped from the additional section"); } return 0; } for (;;) { #return !$truncated == !@$expected_list if !@$got_list; last if ! @$got_list; my $got = shift @$got_list; push @seen, $got; my $expected = shift @$expected_list; my ($got_s, $expected_s) = map { $_->[1]->string } $got, $expected; if ($got->[0] eq "additional" && $expected->[0] eq "additional"){ # this is the situation where we are looking at the truncated additional section. # Since there are still records left the the TC bit should not be set. if ($truncated){ diag ("There are still records in the additonal section but the truncation bit seems set"); return 0; } next; }elsif ($got->[0] ne $expected->[0] || $got_s ne $expected_s) { diag("Got[$got->[0] $got_s] Expected[$expected->[0] $expected_s]"); return 0; } } return(1); } sub make_response { my ($n,$m,$p) = @{shift()}; # create sets of nameservers ns0... ns2 my @ans = map { Net::DNS::RR->new("$ZONE 9 IN A 10.0.0.$_") } 1 .. $n; my @auth = map { Net::DNS::RR->new("$ZONE 9 IN NS ns". $_%3 .".$ZONE") } 1 .. $m; my @add = map { Net::DNS::RR->new("ns". $_%3 .".$ZONE 9 IN A 10.0.1.".$_%256) } 1 .. $p; return \@ans, \@auth, \@add; } { package Mock::UDP; sub new { my ($class, $data) = @_; return bless { input => $data, output => '', }, $class; } sub peerhost { '127.0.0.1' } sub peerport { 65534 } sub output { $_[0]{output} } sub sockhost {$main::Address} sub sockport {$main::TestPort} sub recv { my ($self, $buf, $len) = @_; return if $self->{input} eq ''; my $data = substr $self->{input}, 0, $len, ''; $_[1] = $data; } sub send { my ($self, $data) = @_; $self->{output} .= $data; 1; } } Net-DNS-0.68/t/01-resolver-opt.t0000644000175000017500000000516011710626412015474 0ustar willemwillem# $Id: 01-resolver-opt.t 737 2008-12-17 11:32:10Z olaf $ -*-perl-*- use Test::More tests => 62; use strict; use File::Spec; BEGIN { use_ok('Net::DNS'); } # .txt because this test will run under windows, unlike the other file # configuration tests. my $test_file = File::Spec->catfile('t', 'custom.txt'); my $res = Net::DNS::Resolver->new(config_file => $test_file); ok($res, 'new() returned something'); isa_ok($res, 'Net::DNS::Resolver', 'new() returns an object of the correct class.'); ok(scalar $res->nameservers, 'nameservers() works'); my @servers = $res->nameservers; is($servers[0], '10.0.1.42', 'Nameserver set correctly'); is($servers[1], '10.0.2.42', 'Nameserver set correctly'); my @search = $res->searchlist; is($search[0], 'alt.net-dns.org', 'Search set correctly' ); is($search[1], 'ext.net-dns.org', 'Search set correctly' ); is($res->domain, 't2.net-dns.org', 'Local domain works' ); undef $res; eval { $res = Net::DNS::Resolver->new(config_file => 'nosuch.txt'); }; ok($@, 'Error thrown trying to open non-existant file.'); ok(!$res, 'Net::DNS::Resolver->new returned undef'); # # Check that we can set things in new() # undef $res; my %test_config = ( nameservers => ['10.0.0.1', '10.0.0.2'], port => 54, srcaddr => '10.1.0.1', srcport => 53, domain => 'net-dns.org', searchlist => ['net-dns.org', 't.net-dns.org'], retrans => 6, retry => 5, usevc => 1, stayopen => 1, igntc => 1, recurse => 0, defnames => 0, dnsrch => 0, debug => 1, tcp_timeout => 60, udp_timeout => 60, persistent_tcp => 1, dnssec => 1, cdflag => 0, adflag => 1, ); $res = Net::DNS::Resolver->new(%test_config); foreach my $item (keys %test_config) { is_deeply($res->{$item}, $test_config{$item}, "$item is correct"); } # # Check that new() is vetting things properly. # foreach my $test (qw(nameservers searchlist)) { foreach my $input ({}, 'string', 1, \1, undef) { undef $res; eval { $res = Net::DNS::Resolver->new($test => $input); }; ok($@, 'Invalid input caught'); ok(!$res, 'No resolver returned'); } } undef $res; my %bad_input = ( tsig_rr => 'set', errorstring => 'set', answerfrom => 'set', answersize => 'set', querytime => 'set', axfr_sel => 'set', axfr_rr => 'set', axfr_soa_count => 'set', udppacketsize => 'set', cdflag => 'set', ); $res = Net::DNS::Resolver->new(%bad_input); foreach my $key (keys %bad_input) { isnt($res->{$key}, 'set', "$key is not set"); } Net-DNS-0.68/t/05-rr.t0000644000175000017500000001330011710626412013455 0ustar willemwillem# $Id: 05-rr.t 822 2009-11-30 17:37:30Z olaf $ -*-perl-*- use Test::More; use strict; use t::TestData; use Net::DNS; use vars qw( $HAS_DNSSEC $HAS_DLV $HAS_NSEC3 $HAS_NSEC3PARAM); use Data::Dumper; my $keypathrsa="Kexample.com.+005+24866.private"; my $rsakeyrr; BEGIN { my $methods=0; my $number=0; foreach my $rr ( @rrs ){ $methods += keys(%$rr); } diag "Number of RRs: ". @rrs . " Number of methods: ".$methods."\n"; $number= 3 + 2*$methods + 6*scalar @rrs; if( eval {require Net::DNS::SEC;} ){ $HAS_DNSSEC=1; if ( defined($Net::DNS::SEC::SVNVERSION) && $Net::DNS::SEC::SVNVERSION > 619 ) { $HAS_NSEC3PARAM=1; plan tests => $number; # Hook }else{ plan tests => $number; } }else{ $HAS_DNSSEC=0; plan tests => $number- @rrs -1 ; } }; if ($HAS_DNSSEC){ # Create key material diag "The suite will run additonal DNSSEC tests"; my $privrsakey= << 'ENDRSA' ; Private-key-format: v1.2 Algorithm: 5 (RSASHA1) Modulus: osG7zULAQoU3HxVnQl0dj8pLCcxA4ZQk9lgSzd+Q5GvhQYPS4vtnBRvwQDPTckfINqHYbxLQBZGYyl3n0ZQ0W5GDUlnDkeKk+2fe0UIbArY+xkODYGBmv6VGDk1K0kc7mH6cYHUciEtPMdyzYa9hIPfPDp2IE0+BRpr3hPkRnLE= PublicExponent: Aw== PrivateExponent: bIEn3iyALFjPag5E1ui+X9wyBogrQQ1t+ZAMiT+17Z1A1lfh7KeaA2f1gCKM9tqFecE69Lc1WQu7MZPv4Q14O/uDO/th5aF6oUL6kYYiSkbmxZ138w6g/PRh+Y/F135Hz8nVyTLrbmo+l5tjiaN5LOgUjvYYwSR3k1FFhgW3zks= Prime1: zF8a/5xhYpBZH7uVB0xxuo7FbepslQnCSudXRd+1KFmpJ6z4XSDEJVl/XngaVw4j4IvHL9FpjF8JkH1PUn2c7Q== Prime2: y99dYRRYDdywY6th8ZshkVXYaWUHNWuB68vAr8JZ4XY3qC66S5qehpfPFSX44x05uyRw/JGIDG7gEJHsngBKVQ== Exponent1: iD9nVRLrlwrmFSe4r4hL0bSDnpxIY1vW3Jo6LpUjcDvGGnNQPhXYGOZU6aVm5LQX6wfaH+DxCD9btajfjFO98w== Exponent2: h+o+QLg6s+h1l8eWoRIWYOPlm5ivePJWnTKAdSw766QlGsnRh7xprw/fY26l7L4mfML1/bZasvSVYGFIaVWG4w== Coefficient: BV4xfdcDiyLKBr6647EUocgAziN3qfVsfJc0DdJjYW3VnuECVvNo8Q2ehAYTAwdzNRjBhwB7ZV3Mi6+S8OXFTQ== ENDRSA open (RSA,">$keypathrsa") or die "Could not open $keypathrsa"; print RSA $privrsakey; close(RSA); $rsakeyrr=new Net::DNS::RR ("example.com. IN DNSKEY 256 3 5 AQOiwbvNQsBChTcfFWdCXR2PyksJzEDhlCT2WBLN35Dka+FBg9Li+2cF G/BAM9NyR8g2odhvEtAFkZjKXefRlDRbkYNSWcOR4qT7Z97RQhsCtj7G Q4NgYGa/pUYOTUrSRzuYfpxgdRyIS08x3LNhr2Eg988OnYgTT4FGmveE +RGcsQ== "); ok( $rsakeyrr, 'RSA public key created'); # test 5 if ($HAS_DLV){ diag("DLV Supported in this version of Net::DNS::SEC"); my $dlv=new Net::DNS::RR ("dskey.example.com. 86400 IN DS 60485 5 2 ( D4B7D520E7BB5F0F67674A0C CEB1E3E0614B93C4F9E99B83 83F6A1E4469DA50A )"); ok( $dlv, "DLV RR created"); } if ($HAS_NSEC3PARAM){ diag("NSEC3PARAM / NSEC3 Supported in this version of Net::DNS::SEC (no tests yet)"); } } BEGIN { use_ok('Net::DNS'); } #------------------------------------------------------------------------------ # Canned data. #------------------------------------------------------------------------------ my $name = "foo.example.com"; my $class = "IN"; my $ttl = 43200; #------------------------------------------------------------------------------ # Create the packet and signatures (if DNSSEC is available.) #------------------------------------------------------------------------------ my @rrsigs; my $packet = Net::DNS::Packet->new($name); ok($packet, 'Packet created'); # @rrs is exported from t::TestData foreach my $data (@rrs) { my $RR=Net::DNS::RR->new( name => $name, ttl => $ttl, %{$data}); # Test if new-from-hash strips dots appropriatly for all subtypes foreach my $meth (keys %{$data}) { my $i=$data->{$meth}; $i =~ s/\.$// unless $i eq "."; if ( $data->{'type'} eq "HIP" && $meth eq "rendezvousservers" ) { ok ( is_deeply ($RR->$meth(), $i ),"HIP - $meth() correct for hash based creation (HIP specific test)"); use Data::Dumper; next; } is( $RR->$meth(), $i , $data->{"type"}." - $meth() correct for hash based creation"); } if ($HAS_DNSSEC){ my $sigrr= create Net::DNS::RR::RRSIG( [ $RR ], $keypathrsa, ( ttl => 360, sigval => 100, )); # $sigrr->print; push @rrsigs, $sigrr; } $packet->push('answer', $RR ); } #------------------------------------------------------------------------------ # Re-create the packet from data. #------------------------------------------------------------------------------ my $data = $packet->data; ok($data, 'Packet has data after pushes'); undef $packet; $packet = Net::DNS::Packet->new(\$data); ok($packet, 'Packet reconstructed from data'); my @answer = $packet->answer; ok(@answer && @answer == @rrs, 'Packet returned correct answer section'); while (@answer and @rrs) { my $data = shift @rrs; my $rr = shift @answer; my $type = $data->{'type'}; ok($rr, "$type - RR defined"); is($rr->name, $name, "$type - name() correct"); is($rr->class, $class, "$type - class() correct"); is($rr->ttl, $ttl, "$type - ttl() correct"); foreach my $meth (keys %{$data}) { my $i=$data->{$meth}; $i =~ s/\.$//; next if ( $type eq "IPSECKEY" && $meth eq "gateway" && $rr->{"gatetype"} != 3 ) ; next if ( $type eq "HIP" && $meth eq "rendezvousservers" ) ; is($rr->$meth(), $i , "$type - $meth() correct"); } my $rr2 = Net::DNS::RR->new($rr->string); is($rr2->string, $rr->string, "$type - Parsing from string works"); if ($HAS_DNSSEC){ my $rrsig=shift @rrsigs; ok($rrsig->verify([ $rr ], $rsakeyrr), "RR of type ".$type." signature creation/validation cycle"); } } unlink($keypathrsa); Net-DNS-0.68/t/03-question.t0000644000175000017500000001472111710626412014707 0ustar willemwillem# $Id: 03-question.t 899 2011-09-22 21:45:52Z willem $ -*-perl-*- use strict; use diagnostics; use Test::More; BEGIN { use Net::DNS; plan tests => 98 + keys(%Net::DNS::classesbyname) + keys(%Net::DNS::typesbyname); } { # check type conversion functions my ($anon) = grep { not defined $Net::DNS::typesbyval{$_} } ( 1 .. 1 << 16 ); is( Net::DNS::typesbyval(1), 'A', "Net::DNS::typesbyval(1)" ); is( Net::DNS::typesbyval($anon), "TYPE$anon", "Net::DNS::typesbyval($anon)" ); is( Net::DNS::typesbyname("TYPE$anon"), $anon, "Net::DNS::typesbyname('TYPE$anon')" ); is( Net::DNS::typesbyname("TYPE0$anon"), $anon, "Net::DNS::typesbyname('TYPE0$anon')" ); my $large = 1 << 16; eval { Net::DNS::typesbyval($large); }; my $exception = $1 if $@ =~ /^(.+)\n/; ok( $exception ||= '', "Net::DNS::typesbyval($large)\t[$exception]" ); foreach ( sort keys %Net::DNS::typesbyname ) { my $code = Net::DNS::typesbyname($_); my $name = eval { Net::DNS::typesbyval($code) }; my $exception = $@ =~ /^(.+)\n/ ? $1 : ''; is( $name, $_, "Net::DNS::typesbyname('$_')\t$exception" ); } } { # check class conversion functions my ($anon) = grep { not defined $Net::DNS::classesbyval{$_} } ( 1 .. 1 << 16 ); is( Net::DNS::classesbyval(1), 'IN', "Net::DNS::classesbyval(1)" ); is( Net::DNS::classesbyval($anon), "CLASS$anon", "Net::DNS::classesbyval($anon)" ); is( Net::DNS::classesbyname("CLASS$anon"), $anon, "Net::DNS::classesbyname('CLASS$anon')" ); is( Net::DNS::classesbyname("CLASS0$anon"), $anon, "Net::DNS::classesbyname('CLASS0$anon')" ); my $large = 1 << 16; eval { Net::DNS::classesbyval($large); }; my $exception = $1 if $@ =~ /^(.+)\n/; ok( $exception ||= '', "Net::DNS::classesbyval($large)\t[$exception]" ); foreach ( sort keys %Net::DNS::classesbyname ) { my $code = Net::DNS::classesbyname($_); my $name = eval { Net::DNS::classesbyval($code) }; my $exception = $@ =~ /^(.+)\n/ ? $1 : ''; is( $name, $_, "Net::DNS::classesbyname('$_')\t$exception" ); } } { my $fqdn = 'example.com.'; my $question = new Net::DNS::Question( $fqdn, 'A', 'IN' ); isa_ok( $question, 'Net::DNS::Question', 'object returned by new() constructor' ); my $string = $question->string; my $expected = "$fqdn\tIN\tA"; is( $string, $expected, '$question->string returns text representation of object' ); my $test = 'new() argument undefined or absent'; is( new Net::DNS::Question( $fqdn, 'A', undef )->string, $expected, "$test\t( $fqdn,\tA,\tundef\t)" ); is( new Net::DNS::Question( $fqdn, 'A', () )->string, $expected, "$test\t( $fqdn,\tA,\t\t)" ); is( new Net::DNS::Question( $fqdn, undef, 'IN' )->string, $expected, "$test\t( $fqdn,\tundef,\tIN\t)" ); is( new Net::DNS::Question( $fqdn, (), 'IN' )->string, $expected, "$test\t( $fqdn,\t\tIN\t)" ); is( new Net::DNS::Question( $fqdn, undef, undef )->string, $expected, "$test\t( $fqdn,\tundef,\tundef\t)" ); is( new Net::DNS::Question( $fqdn, (), () )->string, $expected, "$test\t( $fqdn \t\t\t)" ); } { my $test = 'new() arguments in zone file order'; my $fqdn = 'example.com.'; foreach my $class (qw(IN CLASS1 ANY)) { foreach my $type (qw(A TYPE1 ANY)) { my $testcase = new Net::DNS::Question( $fqdn, $class, $type )->string; my $expected = new Net::DNS::Question( $fqdn, $type, $class )->string; is( $testcase, $expected, "$test\t( $fqdn,\t$class,\t$type\t)" ); } } } { my $packet = new Net::DNS::Packet('example.com'); my $encoded = $packet->data; my ($question) = new Net::DNS::Packet( \$encoded )->question; isa_ok( $question, 'Net::DNS::Question', 'check decoded object' ); } { my $test = 'decoded object matches encoded data'; foreach my $class (qw(IN HS ANY)) { foreach my $type (qw(A AAAA MX NS SOA ANY)) { my $packet = new Net::DNS::Packet( 'example.com', $type, $class ); my $encoded = $packet->data; my ($example) = $packet->question; my $expected = $example->string; my ($question) = new Net::DNS::Packet( \$encoded )->question; is( $question->string, $expected, "$test\t$expected" ); } } } { my @part = ( 1 .. 4 ); while (@part) { my $test = 'interpret IPv4 prefix as PTR query'; my $prefix = join '.', @part; my $domain = new Net::DNS::Question($prefix); my $actual = $domain->qname; my $invert = join '.', reverse 'in-addr.arpa', @part; my $inaddr = new Net::DNS::Question($invert); my $expect = $inaddr->qname; is( $actual, $expect, "$test\t$prefix" ); pop @part; } } { foreach my $type (qw(NS SOA ANY)) { my $test = "query $type in in-addr.arpa namespace"; my $question = new Net::DNS::Question( '1.2.3.4', $type ); my $qtype = $question->qtype; my $string = $question->string; is( $qtype, $type, "$test\t$string" ); } } { foreach my $n ( 32, 24, 16, 8 ) { my $ip4 = '1.2.3.4'; my $test = "accept CIDR address/$n prefix syntax"; my $m = ( ( $n + 7 ) >> 3 ) << 3; my $actual = new Net::DNS::Question("$ip4/$n"); my $expect = new Net::DNS::Question("$ip4/$m"); my $string = $expect->qname; is( $actual->qname, $expect->qname, "$test\t$string" ); } } { is( new Net::DNS::Question('1:2:3:4:5:6:7:8')->string, "8.0.0.0.7.0.0.0.6.0.0.0.5.0.0.0.4.0.0.0.3.0.0.0.2.0.0.0.1.0.0.0.ip6.arpa.\tIN\tPTR", 'interpret IPv6 address as PTR query in ip6.arpa namespace' ); is( new Net::DNS::Question('::x')->string, "::x.\tIN\tA", 'non-address character precludes interpretation as PTR query' ); } { my @part = ( 1 .. 8 ); while (@part) { my $n = @part * 16; my $test = 'interpret IPv6 prefix as PTR query'; my $prefix = join ':', @part; my $actual = new Net::DNS::Question($prefix)->qname; my $expect = new Net::DNS::Question("$prefix/$n")->qname; is( $actual, $expect, "$test\t$prefix" ) if $prefix =~ /:/; pop @part; } } { foreach my $n ( 16, 12, 8, 4 ) { my $ip6 = '1234:5678:9012:3456:7890:1234:5678:9012'; my $test = "accept IPv6 address/$n prefix syntax"; my $m = ( ( $n + 3 ) >> 2 ) << 2; my $actual = new Net::DNS::Question("$ip6/$n"); my $expect = new Net::DNS::Question("$ip6/$m"); my $string = $expect->qname; is( $actual->qname, $expect->qname, "$test\t$string" ); } } { my $expected = length new Net::DNS::Question('1:2:3:4:5:6:7:8')->qname; foreach my $i ( reverse 0 .. 6 ) { foreach my $j ( $i + 3 .. 9 ) { my $ip6 = join( ':', 1 .. $i ) . '::' . join( ':', $j .. 8 ); my $name = new Net::DNS::Question("$ip6")->qname; is( length $name, $expected, "check length of expanded IPv6 address\t$ip6" ); } } } Net-DNS-0.68/t/04-packet.t0000644000175000017500000001166611710626412014315 0ustar willemwillem# $Id: 04-packet.t 967 2011-12-08 21:47:41Z willem $ -*-perl-*- use Test::More tests => 78; use strict; use Net::DNS; # new() class constructor method must return object of appropriate class isa_ok(Net::DNS::Packet->new(), 'Net::DNS::Packet', 'new() object'); # string method returns character string representation of object like(Net::DNS::Packet->new()->string, '/HEADER/', '$packet->string' ); # Create a DNS query packet my ($domain, $type, $class) = qw(example.test MX IN); my $question = Net::DNS::Question->new($domain, $type, $class); my $packet = Net::DNS::Packet->new($domain, $type, $class); like($packet->string, "/$class\t$type/", 'create query packet' ); ok($packet->header, 'packet->header() method works'); ok($packet->header->isa('Net::DNS::Header'), 'header() returns header object'); my @question = $packet->question; ok(@question && @question == 1, 'packet->question() returns single element list'); my ($q) = @question; ok($q->isa('Net::DNS::Question'), 'list element is a question object'); is($q->string, $question->string, 'question object correct'); # Empty packet created when new() arguments omitted my $empty = Net::DNS::Packet->new(); ok($empty, 'create empty packet' ); foreach my $method ( qw(question answer authority additional) ) { my @result = $empty->$method; ok(@result == 0, "$method() returns empty list"); } # data() method returns non-empty scalar my $packet_data = $packet->data; ok($packet_data, 'packet->data() method works'); # new(\$data) class constructor method returns object of appropriate class my $packet2 = Net::DNS::Packet->new(\$packet_data); isa_ok($packet2, 'Net::DNS::Packet', 'new(\$data) object'); is($packet2->string, $packet->string, 'decoded packet matches original'); is(unpack('H*', $packet2->data), unpack('H*', $packet_data), 'retransmitted packet matches original'); # new(\$data) class constructor raises exception when data truncated my @data = unpack 'C*', $packet->data; while ( @data ) { pop(@data); my $truncated = pack 'C*', @data; my ($object,$error) = eval{ Net::DNS::Packet->new(\$truncated) }; my $length = length $truncated; chomp $error; ok($error, "truncated ($length octets):\t$error"); } # Use push() to add RRs to each section my $update = Net::DNS::Packet->new('.'); my $index; foreach my $section ( qw(answer authority additional) ) { my $i = ++$index; my $rr1 = Net::DNS::RR->new( Name => "$section$i.example.test", Type => "A", Address => "10.0.0.$i" ); my $string1 = $rr1->string; my $count1 = $update->push($section, $rr1); like($update->string, "/$string1/", "push first RR into $section section"); is($count1, 1, "push() returns $section RR count"); my $j = ++$index; my $rr2 = Net::DNS::RR->new( Name => "$section$j.example.test", Type => "A", Address => "10.0.0.$j" ); my $string2 = $rr2->string; my $count2 = $update->push($section, $rr2); like($update->string, "/$string2/", "push second RR into $section section"); is($count2, 2, "push() returns $section RR count"); } # Add enough distinct labels to render compression unusable at some point for (0..255) { $update->push('answer', Net::DNS::RR->new("X$_ TXT \"" . pack("A255", "x").'"')); } $update->push('answer', Net::DNS::RR->new('XY TXT ""')); $update->push('answer', Net::DNS::RR->new('VW.XY TXT ""')); # Decode data buffer and compare with original my $buffer = $update->data; my $decoded = eval { Net::DNS::Packet->new(\$buffer) }; ok($decoded, 'new() from data buffer works'); foreach my $count ( qw(qdcount ancount nscount arcount) ) { is($decoded->header->$count, $update->header->$count, "check header->$count correct"); } foreach my $section ( qw(question answer authority additional) ) { my @original = map{$_->string} $update->$section; my @content = map{$_->string} $decoded->$section; is_deeply(\@content, \@original, "check content of $section section"); } # check that pop() removes RR from section foreach my $section ( qw(question answer authority additional) ) { my $c1 = $update->push($section); my $rr = $update->pop($section); my $c2 = $update->push($section); is($c2, $c1-1, "pop() RR from $section section"); } # Test using a predefined answer. # This is an answer that was generated by a bind server, with an option munged on the end. my $BIND = pack('H*','22cc85000001000000010001056461636874036e657400001e0001c00c0006000100000e100025026e730472697065c012046f6c6166c02a7754e1ae0000a8c0000038400005460000001c2000002910000000800000050000000130'); my $bind = Net::DNS::Packet->new(\$BIND); is($bind->header->qdcount, 1, 'check question count in synthetic packet header'); is($bind->header->ancount, 0, 'check answer count in synthetic packet header'); is($bind->header->nscount, 1, 'check authority count in synthetic packet header'); is($bind->header->adcount, 1, 'check additional count in synthetic packet header'); my ($rr) = $bind->additional; is($rr->type, 'OPT', 'Additional section packet is EDNS0 type'); is($rr->class, '4096', 'EDNS0 packet size correct'); Net-DNS-0.68/t/01-resolver-flags.t0000644000175000017500000000117411710626412015767 0ustar willemwillem# $Id: 01-resolver-flags.t 759 2008-12-23 21:23:48Z olaf $ -*-perl-*- use Test::More tests => 7; use strict; use File::Spec; use Data::Dumper; BEGIN { use_ok('Net::DNS'); } my $res = Net::DNS::Resolver->new(); SKIP: { skip 'No Net::DNS::SEC installed', 3 unless $Net::DNS::DNSSEC; ok(! $res->dnssec(),"Default DNSSEC off"); $res->dnssec(1); ok( $res->dnssec(),"DNSSEC toggles on"); $res->dnssec(0); ok( ! $res->dnssec(),"DNSSEC toggles off"); } ok(! $res->cdflag(),"Default cdflag off"); $res->cdflag(1); ok( $res->cdflag(),"toggle cdflag on"); $res->cdflag(0); ok(! $res->cdflag(),"toggle cdflag off"); Net-DNS-0.68/t/11-inet6.t0000644000175000017500000000775311710626412014073 0ustar willemwillem# $Id: 11-inet6.t 754 2008-12-22 12:48:09Z olaf $ -*-perl-*- use Test::More; use strict; BEGIN { if (-e 't/IPv6.enabled' && ! -e 't/IPv6.disabled' ) { plan tests => 10; } else { plan skip_all => 'Online tests disabled.'; exit; } } my $answer; my $res= Net::DNS::Resolver->new; ; my $res2; my $AAAA_address; my $A_address; # If there is IPv6 transport only then this works too. my $nsanswer=$res->send("net-dns.org","NS","IN"); is (($nsanswer->answer)[0]->type, "NS","Preparing for v6 transport, got NS records for net-dns.org"); my $found_ns=0; foreach my $ns ($nsanswer->answer){ next if $ns->nsdname !~ /net-dns\.org$/i; # User net-dns.org only my $aaaa_answer=$res->send($ns->nsdname,"AAAA","IN"); next if ($aaaa_answer->header->ancount == 0); is (($aaaa_answer->answer)[0]->type,"AAAA", "Preparing for v6 transport, got AAAA records for ". $ns->nsdname); $AAAA_address=($aaaa_answer->answer)[0]->address; $found_ns=1; diag ("\n\t\t Will try to connect to ". $ns->nsdname . " ($AAAA_address)"); last; } ok(1,"Dummy test: No AAA Records found, we will skip some other tests") unless $found_ns; $res->nameservers($AAAA_address); #$res->print; $answer=$res->send("net-dns.org","SOA","IN"); is (($answer->answer)[0]->type, "SOA","Query over udp6 succeeded"); $res->usevc(1); $res->force_v4(1); # $res->print; # $res->debug(1); $answer=$res->send("net-dns.org","SOA","IN"); is ($res->errorstring,"no nameservers","Correct errorstring when forcing v4"); $res->force_v4(0); $answer=$res->send("net-dns.org","NS","IN"); if ($answer){ is (($answer->answer)[0]->type, "NS","Query over tcp6 succeeded"); }else{ diag "You can safely ignore the following message:"; diag ($res->errorstring) if ($res->errorstring ne "connection failed(IPv6 socket failure)"); diag ("configuring ".$AAAA_address." ". $A_address." as nameservers"); $res->nameservers($AAAA_address,$A_address); undef $answer; # $res->print; $answer=$res->send("net-dns.org","NS","IN"); is (($answer->answer)[0]->type, "NS","Fallback to V4 succeeded"); } # # # Now test AXFR functionality. # # my $socket; SKIP: { skip "online tests are not enabled", 2 unless (-e 't/IPv6.enabled' && ! -e 't/IPv6.disabled'); # First use the local resolver to query for the AAAA record of a $res2=Net::DNS::Resolver->new; # $res2->debug(1); my $nsanswer=$res2->send("net-dns.org","NS","IN"); SKIP:{ skip "No answers for NS queries",2 unless $nsanswer && ( $nsanswer->header->ancount != 0 ); is (($nsanswer->answer)[0]->type, "NS","Preparing for v6 transport, got NS records for net-dns.org"); my $AAAA_address; foreach my $ns ($nsanswer->answer){ next if $ns->nsdname !~ /net-dns\.org$ /; # User net-dns.org only my $aaaa_answer=$res2->send($ns->nsdname,"AAAA","IN"); next if ($aaaa_answer->header->ancount == 0); is (($aaaa_answer->answer)[0]->type,"AAAA", "Preparing for v6 transport, got AAAA records for ". $ns->nsdname); $AAAA_address=($aaaa_answer->answer)[0]->address; diag ("\n\t\t Trying to connect to ". $ns->nsdname . " ($AAAA_address)"); last; } ok(1,"Dummy test: No AAAA Records found, we will skip some other tests") unless $AAAA_address; $res2->nameservers($AAAA_address); # $res2->print; $socket=$res2->axfr_start('example.com'); } } SKIP: { skip "axfr_start did not return a socket", 2 unless defined($socket); is(ref($socket),"IO::Socket::INET6","axfr_start returns IPv6 Socket"); my ($rr,$err)=$res2->axfr_next; is($res2->errorstring,'Response code from server: NOTAUTH',"Transfer is not authorized (but our connection worked)"); } use Net::DNS::Nameserver; my $ns = Net::DNS::Nameserver->new( LocalAddr => ['::1' ], LocalPort => "5363", ReplyHandler => \&reply_handler, Verbose => 1 ); ok($ns,"nameserver object created on IPv6 ::1"); Net-DNS-0.68/t/05-rr-sshfp.t0000644000175000017500000000414311710626412014603 0ustar willemwillem# $Id: 05-rr-sshfp.t 616 2006-10-18 09:15:48Z olaf $ use Test::More; use strict; use Net::DNS; use Net::DNS::RR::SSHFP; BEGIN { if ($Net::DNS::RR::SSHFP::HasBabble) { plan tests => 15; } else { plan skip_all => 'Digest::BubbleBabble not installed.'; } } #------------------------------------------------------------------------------ # Canned data. #------------------------------------------------------------------------------ my $name = "foo.example.com"; my $class = "IN"; my $ttl = 43200; my %data = ( type => 'SSHFP', algorithm => 2, fptype => 1, fingerprint => '5E66E766416A3A3A60CB150CB3F9C01C43953FB6', ); #------------------------------------------------------------------------------ # Create the packet. #------------------------------------------------------------------------------ my $packet = Net::DNS::Packet->new($name); ok($packet, 'Packet created'); $packet->push('answer', Net::DNS::RR->new( name => $name, ttl => $ttl, %data, ) ); #------------------------------------------------------------------------------ # Re-create the packet from data. #------------------------------------------------------------------------------ my $data = $packet->data; ok($data, 'Packet has data after pushes'); undef $packet; $packet = Net::DNS::Packet->new(\$data); ok($packet, 'Packet reconstructed from data'); my @answer = $packet->answer; ok(@answer && @answer == 1, 'Packet returned correct answer section'); my $rr = $answer[0]; isa_ok($rr, 'Net::DNS::RR::SSHFP'); is($rr->name, $name, "name() correct"); is($rr->class, $class, "class() correct"); is($rr->ttl, $ttl, "ttl() correct"); foreach my $meth (keys %data) { is($rr->$meth(), $data{$meth}, "$meth() correct"); } my $rr2 = Net::DNS::RR->new($rr->string); is($rr2->string, $rr->string, "Parsing from string works"); is ($rr->babble, $rr2->babble, "SSHFP - Same babble at both sides"); is ($rr->babble, "xilik-kanuk-kebek-povyf-pamus-rahob-sysoz-nibac-saben-hezur-kuxex", "SSHFP - Same matches input") ; Net-DNS-0.68/t/11-escapedchars.t0000644000175000017500000003066011710626412015464 0ustar willemwillem# $Id: 11-escapedchars.t 949 2011-10-31 13:58:38Z willem $ -*-perl-*- use Test::More; use strict; use Net::DNS qw(name2labels) ; use Net::DNS::Packet qw(dn_expand); # Perl 5.005 actually produces a warning during the run of the script if ( $] < 5.006 ){ diag ("\n\n\nWith this version of perl Net::DNS may give unpredictable results when dealing with\n". "labels with non ascii or escaped data in them.\n". "For instance domain names such as olaf\\.kolkman.net-dns.org\n". "or \\255\\255.example.com\n\n\n"); plan skip_all => "Escaping does not work with perl version $]" ; } else { plan tests => 134; } # # We test al sorts of escaped non-ascii characters. # This is all to be protocol conform... so to speak. # # The collection of tests is somewhat of a hodgepodge that tried to # assess sensitivity to combinations of characters that the regular # expressions and perl itself are sensitive to. (like \\\\\.\..) # Development versions of the code tried to split a domain name in # invidual labels by a regular expression. It made no sense to remove # the more ackward tests as they have to pass anyway ... my $message="Using the "; $message.= $Net::DNS::HAVE_XS? " XS compiled ":" perl implemented "; $message.="dn_expand function "; diag ($message); my $had_xs=$Net::DNS::HAVE_XS; my ($in,$out); # Note that in perl the \\ in a presentation format can only be achieved # through \\\\ . # The hex codes are the names in wireformat: # length octet. content octets, length octet, content , NULL octet # Below are test combos, 1st and 2nd array elements are # representations of the name. The output of the perl functions should # yield the 2nd presentation (eg \037 gets presented as % ) # The 3rd element is a label count. # The 4th element represents the number of octets per label # The 5th element is a hexdump of the domain name in wireformat # The optional 6th element is a boolean instructing to use the perl # based dn_expand. This because the conversion between the native # dn_expand output to a perl varialbe provides some problems. my @testcombos=( [ 'bla\255.foo.org', 'bla\255.foo.org', 3, [4,3,3], #Wire: 4 b l a 0xff 3 f o o 3 o r g 0 "04626c61ff03666f6f036f726700" ], ['bla.fo\.o.org', 'bla.fo\.o.org', 3, [3,4,3], #Wire: 3 b l a 4 f o . o 3 o r g 0 "03626c6104666f2e6f036f726700" ], ['bla\0000.foo.org', 'bla\0000.foo.org', 3, [5,3,3], #Wire: 5 b l a 0x00 0 3 f o o 3 o r g 0 "05626c61003003666f6f036f726700" , ], ['bla.fo\o.org', 'bla.foo.org', 3, [3,3,3], #Wire: 3 b l a 3 f o o 3 o r g 0 ignoring backslash on input "03626c6103666f6f036f726700", ], #drops the \ ['bla(*.foo.org', 'bla\(*.foo.org', 3, [5,3,3], #Wire: 5 b l a ( * 3 f o o 3 o r g 0 "05626c61282a03666f6f036f726700" ], [' .bla.foo.org', '\032.bla.foo.org', 4, [1,3,3,3], "012003626c6103666f6f036f726700", ], ['\\\\a.foo', '\\\\a.foo', 2, [2,3], #Wire: 2 \ a 3 f o o 0 "025c6103666f6f00" ], ['\\\\.foo', '\\\\.foo', 2, [1,3], #Wire: 1 \ 3 f o o 0 "015c03666f6f00", ], ['a\\..foo', 'a\\..foo', 2, [2,3], #Wire: 2 a . 3 f o o 0 "02612e03666f6f00" ], ['a\\.foo.org', 'a\\.foo.org', 2, [5,3], #Wire: 5 a . f o o 3 o r g 0 "05612e666f6f036f726700" , ], ['\..foo.org', '\..foo.org', 3, [1,3,3], #Wire: 1 . 3 f o o 3 o r g 0 "012e03666f6f036f726700" , ], [ '\046.\046', '\..\.', 2, [1,1], '012e012e00', ], [ # all non \w characters :-) '\000\001\002\003\004\005\006\007\008\009\010\011\012\013\014\015\016\017\018\019\020\021\022\023\024\025\026\027\028\029\030\031\032.\033\034\035\036\037\038\039\040\041\042\043\044\045\046\047\048.\058\059\060\061\062\063\064\065.\091\092\093\094\095\096.\123\124\125\126\127\128\129', '\000\001\002\003\004\005\006\007\008\009\010\011\012\013\014\015\016\017\018\019\020\021\022\023\024\025\026\027\028\029\030\031\032.!\"#\$%&\'\(\)*+,-\./0.:\;<=>?\@A.[\\\\]^_`.{|}~\127\128\129', 5, [33,16,8,6,7], "21000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f20102122232425262728292a2b2c2d2e2f30083a3b3c3d3e3f4041065b5c5d5e5f60077b7c7d7e7f808100", ], ); foreach my $testinput (@testcombos){ # test back and forth my @labels=name2labels( $testinput->[0]); # is (labels2name(@labels), $testinput->[1],"consistent name2labels labels2name for ". $testinput->[0]); # test number of labels is (@labels,$testinput->[2],"consistent labelcount ($testinput->[2])"); # test number of elements within label. my $i=0; # Test length of each individual label while ($i<$testinput->[2]){ is (length $labels[$i], $testinput->[3]->[$i], "labellength for label $i equals ".$testinput->[3]->[$i]); $i++; } my $wire=Net::DNS::RR->_name2wire($testinput->[0]); my $wireinhex=unpack("H*",$wire); is( $wireinhex,$testinput->[4], "Wireinhex for ".$testinput->[0] ); # And now call DN_EXPAND my ($name,$offset); my $had_xs=$Net::DNS::HAVE_XS; SKIP: { skip "No dn_expand_xs available", 1 unless $had_xs; ($name,$offset)=dn_expand(\$wire,0); is ($name,$testinput->[1],"DN_EXPAND (xs) consistent"); } $Net::DNS::HAVE_XS=0; ($name,$offset)=dn_expand(\$wire,0); is ($name,$testinput->[1],"DN_EXPAND (pp) consistent"); $Net::DNS::HAVE_XS=$had_xs; } PERL_DN_EXPAND: { if ($had_xs && !$Net::DNS::DN_EXPAND_ESCAPES ){ diag ("\ndisabling XS based dns_expand for a moment."); $Net::DNS::HAVE_XS=0 ; } #;; QUESTION SECTION #;\\.eg.secret-wg.org. IN TXT # #;; ANSWER SECTION: #\\.eg.secret-wg.org. 10 IN TXT "WildCard Match" # #;; AUTHORITY SECTION: #eg.secret-wg.org. 600 IN NS ns.eg.secret-wg.org. # #;; ADDITIONAL SECTION: #ns.eg.secret-wg.org. 600 IN A 10.0.53.208 # my $UUencodedPacket=' c8 d5 85 00 00 01 00 01 00 01 00 01 02 5c 5c 02 65 67 09 73 65 63 72 65 74 2d 77 67 03 6f 72 67 00 00 10 00 01 c0 0c 00 10 00 01 00 00 00 0a 00 0f 0e 57 69 6c 64 43 61 72 64 20 4d 61 74 63 68 c0 0f 00 02 00 01 00 00 02 58 00 05 02 6e 73 c0 0f c0 4c 00 01 00 01 00 00 02 58 00 04 0a 00 35 d0 '; $UUencodedPacket =~ s/\s*//g; my $packetdata = pack('H*',$UUencodedPacket); my $packet = Net::DNS::Packet->new(\$packetdata); is( ($packet->answer)[0]->name,'\\\\\\\\.eg.secret-wg.org',"Correctly dealt escaped backslash from wireformat \\\\.eg.secret-wg.org"); # Now testing for the real esotheric stuff. # domain names can contain NULL and space characters (on the wire) # these should be properly expanded # This only works if the dn_expand_XS() is NOT used. # The UUencoded packet contains a captured packet with this content: #;; QUESTION SECTION: #;\000.n\032ll.eg.secret-wg.org. IN TXT #;; ANSWER SECTION: #\000.n ll.eg.secret-wg.org. 0 IN TXT "NULL byte ownername" # ^ SPACE !!! #;; AUTHORITY SECTION: #eg.secret-wg.org. 600 IN NS ns.eg.secret-wg.org. #;; ADDITIONAL SECTION: #ns.eg.secret-wg.org. 600 IN A 10.0.53.208 $UUencodedPacket =' a6 58 85 00 00 01 00 01 00 01 00 01 01 00 04 6e 20 6c 6c 02 65 67 09 73 65 63 72 65 74 2d 77 67 03 6f 72 67 00 00 10 00 01 c0 0c 00 10 00 01 00 00 00 00 00 14 13 4e 55 4c 4c 20 62 79 74 65 20 6f 77 6e 65 72 6e 61 6d 65 c0 13 00 02 00 01 00 00 02 58 00 05 02 6e 73 c0 13 c0 55 00 01 00 01 00 00 02 58 00 04 0a 00 35 d0 '; $UUencodedPacket =~ s/\s*//g; $packetdata = pack('H*',$UUencodedPacket); $packet = Net::DNS::Packet->new(\$packetdata); is( ($packet->answer)[0]->name,'\000.n\\032ll.eg.secret-wg.org',"Correctly dealt with NULL bytes in domain names"); #slightly modified \\ .eg.secret-wg.org instead of \\\\.eg.secret-wg.org # That is escaped backslash space $UUencodedPacket=' c8 d5 85 00 00 01 00 01 00 01 00 01 02 5c 20 02 65 67 09 73 65 63 72 65 74 2d 77 67 03 6f 72 67 00 00 10 00 01 c0 0c 00 10 00 01 00 00 00 0a 00 0f 0e 57 69 6c 64 43 61 72 64 20 4d 61 74 63 68 c0 0f 00 02 00 01 00 00 02 58 00 05 02 6e 73 c0 0f c0 4c 00 01 00 01 00 00 02 58 00 04 0a 00 35 d0 '; $UUencodedPacket =~ s/\s*//g; $packetdata = pack('H*',$UUencodedPacket); $packet = Net::DNS::Packet->new(\$packetdata); is( ($packet->answer)[0]->name,'\\\\\\032.eg.secret-wg.org',"Correctly dealt escaped backslash from wireformat \\e.eg.secret-wg.org"); if ( $had_xs && !$Net::DNS::HAVE_XS ){ diag("\nContinuing to use the XS based dn_expand()\n") ; $Net::DNS::HAVE_XS=1; } } #slightly modified \\e.eg.secret-wg.org instead of \\\\.eg.secret-wg.org my $UUencodedPacket=' c8 d5 85 00 00 01 00 01 00 01 00 01 02 5c 65 02 65 67 09 73 65 63 72 65 74 2d 77 67 03 6f 72 67 00 00 10 00 01 c0 0c 00 10 00 01 00 00 00 0a 00 0f 0e 57 69 6c 64 43 61 72 64 20 4d 61 74 63 68 c0 0f 00 02 00 01 00 00 02 58 00 05 02 6e 73 c0 0f c0 4c 00 01 00 01 00 00 02 58 00 04 0a 00 35 d0 '; $UUencodedPacket =~ s/\s*//g; my $packetdata = pack('H*',$UUencodedPacket); my $packet = Net::DNS::Packet->new(\$packetdata); is( ($packet->answer)[0]->name,'\\\\e.eg.secret-wg.org',"Correctly dealt escaped backslash from wireformat \\e.eg.secret-wg.org"); #slightly modified \\\..eg.secret-wg.org instead of \\e.eg.secret-wg.org $UUencodedPacket=' c8 d5 85 00 00 01 00 01 00 01 00 01 02 5c 65 02 65 67 09 73 65 63 72 65 74 2d 77 67 03 6f 72 67 00 00 10 00 01 c0 0c 00 10 00 01 00 00 00 0a 00 0f 0e 57 69 6c 64 43 61 72 64 20 4d 61 74 63 68 c0 0f 00 02 00 01 00 00 02 58 00 05 02 6e 73 c0 0f c0 4c 00 01 00 01 00 00 02 58 00 04 0a 00 35 d0 '; $UUencodedPacket =~ s/\s*//g; $packetdata = pack('H*',$UUencodedPacket); $packet = Net::DNS::Packet->new(\$packetdata); $UUencodedPacket =~ s/\s*//g; $packetdata = pack('H*',$UUencodedPacket); $packet = Net::DNS::Packet->new(\$packetdata); is( ($packet->answer)[0]->name,'\\\\e.eg.secret-wg.org',"Correctly dealt escaped backslash from wireformat \\\..eg.secret-wg.org"); my $testrr=Net::DNS::RR->new( name => '\\e.eg.secret-wg.org', type => 'TXT', txtdata => '"WildCard Match"', ttl => 10, class => "IN", ); my $class = "IN"; my $ttl = 43200; my $name = 'def0au<.example.com'; my @rrs = ( { #[0] name => '\..bla\..example.com', type => 'A', address => '10.0.0.1', }, { #[2] name => $name, type => 'AFSDB', subtype => 1, hostname =>'afsdb-hostname.example.com', }, { #[3] name => '\\.funny.example.com', type => 'CNAME', cname => 'cname-cn\244ame.example.com', }, { #[4] name => $name, type => 'DNAME', dname => 'dn\222ame.example.com', }, { #[9] name => $name, type => 'MINFO', rmailbx => 'minfo\.rmailbx.example.com', emailbx => 'minfo\007emailbx.example.com', }, { #[13] name => $name, type => 'NS', nsdname => '\001ns-nsdname.example.com', }, { #[19] name => $name, type => 'SOA', mname => 'soa-mn\001ame.example.com', rname => 'soa\.rname.example.com', serial => 12345, refresh => 7200, retry => 3600, expire => 2592000, minimum => 86400, }, ); #------------------------------------------------------------------------------ # Create the packet. #------------------------------------------------------------------------------ undef $packet; $packet = Net::DNS::Packet->new($name); ok($packet, 'Packet created'); foreach my $data (@rrs) { $packet->push('answer', Net::DNS::RR->new( ttl => $ttl, %{$data}, ) ); } #------------------------------------------------------------------------------ # Re-create the packet from data. #------------------------------------------------------------------------------ my $data = $packet->data; ok($data, 'Packet has data after pushes'); undef $packet; $packet = Net::DNS::Packet->new(\$data); ok($packet, 'Packet reconstructed from data'); my @answer = $packet->answer; ok(@answer && @answer == @rrs, 'Packet returned correct answer section'); while (@answer and @rrs) { my $data = shift @rrs; my $rr = shift @answer; my $type = $data->{'type'}; foreach my $meth (keys %{$data}) { is($rr->$meth(), $data->{$meth}, "$type - $meth() correct"); } my $rr2 = Net::DNS::RR->new($rr->string); is($rr2->string, $rr->string, "$type - Parsing from string works"); } Net-DNS-0.68/netdns.c0000644000175000017500000001322011710626412013620 0ustar willemwillem /* Portions of this code are * Copyright (c) 1985 Regents of the University of California. * All rights reserved. * * Redistribution and use in source and binary forms are permitted provided * that: (1) source distributions retain this entire copyright notice and * comment, and (2) distributions including binaries display the following * acknowledgement: ``This product includes software developed by the * University of California, Berkeley and its contributors'' in the * documentation or other materials provided with the distribution and in * all advertising materials mentioning features or use of this software. * Neither the name of the University nor the names of its contributors may * be used to endorse or promote products derived from this software without * specific prior written permission. * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED * WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF * MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. */ /* Portions of this code are * Copyright (c) 2004 by Internet Systems Consortium, Inc. ("ISC") * Copyright (c) 1996,1999 by Internet Software Consortium. * * Permission to use, copy, modify, and distribute this software for any * purpose with or without fee is hereby granted, provided that the above * copyright notice and this permission notice appear in all copies. * * THE SOFTWARE IS PROVIDED "AS IS" AND ISC DISCLAIMS ALL WARRANTIES * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ISC BE LIABLE FOR * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT * OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. */ /* Portions of this code are * Copyright (c) 2005 RIPE NCC, Olaf Kolkman * * * All Rights Reserved * * Permission to use, copy, modify, and distribute this software and * its documentation for any purpose and without fee is hereby * granted, provided that the above copyright notice appear in all * copies and that both that copyright notice and this permission * notice appear in supporting documentation, and that the name of the * author not be used in advertising or publicity pertaining to * distribution of the software without specific, written prior * permission. * * * THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, * INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS; IN * NO EVENT SHALL AUTHOR BE LIABLE FOR ANY SPECIAL, INDIRECT OR * CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS * OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, * NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN * CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. */ #include #include "./netdns.h" #include static int special(int); static int printable(int); static const char digits[] = "0123456789"; /* * Expand compressed domain name 'comp_dn' to full domain name. * 'msg' is a pointer to the begining of the message, * 'eomorig' points to the first location after the message, * 'exp_dn' is a pointer to a buffer of size 'length' for the result. * Return size of compressed name or -1 if there was an error. */ int netdns_dn_expand(msg, eomorig, comp_dn, exp_dn, length) u_char *msg, *eomorig, *comp_dn, *exp_dn; int length; { register u_char *cp, *dn; register int n, c; u_char *eom; int len = -1, checked = 0; dn = exp_dn; cp = comp_dn; eom = exp_dn + length; /* * fetch next label in domain name */ while ( (n = *cp++) ) { /* * Check for indirection */ switch (n & INDIR_MASK) { case 0: if (dn != exp_dn) { if (dn >= eom) return (-1); *dn++ = '.'; } if (dn+n >= eom) return (-1); checked += n + 1; while (--n >= 0) { c = *cp++; if (special(c)) { if (dn + 1 >= eom) { return (-1); } *dn++ = '\\'; *dn++ = (char)c; }else if (!printable(c)) { if (dn + 3 >= eom) { return (-1); } *dn++ = '\\'; *dn++ = digits[c / 100]; *dn++ = digits[(c % 100) / 10]; *dn++ = digits[c % 10]; } else { if (dn >= eom) { return (-1); } *dn++ = (char)c; } if (cp >= eomorig)/* out of range */ return(-1); } break; case INDIR_MASK: if (len < 0) len = cp - comp_dn + 1; cp = msg + (((n & 0x3f) << 8) | (*cp & 0xff)); if (cp < msg || cp >= eomorig)/* out of range */ return(-1); checked += 2; /* * Check for loops in the compressed name; * if we've looked at the whole message, * there must be a loop. */ if (checked >= eomorig - msg) return (-1); break; default: return (-1);/* flag error */ } } *dn = '\0'; if (len < 0) len = cp - comp_dn; return (len); } /* * special(ch) * Thinking in noninternationalized USASCII (per the DNS spec), * is this characted special ("in need of quoting") ? * return: * boolean. */ static int special(int ch) { switch (ch) { case 0x22: /* '"' */ case 0x2E: /* '.' */ case 0x3B: /* ';' */ case 0x5C: /* '\\' */ case 0x28: /* '(' */ case 0x29: /* ')' */ /* Special modifiers in zone files. */ case 0x40: /* '@' */ case 0x24: /* '$' */ return (1); default: return (0); } } /* * printable(ch) * Thinking in noninternationalized USASCII (per the DNS spec), * is this character visible and not a space when printed ? * return: * boolean. */ static int printable(int ch) { return (ch > 0x20 && ch < 0x7f); } Net-DNS-0.68/README0000644000175000017500000002612111710626412013045 0ustar willemwillemNet::DNS - Perl DNS Resolver Module =================================== TABLE OF CONTENTS ----------------- 1. Description 2. Availability 3. Prerequisites 4. Installation 5. Running Tests 6. Demonstration Scripts 7. Dynamic Updates 8. Signed Queries & Updates 9. DNSSEC 10. Bugs 11. Copyright 12. Author Information 13. Staying Tuned 14. Acknowledgments 1. DESCRIPTION -------------- Net::DNS is a DNS resolver implemented in Perl. It allows the programmer to perform nearly any type of DNS query from a Perl script. For details and examples, please read the Net::DNS manual page. To read about the latest features, see the Changes file. To find out about known bugs and to see what's planned for future versions, see the TODO file. Net::DNS does not depend on any C libraries. However, if possible Net::DNS tries to link against a C-module (library) that is supplied with the code. This provides a notable speed increase. The author invites feedback on Net::DNS. If there's something you'd like to have added, please let me know. If you find a bug, please send me the information described in the BUGS section below. See http://www.net-dns.org/blog/ for announcments about Net::DNS. 2. AVAILABILITY --------------- You can get the latest version of Net::DNS from the Comprehensive Perl Archive Network (CPAN) or from the module's homepage: http://search.cpan.org/dist/Net-DNS/ or through http://www.net-dns.org/ The following link will always be the current released version: http://www.net-dns.org/download/Net-DNS-release.tar.gz Additionally a subversion repository is made available through http://www.net-dns.org/svn/net-dns/ The version on the "trunk" (http://www.net-dns.org/svn/net-dns/trunk) is the version that is targeted for next release. Please note that the SVN version at any given moment may be broken. 3. PREREQUISITES ---------------- The availability of prerequisites for Net::DNS is tested at installation time. These are the core packages that need to be available. Test::More IO::Socket MIME::Base64 Digest::MD5 Digest::HMAC_MD5 For IPv6 support you will need Socket6 and IO::Socket::INET6. The availability of these is tested at runtime. You can obtain the latest version of Perl from: http://www.cpan.org/src/ Some of the demonstration and contributed scripts may require additional modules -- see demo/README and contrib/README for details. Note that the Test::More module is actually part of the Test-Simple distribution. See the FAQ (lib/Net/DNS/FAQ.pod) for more information. Net::DNS is mostly developed on MacOS X. I have access to Linux, FreeBSD and if need be to cygwin. 4. INSTALLATION --------------- Please install any modules mentioned in the PREREQUISITES section above. If you don't, Net::DNS won't work. When you run "perl Makefile.PL", Perl should complain if any of the required modules are missing. To build this module, run the following commands: perl Makefile.PL make make test make install Net::DNS can optionally link with a included C module. This speeds up parts of the packet parsing process. The Makefile.PL script will attempt to determine if the C module can be used. To override Makefile.PL's guess, use the '--xs' option to force linking the library: perl Makefile.PL --xs Use the '--noxs' option to use the pure perl version: perl Makefile.PL --noxs If you wish to not run the online tests, the '--no-online-tests' option can be used. Similarly, '--online-tests' will enable the online tests. Online tests will be run by default, but the result will not negatively affect the outcome of test suite. Also, if you wish to not run the IPv6 tests, the '--no-IPv6-tests' option can be used. Similarly, '--IPv6-tests' will enable the IPv6 tests. 5. RUNNING TESTS ---------------- If any of the tests fail, please contact the author with the output from the following command: make test TEST_VERBOSE=1 6. DEMONSTRATION SCRIPTS ------------------------ There are a few demonstration scripts in the demo/ directory -- see demo/README for more information. Contributed scripts are in the contrib/ directory -- see contrib/README. The author would be happy to include any contributed scripts in future versions of this module. All I ask is that they be documented (preferably using POD) and that the contributor's name and contact information be mentioned somewhere. 7. DYNAMIC UPDATES ------------------ Net::DNS supports DNS dynamic updates as documented in RFC 2136; for more information and examples, please see the Net::DNS::Update manual page. Please note that there are some bugs in the BIND 8.1-REL nameserver that can cause it to dump core when receiving certain dynamic updates, so if you have problems using Net::DNS that might be the cause. If you're running BIND 9, you should be using the latest version available from the Internet Software Consortium (ISC, www.isc.org) or from your OS vendor. As of this writing, the latest production version of BIND 9 available from the ISC is 9.3.1 (with 9.3.2 at the horizon). Here's a summary of the update semantics for those interested (see RFC 2136 for details): PREREQUISITE SECTION # RRs NAME TTL CLASS TYPE RDLENGTH RDATA ----- ---- --- ----- ---- -------- ----- yxrrset 1 name 0 ANY type 0 empty yxrrset 1+ name 0 class type rdlength rdata nxrrset 1 name 0 NONE type 0 empty yxdomain 1 name 0 ANY ANY 0 empty nxdomain 1 name 0 NONE ANY 0 empty UPDATE SECTION # RRs NAME TTL CLASS TYPE RDLENGTH RDATA ----- ---- --- ----- ---- -------- ----- add RRs 1+ name ttl class type rdlength rdata del RRset 1 name 0 ANY type 0 empty del all RRsets 1 name 0 ANY ANY 0 empty del RRs 1+ name 0 NONE type rdlength rdata 8. SIGNED QUERIES & UPDATES --------------------------- As of version 0.15, Net::DNS supports the TSIG resource record to perform signed queries and updates (see RFC 2845). See the Net::DNS::Packet and Net::DNS::Update manual pages for examples. If you're using the BIND nameserver, the BIND FAQ shows how to generate keys and configure the nameserver to use them: http://www.nominum.com/resources/faqs/bind-faq.html TSIG support is new and isn't yet complete. Please use with caution on production systems. Feedback on TSIG functionality would be most welcome. 9. DNSSEC --------- The extensions to make Net::DNS DNSSEC-aware are distributed separately as Net::DNS::SEC. The package is available from CPAN. Because of its dependency on Crypt::OpenSSL and other not-so-standard libraries, it is distributed as a separate package. 10. BUGS -------- Net::DNS, while over fourteen years old, is still under development and is sure to contain a few bugs. Please see the TODO and Changes files for more information. I recommend that you exercise caution when using Net::DNS to maintain a production nameserver via dynamic updates. Always test your code *thoroughly*. The Net::DNS author accepts no blame if you corrupt your zone. That warning in place, I am aware of at least one large company that has used Net::DNS to make thousands of dynamic updates per day for nearly three years without any problems. Please use the following form to submit bug reports: https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-DNS If you find a bug, please report it in "rt.cpan.org" along with the following information: * version of Perl (output of 'perl -V' is best) * version of Net::DNS * operating system type and version * version of nameserver (if known) * exact text of error message or description of problem * the shortest possible program that exhibits the problem * the specific queries you're making, if the data is available to Internet nameservers If I don't have access to a system similar to yours, I may ask you to insert some debugging lines and report back on the results. The more help and information you can provide, the better. 11. COPYRIGHT ------------- Copyright (c) 1997-2002 Michael Fuhr. Portions Copyright (c) 2002-2004 Chris Reinhardt. Portions Copyright (c) 2005 Olaf Kolkman (RIPE NCC) Portions Copyright (c) 2005 Olaf Kolkman (NLnet Labs) All rights reserved. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. 12. AUTHOR INFORMATION ---------------------- Net::DNS is currently maintained at NLnet Labs (www.nlnetlabs.nl) by: Olaf Kolkman and his team. olaf at net-dns.org Between 2002 and 2004 Net::DNS was maintained by: Chris Reinhardt Net::DNS was created by: Michael Fuhr mike at fuhr.org 13. STAYING TUNED ----------------- http://www.net-dns.org is a web site dedicated to the development of Net::DNS. Announcements about Net::DNS and Net::DNS::SEC will be done through the Net::DNS weblog at http://www.net-dns.org/blog/. An RSS feed for the weblog is available. If you want to have access to the latest and greatest code a subversion repository is made available through http://www.net-dns.org/svn/net-dns/ The version on the "trunk" (http://www.net-dns.org/svn/net-dns/trunk) is the version that is targeted for next release. Please note that code from the SVN repositories trunk and development branches may be broken at any time. 14. ACKNOWLEDGMENTS ------------------- Thanks to Mike for letting me take care of his baby. Thanks to Chris for maintaing Net::DNS for a couple of years. Thanks to Rob Brown and Dick Franks for all their patches and input. Thanks to all who have used Net::DNS and reported bugs, made suggestions, contributed code, and encouraged me to add certain features. Many of these people are mentioned by name in the Changes and TODO files; lack of mention should be considered an oversight and not a conscious act of omission. Thanks to Larry Wall and all who have made Perl possible. Thanks to Paul Albitz and Cricket Liu for allowing me [OK: that's Mike] to write the Net::DNS section in the programming chapter of _DNS and BIND_, 3rd Edition. This chapter in earlier editions was very helpful while I was developing Net::DNS, and I was proud to contribute to it. Thanks to Paul Vixie and all who have worked on the BIND nameserver, which I've used exclusively while developing Net::DNS. Thanks to Andreas Gustafsson for DNAME support, and for all the work he has done on BIND 9. Olaf acknowledges the RIPE NCC for allowing Net::DNS maintenance to take place as part of 'the job'. Thanks to the team that maintains wireshark. Without its marvelous interface, debugging of bugs in wireformat would be so much more difficult. Thanks to the thousands who participate in the open-source community. I've always developed Net::DNS using open-source systems and I'm proud to make Net::DNS freely available to the world. ---- $Id: README 935 2011-10-27 12:41:31Z willem $ Net-DNS-0.68/lib/0000755000175000017500000000000011711344242012730 5ustar willemwillemNet-DNS-0.68/lib/Net/0000755000175000017500000000000011711344242013456 5ustar willemwillemNet-DNS-0.68/lib/Net/DNS.pm0000644000175000017500000006344111710626412014451 0ustar willemwillempackage Net::DNS; # # $Id: DNS.pm 981 2012-01-27 23:01:31Z willem $ # use vars qw($SVNVERSION $VERSION); BEGIN { $SVNVERSION = (qw$LastChangedRevision: 981 $)[1]; $VERSION = '0.68'; } =head1 NAME Net::DNS - Perl interface to the Domain Name System =head1 SYNOPSIS use Net::DNS; =head1 DESCRIPTION Net::DNS is a collection of Perl modules that act as a Domain Name System (DNS) resolver. It allows the programmer to perform DNS queries that are beyond the capabilities of C and C. The programmer should be somewhat familiar with the format of a DNS packet and its various sections. See RFC 1035 or I (Albitz & Liu) for details. =cut use vars qw( $HAVE_XS $DNSSEC $DN_EXPAND_ESCAPES @ISA @EXPORT @EXPORT_OK %typesbyname %typesbyval %qtypesbyname %qtypesbyval %metatypesbyname %metatypesbyval %classesbyname %classesbyval %opcodesbyname %opcodesbyval %rcodesbyname %rcodesbyval ); BEGIN { require Exporter; @ISA = qw(Exporter ); # these need to live here because of dependencies further on. @EXPORT = qw(mx yxrrset nxrrset yxdomain nxdomain rr_add rr_del SEQUENTIAL UNIXTIME YYYYMMDDxx); @EXPORT_OK= qw(name2labels wire2presentation rrsort stripdot); $HAVE_XS = eval { local $SIG{'__DIE__'} = 'DEFAULT'; eval { require XSLoader; XSLoader::load('Net::DNS', $VERSION); 1; } or do { require DynaLoader; push @ISA, 'DynaLoader'; bootstrap Net::DNS $VERSION; 1; }; } ? 1 : 0; } BEGIN { $DNSSEC = eval { local $SIG{'__DIE__'} = 'DEFAULT'; require Net::DNS::SEC; 1 } ? 1 : 0; } use strict; use Carp; use Net::DNS::Resolver; use Net::DNS::Packet; use Net::DNS::Update; use Net::DNS::Header; use Net::DNS::Question; use Net::DNS::RR; # use only after $Net::DNS::DNSSEC has been evaluated # # If you implement an RR record make sure you also add it to # %Net::DNS::RR::RR hash otherwise it will be treated as unknown type. # # See http://www.iana.org/assignments/dns-parameters for assignments and references. # Do not use these tybesby hashes directly. Use the interface # functions, see below. %typesbyname = ( 'SIGZERO' => 0, # RFC2931 consider this a pseudo type 'A' => 1, # RFC 1035, Section 3.4.1 'NS' => 2, # RFC 1035, Section 3.3.11 'MD' => 3, # RFC 1035, Section 3.3.4 (obsolete) NOT IMPLEMENTED 'MF' => 4, # RFC 1035, Section 3.3.5 (obsolete) NOT IMPLEMENTED 'CNAME' => 5, # RFC 1035, Section 3.3.1 'SOA' => 6, # RFC 1035, Section 3.3.13 'MB' => 7, # RFC 1035, Section 3.3.3 'MG' => 8, # RFC 1035, Section 3.3.6 'MR' => 9, # RFC 1035, Section 3.3.8 'NULL' => 10, # RFC 1035, Section 3.3.10 'WKS' => 11, # RFC 1035, Section 3.4.2 (deprecated) NOT IMPLEMENTED 'PTR' => 12, # RFC 1035, Section 3.3.12 'HINFO' => 13, # RFC 1035, Section 3.3.2 'MINFO' => 14, # RFC 1035, Section 3.3.7 'MX' => 15, # RFC 1035, Section 3.3.9 'TXT' => 16, # RFC 1035, Section 3.3.14 'RP' => 17, # RFC 1183, Section 2.2 'AFSDB' => 18, # RFC 1183, Section 1 'X25' => 19, # RFC 1183, Section 3.1 'ISDN' => 20, # RFC 1183, Section 3.2 'RT' => 21, # RFC 1183, Section 3.3 'NSAP' => 22, # RFC 1706, Section 5 'NSAP_PTR' => 23, # RFC 1348 (obsolete by RFC 1637) NOT IMPLEMENTED 'SIG' => 24, # RFC 2535, Section 4.1 impemented in Net::DNS::SEC 'KEY' => 25, # RFC 2535, Section 3.1 impemented in Net::DNS::SEC 'PX' => 26, # RFC 2163, 'GPOS' => 27, # RFC 1712 (obsolete ?) NOT IMPLEMENTED 'AAAA' => 28, # RFC 1886, Section 2.1 'LOC' => 29, # RFC 1876 'NXT' => 30, # RFC 2535, Section 5.2 obsoleted by RFC3755 impemented in Net::DNS::SEC 'EID' => 31, # draft-ietf-nimrod-dns-xx.txt 'NIMLOC' => 32, # draft-ietf-nimrod-dns-xx.txt 'SRV' => 33, # RFC 2052 'ATMA' => 34, # non-standard NOT IMPLEMENTED 'NAPTR' => 35, # RFC 2168 'KX' => 36, # RFC 2230 'CERT' => 37, # RFC 2538 'A6' => 38, # RFC3226, RFC2874. See RFC 3363 made A6 exp. NOT IMPLEMENTED 'DNAME' => 39, # RFC 2672 'SINK' => 40, # non-standard NOT IMPLEMENTED 'OPT' => 41, # RFC 2671 'APL' => 42, # RFC 3123 'DS' => 43, # RFC 4034 implemented in Net::DNS::SEC 'SSHFP' => 44, # RFC 4255 'IPSECKEY' => 45, # RFC 4025 'RRSIG' => 46, # RFC 4034 implemented in Net::DNS::SEC 'NSEC' => 47, # RFC 4034 implemented in Net::DNS::SEC 'DNSKEY' => 48, # RFC 4034 inplemented in Net::DNS::SEC 'DHCID' => 49, # RFC4701 'NSEC3' => 50, # RFC5155 'NSEC3PARAM' => 51, # RFC5155 # 52-54 are unassigned 'HIP' => 55, # RFC5205 'NINFO' => 56, # non-standard NOT IMPLEMENTED 'RKEY' => 57, # non-standard NOT IMPLEMENTED # 58-98 are unasigned 'SPF' => 99, # RFC 4408 'UINFO' => 100, # non-standard 'UID' => 101, # non-standard 'GID' => 102, # non-standard 'UNSPEC' => 103, # non-standard # 104-248 are unasigned 'TKEY' => 249, # RFC 2930 'TSIG' => 250, # RFC 2931 'IXFR' => 251, # RFC 1995 'AXFR' => 252, # RFC 1035 'MAILB' => 253, # RFC 1035 (MB, MG, MR) 'MAILA' => 254, # RFC 1035 (obsolete - see MX) 'ANY' => 255, # RFC 1035 'TA' => 32768, # non-standard NOT IMPLEMENTED 'DLV' => 32769 # RFC 4431 implemented in Net::DNS::SEC ); %typesbyval = reverse %typesbyname; # # typesbyval and typesbyname functions are wrappers around the similarly named # hashes. They are used for 'unknown' DNS RR types (RFC3597) # typesbyname returns they TYPEcode as a function of the TYPE # mnemonic. If the TYPE mapping is not specified the generic mnemonic # TYPE### is returned. # typesbyval returns they TYPE mnemonic as a function of the TYPE # code. If the TYPE mapping is not specified the generic mnemonic # TYPE### is returned. # sub typesbyname { my $name = uc shift; return $typesbyname{$name} if defined $typesbyname{$name}; confess "unknown type $name" unless $name =~ m/TYPE(\d+)/o; my $val = 0 + $1; confess 'argument out of range' if $val > 0xffff; return $val ? $val : '00'; ## preserve historical behaviour for TYPE0 ## } sub typesbyval { my $val = shift; return $typesbyval{$val} if defined $typesbyval{$val}; $val += 0; confess 'argument out of range' if $val > 0xffff; return "TYPE$val"; } # # Do not use these classesby hashes directly. See below. # %classesbyname = ( 'IN' => 1, # RFC 1035 'CH' => 3, # RFC 1035 'HS' => 4, # RFC 1035 'NONE' => 254, # RFC 2136 'ANY' => 255, # RFC 1035 ); %classesbyval = reverse %classesbyname; # classesbyval and classesbyname functions are wrappers around the # similarly named hashes. They are used for 'unknown' DNS RR classess # (RFC3597) # See typesbyval and typesbyname, these beasts have the same functionality sub classesbyname { my $name = uc shift; return $classesbyname{$name} if defined $classesbyname{$name}; confess "unknown class $name" unless $name =~ m/CLASS(\d+)/o; my $val = 0 + $1; confess 'argument out of range' if $val > 0xffff; return $val; } sub classesbyval { my $val = shift; return $classesbyval{$val} if defined $classesbyval{$val}; $val += 0; confess 'argument out of range' if $val > 0xffff; return "CLASS$val"; } # The qtypesbyval and metatypesbyval specify special typecodes # See rfc2929 and the relevant IANA registry # http://www.iana.org/assignments/dns-parameters %qtypesbyname = ( 'IXFR' => 251, # incremental transfer [RFC1995] 'AXFR' => 252, # transfer of an entire zone [RFC1035] 'MAILB' => 253, # mailbox-related RRs (MB, MG or MR) [RFC1035] 'MAILA' => 254, # mail agent RRs (Obsolete - see MX) [RFC1035] 'ANY' => 255, # all records [RFC1035] ); %qtypesbyval = reverse %qtypesbyname; %metatypesbyname = ( 'TKEY' => 249, # Transaction Key [RFC2930] 'TSIG' => 250, # Transaction Signature [RFC2845] 'OPT' => 41, # RFC 2671 ); %metatypesbyval = reverse %metatypesbyname; %opcodesbyname = ( 'QUERY' => 0, # RFC 1035 'IQUERY' => 1, # RFC 1035 'STATUS' => 2, # RFC 1035 'NS_NOTIFY_OP' => 4, # RFC 1996 'UPDATE' => 5, # RFC 2136 ); %opcodesbyval = reverse %opcodesbyname; %rcodesbyname = ( 'NOERROR' => 0, # RFC 1035 'FORMERR' => 1, # RFC 1035 'SERVFAIL' => 2, # RFC 1035 'NXDOMAIN' => 3, # RFC 1035 'NOTIMP' => 4, # RFC 1035 'REFUSED' => 5, # RFC 1035 'YXDOMAIN' => 6, # RFC 2136 'YXRRSET' => 7, # RFC 2136 'NXRRSET' => 8, # RFC 2136 'NOTAUTH' => 9, # RFC 2136 'NOTZONE' => 10, # RFC 2136 ); %rcodesbyval = reverse %rcodesbyname; sub version { $VERSION; } sub PACKETSZ () { 512; } sub HFIXEDSZ () { 12; } sub QFIXEDSZ () { 4; } sub RRFIXEDSZ () { 10; } sub INT32SZ () { 4; } sub INT16SZ () { 2; } # mx() # # Usage: # my @mxes = mx('example.com', 'IN'); # sub mx { my $res = ref $_[0] ? shift : Net::DNS::Resolver->new; my ($name, $class) = @_; $class ||= 'IN'; my $ans = $res->query($name, 'MX', $class) || return; # This construct is best read backwords. # # First we take the answer secion of the packet. # Then we take just the MX records from that list # Then we sort the list by preference # Then we return it. # We do this into an array to force list context. my @ret = sort { $a->preference <=> $b->preference } grep { $_->type eq 'MX'} $ans->answer; return @ret; } # # Auxiliary functions to support dynamic update. # sub yxrrset { return new Net::DNS::RR( shift, 'yxrrset' ); } sub nxrrset { return new Net::DNS::RR( shift, 'nxrrset' ); } sub yxdomain { return new Net::DNS::RR( shift, 'yxdomain' ); } sub nxdomain { return new Net::DNS::RR( shift, 'nxdomain' ); } sub rr_add { return new Net::DNS::RR( shift, 'rr_add' ); } sub rr_del { return new Net::DNS::RR( shift, 'rr_del' ); } # Utility function # # name2labels to translate names from presentation format into an # array of "wire-format" labels. # in: $dname a string with a domain name in presentation format (1035 # sect 5.1) # out: an array of labels in wire format. sub name2labels { my $dname=shift; my @names; my $j=0; while ($dname){ ($names[$j],$dname)=presentation2wire($dname); $j++; } return @names; } sub wire2presentation { my $wire=shift; my $presentation=""; my $length=length($wire); # There must be a nice regexp to do this.. but since I failed to # find one I scan the name string until I find a '\', at that time # I start looking forward and do the magic. my $i=0; while ($i < $length ){ my $char=unpack("x".$i."C1",$wire); if ( $char < 33 || $char > 126 ){ $presentation.= sprintf ("\\%03u" ,$char); }elsif ( $char == ord( "\"" )) { $presentation.= "\\\""; }elsif ( $char == ord( "\$" )) { $presentation.= "\\\$"; }elsif ( $char == ord( "(" )) { $presentation.= "\\("; }elsif ( $char == ord( ")" )) { $presentation.= "\\)"; }elsif ( $char == ord( ";" )) { $presentation.= "\\;"; }elsif ( $char == ord( "@" )) { $presentation.= "\\@"; }elsif ( $char == ord( "\\" )) { $presentation.= "\\\\" ; }elsif ( $char==ord (".") ){ $presentation.= "\\." ; }else{ $presentation.=chr($char) ; } $i++; } return $presentation; } sub stripdot { # Code courtesy of JMEHNLE # rt.cpan.org #51009 # Strips the final non-escaped dot from a domain name. Note # that one could have a label that looks like "foo\\\\\.\.." # although not likely one wants to deal with that cracefully. # This utilizes 2 functions in the DNS module to deal with # thing cracefully. return join('.', map(wire2presentation($_), name2labels(shift))); } # ($wire,$leftover)=presentation2wire($leftover); # Will parse the input presentation format and return everything before # the first non-escaped "." in the first element of the return array and # all that has not been parsed yet in the 2nd argument. sub presentation2wire { my $presentation=shift; my $wire=""; while ($presentation =~ /\G([^.\\]*)([.\\]?)/g){ $wire .= $1 if defined $1; if ($2) { if ($2 eq '.') { return ($wire,substr($presentation,pos $presentation)); } #backslash found if ($presentation =~ /\G(\d\d\d)/gc) { $wire.=pack("C",$1); } elsif ($presentation =~ /\G([@().\\])/gc){ $wire .= $1; } } } return $wire; } # # Auxiliary functions to support policy-driven zone serial numbering. # # $successor = $soa->serial(SEQUENTIAL); # $successor = $soa->serial(UNIXTIME); # $successor = $soa->serial(YYYYMMDDxx); # sub SEQUENTIAL { undef } sub UNIXTIME { return CORE::time; } sub YYYYMMDDxx { my ( $dd, $mm, $yy ) = ( localtime )[3 .. 5]; return 1900010000 + sprintf '%d%0.2d%0.2d00', $yy, $mm, $dd; } sub rrsort { my ($rrtype,$attribute,@rr_array)=@_; unless (exists($Net::DNS::typesbyname{uc($rrtype)})){ # unvalid error type return(); } unless (defined($attribute)){ # no second argument... hence no array. return(); } # attribute is empty or not specified. if( ref($attribute)=~/^Net::DNS::RR::.*/){ # push the attribute back on the array. push @rr_array,$attribute; undef($attribute); } my @extracted_rr; foreach my $rr (@rr_array){ push( @extracted_rr, $rr )if (uc($rr->type) eq uc($rrtype)); } return () unless @extracted_rr; my $func=("Net::DNS::RR::".$rrtype)->get_rrsort_func($attribute); my @sorted=sort $func @extracted_rr; return @sorted; } 1; __END__ =head2 Resolver Objects A resolver object is an instance of the L class. A program can have multiple resolver objects, each maintaining its own state information such as the nameservers to be queried, whether recursion is desired, etc. =head2 Packet Objects L queries return L objects. Packet objects have five sections: =over 3 =item * The header section, a L object. =item * The question section, a list of L objects. =item * The answer section, a list of L objects. =item * The authority section, a list of L objects. =item * The additional section, a list of L objects. =back =head2 Update Objects The L package is a subclass of L for creating packet objects to be used in dynamic updates. =head2 Header Objects L objects represent the header section of a DNS packet. =head2 Question Objects L objects represent the question section of a DNS packet. =head2 RR Objects L is the base class for DNS resource record (RR) objects in the answer, authority, and additional sections of a DNS packet. Don't assume that RR objects will be of the type you requested -- always check an RR object's type before calling any of its methods. =head1 METHODS See the manual pages listed above for other class-specific methods. =head2 version print Net::DNS->version, "\n"; Returns the version of Net::DNS. =head2 mx # Use a default resolver -- can't get an error string this way. use Net::DNS; my @mx = mx("example.com"); # Use your own resolver object. use Net::DNS; my $res = Net::DNS::Resolver->new; my @mx = mx($res, "example.com"); Returns a list of L objects representing the MX records for the specified name; the list will be sorted by preference. Returns an empty list if the query failed or no MX records were found. This method does not look up A records -- it only performs MX queries. See L for a more complete example. =head2 yxrrset Use this method to add an "RRset exists" prerequisite to a dynamic update packet. There are two forms, value-independent and value-dependent: # RRset exists (value-independent) $update->push(pre => yxrrset("host.example.com A")); Meaning: At least one RR with the specified name and type must exist. # RRset exists (value-dependent) $packet->push(pre => yxrrset("host.example.com A 10.1.2.3")); Meaning: At least one RR with the specified name and type must exist and must have matching data. Returns a C object or C if the object couldn't be created. =head2 nxrrset Use this method to add an "RRset does not exist" prerequisite to a dynamic update packet. $packet->push(pre => nxrrset("host.example.com A")); Meaning: No RRs with the specified name and type can exist. Returns a C object or C if the object couldn't be created. =head2 yxdomain Use this method to add a "name is in use" prerequisite to a dynamic update packet. $packet->push(pre => yxdomain("host.example.com")); Meaning: At least one RR with the specified name must exist. Returns a C object or C if the object couldn't be created. =head2 nxdomain Use this method to add a "name is not in use" prerequisite to a dynamic update packet. $packet->push(pre => nxdomain("host.example.com")); Meaning: No RR with the specified name can exist. Returns a C object or C if the object couldn't be created. =head2 rr_add Use this method to add RRs to a zone. $packet->push(update => rr_add("host.example.com A 10.1.2.3")); Meaning: Add this RR to the zone. RR objects created by this method should be added to the "update" section of a dynamic update packet. The TTL defaults to 86400 seconds (24 hours) if not specified. Returns a C object or C if the object couldn't be created. =head2 rr_del Use this method to delete RRs from a zone. There are three forms: delete an RRset, delete all RRsets, and delete an RR. # Delete an RRset. $packet->push(update => rr_del("host.example.com A")); Meaning: Delete all RRs having the specified name and type. # Delete all RRsets. $packet->push(update => rr_del("host.example.com")); Meaning: Delete all RRs having the specified name. # Delete an RR. $packet->push(update => rr_del("host.example.com A 10.1.2.3")); Meaning: Delete all RRs having the specified name, type, and data. RR objects created by this method should be added to the "update" section of a dynamic update packet. Returns a C object or C if the object couldn't be created. =head1 Zone Serial Number Management The Net::DNS module provides auxiliary functions which support policy-driven zone serial numbering regimes. =head2 Strictly Sequential $successor = $soa->serial( SEQUENTIAL ); The existing serial number is incremented modulo 2**32. =head2 Time Encoded $successor = $soa->serial( UNIXTIME ); The Unix time scale will be used as the basis for zone serial numbering. The serial number will be incremented if the time elapsed since the previous update is less than one second. =head2 Date Encoded $successor = $soa->serial( YYYYMMDDxx ); The 32 bit value returned by the auxiliary YYYYMMDDxx() function will be used as the base for the date-coded zone serial number. Serial number increments must be limited to 100 per day for the date information to remain useful. =head2 Sorting of RR arrays As of version 0.55 there is functionality to help you sort RR arrays. 'rrsort()' is the function that is available to do the sorting. In most cases rrsort will give you the answer that you want but you can specify your own sorting method by using the Net::DNS::RR::FOO->set_rrsort_func() class method. See L for details. =head3 rrsort() use Net::DNS qw(rrsort); my @prioritysorted=rrsort("SRV","priority",@rr_array); rrsort() selects all RRs from the input array that are of the type that are defined in the first argument. Those RRs are sorted based on the attribute that is specified as second argument. There are a number of RRs for which the sorting function is specifically defined for certain attributes. If such sorting function is defined in the code (it can be set or overwritten using the set_rrsort_func() class method) that function is used. For instance: my @prioritysorted=rrsort("SRV","priority",@rr_array); returns the SRV records sorted from lowest to heighest priority and for equal priorities from heighes to lowes weight. If the function does not exist then a numerical sort on the attribute value is performed. my @portsorted=rrsort("SRV","port",@rr_array); If the attribute does not exist for a certain RR than the RRs are sorted on string comparrisson of the rdata. If the attribute is not defined than either the default_sort function will be defined or "Canonical sorting" (as defined by DNSSEC) will be used. rrsort() returns a sorted array with only elements of the specified RR type or undef. rrsort() returns undef when arguments are incorrect. =head1 EXAMPLES The following examples show how to use the C modules. See the other manual pages and the demo scripts included with the source code for additional examples. See the C manual page for an example of performing dynamic updates. =head2 Look up a host's addresses. use Net::DNS; my $res = Net::DNS::Resolver->new; my $query = $res->search("host.example.com"); if ($query) { foreach my $rr ($query->answer) { next unless $rr->type eq "A"; print $rr->address, "\n"; } } else { warn "query failed: ", $res->errorstring, "\n"; } =head2 Find the nameservers for a domain. use Net::DNS; my $res = Net::DNS::Resolver->new; my $query = $res->query("example.com", "NS"); if ($query) { foreach $rr (grep { $_->type eq 'NS' } $query->answer) { print $rr->nsdname, "\n"; } } else { warn "query failed: ", $res->errorstring, "\n"; } =head2 Find the MX records for a domain. use Net::DNS; my $name = "example.com"; my $res = Net::DNS::Resolver->new; my @mx = mx($res, $name); if (@mx) { foreach $rr (@mx) { print $rr->preference, " ", $rr->exchange, "\n"; } } else { warn "Can't find MX records for $name: ", $res->errorstring, "\n"; } =head2 Print a domain's SOA record in zone file format. use Net::DNS; my $res = Net::DNS::Resolver->new; my $query = $res->query("example.com", "SOA"); if ($query) { ($query->answer)[0]->print; } else { print "query failed: ", $res->errorstring, "\n"; } =head2 Perform a zone transfer and print all the records. use Net::DNS; my $res = Net::DNS::Resolver->new; $res->nameservers("ns.example.com"); my @zone = $res->axfr("example.com"); foreach $rr (@zone) { $rr->print; } =head2 Perform a background query and do some other work while waiting for the answer. use Net::DNS; my $res = Net::DNS::Resolver->new; my $socket = $res->bgsend("host.example.com"); until ($res->bgisready($socket)) { # do some work here while waiting for the answer # ...and some more here } my $packet = $res->bgread($socket); $packet->print; =head2 Send a background query and use select to determine when the answer has arrived. use Net::DNS; use IO::Select; my $timeout = 5; my $res = Net::DNS::Resolver->new; my $bgsock = $res->bgsend("host.example.com"); my $sel = IO::Select->new($bgsock); # Add more sockets to $sel if desired. my @ready = $sel->can_read($timeout); if (@ready) { foreach my $sock (@ready) { if ($sock == $bgsock) { my $packet = $res->bgread($bgsock); $packet->print; $bgsock = undef; } # Check for the other sockets. $sel->remove($sock); $sock = undef; } } else { warn "timed out after $timeout seconds\n"; } =head1 BUGS C is slow. For other items to be fixed, or if you discover a bug in this distribution please use the CPAN bug reporting system. =head1 COPYRIGHT Copyright (c)1997-2002 Michael Fuhr. Portions Copyright(c)2002-2004 Chris Reinhardt. Portions Copyright(c)2005 Olaf Kolkman (RIPE NCC) Portions Copyright(c)2006 Olaf Kolkman (NLnet Labs) All rights reserved. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. =head1 AUTHOR INFORMATION Net::DNS is currently maintained at NLnet Labs (www.nlnetlabs.nl) by: Olaf Kolkman olaf@net-dns.org Between 2002 and 2004 Net::DNS was maintained by: Chris Reinhardt Net::DNS was created by: Michael Fuhr mike@fuhr.org For more information see: http://www.net-dns.org/ Stay tuned and syndicate: http://www.net-dns.org/blog/ =head1 SEE ALSO L, L, L, L, L, L, L, RFC 1035, I by Paul Albitz & Cricket Liu =cut Net-DNS-0.68/lib/Net/DNS/0000755000175000017500000000000011711344242014102 5ustar willemwillemNet-DNS-0.68/lib/Net/DNS/Text.pm0000644000175000017500000001446711710626412015401 0ustar willemwillempackage Net::DNS::Text; # # $Id: Text.pm 965 2011-12-02 22:04:30Z willem $ # use vars qw($VERSION); $VERSION = (qw$LastChangedRevision: 965 $)[1]; =head1 NAME Net::DNS::Text - Domain Name System text representation =head1 SYNOPSIS use Net::DNS::Text; $object = new Net::DNS::Text('example'); $string = $object->string; $object = decode Net::DNS::Text( \$data, $offset ); ( $object, $next ) = decode Net::DNS::Text( \$data, $offset ); $data = $object->encode; $text = $object->value; =head1 DESCRIPTION The C module implements a class of text objects with associated class and instance methods. Each text object instance has a fixed identity throughout its lifetime. =cut use strict; use integer; use Carp; use constant ASCII => eval { require Encode; Encode::find_encoding('ASCII'); # return encoding object } || 0; use constant UTF8 => eval { die if Encode::decode_utf8( chr(91) ) ne '['; # not UTF-EBCDIC [see UTR#16 §3.6] Encode::find_encoding('UTF8'); # return encoding object } || 0; =head1 METHODS =head2 new $object = new Net::DNS::Text('example'); Creates a text object which encapsulates a single character string component of a resource record. Arbitrary single-byte characters can be represented by \ followed by exactly three decimal digits. Such characters are devoid of any special meaning. A character preceded by \ represents itself, without any special interpretation. =cut my %unescape; ## precalculated numeric escape table sub new { my $self = bless [], shift; croak 'argument undefined' unless defined $_[0]; local $_ = &_encode_utf8; s/^([\042\047])(.*)\1$/$2/; # strip quotes s/\134\134/\134\066\066\066/g; # disguise escaped escape while (/\134([\060-\062][\060-\071]{2})/) { # numeric escape s/\134($1)/$unescape{$1}/eg; } s/\134\066\066\066/\134\134/g; # reveal escaped escape s/\134(.)/$1/g; # character escape while ( length $_ > 255 ) { my $chunk = substr( $_, 0, 255 ); # carve into chunks substr( $chunk, -length($1) ) = '' if $chunk =~ /.([\300-\377][\200-\277]+)$/; push @$self, $chunk; substr( $_, 0, length $chunk ) = ''; } push @$self, $_; return $self; } =head2 decode $object = decode Net::DNS::Text( \$buffer, $offset ); ( $object, $next ) = decode Net::DNS::Text( \$buffer, $offset ); Creates a text object which represents the decoded data at the indicated offset within the data buffer. The argument list consists of a reference to a scalar containing the wire-format data and offset of the text data. The returned offset value indicates the start of the next item in the data buffer. =cut sub decode { my $self = bless [], shift; my $buffer = shift; # reference to data buffer my $offset = shift || 0; # offset within buffer my $size = unpack "\@$offset C", $$buffer; my $next = ++$offset + $size; croak 'corrupt wire-format data' if $next > length $$buffer; push @$self, unpack "\@$offset a$size", $$buffer; return wantarray ? ( $self, $next ) : $self; } =head2 encode $data = $object->encode; Returns the wire-format encoded representation of the text object suitable for inclusion in a DNS packet buffer. =cut sub encode { my $self = shift; join '', map { pack 'C a*', length $_, $_ } @$self; } =head2 value $value = $text->value; Returns the character representation of the text object. =cut sub value { my $self = shift; _decode_utf8( join '', @$self ); } =head2 string $string = $text->string; Returns the escaped string representation of the text object. =cut my %escape; # precalculated ASCII/UTF-8 escape table my $QQ = _decode_utf8( pack 'C', 34 ); sub string { my $self = shift; local $_ = join '', @$self; s/([^\040\060-\132\141-\172])/$escape{$1}/eg; # escape special and unprintable $_ = _decode_utf8($_); # Note: Script-specific rules determine which Unicode characters match \s return $_ unless /^$|\s|["\$'():;@`]/; # unquoted contiguous return join '', $QQ, $_, $QQ; # quoted string } ######################################## use vars qw($AUTOLOAD); sub AUTOLOAD { ## Default method no strict; @_ = ("method $AUTOLOAD undefined"); goto &{'Carp::confess'}; } sub DESTROY { } ## Avoid tickling AUTOLOAD (in cleanup) sub _decode_utf8 { return UTF8->decode(shift) if UTF8; return ASCII->decode(shift) if ASCII && not UTF8; # partial transliteration for single octet character encodings local $_ = shift; tr [\055\011\040-\054\056-\176\302-\364\000-\377] [- !"#$%&'()*+,./0-9:;<=>?@A-Z\[\\\]^_`a-z{|}~???????????????????????????????????????????????????]d unless ASCII; return $_; # native 8-bit code } sub _encode_utf8 { return UTF8->encode(shift) if UTF8; return ASCII->encode(shift) if ASCII && not UTF8; # partial transliteration for single octet character encodings local $_ = shift; tr [- !"#$%&'()*+,./0-9:;<=>?@A-Z\[\\\]^_`a-z{|}~\000-\377] [\055\011\040-\054\056-\176]d unless ASCII; return $_; # ASCII } %escape = eval { ## precalculated ASCII/UTF-8 escape table my %table; my @C0 = ( 0 .. 8, 10 .. 31 ); # except tab character my @NA = UTF8 ? () : ( 128 .. 255 ); foreach ( 0 .. 255 ) { # transparent my $char = pack 'C', $_; $table{$char} = $char; } # minimal character escapes foreach ( 34, 92 ) { # \" \\ my $char = pack 'C', $_; $table{$char} = pack 'C*', 92, $_; } foreach ( @C0, 127, @NA ) { # \ddd my $char = pack 'C', $_; $table{$char} = sprintf '\\%03u', $_; } return %table; }; %unescape = eval { ## precalculated numeric escape table my %table; foreach ( 0 .. 255 ) { my $aseq = _encode_utf8 sprintf( '%03u', $_ ); $table{$aseq} = pack 'C', $_; $table{$aseq} = pack 'Ca*', $_, _encode_utf8 '666' if $_ == 92; } return %table; }; 1; __END__ ######################################## =head1 BUGS Coding strategy is intended to avoid creating unnecessary argument lists and stack frames. This improves efficiency at the expense of code readability. Platform specific character coding features are conditionally compiled into the code. =head1 COPYRIGHT Copyright (c)2009-2011 Dick Franks. All rights reserved. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, RFC1035, RFC3629, Unicode Technical Report #16 =cut Net-DNS-0.68/lib/Net/DNS/Question.pm0000644000175000017500000001533411710626412016256 0ustar willemwillempackage Net::DNS::Question; # # $Id: Question.pm 971 2011-12-14 10:39:30Z willem $ # use vars qw($VERSION); $VERSION = (qw$LastChangedRevision: 971 $)[1]; =head1 NAME Net::DNS::Question - DNS question record =head1 SYNOPSIS use Net::DNS::Question; $question = new Net::DNS::Question('example.com', 'A', 'IN'); =head1 DESCRIPTION A Net::DNS::Question object represents a record in the question section of a DNS packet. =cut use strict; use integer; use Carp; use Net::DNS; use Net::DNS::DomainName; =head1 METHODS =head2 new $question = new Net::DNS::Question('example.com', 'A', 'IN'); $question = new Net::DNS::Question('example.com'); $question = new Net::DNS::Question('192.0.32.10', 'PTR', 'IN'); $question = new Net::DNS::Question('192.0.32.10'); Creates a question object from the domain, type, and class passed as arguments. One or both type and class arguments may be omitted and will assume the default values shown above. RFC4291 and RFC4632 IP address/prefix notation is supported for queries in both in-addr.arpa and ip6.arpa namespaces. =cut sub new { my $self = bless {}, shift; my $qname = shift; my $qtype = uc( shift || '' ); my $qclass = uc( shift || '' ); # tolerate (possibly unknown) type and class in zone file order unless ( exists $Net::DNS::classesbyname{$qclass} ) { ( $qtype, $qclass ) = ( $qclass, $qtype ) if exists $Net::DNS::classesbyname{$qtype}; ( $qtype, $qclass ) = ( $qclass, $qtype ) if $qtype =~ /CLASS/; } unless ( exists $Net::DNS::typesbyname{$qtype} ) { ( $qtype, $qclass ) = ( $qclass, $qtype ) if exists $Net::DNS::typesbyname{$qclass}; ( $qtype, $qclass ) = ( $qclass, $qtype ) if $qclass =~ /TYPE/; } # if argument is an IP address, do appropriate reverse lookup if ( defined $qname and $qname =~ m/:|\d$/ ) { if ( my $reverse = _dns_addr($qname) ) { $qname = $reverse; $qtype ||= 'PTR'; } } $self->{name} = new Net::DNS::DomainName1035($qname); $self->{type} = Net::DNS::typesbyname( $qtype || 'A' ); $self->{class} = Net::DNS::classesbyname( $qclass || 'IN' ); return $self; } =head2 decode $question = decode Net::DNS::Question(\$data, $offset); ($question, $offset) = decode Net::DNS::Question(\$data, $offset); Decodes the question record at the specified location within a DNS wire-format packet. The first argument is a reference to the buffer containing the packet data. The second argument is the offset of the start of the question record. Returns a Net::DNS::Question object and the offset of the next location in the packet. An exception is raised if the object cannot be created (e.g., corrupt or insufficient data). =cut use constant QFIXEDSZ => length pack 'n2', (0) x 2; sub decode { my $self = bless {}, shift; my ( $data, $offset ) = @_; ( $self->{name}, $offset ) = decode Net::DNS::DomainName1035(@_); my $next = $offset + QFIXEDSZ; die 'corrupt wire-format data' if length $$data < $next; @{$self}{qw(type class)} = unpack "\@$offset n2", $$data; return wantarray ? ( $self, $next ) : $self; } =head2 encode $data = $question->encode( $offset, $hash ); Returns the Net::DNS::Question in binary format suitable for inclusion in a DNS packet buffer. The optional arguments are the offset within the packet data where the Net::DNS::Question is to be stored and a reference to a hash table used to index compressed names within the packet. =cut sub encode { my $self = shift; return pack 'a* n2', $self->{name}->encode(@_), @{$self}{qw(type class)}; } =head2 qname, zname $qname = $question->qname; $zname = $question->zname; Returns the question name attribute. In dynamic update packets, this attribute is known as zname() and refers to the zone name. =cut sub qname { my $self = shift; return $self->{name}->identifier unless @_; croak 'method invoked with unexpected argument'; } sub zname { &qname; } =head2 qtype, ztype $qtype = $question->qtype; $ztype = $question->ztype; Returns the question type attribute. In dynamic update packets, this attribute is known as ztype() and refers to the zone type. =cut sub type { my $self = shift; return Net::DNS::typesbyval( $self->{type} ) unless @_; croak 'method invoked with unexpected argument'; } sub qtype { &type; } sub ztype { &type; } =head2 qclass, zclass $qclass = $question->qclass; $zclass = $question->zclass; Returns the question class attribute. In dynamic update packets, this attribute is known as zclass() and refers to the zone class. =cut sub class { my $self = shift; return Net::DNS::classesbyval( $self->{class} ) unless @_; croak 'method invoked with unexpected argument'; } sub qclass { &class; } sub zclass { &class; } =head2 print $object->print; Prints the record to the standard output. Calls the string() method to get the string representation. =cut sub print { print shift->string, "\n"; } =head2 string print "string = ", $question->string, "\n"; Returns a string representation of the question record. =cut sub string { my $self = shift; return join "\t", $self->{name}->string, $self->qclass, $self->qtype; } ######################################## use vars qw($AUTOLOAD); sub AUTOLOAD { ## Default method no strict; @_ = ("method $AUTOLOAD undefined"); goto &{'Carp::confess'}; } sub DESTROY { } ## Avoid tickling AUTOLOAD (in cleanup) sub _dns_addr { ## Map IP address into reverse lookup namespace local $_ = shift; # IP address must contain address characters only return undef unless m#^[a-fA-F0-9:./]+$#; # arg looks like IPv4 address: map to in-addr.arpa space if (m#(^|:.*:)((^|\d+\.)+\d+)(/(\d+))?$#) { my @parse = split /\./, $2; my $prefx = $5 || @parse << 3; my $last = $prefx > 24 ? 3 : ( $prefx - 1 ) >> 3; return join '.', reverse( ( @parse, (0) x 3 )[0 .. $last] ), 'in-addr.arpa'; } # arg looks like IPv6 address: map to ip6.arpa space if (m#^((\w*:)+)(\w*)(/(\d+))?$#) { my @parse = split /:/, ( reverse "0${1}0${3}" ), 9; my @xpand = map { /./ ? $_ : ('0') x ( 9 - @parse ) } @parse; # expand :: my $prefx = $5 || @xpand << 4; # implicit length if unspecified my $hex = pack 'A4' x 8, map { $_ . '000' } ('0') x ( 8 - @xpand ), @xpand; my $len = $prefx > 124 ? 32 : ( $prefx + 3 ) >> 2; return join '.', split( //, substr( $hex, -$len ) ), 'ip6.arpa'; } return undef; } 1; __END__ ######################################## =head1 COPYRIGHT Copyright (c)1997-2002 Michael Fuhr. Portions Copyright (c)2002-2004 Chris Reinhardt. Portions Copyright (c)2003,2006-2011 Dick Franks. All rights reserved. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L, L, RFC 1035 Section 4.1.2 Net-DNS-0.68/lib/Net/DNS/Mailbox.pm0000644000175000017500000000535411710626412016043 0ustar willemwillempackage Net::DNS::Mailbox; use base qw(Net::DNS::DomainName); # # $Id: Mailbox.pm 970 2011-12-13 10:51:06Z willem $ # use vars qw($VERSION); $VERSION = (qw$LastChangedRevision: 970 $)[1]; =head1 NAME Net::DNS::Mailbox - DNS mailbox representation =head1 SYNOPSIS use Net::DNS::Mailbox; $mailbox = new Net::DNS::Mailbox('user@example.com'); $address = $mailbox->address; =head1 DESCRIPTION The Net::DNS::Mailbox module implements a subclass of DNS domain name objects representing the DNS coded form of RFC822 mailbox address. =cut use strict; use Carp; =head1 METHODS =head2 new $mailbox = new Net::DNS::Mailbox('John.Doe@example.com'); $mailbox = new Net::DNS::Mailbox('John Doe '); Creates a mailbox object which represents the DNS domain encoded form of the mail address specified by the character string argument. The argument string consists of printable characters from the 7-bit ASCII repertoire. =cut sub new { my $class = shift; local $_ = shift; confess 'undefined mail address' unless defined $_; s/^.*.*$//g; # strip excess on right s/\\\./\\046/g; # disguise escaped . s/\\\@/\\064/g; # disguise escaped @ my ( $mbox, @host ) = split /\@/; # split on @ if present $mbox ||= ''; $mbox =~ s/\./\\046/g if @host; # escape dots bless __PACKAGE__->SUPER::new( join '.', $mbox, @host ), $class; } =head2 address $address = $mailbox->address; Returns a character string corresponding to the RFC822 form of mailbox address of the domain as described in RFC1035 section 8. The string consists of printable characters from the 7-bit ASCII repertoire. =cut sub address { my @label = shift->label; local $_ = shift(@label) || return '<>'; s/\\\./\./g; # unescape dots s/\@/\\@/g; # escape @ return join '@', $_, join( '.', @label ) || (); } ######################################## =head1 DOMAIN NAME COMPRESSION AND CANONICALISATION The Net::DNS::Mailbox1035 and Net::DNS::Mailbox2535 subclass packages implement RFC1035 domain name compression and RFC2535 canonicalisation. =cut package Net::DNS::Mailbox1035; use base qw(Net::DNS::DomainName1035); sub new { &Net::DNS::Mailbox::new; } sub address { &Net::DNS::Mailbox::address; } package Net::DNS::Mailbox2535; use base qw(Net::DNS::DomainName2535); sub new { &Net::DNS::Mailbox::new; } sub address { &Net::DNS::Mailbox::address; } 1; __END__ ######################################## =head1 COPYRIGHT Copyright (c)2009,2010 Dick Franks. All rights reserved. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L, RFC822, RFC1035, RFC5322 =cut Net-DNS-0.68/lib/Net/DNS/DomainName.pm0000644000175000017500000001554011710626412016456 0ustar willemwillempackage Net::DNS::DomainName; use base qw(Net::DNS::Domain); # # $Id: DomainName.pm 964 2011-12-02 10:23:51Z willem $ # use vars qw($VERSION); $VERSION = (qw$LastChangedRevision: 964 $)[1]; =head1 NAME Net::DNS::DomainName - DNS domain name wire representation =head1 SYNOPSIS use Net::DNS::DomainName; $object = new Net::DNS::DomainName('example.com'); $name = $object->name; $data = $object->encode; ( $object, $next ) = decode Net::DNS::DomainName( \$data, $offset ); =head1 DESCRIPTION The Net::DNS::DomainName module implements the concrete representation of DNS domain names used within DNS packets. Net::DNS::DomainName defines methods for encoding and decoding wire format octet strings as defined in RFC1035. All other behaviour, including the new() constructor, is inherited from Net::DNS::Domain. The Net::DNS::DomainName1035 and Net::DNS::DomainName2535 packages implement disjoint domain name subtypes which provide the name compression and canonicalisation specified by RFC1035 and RFC2535. These are necessary to meet the backward compatibility requirements introduced by RFC3597. =cut use strict; use integer; use Carp; =head1 METHODS =head2 new $object = new Net::DNS::DomainName('example.com'); Creates a domain name object which identifies the domain specified by the character string argument. =head2 decode $object = decode Net::DNS::DomainName( \$buffer, $offset, $hash ); ( $object, $next ) = decode Net::DNS::DomainName( \$buffer, $offset, $hash ); Creates a domain name object which represents the DNS domain name identified by the wire-format data at the indicated offset within the data buffer. The argument list consists of a reference to a scalar containing the wire-format data and specified offset. The optional reference to a hash table provides improved efficiency of decoding compressed names by exploiting already cached compression pointers. The returned offset value indicates the start of the next item in the data buffer. =cut sub decode { my $self = bless {}, shift; my $buffer = shift; # reference to data buffer my $offset = shift || 0; # offset within buffer my $cache = shift || {}; # hashed objectref by offset my $buflen = length $$buffer; my $index = $offset; while ( $index < $buflen ) { my $header = unpack( "\@$index C", $$buffer ); unless ($header) { # terminal empty label return wantarray ? ( $self, ++$index ) : $self; } elsif ( $header < 0x40 ) { # non-terminal label push( @{$self->{label}}, substr( $$buffer, ++$index, $header ) ); $index += $header; } elsif ( $header < 0xC0 ) { # deprecated extended label types croak 'unimplemented label type'; } else { # compression pointer my $link = 0x3FFF & unpack( "\@$index n", $$buffer ); croak 'corrupt compression pointer' unless $link < $offset; $self->{origin} = $cache->{$link} ||= decode Net::DNS::DomainName( $buffer, $link, $cache ); return wantarray ? ( $self, $index + 2 ) : $self; } } croak 'corrupt wire-format data'; } =head2 encode $data = $object->encode; Returns the wire-format representation of the domain name suitable for inclusion in a DNS packet buffer. =cut sub encode { join '', map pack( 'C a*', length($_), $_ ), shift->_wire, ''; } ######################################## sub _wire { ## Generate list of wire-format labels my $self = shift; my @label = @{$self->{label}} if $self->{label}; my @suffx = $self->{origin}->_wire if $self->{origin}; return ( @label, @suffx ); } ######################################## package Net::DNS::DomainName1035; use base qw(Net::DNS::DomainName); =head1 Net::DNS::DomainName1035 Net::DNS::DomainName1035 implements a subclass of domain name objects which are to be encoded using the compressed wire format defined in RFC1035. use Net::DNS::DomainName; $object = new Net::DNS::DomainName1035('compressible.example.com'); $data = $object->encode( $offset, $hash ); ( $object, $next ) = decode Net::DNS::DomainName1035( \$data, $offset ); Note that RFC3597 implies that the RR types defined in RFC1035 section 3.3 are the only types eligible for compression. =head2 encode $data = $object->encode( $offset, $hash ); Returns the wire-format representation of the domain name suitable for inclusion in a DNS packet buffer. The optional arguments are the offset within the packet data where the domain name is to be stored and a reference to a hash table used to index compressed names within the packet. If the hash reference is undefined, encode() returns the lowercase uncompressed canonical representation defined in RFC2535(8.1). =cut sub encode { my $self = shift; my $offset = shift || 0; # offset in data buffer my $hash = shift; # hashed offset by name return join '', map pack( 'C a*', length($_), _lc($_) ), $self->_wire, '' unless defined $hash; my @labels = $self->_wire; my $data = ''; while (@labels) { my $name = join( '.', @labels ); return $data . pack( 'n', 0xC000 | $hash->{$name} ) if defined $hash->{$name}; my $label = shift @labels; my $length = length $label; $data .= pack( 'C a*', $length, $label ); next unless $offset < 0x4000; $hash->{$name} = $offset; $offset += 1 + $length; } $data .= chr(0); } sub _lc { local $_ = shift; tr [\101-\132] [\141-\172]; return $_; } ######################################## package Net::DNS::DomainName2535; use base qw(Net::DNS::DomainName); =head1 Net::DNS::DomainName2535 Net::DNS::DomainName2535 implements a subclass of domain name objects which are to be encoded using uncompressed wire format. Note that RFC3597, and latterly RFC4034, specifies that the lower case canonical encoding defined in RFC2535 is to be used for RR types defined prior to RFC3597. use Net::DNS::DomainName; $object = new Net::DNS::DomainName2535('incompressible.example.com'); $data = $object->encode( $offset, $hash ); ( $object, $next ) = decode Net::DNS::DomainName2535( \$data, $offset ); =head2 encode $data = $object->encode( $offset, $hash ); Returns the uncompressed wire-format representation of the domain name suitable for inclusion in a DNS packet buffer. If the hash reference is undefined, encode() returns the lowercase canonical form defined in RFC2535(8.1). =cut sub encode { my ( $self, $offset, $hash ) = @_; return join '', map pack( 'C a*', length($_), $_ ), $self->_wire, '' if defined $hash; return join '', map pack( 'C a*', length($_), _lc($_) ), $self->_wire, ''; } sub _lc { local $_ = shift; tr [\101-\132] [\141-\172]; return $_; } 1; __END__ ######################################## =head1 COPYRIGHT Copyright (c)2009-2011 Dick Franks. All rights reserved. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L, RFC1035, RFC2535, RFC3597, RFC4034 =cut Net-DNS-0.68/lib/Net/DNS/Packet.pm0000644000175000017500000004612211710626412015655 0ustar willemwillempackage Net::DNS::Packet; # # $Id: Packet.pm 969 2011-12-13 10:34:39Z willem $ # use vars qw($VERSION); $VERSION = (qw$LastChangedRevision: 969 $)[1]; =head1 NAME Net::DNS::Packet - DNS protocol packet =head1 SYNOPSIS use Net::DNS::Packet; $packet = new Net::DNS::Packet('example.com', 'MX', 'IN'); $resolver->send($packet); =head1 DESCRIPTION A C object represents a DNS protocol packet. =cut use strict; use integer; use Carp; use Net::DNS; use Net::DNS::Question; use Net::DNS::RR; use vars qw(@ISA @EXPORT_OK); require Exporter; @ISA = qw(Exporter); @EXPORT_OK = qw(dn_expand); =head1 METHODS =head2 new $packet = new Net::DNS::Packet('example.com'); $packet = new Net::DNS::Packet('example.com', 'MX', 'IN'); $packet = new Net::DNS::Packet(); If passed a domain, type, and class, C creates a packet object appropriate for making a DNS query for the requested information. The type and class can be omitted; they default to A and IN. If called with an empty argument list, C creates an empty packet. $packet = new Net::DNS::Packet(\$data); $packet = new Net::DNS::Packet(\$data, 1); # set debugging ($packet, $err) = new Net::DNS::Packet(\$data); If passed a reference to a scalar containing DNS packet data, C creates a packet object by decoding the data. The optional second argument can be passed to turn on debugging output. If called in array context, returns a packet object and an error string. The content of the error string is unspecified if the packet object was successfully created. Returns undef if unable to create a packet object (e.g., if the packet data is truncated). =cut sub new { return &decode if ref $_[1]; my $class = shift; my $self = bless { header => Net::DNS::Header->new, question => [], answer => [], authority => [], additional => []}, $class; $self->{question} = [Net::DNS::Question->new(@_)] if @_; return $self; } sub decode { my $class = shift; my $data = shift; my $debug = shift || 0; my $self = eval { my %self = ( question => [], answer => [], authority => [], additional => [], answersize => length $$data, buffer => $data ); # Parse header section my ( $header, $offset ) = decode Net::DNS::Header($data); $self{header} = $header; # Parse question/zone section for ( 1 .. $header->qdcount ) { my $qd; ( $qd, $offset ) = decode Net::DNS::Question( $data, $offset ); CORE::push( @{$self{question}}, $qd ); } # Retain offset for on-demand decoding of remaining data $self{offset} = $offset; bless \%self, $class; }; ( $self || die $@ )->print if $debug; return wantarray ? ( $self, $@ ) : $self; } =head2 data $data = $packet->data; Returns the packet data in binary format, suitable for sending to a nameserver. =cut sub encode {&data} sub data { my $self = shift; return ${$self->{buffer}} if $self->{buffer}; # retransmit raw packet #---------------------------------------------------------------------- # Set record counts in packet header #---------------------------------------------------------------------- my $header = $self->{header}; $header->qdcount( scalar @{$self->{question}} ); $header->ancount( scalar @{$self->{answer}} ); $header->nscount( scalar @{$self->{authority}} ); $header->arcount( scalar @{$self->{additional}} ); #---------------------------------------------------------------------- # Get the data for each section in the packet #---------------------------------------------------------------------- my $data = $header->encode; my $hash = {}; foreach my $component ( @{$self->{question}}, @{$self->{answer}}, @{$self->{authority}}, @{$self->{additional}} ) { $data .= $component->encode( length $data, $hash, $self ); } return $data; } =head2 header $header = $packet->header; Returns a C object representing the header section of the packet. =cut sub header { return shift->{header}; } =head2 question, zone @question = $packet->question; Returns a list of C objects representing the question section of the packet. In dynamic update packets, this section is known as C and specifies the zone to be updated. =cut sub question { return @{shift->{question}}; } sub zone {&question} =head2 answer, pre, prerequisite @answer = $packet->answer; Returns a list of C objects representing the answer section of the packet. In dynamic update packets, this section is known as C
 or
C and specifies the RRs or RRsets which must or
must not preexist.

=cut

sub answer {
	my ($self) = @_;
	my $rrlist = $self->{answer};
	return @$rrlist if @$rrlist;
	@$rrlist = $self->_section( $self->{header}->ancount );
}

sub pre		 {&answer}
sub prerequisite {&answer}

sub _section {
	my $self = shift;
	my $count = shift || return ();

	my $offset = $self->{offset} || return ();
	my $data   = $self->{buffer} || return ();
	my $hash   = {};
	my $byte   = $offset;
	my @rr;
	eval {
		my $rr;
		undef $self->{offset};
		while ( $count-- ) {
			$byte = $offset;
			( $rr, $offset ) = decode Net::DNS::RR( $data, $offset, $hash );
			CORE::push( @rr, $rr );
		}
		$self->{offset} = $offset;
	};
	carp "$@ RR at octet $byte corrupt/incomplete" if $@;
	return @rr;
}


=head2 authority, update

    @authority = $packet->authority;

Returns a list of C objects representing the authority
section of the packet.

In dynamic update packets, this section is known as C and
specifies the RRs or RRsets to be added or deleted.

=cut

sub authority {
	my ($self) = @_;
	my $rrlist = $self->{authority};
	return @$rrlist if @$rrlist;
	&answer;
	@$rrlist = $self->_section( $self->{header}->nscount );
}

sub update {&authority}


=head2 additional

    @additional = $packet->additional;

Returns a list of C objects representing the additional
section of the packet.

=cut

sub additional {
	my ($self) = @_;
	my $rrlist = $self->{additional};
	return @$rrlist if @$rrlist;
	&authority;
	@$rrlist = $self->_section( $self->{header}->arcount );
	undef $self->{buffer};
	return @$rrlist;
}


=head2 print

    $packet->print;

Prints the packet data on the standard output in an ASCII format
similar to that used in DNS zone files.

=cut

sub print { print &string; }


=head2 string

    print $packet->string;

Returns a string representation of the packet.

=cut

sub string {
	my $self = shift;

	my $header = $self->{header};
	my $update = $header->opcode eq 'UPDATE';

	my $server = $self->{answerfrom};
	my $string = $server ? ";; Answer received from $server ($self->{answersize} bytes)\n" : "";

	$string .= ";; HEADER SECTION\n".$header->string;

	my $question = $update ? 'ZONE' : 'QUESTION';
	my @question = map $_->string, $self->question;
	my $qdcount = @question;
	my $qds = $qdcount != 1 ? 's' : '';
	$string .= join "\n;; ", "\n;; $question SECTION ($qdcount record$qds)", @question;

	my $answer = $update ? 'PREREQUISITE' : 'ANSWER';
	my @answer = map $_->string, $self->answer;
	my $ancount = @answer;
	my $ans = $ancount != 1 ? 's' : '';
	$string .= join "\n", "\n\n;; $answer SECTION ($ancount record$ans)", @answer;

	my $authority = $update ? 'UPDATE' : 'AUTHORITY';
	my @authority = map $_->string, $self->authority;
	my $nscount = @authority;
	my $nss = $nscount != 1 ? 's' : '';
	$string .= join "\n", "\n\n;; $authority SECTION ($nscount record$nss)", @authority;

	my @additional = map $_->string, $self->additional;
	my $arcount = @additional;
	my $ars = $arcount != 1 ? 's' : '';
	$string .= join "\n", "\n\n;; ADDITIONAL SECTION ($arcount record$ars)", @additional;

	return $string."\n\n";
}


=head2 answerfrom

    print "packet received from ", $packet->answerfrom, "\n";

Returns the IP address from which we received this packet.  User-created
packets will return undef for this method.

=cut

sub answerfrom {
	my $self = shift;

	return $self->{answerfrom} = shift if @_;

	return $self->{answerfrom};
}


=head2 answersize

    print "packet size: ", $packet->answersize, " bytes\n";

Returns the size of the packet in bytes as it was received from a
nameserver.  User-created packets will return undef for this method
(use C<< length $packet->data >> instead).

=cut

sub answersize {
	return shift->{answersize};
}


=head2 push

    $ancount = $packet->push(pre        => $rr);
    $nscount = $packet->push(update     => $rr);
    $arcount = $packet->push(additional => $rr);

    $nscount = $packet->push(update => $rr1, $rr2, $rr3);
    $nscount = $packet->push(update => @rr);

Adds RRs to the specified section of the packet.

Returns the number of resource records in the specified section.

=cut

sub push {
	my $self    = shift;
	my $section = lc shift || '';
	my @rr	    = grep ref($_), @_;

	my $hdr = $self->{header};
	for ($section) {
		return $hdr->qdcount( CORE::push( @{$self->{question}}, @rr ) ) if /^question/;

		if ( $hdr->opcode eq 'UPDATE' ) {
			my ($zone) = $self->zone;
			my $zclass = $zone->zclass;
			foreach (@rr) {
				$_->class($zclass) unless $_->class =~ /ANY|NONE/;
			}
		}

		return $hdr->ancount( CORE::push( @{$self->{answer}},	  @rr ) ) if /^ans|^pre/;
		return $hdr->nscount( CORE::push( @{$self->{authority}},  @rr ) ) if /^auth|^upd/;
		return $hdr->adcount( CORE::push( @{$self->{additional}}, @rr ) ) if /^add/;
	}

	carp qq(invalid section "$section");
	return undef;
}


=head2 unique_push

    $ancount = $packet->unique_push(pre        => $rr);
    $nscount = $packet->unique_push(update     => $rr);
    $arcount = $packet->unique_push(additional => $rr);

    $nscount = $packet->unique_push(update => $rr1, $rr2, $rr3);
    $nscount = $packet->unique_push(update => @rr);

Adds RRs to the specified section of the packet provided that
the RRs do not already exist in the packet.

Returns the number of resource records in the specified section.

=cut

sub unique_push {
	my $self    = shift;
	my $section = shift;
	my @rr	    = grep ref($_), @_;

	my @unique = grep !$self->{seen}->{lc( $_->name ) . $_->class . $_->type . $_->rdatastr}++, @rr;

	return $self->push( $section, @unique );
}

sub safe_push {
	carp('safe_push() is deprecated, please use unique_push() instead,');
	&unique_push;
}


=head2 pop

    my $rr = $packet->pop("pre");
    my $rr = $packet->pop("update");
    my $rr = $packet->pop("additional");
    my $rr = $packet->pop("question");

Removes RRs from the specified section of the packet.

=cut

sub pop {
	my $self = shift;
	my $section = lc shift || '';

	for ($section) {
		return CORE::pop( @{$self->{question}} ) if /^question/;

		$self->additional if $self->{buffer};		# decode remaining data

		return CORE::pop( @{$self->{answer}} )	   if /^ans|^pre/;
		return CORE::pop( @{$self->{authority}} )  if /^auth|^upd/;
		return CORE::pop( @{$self->{additional}} ) if /^add/;
	}

	carp qq(invalid section "$section");
	return undef;
}


=head2 dn_comp

    $compname = $packet->dn_comp("foo.example.com", $offset);

Returns a domain name compressed for a particular packet object, to
be stored beginning at the given offset within the packet data.  The
name will be added to a running list of compressed domain names for
future use.

=cut

sub dn_comp {
	my ($self, $fqdn, $offset) = @_;

	my @labels = Net::DNS::name2labels($fqdn);
	my $hash   = $self->{compnames};
	my $data   = '';
	while (@labels) {
		my $name = join( '.', @labels );

		return $data . pack( 'n', 0xC000 | $hash->{$name} ) if defined $hash->{$name};

		my $label = shift @labels;
		my $length = length($label) || next;		   # skip if null
		if ( $length > 63 ) {
			$length = 63;
			$label = substr( $label, 0, $length );
			carp "\n$label...\ntruncated to $length octets (RFC1035 2.3.1)";
		}
		$data .= pack( 'C a*', $length, $label );

		next unless $offset < 0x4000;
		$hash->{$name} = $offset;
		$offset += 1 + $length;
	}
	$data .= chr(0);
}


=head2 dn_expand

    use Net::DNS::Packet qw(dn_expand);
    ($name, $nextoffset) = dn_expand(\$data, $offset);

    ($name, $nextoffset) = Net::DNS::Packet::dn_expand(\$data, $offset);

Expands the domain name stored at a particular location in a DNS
packet.  The first argument is a reference to a scalar containing
the packet data.  The second argument is the offset within the
packet where the (possibly compressed) domain name is stored.

Returns the domain name and the offset of the next location in the
packet.

Returns undef if the domain name could not be expanded.

=cut


# This is very hot code, so we try to keep things fast.  This makes for
# odd style sometimes.

sub dn_expand {
#FYI	my ($packet, $offset) = @_;
	return dn_expand_XS(@_) if $Net::DNS::HAVE_XS;
#	warn "USING PURE PERL dn_expand()\n";
	return dn_expand_PP(@_, {} );	# $packet, $offset, anonymous hash
}

sub dn_expand_PP {
	my ($packet, $offset, $visited) = @_;
	my $packetlen = length $$packet;
	my $name = '';

	while ( $offset < $packetlen ) {
		unless ( my $length = unpack("\@$offset C", $$packet) ) {
			$name =~ s/\.$//o;
			return ($name, ++$offset);

		} elsif ( ($length & 0xc0) == 0xc0 ) {		# pointer
			my $point = 0x3fff & unpack("\@$offset n", $$packet);
			die 'Exception: unbounded name expansion' if $visited->{$point}++;

			my ($suffix) = dn_expand_PP($packet, $point, $visited);

			return ($name.$suffix, $offset+2) if defined $suffix;

		} else {
			my $element = substr($$packet, ++$offset, $length);
			$name .= Net::DNS::wire2presentation($element).'.';
			$offset += $length;
		}
	}
	return undef;
}


=head2 sign_tsig

    $key_name = "tsig-key";
    $key      = "awwLOtRfpGE+rRKF2+DEiw==";

    $update = Net::DNS::Update->new("example.com");
    $update->push("update", rr_add("foo.example.com A 10.1.2.3"));

    $update->sign_tsig($key_name, $key);

    $response = $res->send($update);

Attaches a TSIG resource record object containing a key, which will
be used to signs a packet with a TSIG resource record (see RFC 2845).
Uses the following defaults:

    algorithm   = HMAC-MD5.SIG-ALG.REG.INT
    time_signed = current time
    fudge       = 300 seconds

If you wish to customize the TSIG record, you'll have to create it
yourself and call the appropriate Net::DNS::RR::TSIG methods.  The
following example creates a TSIG record and sets the fudge to 60
seconds:

    $key_name = "tsig-key";
    $key      = "awwLOtRfpGE+rRKF2+DEiw==";

    $tsig = Net::DNS::RR->new("$key_name TSIG $key");
    $tsig->fudge(60);

    $query = Net::DNS::Packet->new("www.example.com");
    $query->sign_tsig($tsig);

    $response = $res->send($query);

=cut

sub sign_tsig {
	my $self = shift;
	my $tsig = shift || return undef;

	unless ( ref $tsig && ($tsig->type eq "TSIG") ) {
		my $key = shift || return undef;
		$tsig = Net::DNS::RR->new("$tsig TSIG $key");
	}

	$self->push('additional', $tsig) if $tsig;
	return $tsig;
}


=head2 sign_sig0

SIG0 support is provided through the Net::DNS::RR::SIG class. This class is not part
of the default Net::DNS distribution but resides in the Net::DNS::SEC distribution.

    $update = Net::DNS::Update->new("example.com");
    $update->push("update", rr_add("foo.example.com A 10.1.2.3"));
    $update->sign_sig0("Kexample.com+003+25317.private");


SIG0 support is experimental see Net::DNS::RR::SIG for details.

The method will call C if Net::DNS::RR::SIG cannot be found.

=cut

sub sign_sig0 {
	my $self = shift;
	my $arg = shift || return undef;
	my $sig0;

	croak('sign_sig0() is only available when Net::DNS::SEC is installed')
		unless $Net::DNS::DNSSEC;

	if ( ref $arg ) {
		if ( UNIVERSAL::isa($arg,'Net::DNS::RR::SIG') ) {
			$sig0 = $arg;

		} elsif ( UNIVERSAL::isa($arg,'Net::DNS::SEC::Private') ) {
			$sig0 = Net::DNS::RR::SIG->create('', $arg);

		} elsif ( UNIVERSAL::isa($arg,'Net::DNS::RR::SIG::Private') ) {
			carp ref($arg).' is deprecated - use Net::DNS::SEC::Private instead';
			$sig0 = Net::DNS::RR::SIG->create('', $arg);

		} else {
			croak 'Incompatible class as argument to sign_sig0: '.ref($arg);

		}

	} else {
		$sig0 = Net::DNS::RR::SIG->create('', $arg);
	}

	$self->push('additional', $sig0) if $sig0;
	return $sig0;
}


=head2 truncate

The truncate method takes a maximum length as argument and then tries
to truncate the packet an set the TC bit according to the rules of
RFC2181 Section 9.

The minimum maximum length that is honored is 512 octets.

=cut

# From RFC2181:
#9. The TC (truncated) header bit
#
#   The TC bit should be set in responses only when an RRSet is required
#   as a part of the response, but could not be included in its entirety.
#   The TC bit should not be set merely because some extra information
#   could have been included, but there was insufficient room.  This
#   includes the results of additional section processing.  In such cases
#   the entire RRSet that will not fit in the response should be omitted,
#   and the reply sent as is, with the TC bit clear.  If the recipient of
#   the reply needs the omitted data, it can construct a query for that
#   data and send that separately.
#
#   Where TC is set, the partial RRSet that would not completely fit may
#   be left in the response.  When a DNS client receives a reply with TC
#   set, it should ignore that response, and query again, using a
#   mechanism, such as a TCP connection, that will permit larger replies.

# Code inspired on a contribution from Aaron Crane via rt.cpan.org 33547

sub truncate {
	my $self=shift;
	my $max_len=shift;
	my $debug=0;
	$max_len=$max_len>512?$max_len:512;

	print "Truncating to $max_len\n" if $debug;

	if (length $self->data() > $max_len) {
		# first remove data from the additional section
		while (length $self->data() > $max_len){
			# first remove _complete_ RRstes from the additonal section.
			my $popped= CORE::pop(@{$self->{'additional'}});
			last unless defined($popped);
			print "Removed ".$popped->string." from additional \n" if $debug;
			my $i=0;
			my @stripped_additonal;

			while ($i< @{$self->{'additional'}}){
				#remove all of these same RRtypes
				if  (
				    ${$self->{'additional'}}[$i]->type eq $popped->type &&
				    ${$self->{'additional'}}[$i]->name eq $popped->name &&
				    ${$self->{'additional'}}[$i]->class eq $popped->class ){
					print "       Also removed ". ${$self->{'additional'}}[$i]->string." from additonal \n" if $debug;				}else{
					CORE::push @stripped_additonal,  ${$self->{'additional'}}[$i];
				}
				$i++;
			}
			$self->{'additional'}=\@stripped_additonal;
		}

		return $self if length $self->data <= $max_len;

      		my @sections = qw;
		while (@sections) {
			while (my $popped=$self->pop($sections[0])) {
				last unless defined($popped);
				print "Popped ".$popped->string." from the $sections[0] section\n" if $debug;
				$self->header->tc(1);
				return $self if length $self->data <= $max_len;
				next;
			}
			shift @sections;
		}
	}
	return $self;
}


1;
__END__


=head1 COPYRIGHT

Copyright (c)1997-2002 Michael Fuhr.

Portions Copyright (c)2002-2004 Chris Reinhardt.

Portions Copyright (c)2002-2009 Olaf Kolkman

Portions Copyright (c)2007-2008 Dick Franks

All rights reserved.

This program is free software; you may redistribute it and/or
modify it under the same terms as Perl itself.


=head1 SEE ALSO

L, L, L, L,
L, L, L,
RFC 1035 Section 4.1, RFC 2136 Section 2, RFC 2845

=cut

Net-DNS-0.68/lib/Net/DNS/Resolver/0000755000175000017500000000000011711344242015703 5ustar  willemwillemNet-DNS-0.68/lib/Net/DNS/Resolver/Cygwin.pm0000644000175000017500000001132311710626412017502 0ustar  willemwillempackage Net::DNS::Resolver::Cygwin; # -*- tab-width:4 -*-
#
# $Id: Cygwin.pm 932 2011-10-26 12:40:48Z willem $
#

use strict;
use vars qw(@ISA $VERSION);

use Net::DNS::Resolver::Base ();

@ISA	 = qw(Net::DNS::Resolver::Base);
$VERSION = (qw$LastChangedRevision: 932 $)[1];

sub getregkey {
	my $key	  = $_[0] . $_[1];
	my $value = '';

	local *LM;

	if (open(LM, "<$key")) {
		$value = ;
		$value =~ s/\0+$// if $value;
		close(LM);
	}

	return $value;
}

sub init {
	my ($class) = @_;
	my $defaults = $class->defaults;

	local *LM;

	my $root = '/proc/registry/HKEY_LOCAL_MACHINE/SYSTEM/CurrentControlSet/Services/Tcpip/Parameters/';

	unless (-d $root) {
		# Doesn't exist, maybe we are on 95/98/Me?
		$root = '/proc/registry/HKEY_LOCAL_MACHINE/SYSTEM/CurrentControlSet/Services/VxD/MSTCP/';
		-d $root || Carp::croak "can't read registry: $!";
	}

	# Best effort to find a useful domain name for the current host
	# if domain ends up blank, we're probably (?) not connected anywhere
	# a DNS server is interesting either...
	my $domain = getregkey($root, 'Domain') || getregkey($root, 'DhcpDomain') || '';

	# If nothing else, the searchlist should probably contain our own domain
	# also see below for domain name devolution if so configured
	# (also remove any duplicates later)
	my $searchlist = "$domain ";
	$searchlist	 .= getregkey($root, 'SearchList');

	# This is (probably) adequate on NT4
	my $nt4nameservers = getregkey($root, 'NameServer') || getregkey($root, 'DhcpNameServer');
	my $nameservers = "";
	#
	# but on W2K/XP the registry layout is more advanced due to dynamically
	# appearing connections. So we attempt to handle them, too...
	# opt to silently fail if something isn't ok (maybe we're on NT4)
    # If this doesn't fail override any NT4 style result we found, as it
    # may be there but is not valid.
	# drop any duplicates later
	my $dnsadapters = $root . "DNSRegisteredAdapters/";
	if (opendir(LM, $dnsadapters)) {
		my @adapters = grep($_ ne "." && $_ ne "..", readdir(LM));
		closedir(LM);
		foreach my $adapter (@adapters) {
			my $regadapter = $dnsadapters . $adapter . '/';
			if (-e $regadapter) {
				my $ns = getregkey($regadapter, 'DNSServerAddresses') || '';
				while (length($ns) >= 4) {
					my $addr = join('.', unpack("C4", substr($ns,0,4,"")));
					$nameservers .= " $addr";
				}
			}
		}
	}

	my $interfaces = $root . "Interfaces/";
	if (opendir(LM, $interfaces)) {
		my @ifacelist = grep($_ ne "." && $_ ne "..", readdir(LM));
		closedir(LM);
		foreach my $iface (@ifacelist) {
			my $regiface = $interfaces . $iface . '/';
			if (opendir(LM, $regiface)) {
				closedir(LM);

				my $ns;
				my $ip;
				$ip = getregkey($regiface, "DhcpIPAddress") || getregkey($regiface, "IPAddress");
				$ns = getregkey($regiface, "NameServer") ||
				    getregkey($regiface, "DhcpNameServer") || ''
                      unless !$ip || ($ip =~ /0\.0\.0\.0/);

				$nameservers .= " $ns" if $ns;
            }
        }
    }

	if (!$nameservers) {
		$nameservers = $nt4nameservers;
	}

	if ($domain) {
		$defaults->{'domain'} = $domain;
	}

	my $usedevolution = getregkey($root, 'UseDomainNameDevolution');
	if ($searchlist) {
		# fix devolution if configured, and simultaneously make sure no dups (but keep the order)
		my @a;
		my %h;
		foreach my $entry (split(m/[\s,]+/, $searchlist)) {
			push(@a, $entry) unless $h{$entry};
			$h{$entry} = 1;
			if ($usedevolution) {
				# as long there's more than two pieces, cut
				while ($entry =~ m#\..+\.#) {
					$entry =~ s#^[^\.]+\.(.+)$#$1#;
					push(@a, $entry) unless $h{$entry};
					$h{$entry} = 1;
					}
				}
			}
		$defaults->{'searchlist'} = \@a;
	}

	if ($nameservers) {
		# just in case dups were introduced...
		my @a;
		my %h;
		foreach my $ns (split(m/[\s,]+/, $nameservers)) {
			push @a, $ns unless (!$ns || $h{$ns});
			$h{$ns} = 1;
		}
		$defaults->{'nameservers'} = [map { m/(.*)/ } @a];
	}

	$class->read_env;

	if (!$defaults->{'domain'} && @{$defaults->{'searchlist'}}) {
		$defaults->{'domain'} = $defaults->{'searchlist'}[0];
	} elsif (!@{$defaults->{'searchlist'}} && $defaults->{'domain'}) {
		$defaults->{'searchlist'} = [ $defaults->{'domain'} ];
	}
}

1;
__END__


=head1 NAME

Net::DNS::Resolver::Cygwin - Cygwin Resolver Class

=head1 SYNOPSIS

 use Net::DNS::Resolver;

=head1 DESCRIPTION

This class implements the cygwin specific portions of C.

No user serviceable parts inside, see L
for all your resolving needs.

=head1 COPYRIGHT

Copyright (c) 1997-2002 Michael Fuhr.

Portions Copyright (c) 2002-2004 Chris Reinhardt.

All rights reserved.  This program is free software; you may redistribute
it and/or modify it under the same terms as Perl itself.

=head1 SEE ALSO

L, L, L

=cut
Net-DNS-0.68/lib/Net/DNS/Resolver/Recurse.pm0000644000175000017500000004133611710626412017661 0ustar  willemwillempackage Net::DNS::Resolver::Recurse;
#
# $Id: Recurse.pm 932 2011-10-26 12:40:48Z willem $
#
use strict;
use Net::DNS::Resolver;

use vars qw($VERSION @ISA);

$VERSION = (qw$LastChangedRevision: 932 $)[1];
@ISA = qw(Net::DNS::Resolver);


my @hardcodedhints = qw (
198.41.0.4
192.58.128.30
192.112.36.4
202.12.27.33
192.5.5.241
128.63.2.53
192.36.148.17
192.33.4.12
192.228.79.201
199.7.83.42
128.8.10.90
193.0.14.129
192.203.230.10
2001:503:ba3e::2:30
2001:500:2f::f
2001:500:1::803f:235
2001:503:c27::2:30
2001:500:3::42
2001:dc3::35
);

sub hints {
  my $self = shift;
  my @hints = @_;
  print ";; hints(@hints)\n" if $self->{'debug'};

  if (!@hints && !$self->nameservers){
	  return $self->hints( @hardcodedhints )
  }elsif (!@hints && $self->nameservers) {
	  return $self->hints($self->nameservers);
  } else {
	  $self->nameservers(@hints);
  }

  print ";; verifying (root) zone...\n" if $self->{'debug'};
  # bind always asks one of the hint servers
  # for who it thinks is authoritative for
  # the (root) zone as a sanity check.
  # Nice idea.

  $self->recurse(1);
  my $packet=$self->query(".", "NS", "IN");
  $self->recurse(0);
  my %hints = ();
  if ($packet) {
    if (my @ans = $packet->answer) {
      foreach my $rr (@ans) {
        if ($rr->name =~ /^\.?$/ and
            $rr->type eq "NS") {
          # Found root authority
          my $server = lc $rr->rdatastr;
          $server =~ s/\.$//;
          print ";; FOUND HINT: $server\n" if $self->{'debug'};
          $hints{$server} = [];
        }
      }
      foreach my $rr ($packet->additional) {
	print ";; ADDITIONAL: ",$rr->string,"\n" if $self->{'debug'};
	if (my $server = lc $rr->name){
	  if ( $rr->type eq "A") {
	    #print ";; ADDITIONAL HELP: $server -> [".$rr->rdatastr."]\n" if $self->{'debug'};
	    if ($hints{$server}) {
	      print ";; STORING IP: $server IN A ",$rr->rdatastr,"\n" if $self->{'debug'};
	      push @{ $hints{$server} }, $rr->rdatastr;
	    }
	  }
	  if ( $rr->type eq "AAAA") {
	    #print ";; ADDITIONAL HELP: $server -> [".$rr->rdatastr."]\n" if $self->{'debug'};
	    if ($hints{$server}) {
	      print ";; STORING IP6: $server IN AAAA ",$rr->rdatastr,"\n" if $self->{'debug'};
	      push @{ $hints{$server} }, $rr->rdatastr;
	    }
	  }

	}
      }
    }
    foreach my $server (keys %hints) {
      if (!@{ $hints{$server} }) {
	# Wipe the servers without lookups
	delete $hints{$server};
      }
    }
    $self->{'hints'} = \%hints;
  } else {
    $self->{'hints'} = {};
  }
  if (%{ $self->{'hints'} }) {
    if ($self->{'debug'}) {
      print ";; USING THE FOLLOWING HINT IPS:\n";
      foreach my $ips (values %{ $self->{'hints'} }) {
	foreach my $server (@{ $ips }) {
	  print ";;  $server\n";
	}
      }
    }
  } else {
    warn "Servers [". join " ",($self->nameservers),"] did not give answers";
    print ";; Unsetting hints and nameservers, trying with hardcoded nameservers\n" if  $self->{'debug'};
    print $self->nameservers([]);
    return $self->hints();
  }

  # Disable recursion flag.


  return $self->nameservers( map { @{ $_ } } values %{ $self->{'hints'} } );
}


sub recursion_callback {
	my ($self, $sub) = @_;

	if ($sub && UNIVERSAL::isa($sub, 'CODE')) {
		$self->{'callback'} = $sub;
	}

	return $self->{'callback'};
}


# $res->query_dorecursion( args );
# Takes same args as Net::DNS::Resolver->query
# Purpose: Do that "hot pototo dance" on args.
sub query_dorecursion {
  my $self = shift;
  my @query = @_;

  # Make sure the hint servers are initialized.
  $self->hints unless $self->{'hints'};
  $self->recurse(0);
  # Make sure the authority cache is clean.
  # It is only used to store A and AAAA records of
  # the suposedly authoritative name servers.
  $self->{'authority_cache'} = {};

  # Obtain real question Net::DNS::Packet
  my $query_packet = $self->make_query_packet(@query);

  # Seed name servers with hints
  return $self->_dorecursion( $query_packet, ".", $self->{'hints'}, 0);
}

sub _dorecursion {
  my $self = shift;
  my $query_packet = shift;
  my $known_zone = shift;
  my $known_authorities = shift;
  my $depth = shift;
  my $cache = $self->{'authority_cache'};

  # die "Recursion too deep, aborting..." if $depth > 255;
  if ( $depth > 255 ) {
      print ";; _dorecursion() Recursion too deep, aborting...\n" if
	  $self->{'debug'};
      $self->errorstring("Recursion too deep, abborted");
      return undef;
  }

  $known_zone =~ s/\.*$/./;

  # Get IPs from authorities
  my @ns = ();
  foreach my $ns (keys %{ $known_authorities }) {
    if (scalar @{ $known_authorities->{$ns} }) {
      $cache->{$ns} = $known_authorities->{$ns};
      push (@ns, @{ $cache->{$ns} });
    } elsif ($cache->{$ns}) {
      $known_authorities->{$ns} = $cache->{$ns};
      push (@ns, @{ $cache->{$ns} });
    }
  }

  if (!@ns) {
    my $found_auth = 0;
    if ($self->{'debug'}) {
      require Data::Dumper;
      print ";; _dorecursion() Failed to extract nameserver IPs:\n";
      print Data::Dumper::Dumper([$known_authorities,$cache]);
    }
    foreach my $ns (keys %{ $known_authorities }) {
      if (!@{ $known_authorities->{$ns} }) {
        print ";; _dorecursion() Manual lookup for authority [$ns]\n" if $self->{'debug'};

        my $auth_packet;
	my @ans;

	# Don't query for V6 if its not there.
	if ($Net::DNS::Resolver::Base::has_inet6 && ! $self->{force_v4}){
	    $auth_packet =
		$self->_dorecursion
		($self->make_query_packet($ns,"AAAA"),  # packet
		 ".",               # known_zone
		 $self->{'hints'},  # known_authorities
		 $depth+1);         # depth
	    @ans = $auth_packet->answer if $auth_packet;
	}

	$auth_packet =
	    $self->_dorecursion
	    ($self->make_query_packet($ns,"A"),  # packet
	     ".",               # known_zone
	     $self->{'hints'},  # known_authorities
	     $depth+1);         # depth

	push (@ans,$auth_packet->answer ) if $auth_packet;

        if ( @ans ) {
          print ";; _dorecursion() Answers found for [$ns]\n" if $self->{'debug'};
          foreach my $rr (@ans) {
	    print ";; RR:".$rr->string."\n" if $self->{'debug'};
            if ($rr->type eq "CNAME") {
              # Follow CNAME
              if (my $server = lc $rr->name) {
                $server =~ s/\.*$/./;
                if ($server eq $ns) {
                  my $cname = lc $rr->rdatastr;
                  $cname =~ s/\.*$/./;
                  print ";; _dorecursion() Following CNAME ns [$ns] -> [$cname]\n" if $self->{'debug'};
                  $known_authorities->{$cname} ||= [];
                  delete $known_authorities->{$ns};
                  next;
                }
              }
            } elsif ($rr->type eq "A" ||$rr->type eq "AAAA" ) {
              if (my $server = lc $rr->name) {
                $server =~ s/\.*$/./;
                if ($known_authorities->{$server}) {
                  my $ip = $rr->rdatastr;
                  print ";; _dorecursion() Found ns: $server IN A $ip\n" if $self->{'debug'};
                  $cache->{$server} = $known_authorities->{$server};
                  push (@{ $cache->{$ns} }, $ip);
                  $found_auth++;
                  next;
                }
              }
            }
            print ";; _dorecursion() Ignoring useless answer: ",$rr->string,"\n" if $self->{'debug'};
          }
        } else {
          print ";; _dorecursion() Could not find A records for [$ns]\n" if $self->{'debug'};
        }
      }
    }
    if ($found_auth) {
      print ";; _dorecursion() Found $found_auth new NS authorities...\n" if $self->{'debug'};
      return $self->_dorecursion( $query_packet, $known_zone, $known_authorities, $depth+1);
    }
    print ";; _dorecursion() No authority information could be obtained.\n" if $self->{'debug'};
    return undef;
  }

  # Cut the deck of IPs in a random place.
  print ";; _dorecursion() cutting deck of (".scalar(@ns).") authorities...\n" if $self->{'debug'};
  splice(@ns, 0, 0, splice(@ns, int(rand @ns)));


 LEVEL:  foreach my $levelns (@ns){
   print ";; _dorecursion() Trying nameserver [$levelns]\n" if $self->{'debug'};
   $self->nameservers($levelns);

   if (my $packet = $self->send( $query_packet )) {

     if ($self->{'callback'}) {
       $self->{'callback'}->($packet);
     }

     my $of = undef;
     print ";; _dorecursion() Response received from [",$self->answerfrom,"]\n" if $self->{'debug'};
     if (my $status = $packet->header->rcode) {
       if ($status eq "NXDOMAIN") {
	 # I guess NXDOMAIN is the best we'll ever get
	 print ";; _dorecursion() returning NXDOMAIN\n" if $self->{'debug'};
	 return $packet;
       } elsif (my @ans = $packet->answer) {
	 print ";; _dorecursion() Answers were found.\n" if $self->{'debug'};
	 return $packet;
       } elsif (my @authority = $packet->authority) {
	 my %auth = ();
	 foreach my $rr (@authority) {
	   if ($rr->type =~ /^(NS|SOA)$/) {
	     my $server = lc ($1 eq "NS" ? $rr->nsdname : $rr->mname);
	     $server =~ s/\.*$/./;
	     $of = lc $rr->name;
	     $of =~ s/\.*$/./;
	     print ";; _dorecursion() Received authority [$of] [",$rr->type(),"] [$server]\n" if $self->{'debug'};
	     if (length $of <= length $known_zone) {
	       print ";; _dorecursion() Deadbeat name server did not provide new information.\n" if $self->{'debug'};
	       next LEVEL;
	     } elsif ($of =~ /$known_zone$/) {
	       print ";; _dorecursion() FOUND closer authority for [$of] at [$server].\n" if $self->{'debug'};
	       $auth{$server} ||= [];
	     } else {
	       print ";; _dorecursion() Confused name server [",$self->answerfrom,"] thinks [$of] is closer than [$known_zone]?\n" if $self->{'debug'};
	       last;
	     }
	   } else {
	     print ";; _dorecursion() Ignoring NON NS entry found in authority section: ",$rr->string,"\n" if $self->{'debug'};
	   }
	 }
	 foreach my $rr ($packet->additional) {
	   if ($rr->type eq "CNAME") {
	     # Store this CNAME into %auth too
	     if (my $server = lc $rr->name) {
	       $server =~ s/\.*$/./;
	       if ($auth{$server}) {
		 my $cname = lc $rr->rdatastr;
		 $cname =~ s/\.*$/./;
		 print ";; _dorecursion() FOUND CNAME authority: ",$rr->string,"\n" if $self->{'debug'};
		 $auth{$cname} ||= [];
		 $auth{$server} = $auth{$cname};
		 next;
	       }
	     }
	   } elsif ($rr->type eq "A" || $rr->type eq "AAAA") {
	     if (my $server = lc $rr->name) {
	       $server =~ s/\.*$/./;
	       if ($auth{$server}) {
		 print ";; _dorecursion() STORING: $server IN A    ",$rr->rdatastr,"\n" if $self->{'debug'} &&  $rr->type eq "A";
		 print ";; _dorecursion() STORING: $server IN AAAA ",$rr->rdatastr,"\n" if $self->{'debug'}&&  $rr->type eq "AAAA";
		 push @{ $auth{$server} }, $rr->rdatastr;
		 next;
	       }
	     }
	   }
	   print ";; _dorecursion() Ignoring useless: ",$rr->string,"\n" if $self->{'debug'};
	 }
	 if ($of =~ /$known_zone$/) {
	   return $self->_dorecursion( $query_packet, $of, \%auth, $depth+1 );
	 } else {
	   return $self->_dorecursion( $query_packet, $known_zone, $known_authorities, $depth+1 );
	 }
      }
     }
   }
 }

  return undef;
}

1;

__END__


=head1 NAME

Net::DNS::Resolver::Recurse - Perform recursive dns lookups

=head1 SYNOPSIS

  use Net::DNS::Resolver::Recurse;
  my $res = Net::DNS::Resolver::Recurse->new;

=head1 DESCRIPTION

This module is a sub class of Net::DNS::Resolver. So the methods for
Net::DNS::Resolver still work for this module as well.  There are just a
couple methods added:

=head2 hints

Initialize the hint servers.  Recursive queries need a starting name
server to work off of. This method takes a list of IP addresses to use
as the starting servers.  These name servers should be authoritative for
the root (.) zone.

  $res->hints(@ips);

If no hints are passed, the default nameserver is asked for the hints.
Normally these IPs can be obtained from the following location:

  ftp://ftp.internic.net/domain/named.root

=head2 recursion_callback

This method is takes a code reference, which is then invoked each time a
packet is received during the recursive lookup.  For example to emulate
dig's C<+trace> function:

 $res->recursion_callback(sub {
     my $packet = shift;

     $_->print for $packet->additional;

     printf(";; Received %d bytes from %s\n\n",
         $packet->answersize,
         $packet->answerfrom
     );
 });

=head2 query_dorecursion

This method is much like the normal query() method except it disables
the recurse flag in the packet and explicitly performs the recursion.

  $packet = $res->query_dorecursion( "www.netscape.com.", "A");


=head1 IPv6 transport

If the appropriate IPv6 libraries are installed the recursive resolver
will randomly choose between IPv6 and IPv4 addresses of the
nameservers it encounters during recursion.

If you want to force IPv4 transport use the force_v4() method. Also see
the IPv6 transport notes in the Net::DNS::Resolver documentation.

=head1 AUTHOR

Rob Brown, bbb@cpan.org

=head1 SEE ALSO

L,

=head1 COPYRIGHT

Copyright (c) 2002, Rob Brown.  All rights reserved.
Portions Copyright (c) 2005, Olaf M Kolkman.

This module is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.

$Id: Recurse.pm 932 2011-10-26 12:40:48Z willem $

=cut

Example lookup process:

[root@box root]# dig +trace www.rob.com.au.

; <<>> DiG 9.2.0 <<>> +trace www.rob.com.au.
;; global options:  printcmd
.                       507343  IN      NS      C.ROOT-SERVERS.NET.
.                       507343  IN      NS      D.ROOT-SERVERS.NET.
.                       507343  IN      NS      E.ROOT-SERVERS.NET.
.                       507343  IN      NS      F.ROOT-SERVERS.NET.
.                       507343  IN      NS      G.ROOT-SERVERS.NET.
.                       507343  IN      NS      H.ROOT-SERVERS.NET.
.                       507343  IN      NS      I.ROOT-SERVERS.NET.
.                       507343  IN      NS      J.ROOT-SERVERS.NET.
.                       507343  IN      NS      K.ROOT-SERVERS.NET.
.                       507343  IN      NS      L.ROOT-SERVERS.NET.
.                       507343  IN      NS      M.ROOT-SERVERS.NET.
.                       507343  IN      NS      A.ROOT-SERVERS.NET.
.                       507343  IN      NS      B.ROOT-SERVERS.NET.
;; Received 436 bytes from 127.0.0.1#53(127.0.0.1) in 9 ms
  ;;; But these should be hard coded as the hints

  ;;; Ask H.ROOT-SERVERS.NET gave:
au.                     172800  IN      NS      NS2.BERKELEY.EDU.
au.                     172800  IN      NS      NS1.BERKELEY.EDU.
au.                     172800  IN      NS      NS.UU.NET.
au.                     172800  IN      NS      BOX2.AUNIC.NET.
au.                     172800  IN      NS      SEC1.APNIC.NET.
au.                     172800  IN      NS      SEC3.APNIC.NET.
;; Received 300 bytes from 128.63.2.53#53(H.ROOT-SERVERS.NET) in 322 ms
  ;;; A little closer than before

  ;;; Ask NS2.BERKELEY.EDU gave:
com.au.                 259200  IN      NS      ns4.ausregistry.net.
com.au.                 259200  IN      NS      dns1.telstra.net.
com.au.                 259200  IN      NS      au2ld.CSIRO.au.
com.au.                 259200  IN      NS      audns01.syd.optus.net.
com.au.                 259200  IN      NS      ns.ripe.net.
com.au.                 259200  IN      NS      ns1.ausregistry.net.
com.au.                 259200  IN      NS      ns2.ausregistry.net.
com.au.                 259200  IN      NS      ns3.ausregistry.net.
com.au.                 259200  IN      NS      ns3.melbourneit.com.
;; Received 387 bytes from 128.32.206.12#53(NS2.BERKELEY.EDU) in 10312 ms
  ;;; A little closer than before

  ;;; Ask ns4.ausregistry.net gave:
com.au.                 259200  IN      NS      ns1.ausregistry.net.
com.au.                 259200  IN      NS      ns2.ausregistry.net.
com.au.                 259200  IN      NS      ns3.ausregistry.net.
com.au.                 259200  IN      NS      ns4.ausregistry.net.
com.au.                 259200  IN      NS      ns3.melbourneit.com.
com.au.                 259200  IN      NS      dns1.telstra.net.
com.au.                 259200  IN      NS      au2ld.CSIRO.au.
com.au.                 259200  IN      NS      ns.ripe.net.
com.au.                 259200  IN      NS      audns01.syd.optus.net.
;; Received 259 bytes from 137.39.1.3#53(ns4.ausregistry.net) in 606 ms
  ;;; Uh... yeah... I already knew this
  ;;; from what NS2.BERKELEY.EDU told me.
  ;;; ns4.ausregistry.net must have brain damage

  ;;; Ask ns1.ausregistry.net gave:
rob.com.au.             86400   IN      NS      sy-dns02.tmns.net.au.
rob.com.au.             86400   IN      NS      sy-dns01.tmns.net.au.
;; Received 87 bytes from 203.18.56.41#53(ns1.ausregistry.net) in 372 ms
  ;;; Ah, much better.  Something more useful.

  ;;; Ask sy-dns02.tmns.net.au gave:
www.rob.com.au.         7200    IN      A       139.134.5.123
rob.com.au.             7200    IN      NS      sy-dns01.tmns.net.au.
rob.com.au.             7200    IN      NS      sy-dns02.tmns.net.au.
;; Received 135 bytes from 139.134.2.18#53(sy-dns02.tmns.net.au) in 525 ms
  ;;; FINALLY, THE ANSWER!
Net-DNS-0.68/lib/Net/DNS/Resolver/Base.pm0000644000175000017500000011611011710626412017114 0ustar  willemwillempackage Net::DNS::Resolver::Base;
#
# $Id: Base.pm 932 2011-10-26 12:40:48Z willem $
#

use strict;

BEGIN {
    eval { require bytes; }
}

use vars qw(
	    $VERSION
	    $has_inet6
	    $AUTOLOAD
);

use Carp;
use Config ();
use Socket;
use IO::Socket;
use IO::Select;

use Net::DNS;
use Net::DNS::Packet;

$VERSION = (qw$LastChangedRevision: 932 $)[1];


#
#  A few implementation notes wrt IPv6 support.
#
#  In general we try to be gracious to those stacks that do not have ipv6 support.
#  We test that by means of the availability of Socket6 and IO::Socket::INET6
#


#  We have chosen to not use mapped IPv4 addresses, there seem to be
#  issues with this; as a result we have to use sockets for both
#  family types.  To be able to deal with persistent sockets and
#  sockets of both family types we use an array that is indexed by the
#  socketfamily type to store the socket handlers. I think this could
#  be done more efficiently.


#  inet_pton is not available on WIN32, so we only use the getaddrinfo
#  call to translate IP addresses to socketaddress



#  Set the $force_inet4_only variable inside the BEGIN block to force
#  not to use the IPv6 stuff. You can use this for compatibility
#  test. We do not see a need to do this from the calling code.


# Olaf Kolkman, RIPE NCC, December 2003.


BEGIN {
    if (
	 eval {require IO::Socket::INET6; IO::Socket::INET6->VERSION("2.00");}
	 ) {
 	$has_inet6=1;
    }else{
 	$has_inet6=0;
    }
 }






#
# Set up a closure to be our class data.
#
{
	my %defaults = (
		nameservers	   => ['127.0.0.1'],
		port		   => 53,
		srcaddr        => '0.0.0.0',
		srcport        => 0,
		domain	       => '',
		searchlist	   => [],
		retrans	       => 5,
		retry		   => 4,
		usevc		   => 0,
		stayopen       => 0,
		igntc          => 0,
		recurse        => 1,
		defnames       => 1,
		dnsrch         => 1,
		debug          => 0,
		errorstring	   => 'unknown error or no error',
		tsig_rr        => undef,
		answerfrom     => '',
		querytime      => undef,
		tcp_timeout    => 120,
		udp_timeout    => undef,
		axfr_sel       => undef,
		axfr_rr        => [],
		axfr_soa_count => 0,
		persistent_tcp => 0,
		persistent_udp => 0,
		dnssec         => 0,
		udppacketsize  => 0,  # The actual default is lower bound by Net::DNS::PACKETSZ
	        cdflag         => 0,  # this is only used when {dnssec} == 1
	        adflag         => 1,  # this is only used when {dnssec} == 1
		force_v4       => 0,  # force_v4 is only relevant when we have
                                      # v6 support available
		ignqrid        => 0,  # normally packets with non-matching ID
                                      # or with the qr bit of are thrown away
			              # in 'ignqrid' these packets are
			              # are accepted.
			              # USE WITH CARE, YOU ARE VULNARABLE TO
			              # SPOOFING IF SET.
			              # This is may be a temporary feature
	);

	# If we're running under a SOCKSified Perl, use TCP instead of UDP
	# and keep the sockets open.
	if ($Config::Config{'usesocks'}) {
		$defaults{'usevc'} = 1;
		$defaults{'persistent_tcp'} = 1;
	}

	sub defaults { \%defaults }
}

# These are the attributes that we let the user specify in the new().
# We also deprecate access to these with AUTOLOAD (some may be useful).
my %public_attr = map { $_ => 1 } qw(
	nameservers
	port
	srcaddr
	srcport
	domain
	searchlist
	retrans
	retry
	usevc
	stayopen
	igntc
	recurse
	defnames
	dnsrch
	debug
	tcp_timeout
	udp_timeout
	persistent_tcp
	persistent_udp
	dnssec
	ignqrid
);


sub new {
	my $class = shift;
	my $self = bless({ %{$class->defaults} }, $class);

	$self->_process_args(@_) if @_ and @_ % 2 == 0;
	return $self;
}



sub _process_args {
	my ($self, %args) = @_;

	if ($args{'config_file'}) {
		my $file = $args{'config_file'};
		$self->read_config_file($file) or croak "Could not open $file: $!";
	}

	foreach my $attr (keys %args) {
		next unless $public_attr{$attr};

		if ($attr eq 'nameservers' || $attr eq 'searchlist') {

			die "Net::DNS::Resolver->new(): $attr must be an arrayref\n" unless
			  defined($args{$attr}) &&  UNIVERSAL::isa($args{$attr}, 'ARRAY');

		}

		if ($attr eq 'nameservers') {
			$self->nameservers(@{$args{$attr}});
		} else {
			$self->{$attr} = $args{$attr};
		}
	}


}





#
# Some people have reported that Net::DNS dies because AUTOLOAD picks up
# calls to DESTROY.
#
sub DESTROY {}


sub read_env {
	my ($invocant) = @_;
	my $config     = ref $invocant ? $invocant : $invocant->defaults;

	$config->{'nameservers'} = [ $ENV{'RES_NAMESERVERS'} =~ m/(\S+)/g ]
		if exists $ENV{'RES_NAMESERVERS'};

	$config->{'searchlist'}  = [ split(' ', $ENV{'RES_SEARCHLIST'})  ]
		if exists $ENV{'RES_SEARCHLIST'};

	$config->{'domain'} = $ENV{'LOCALDOMAIN'}
		if exists $ENV{'LOCALDOMAIN'};

	if (exists $ENV{'RES_OPTIONS'}) {
		foreach ($ENV{'RES_OPTIONS'} =~ m/(\S+)/g) {
			my ($name, $val) = split(m/:/);
			$val = 1 unless defined $val;
			$config->{$name} = $val if exists $config->{$name};
		}
	}
}

#
# $class->read_config_file($filename) or $self->read_config_file($file)
#
sub read_config_file {
	my ($invocant, $file) = @_;
	my $config            = ref $invocant ? $invocant : $invocant->defaults;


	my @ns;
	my @searchlist;

	local *FILE;

	open(FILE, "<", $file) or return;
	local $/ = "\n";
	local $_;

	while () {
 		s/\s*[;#].*//;

		# Skip ahead unless there's non-whitespace characters
		next unless m/\S/;

		SWITCH: {
			/^\s*domain\s+(\S+)/ && do {
				$config->{'domain'} = $1;
				last SWITCH;
			};

			/^\s*search\s+(.*)/ && do {
				push(@searchlist, split(' ', $1));
				last SWITCH;
			};

			/^\s*nameserver\s+(.*)/ && do {
				foreach my $ns (split(' ', $1)) {
					$ns = '0.0.0.0' if $ns eq '0';
#					next if $ns =~ m/:/;  # skip IPv6 nameservers
					push @ns, $ns;
				}
				last SWITCH;
			};
		    }
		  }
		close FILE || croak "Could not close $file: $!";

		$config->{'nameservers'} = [ @ns ]         if @ns;
		$config->{'searchlist'}  = [ @searchlist ] if @searchlist;

		return 1;
	    }




sub print { print $_[0]->string }

sub string {
	my $self = shift;

	my $timeout = defined $self->{'tcp_timeout'} ? $self->{'tcp_timeout'} : 'indefinite';
	my $hasINET6line= $has_inet6 ?" (IPv6 Transport is available)":" (IPv6 Transport is not available)";
	my $ignqrid=$self->{'ignqrid'} ? "\n;; ACCEPTING ALL PACKETS (IGNQRID)":"";
	return <{domain}
;;  searchlist   = @{$self->{searchlist}}
;;  nameservers  = @{$self->{nameservers}}
;;  port         = $self->{port}
;;  srcport      = $self->{srcport}
;;  srcaddr      = $self->{srcaddr}
;;  tcp_timeout  = $timeout
;;  retrans  = $self->{retrans}  retry    = $self->{retry}
;;  usevc    = $self->{usevc}  stayopen = $self->{stayopen}    igntc = $self->{igntc}
;;  defnames = $self->{defnames}  dnsrch   = $self->{dnsrch}
;;  recurse  = $self->{recurse}  debug    = $self->{debug}
;;  force_v4 = $self->{force_v4} $hasINET6line $ignqrid
END

}


sub searchlist {
	my $self = shift;
	$self->{'searchlist'} = [ @_ ] if @_;
	return @{$self->{'searchlist'}};
}

sub nameservers {
    my $self   = shift;

    if (@_) {
	my @a;
	foreach my $ns (@_) {
	    next unless defined($ns);
	    if ( _ip_is_ipv4($ns) ) {
		push @a, ($ns eq '0') ? '0.0.0.0' : $ns;

	    } elsif ( _ip_is_ipv6($ns) ) {
		push @a, ($ns eq '0') ? '::0' : $ns;

	} else  {

		my $defres = Net::DNS::Resolver->new(
			    udp_timeout => $self->udp_timeout,
			    tcp_timeout => $self->tcp_timeout
			);
		$defres->{"debug"}=$self->{"debug"};



		my @names;

		if ($ns !~ /\./) {
		    if (defined $defres->searchlist) {
			@names = map { $ns . '.' . $_ }
			$defres->searchlist;
		    } elsif (defined $defres->domain) {
			@names = ($ns . '.' . $defres->domain);
		    }
		}
		else {
		    @names = ($ns);
		}

		my $packet = $defres->search($ns);
		$self->errorstring($defres->errorstring);
		if (defined($packet) && (my @adresses = cname_addr([@names], $packet))) {
		    push @a, @adresses;
		}
		else {
		    $packet = $defres->search($ns, 'AAAA');
		    $self->errorstring($defres->errorstring);
		    if (defined($packet)) {
			push @a, cname_addr([@names], $packet);
		    }
		}
	    }
	}


	$self->{'nameservers'} = [ @a ];
    }
    my @returnval;
    foreach my $ns (@{$self->{'nameservers'}}){
	next if _ip_is_ipv6($ns) && (! $has_inet6 || $self->force_v4() );
	push @returnval, $ns;
    }

    return @returnval;
}

sub nameserver { &nameservers }

sub cname_addr {
	# TODO 20081217
	# This code does not follow CNAME chanes, it only looks inside the packet. Out of bailiwick will fail.
	# Also it is not IP agnostic
	my $names  = shift;
	my $packet = shift;
	my @addr;
	my @names = @{$names};

	my $oct2 = '(?:2[0-4]\d|25[0-5]|[0-1]?\d\d|\d)';

	RR: foreach my $rr ($packet->answer) {
		next RR unless grep {$rr->name} @names;

		if ($rr->type eq 'CNAME') {
			push(@names, $rr->cname);
		} elsif ($rr->type eq 'A') {
			# Run a basic taint check.
			# Remark olaf 20081217: This taint check seems to be unneeded (albeit harmless). The packet
			# came from the wire and all parsing (untainting) has been done in Net::DNS::RR::A
			next RR unless $rr->address =~ m/^($oct2\.$oct2\.$oct2\.$oct2)$/o;

			push(@addr, $1)
		}
		elsif ($rr->type eq 'AAAA') {
			push(@addr, $rr->address)
        }
	}


	return @addr;
}


# if ($self->{"udppacketsize"}  > Net::DNS::PACKETSZ()
# then we use EDNS and $self->{"udppacketsize"}
# should be taken as the maximum packet_data length
sub _packetsz {
	my ($self) = @_;

	return $self->{"udppacketsize"} > Net::DNS::PACKETSZ() ?
		   $self->{"udppacketsize"} : Net::DNS::PACKETSZ();
}

sub _reset_errorstring {
	my ($self) = @_;

	$self->errorstring($self->defaults->{'errorstring'});
}


sub search {
	my $self = shift;
	my $name = shift || '.';

	my $defdomain = $self->{domain} if $self->{defnames};
	my @searchlist = @{$self->{searchlist}} if $self->{dnsrch};

	# resolve name by trying as absolute name, then applying searchlist
	my @list = (undef, @searchlist);
	for ($name) {
		# resolve name with no dots or colons by applying searchlist (or domain)
		@list = @searchlist ? @searchlist : ($defdomain) unless  m/[:.]/;
		# resolve name with trailing dot as absolute name
		@list = (undef) if m/\.$/;
	}

	foreach my $suffix ( @list ) {
	        my $fqname = join '.', $name, ($suffix || ());

		print ';; search(', join(', ', $fqname, @_), ")\n" if $self->{debug};

		my $packet = $self->send($fqname, @_) || return undef;

		next unless ($packet->header->rcode eq "NOERROR"); # something
								 #useful happened
		return $packet if $packet->header->ancount;	# answer found
		next unless $packet->header->qdcount;           # question empty?

		last if ($packet->question)[0]->qtype eq 'PTR';	# abort search if IP
	}
	return undef;
}


sub query {
	my $self = shift;
	my $name = shift || '.';

	# resolve name containing no dots or colons by appending domain
	my @suffix = ($self->{domain} || ()) if $name !~ m/[:.]/ and $self->{defnames};

	my $fqname = join '.', $name, @suffix;

	print ';; query(', join(', ', $fqname, @_), ")\n" if $self->{debug};

	my $packet = $self->send($fqname, @_) || return undef;

	return $packet if $packet->header->ancount;	# answer found
	return undef;
}


sub send {
	my $self = shift;
	my $packet = $self->make_query_packet(@_);
	my $packet_data = $packet->data;


	my $ans;

	if ($self->{'usevc'} || length $packet_data > $self->_packetsz) {

	    $ans = $self->send_tcp($packet, $packet_data);

	} else {
	    $ans = $self->send_udp($packet, $packet_data);

	    if ($ans && $ans->header->tc && !$self->{'igntc'}) {
			print ";;\n;; packet truncated: retrying using TCP\n" if $self->{'debug'};
			$ans = $self->send_tcp($packet, $packet_data);
	    }
	}

	return $ans;
}



sub send_tcp {
	my ($self, $packet, $packet_data) = @_;
	my $lastanswer;

	my $srcport = $self->{'srcport'};
	my $srcaddr = $self->{'srcaddr'};
	my $dstport = $self->{'port'};

	unless ( $self->nameservers()) {
		$self->errorstring('no nameservers');
		print ";; ERROR: send_tcp: no nameservers\n" if $self->{'debug'};
		return;
	}

	$self->_reset_errorstring;


      NAMESERVER: foreach my $ns ($self->nameservers()) {

	      print ";; attempt to send_tcp($ns:$dstport) (src port = $srcport)\n"
		  if $self->{'debug'};



	      my $sock;
	      my $sock_key = "$ns:$dstport";
	      my ($host,$port);
	      if ($self->persistent_tcp && $self->{'sockets'}[AF_UNSPEC]{$sock_key}) {
		      $sock = $self->{'sockets'}[AF_UNSPEC]{$sock_key};
		      print ";; using persistent socket\n"
			if $self->{'debug'};
		      unless ($sock->connected){
			print ";; persistent socket disconnected (trying to reconnect)"
			  if $self->{'debug'};
			undef($sock);
			$sock= $self->_create_tcp_socket($ns);
			next NAMESERVER unless $sock;
			$self->{'sockets'}[AF_UNSPEC]{$sock_key} = $sock;
		      }

	      } else {
		      $sock= $self->_create_tcp_socket($ns);
		      next NAMESERVER unless $sock;

		      $self->{'sockets'}[AF_UNSPEC]{$sock_key} = $sock if
			  $self->persistent_tcp;
	      }


	      my $lenmsg = pack('n', length($packet_data));
	      print ';; sending ', length($packet_data), " bytes\n"
		  if $self->{'debug'};

	      # note that we send the length and packet data in a single call
	      # as this produces a single TCP packet rather than two. This
	      # is more efficient and also makes things much nicer for sniffers.
	      # (ethereal doesn't seem to reassemble DNS over TCP correctly)


	      unless ($sock->send( $lenmsg . $packet_data)) {
		      $self->errorstring($!);
		      print ";; ERROR: send_tcp: data send failed: $!\n"
			  if $self->{'debug'};
		      next NAMESERVER;
	      }

	      my $sel = IO::Select->new($sock);
	      my $timeout=$self->{'tcp_timeout'};
	      if ($sel->can_read($timeout)) {
		      my $buf = read_tcp($sock, Net::DNS::INT16SZ(), $self->{'debug'});
		      next NAMESERVER unless length($buf); # Failure to get anything
		      my ($len) = unpack('n', $buf);
		      next NAMESERVER unless $len;         # Cannot determine size

		      unless ($sel->can_read($timeout)) {
			      $self->errorstring('timeout');
			      print ";; TIMEOUT\n" if $self->{'debug'};
			      next;
		      }

		      $buf = read_tcp($sock, $len, $self->{'debug'});

		      # Cannot use $sock->peerhost, because on some systems it
		      # returns garbage after reading from TCP. I have observed
		      # this myself on cygwin.
		      # -- Willem
		      #
		      $self->answerfrom( $ns );

		      print ';; received ', length($buf), " bytes\n"
			  if $self->{'debug'};

		      unless (length($buf) == $len) {
				$self->errorstring("expected $len bytes, " .
						   'received ' . length($buf));
				next;
			}

			my ($ans, $err) = Net::DNS::Packet->new(\$buf, $self->{'debug'});
			if (defined $ans) {
				$self->errorstring($ans->header->rcode);
				$ans->answerfrom($self->answerfrom);

				if ($ans->header->rcode ne "NOERROR" &&
				    $ans->header->rcode ne "NXDOMAIN"){
					# Remove this one from the stack
					print "RCODE: ".$ans->header->rcode ."; trying next nameserver\n" if $self->{'debug'};
					$lastanswer=$ans;
					next NAMESERVER ;

				}

			}
			elsif (defined $err) {
				$self->errorstring($err);
			}

			return $ans;
		}
		else {
			$self->errorstring('timeout');
			next;
		}
	}

	if ($lastanswer){
		$self->errorstring($lastanswer->header->rcode );
		return $lastanswer;

	}

	return;
}



sub send_udp {
	my ($self, $packet, $packet_data) = @_;
	my $retrans = $self->{'retrans'};
	my $timeout = $retrans;

	my $lastanswer;

	my $stop_time = time + $self->{'udp_timeout'} if $self->{'udp_timeout'};

	$self->_reset_errorstring;

 	my @ns;
  	my $dstport = $self->{'port'};
  	my $srcport = $self->{'srcport'};
  	my $srcaddr = $self->{'srcaddr'};

 	my @sock;


 	if ($self->persistent_udp){
 	    if ($has_inet6){
 		if ( defined ($self->{'sockets'}[AF_INET6()]{'UDP'})) {
 		    $sock[AF_INET6()] = $self->{'sockets'}[AF_INET6()]{'UDP'};
 		    print ";; using persistent AF_INET6() family type socket\n"
			if $self->{'debug'};
 		}
 	    }
 	    if ( defined ($self->{'sockets'}[AF_INET]{'UDP'})) {
 		$sock[AF_INET] = $self->{'sockets'}[AF_INET]{'UDP'};
 		print ";; using persistent AF_INET() family type socket\n"
 		    if $self->{'debug'};
 	    }
	}

	if ($has_inet6  && ! $self->force_v4() && !defined( $sock[AF_INET6()] )){


	    # '::' Otherwise the INET6 socket will fail.

            my $srcaddr6 = $srcaddr eq '0.0.0.0' ? '::' : $srcaddr;

	    print ";; Trying to set up a AF_INET6() family type UDP socket with srcaddr: $srcaddr6 ... "
		if $self->{'debug'};


	    # IO::Socket carps on errors if Perl's -w flag is turned on.
	    # Uncomment the next two lines and the line following the "new"
	    # call to turn off these messages.

	    #my $old_wflag = $^W;
	    #$^W = 0;

	    $sock[AF_INET6()] = IO::Socket::INET6->new(
						       LocalAddr => $srcaddr6,
						       LocalPort => ($srcport || undef),
						       Proto     => 'udp',
						       );




	    print (defined($sock[AF_INET6()])?"done\n":"failed\n") if $has_inet6 && $self->debug();

	}

	# Always set up an AF_INET socket.
	# It will be used if the address familly of for the endpoint is V4.

	if (!defined( $sock[AF_INET]))

	{
	    print ";; setting up an AF_INET() family type UDP socket\n"
		if $self->{'debug'};

	    #my $old_wflag = $^W;
	    #$^W = 0;

 	    $sock[AF_INET] = IO::Socket::INET->new(
 						   LocalAddr => $srcaddr,
 						   LocalPort => ($srcport || undef),
 						   Proto     => 'udp',
 						   ) ;
 	    #$^W = $old_wflag;
	}



	unless (defined $sock[AF_INET] || ($has_inet6 && defined $sock[AF_INET6()])) {

	    $self->errorstring("could not get socket");   #'
	    return;
	}

	$self->{'sockets'}[AF_INET]{'UDP'} = $sock[AF_INET] if ($self->persistent_udp) && defined( $sock[AF_INET] );
	$self->{'sockets'}[AF_INET6()]{'UDP'} = $sock[AF_INET6()] if $has_inet6 && ($self->persistent_udp) && defined( $sock[AF_INET6()]) && ! $self->force_v4();

 	# Constructing an array of arrays that contain 3 elements: The
 	# nameserver IP address, its sockaddr and the sockfamily for
 	# which the sockaddr structure is constructed.

	my $nmbrnsfailed=0;
      NSADDRESS: foreach my $ns_address ($self->nameservers()){
	  # The logic below determines the $dst_sockaddr.
	  # If getaddrinfo is available that is used for both INET4 and INET6
	  # If getaddrinfo is not avialable (Socket6 failed to load) we revert
	  # to the 'classic mechanism
	  if ($has_inet6  && ! $self->force_v4() ){
	      # we can use getaddrinfo
	      no strict 'subs';   # Because of the eval statement in the BEGIN
	      # AI_NUMERICHOST is not available at compile time.
	      # The AI_NUMERICHOST surpresses lookups.

	      my $old_wflag = $^W; 		#circumvent perl -w warnings about 'udp'
	      $^W = 0;



	      my @res = Socket6::getaddrinfo($ns_address, $dstport, AF_UNSPEC, SOCK_DGRAM,
				    0, AI_NUMERICHOST);

	      $^W=$old_wflag ;


	      use strict 'subs';

	      my ($sockfamily, $socktype_tmp,
		  $proto_tmp, $dst_sockaddr, $canonname_tmp) = @res;

	      if (scalar(@res) < 5) {
		  die ("can't resolve \"$ns_address\" to address");
	      }

	      push @ns,[$ns_address,$dst_sockaddr,$sockfamily];

	  }else{
	      next NSADDRESS unless( _ip_is_ipv4($ns_address));
	      my $dst_sockaddr = sockaddr_in($dstport, inet_aton($ns_address));
	      push @ns, [$ns_address,$dst_sockaddr,AF_INET];
	  }

      }

      	unless (@ns) {
	    print "No nameservers" if $self->debug();
	    $self->errorstring('no nameservers');
	    return;
	}

 	my $sel = IO::Select->new() ;
	# We allready tested that one of the two socket exists

 	$sel->add($sock[AF_INET]) if defined ($sock[AF_INET]);
 	$sel->add($sock[AF_INET6()]) if $has_inet6 &&  defined ($sock[AF_INET6()]) && ! $self->force_v4();


	# Perform each round of retries.
	for (my $i = 0;
	     $i < $self->{'retry'};
	     ++$i, $retrans *= 2, $timeout = int($retrans / (@ns || 1))) {

		$timeout = 1 if ($timeout < 1);

		# Try each nameserver.
	      NAMESERVER: foreach my $ns (@ns) {
		  next if defined $ns->[3];
			if ($stop_time) {
				my $now = time;
				if ($stop_time < $now) {
					$self->errorstring('query timed out');
					return;
				}
				if ($timeout > 1 && $timeout > ($stop_time-$now)) {
					$timeout = $stop_time-$now;
				}
			}
			my $nsname = $ns->[0];
			my $nsaddr = $ns->[1];
   	                my $nssockfamily = $ns->[2];

			# If we do not have a socket for the transport
			# we are supposed to reach the namserver on we
			# should skip it.
			unless (defined ($sock[ $nssockfamily ])){
			    print "Send error: cannot reach $nsname (".

				( ($has_inet6 && $nssockfamily == AF_INET6()) ? "IPv6" : "" ).
				( ($nssockfamily == AF_INET) ? "IPv4" : "" ).
				") not available"
				if $self->debug();


			    $self->errorstring("Send error: cannot reach $nsname (" .
					       ( ($has_inet6 && $nssockfamily == AF_INET6()) ? "IPv6" : "" ).
					       ( ($nssockfamily == AF_INET) ? "IPv4" : "" ).
					       ") not available"

);
			    next NAMESERVER ;
			    }

			print ";; send_udp($nsname:$dstport)\n"
				if $self->{'debug'};

			unless ($sock[$nssockfamily]->send($packet_data, 0, $nsaddr)) {
				print ";; send error: $!\n" if $self->{'debug'};
				$self->errorstring("Send error: $!");
				$nmbrnsfailed++;
				$ns->[3]="Send error".$self->errorstring();
				next;
			}

			# See ticket 11931 but this works not quite yet
			my $oldpacket_timeout=time+$timeout;
			until ( $oldpacket_timeout && ($oldpacket_timeout < time())) {
			    my @ready = $sel->can_read($timeout);
			  SELECTOR: foreach my $ready (@ready) {
			      my $buf = '';

			      if ($ready->recv($buf, $self->_packetsz)) {

				  $self->answerfrom($ready->peerhost);

				  print ';; answer from ',
				  $ready->peerhost, ':',
				  $ready->peerport, ' : ',
				  length($buf), " bytes\n"
				      if $self->{'debug'};

				  my ($ans, $err) = Net::DNS::Packet->new(\$buf, $self->{'debug'});

				  if (defined $ans) {
				      next SELECTOR unless ( $ans->header->qr || $self->{'ignqrid'});
				      next SELECTOR unless  ( ($ans->header->id == $packet->header->id) || $self->{'ignqrid'} );
				      $self->errorstring($ans->header->rcode);
				      $ans->answerfrom($self->answerfrom);
				      if ($ans->header->rcode ne "NOERROR" &&
					  $ans->header->rcode ne "NXDOMAIN"){
					  # Remove this one from the stack

					  print "RCODE: ".$ans->header->rcode ."; trying next nameserver\n" if $self->{'debug'};
					  $nmbrnsfailed++;
					  $ns->[3]="RCODE: ".$ans->header->rcode();
					  $lastanswer=$ans;
					  next NAMESERVER ;

				      }
				  } elsif (defined $err) {
				      $self->errorstring($err);
				  }
				  return $ans;
			      } else {
				  $self->errorstring($!);
      				  print ';; recv ERROR(',
				  $ready->peerhost, ':',
				  $ready->peerport, '): ',
				  $self->errorstring, "\n"
				      if $self->{'debug'};
				  $ns->[3]="Recv error ".$self->errorstring();
				  $nmbrnsfailed++;
				  # We want to remain in the SELECTOR LOOP...
				  # unless there are no more nameservers
				  return unless ($nmbrnsfailed < @ns);
				  print ';; Number of failed nameservers: $nmbrnsfailed out of '.scalar @ns."\n" if $self->{'debug'};

			      }
			  } #SELECTOR LOOP
			} # until stop_time loop
		    } #NAMESERVER LOOP

	}

	if ($lastanswer){
		$self->errorstring($lastanswer->header->rcode );
		return $lastanswer;

	}
	if ($sel->handles) {
	    # If there are valid hanndles than we have either a timeout or
	    # a send error.
	    $self->errorstring('query timed out') unless ($self->errorstring =~ /Send error:/);
	}
	else {
	    if ($nmbrnsfailed < @ns){
		$self->errorstring('Unexpected Error') ;
	    }else{
		$self->errorstring('all nameservers failed');
	    }
	}
	return;
}


sub bgsend {
	my $self = shift;

	unless ($self->nameservers()) {
		$self->errorstring('no nameservers');
		return;
	}

	$self->_reset_errorstring;

	my $packet = $self->make_query_packet(@_);
	my $packet_data = $packet->data;

	my $srcaddr = $self->{'srcaddr'};
	my $srcport = $self->{'srcport'};


	my (@res, $sockfamily, $dst_sockaddr);
	my $ns_address = ($self->nameservers())[0];
	my $dstport = $self->{'port'};


	# The logic below determines ther $dst_sockaddr.
	# If getaddrinfo is available that is used for both INET4 and INET6
	# If getaddrinfo is not avialable (Socket6 failed to load) we revert
	# to the 'classic mechanism
	if ($has_inet6  && ! $self->force_v4()){

	    my ( $socktype_tmp, $proto_tmp, $canonname_tmp);

	    no strict 'subs';   # Because of the eval statement in the BEGIN
	                      # AI_NUMERICHOST is not available at compile time.

	      my $old_wflag = $^W; 		#circumvent perl -w warnings about 'udp'
	      $^W = 0;


	    # The AI_NUMERICHOST surpresses lookups.
	    my @res = Socket6::getaddrinfo($ns_address, $dstport, AF_UNSPEC, SOCK_DGRAM,
				  0 , AI_NUMERICHOST);

	    $^W=$old_wflag;

	    use strict 'subs';

	    ($sockfamily, $socktype_tmp,
	     $proto_tmp, $dst_sockaddr, $canonname_tmp) = @res;

	    if (scalar(@res) < 5) {
		die ("can't resolve \"$ns_address\" to address (it could have been an IP address)");
	    }

	}else{
	    $sockfamily=AF_INET;

	    if (! _ip_is_ipv4($ns_address)){
		$self->errorstring("bgsend(ipv4 only):$ns_address does not seem to be a valid IPv4 address");
		return;
	    }

	    $dst_sockaddr = sockaddr_in($dstport, inet_aton($ns_address));
	}
	my @socket;

	if ($sockfamily == AF_INET) {
	    $socket[$sockfamily] = IO::Socket::INET->new(
							 Proto => 'udp',
							 Type => SOCK_DGRAM,
							 LocalAddr => $srcaddr,
							 LocalPort => ($srcport || undef),
					    );
	} elsif ($has_inet6 && $sockfamily == AF_INET6() ) {
	    # Otherwise the INET6 socket will just fail
	    my $srcaddr6 = $srcaddr eq "0.0.0.0" ? '::' : $srcaddr;
	    $socket[$sockfamily] = IO::Socket::INET6->new(
							  Proto => 'udp',
							  Type => SOCK_DGRAM,
							  LocalAddr => $srcaddr6,
							  LocalPort => ($srcport || undef),
					     );
	} else {
	    die ref($self)." bgsend: Unsupported Socket Family: $sockfamily";
	}

	unless ($socket[$sockfamily]) {
		$self->errorstring("could not get socket");
		return;
	}

	print ";; bgsend($ns_address : $dstport)\n" if $self->{'debug'}	;

	foreach my $socket (@socket){
	    next if !defined $socket;

	    unless ($socket->send($packet_data,0,$dst_sockaddr)){
		my $err = $!;
		print ";; send ERROR($ns_address): $err\n" if $self->{'debug'};

		$self->errorstring("Send: ".$err);
		return;
	    }
	    return $socket;
	}
	$self->errorstring("Could not find a socket to send on");
	return;

}

sub bgread {
	my ($self, $sock) = @_;

	my $buf = '';

	my $peeraddr = $sock->recv($buf, $self->_packetsz);

	if ($peeraddr) {
		print ';; answer from ', $sock->peerhost, ':',
		      $sock->peerport, ' : ', length($buf), " bytes\n"
			if $self->{'debug'};

		my ($ans, $err) = Net::DNS::Packet->new(\$buf, $self->{'debug'});

		if (defined $ans) {
			$self->errorstring($ans->header->rcode);
			$ans->answerfrom($sock->peerhost);
		} elsif (defined $err) {
			$self->errorstring($err);
		}

		return $ans;
	} else {
		$self->errorstring($!);
		return;
	}
}

sub bgisready {
	my $self = shift;
	my $sel = IO::Select->new(@_);
	my @ready = $sel->can_read(0.0);
	return @ready > 0;
}



#
# Keep this method around. Folk depend on it although its not documented and exported.
#
sub make_query_packet {
	my $self = shift;
	my $packet;

	if (ref($_[0]) and $_[0]->isa('Net::DNS::Packet')) {
		$packet = shift;
	} else {
		$packet = Net::DNS::Packet->new(@_);
	}

	if ($packet->header->opcode eq 'QUERY') {
		$packet->header->rd($self->{'recurse'});
	}

    if ($self->{'dnssec'}) {
	    # RFC 3225
    	print ";; Adding EDNS extention with UDP packetsize $self->{'udppacketsize'} and DNS OK bit set\n"
    		if $self->{'debug'};


	$packet->header->cd($self->{'cdflag'});
	$packet->header->ad($self->{'adflag'});
	my $optrr = Net::DNS::RR->new(
						Type         => 'OPT',
						Name         => '',
						Class        => $self->{'udppacketsize'},  # Decimal UDPpayload
						ednsflags    => 0x8000, # first bit set see RFC 3225
				   );


	    $packet->push('additional', $optrr) unless defined  $packet->{'optadded'} ;
	    $packet->{'optadded'}=1;
	} elsif ($self->{'udppacketsize'} > Net::DNS::PACKETSZ()) {
	    print ";; Adding EDNS extention with UDP packetsize  $self->{'udppacketsize'}.\n" if $self->{'debug'};
	    # RFC 3225
	    my $optrr = Net::DNS::RR->new(
						Type         => 'OPT',
						Name         => '',
						Class        => $self->{'udppacketsize'},  # Decimal UDPpayload
						TTL          => 0x0000 # RCODE 32bit Hex
				    );

	    $packet->push('additional', $optrr) unless defined  $packet->{'optadded'} ;
	    $packet->{'optadded'}=1;
	}


	if ($self->{'tsig_rr'}) {
		if (!grep { $_->type eq 'TSIG' } $packet->additional) {
			$packet->push('additional', $self->{'tsig_rr'});
		}
	}

	return $packet;
}

sub axfr {
	my $self = shift;
	my @zone;

	if ($self->axfr_start(@_)) {
		my ($rr, $err);
		while (($rr, $err) = $self->axfr_next, $rr && !$err) {
			push @zone, $rr;
		}
		@zone = () if $err;
	}

	return @zone;
}

sub axfr_old {
	croak "Use of Net::DNS::Resolver::axfr_old() is deprecated, use axfr() or axfr_start().";
}


sub axfr_start {
	my $self = shift;
	my ($dname, $class) = @_;
	$dname ||= $self->{'searchlist'}->[0];
	$class ||= 'IN';
	my $timeout = $self->{'tcp_timeout'};

	unless ($dname) {
		print ";; ERROR: axfr: no zone specified\n" if $self->{'debug'};
		$self->errorstring('no zone');
		return;
	}


	print ";; axfr_start($dname, $class)\n" if $self->{'debug'};

	unless ($self->nameservers()) {
		$self->errorstring('no nameservers');
		print ";; ERROR: no nameservers\n" if $self->{'debug'};
		return;
	}

	my $packet = $self->make_query_packet($dname, 'AXFR', $class);
	my $packet_data = $packet->data;

	my $ns = ($self->nameservers())[0];


	my $srcport = $self->{'srcport'};
	my $srcaddr = $self->{'srcaddr'};
	my $dstport = $self->{'port'};

	print ";; axfr_start nameserver = $ns\n" if $self->{'debug'};
	print ";; axfr_start srcport: $srcport, srcaddr: $srcaddr, dstport: $dstport\n" if $self->{'debug'};


	my $sock;
	my $sock_key = "$ns:$self->{'port'}";


	if ($self->persistent_tcp && $self->{'axfr_sockets'}[AF_UNSPEC]{$sock_key}) {
		$sock = $self->{'axfr_sockets'}[AF_UNSPEC]{$sock_key};
		print ";; using persistent socket\n"
		    if $self->{'debug'};
	} else {
		$sock=$self->_create_tcp_socket($ns);

		return unless ($sock);  # all error messages
		                        # are set by _create_tcp_socket


		$self->{'axfr_sockets'}[AF_UNSPEC]{$sock_key} = $sock if
		    $self->persistent_tcp;
	}

	my $lenmsg = pack('n', length($packet_data));

	unless ($sock->send($lenmsg)) {
		$self->errorstring($!);
		return;
	}

	unless ($sock->send($packet_data)) {
		$self->errorstring($!);
		return;
	}

	my $sel = IO::Select->new($sock);

	$self->{'axfr_sel'}       = $sel;
	$self->{'axfr_rr'}        = [];
	$self->{'axfr_soa_count'} = 0;

	return $sock;
}


sub axfr_next {
	my $self = shift;
	my $err  = '';

	unless (@{$self->{'axfr_rr'}}) {
		unless ($self->{'axfr_sel'}) {
			my $err = 'no zone transfer in progress';

			print ";; $err\n" if $self->{'debug'};
			$self->errorstring($err);

			return wantarray ? (undef, $err) : undef;
		}

		my $sel = $self->{'axfr_sel'};
		my $timeout = $self->{'tcp_timeout'};

		#--------------------------------------------------------------
		# Read the length of the response packet.
		#--------------------------------------------------------------

		my @ready = $sel->can_read($timeout);
		unless (@ready) {
			$err = 'timeout';
			$self->errorstring($err);
			return wantarray ? (undef, $err) : undef;
		}

		my $buf = read_tcp($ready[0], Net::DNS::INT16SZ(), $self->{'debug'});
		unless (length $buf) {
			$err = 'truncated zone transfer';
			$self->errorstring($err);
			return wantarray ? (undef, $err) : undef;
		}

		my ($len) = unpack('n', $buf);
		unless ($len) {
			$err = 'truncated zone transfer';
			$self->errorstring($err);
			return wantarray ? (undef, $err) : undef;
		}

		#--------------------------------------------------------------
		# Read the response packet.
		#--------------------------------------------------------------

		@ready = $sel->can_read($timeout);
		unless (@ready) {
			$err = 'timeout';
			$self->errorstring($err);
			return wantarray ? (undef, $err) : undef;
		}

		$buf = read_tcp($ready[0], $len, $self->{'debug'});

		print ';; received ', length($buf), " bytes\n"
			if $self->{'debug'};

		unless (length($buf) == $len) {
			$err = "expected $len bytes, received " . length($buf);
			$self->errorstring($err);
			print ";; $err\n" if $self->{'debug'};
			return wantarray ? (undef, $err) : undef;
		}

		my $ans;
		($ans, $err) = Net::DNS::Packet->new(\$buf, $self->{'debug'});

		if ($ans) {
			if ($ans->header->rcode ne 'NOERROR') {
				$self->errorstring('Response code from server: ' . $ans->header->rcode);
				print ';; Response code from server: ' . $ans->header->rcode . "\n" if $self->{'debug'};
				return wantarray ? (undef, $err) : undef;
			}
			if ($ans->header->ancount < 1) {
				$err = 'truncated zone transfer';
				$self->errorstring($err);
				print ";; $err\n" if $self->{'debug'};
				return wantarray ? (undef, $err) : undef;
			}
		}
		else {
			$err ||= 'unknown error during packet parsing';
			$self->errorstring($err);
			print ";; $err\n" if $self->{'debug'};
			return wantarray ? (undef, $err) : undef;
		}

		foreach my $rr ($ans->answer) {
			if ($rr->type eq 'SOA') {
				if (++$self->{'axfr_soa_count'} < 2) {
					push @{$self->{'axfr_rr'}}, $rr;
				}
			}
			else {
				push @{$self->{'axfr_rr'}}, $rr;
			}
		}

		if ($self->{'axfr_soa_count'} >= 2) {
			$self->{'axfr_sel'} = undef;
			# we need to mark the transfer as over if the responce was in
			# many answers.  Otherwise, the user will call axfr_next again
			# and that will cause a 'no transfer in progress' error.
			push(@{$self->{'axfr_rr'}}, undef);
		}
	}

	my $rr = shift @{$self->{'axfr_rr'}};

	return wantarray ? ($rr, undef) : $rr;
}




sub dnssec {
    my ($self, $new_val) = @_;
    if (defined $new_val) {
	$self->{"dnssec"} = $new_val;
	# Setting the udppacket size to some higher default
	$self->udppacketsize(2048) if $new_val;
    }

    Carp::carp ("You called the Net::DNS::Resolver::dnssec() method but do not have Net::DNS::SEC installed") if $self->{"dnssec"} && ! $Net::DNS::DNSSEC;
    return $self->{"dnssec"};
};



sub tsig {
	my $self = shift;

	if (@_ == 1) {
		if ($_[0] && ref($_[0])) {
			$self->{'tsig_rr'} = $_[0];
		}
		else {
			$self->{'tsig_rr'} = undef;
		}
	}
	elsif (@_ == 2) {
		my ($key_name, $key) = @_;
		$self->{'tsig_rr'} = Net::DNS::RR->new("$key_name TSIG $key");
	}

	return $self->{'tsig_rr'};
}

#
# Usage:  $data = read_tcp($socket, $nbytes, $debug);
#
sub read_tcp {
	my ($sock, $nbytes, $debug) = @_;
	my $buf = '';

	while (length($buf) < $nbytes) {
		my $nread = $nbytes - length($buf);
		my $read_buf = '';

		print ";; read_tcp: expecting $nread bytes\n" if $debug;

		# During some of my tests recv() returned undef even
		# though there wasn't an error.  Checking for the amount
		# of data read appears to work around that problem.

		unless ($sock->recv($read_buf, $nread)) {
			if (length($read_buf) < 1) {
				my $errstr = $!;

				print ";; ERROR: read_tcp: recv failed: $!\n"
					if $debug;

				if ($errstr eq 'Resource temporarily unavailable') {
					warn "ERROR: read_tcp: recv failed: $errstr\n";
					warn "ERROR: try setting \$res->timeout(undef)\n";
				}

				last;
			}
		}

		print ';; read_tcp: received ', length($read_buf), " bytes\n"
			if $debug;

		last unless length($read_buf);
		$buf .= $read_buf;
	}

	return $buf;
}



sub _create_tcp_socket {
	my $self=shift;
	my $ns=shift;
	my $sock;

	my $srcport = $self->{'srcport'};
	my $srcaddr = $self->{'srcaddr'};
	my $dstport = $self->{'port'};

	my $timeout = $self->{'tcp_timeout'};
	# IO::Socket carps on errors if Perl's -w flag is
	# turned on.  Uncomment the next two lines and the
	# line following the "new" call to turn off these
	# messages.

	#my $old_wflag = $^W;
	#$^W = 0;

	if ($has_inet6 && ! $self->force_v4() && _ip_is_ipv6($ns) ){
		# XXX IO::Socket::INET6 fails in a cryptic way upon send()
		# on AIX5L if "0" is passed in as LocalAddr
		# $srcaddr="0" if $srcaddr eq "0.0.0.0";  # Otherwise the INET6 socket will just fail

		my $srcaddr6 = $srcaddr eq '0.0.0.0' ? '::' : $srcaddr;

		$sock =
		    IO::Socket::INET6->new(
					   PeerPort =>    $dstport,
					   PeerAddr =>    $ns,
					   LocalAddr => $srcaddr6,
					   LocalPort => ($srcport || undef),
					   Proto     => 'tcp',
					   Timeout   => $timeout,
					   );

		unless($sock){
			$self->errorstring('connection failed(IPv6 socket failure)');
			print ";; ERROR: send_tcp: IPv6 connection to $ns".
			    "failed: $!\n" if $self->{'debug'};
			return();
		}
	}

	# At this point we have sucessfully obtained an
	# INET6 socket to an IPv6 nameserver, or we are
	# running forced v4, or we do not have v6 at all.
	# Try v4.

	unless($sock){
		if (_ip_is_ipv6($ns)){
			$self->errorstring(
					   'connection failed (trying IPv6 nameserver without having IPv6)');
			print
			    ';; ERROR: send_tcp: You are trying to connect to '.
			    $ns . " but you do not have IPv6 available\n"
			    if $self->{'debug'};
			return();
		}


		$sock = IO::Socket::INET->new(
					      PeerAddr  => $ns,
					      PeerPort  => $dstport,
					      LocalAddr => $srcaddr,
					      LocalPort => ($srcport || undef),
					      Proto     => 'tcp',
					      Timeout   => $timeout
					      )
	    }

	#$^W = $old_wflag;

	unless ($sock) {
		$self->errorstring('connection failed');
		print ';; ERROR: send_tcp: connection ',
		"failed: $!\n" if $self->{'debug'};
		return();
	}

	return $sock;
}


# Lightweight versions of subroutines from Net::IP module, recoded to fix rt#28198

sub _ip_is_ipv4 {
	my @field = split /\./, shift;

	return 0 if @field > 4;				# too many fields
	return 0 if @field == 0;			# no fields at all

	foreach ( @field ) {
		return 0 unless /./;			# reject if empty
		return 0 if /[^0-9]/;			# reject non-digit
		return 0 if $_ > 255;			# reject bad value
	}


	return 1;
}


sub _ip_is_ipv6 {

	for ( shift ) {
		my @field = split /:/;			# split into fields
		return 0 if (@field < 3) or (@field > 8);

		return 0 if /::.*::/;			# reject multiple ::

		if ( /\./ ) {				# IPv6:IPv4
			return 0 unless _ip_is_ipv4(pop @field);
		}

		foreach ( @field ) {
			next unless /./;		# skip ::
			return 0 if /[^0-9a-f]/i;	# reject non-hexdigit
			return 0 if length $_ > 4;	# reject bad value
		}
	}
	return 1;
}



sub AUTOLOAD {
	my ($self) = @_;

	my $name = $AUTOLOAD;
	$name =~ s/.*://;

	Carp::croak "$name: no such method" unless exists $self->{$name};

	no strict q/refs/;


	*{$AUTOLOAD} = sub {
		my ($self, $new_val) = @_;

		if (defined $new_val) {
			$self->{"$name"} = $new_val;
		}

		return $self->{"$name"};
	};


	goto &{$AUTOLOAD};
}

1;

__END__

=head1 NAME

Net::DNS::Resolver::Base - Common Resolver Class

=head1 SYNOPSIS

 use base qw/Net::DNS::Resolver::Base/;

=head1 DESCRIPTION

This class is the common base class for the different platform
sub-classes of L.

No user serviceable parts inside, see L
for all your resolving needs.

=head1 COPYRIGHT

Copyright (c) 1997-2002 Michael Fuhr.

Portions Copyright (c) 2002-2004 Chris Reinhardt.
Portions Copyright (c) 2005 Olaf Kolkman  
Portions Copyright (c) 2006 Dick Franks.

All rights reserved.  This program is free software; you may redistribute
it and/or modify it under the same terms as Perl itself.

=head1 SEE ALSO

L, L, L

=cut


Net-DNS-0.68/lib/Net/DNS/Resolver/Win32.pm0000644000175000017500000000655511710626412017157 0ustar  willemwillempackage Net::DNS::Resolver::Win32;
#
# $Id: Win32.pm 932 2011-10-26 12:40:48Z willem $
#

use strict;
use vars qw(@ISA $VERSION);

use Net::DNS::Resolver::Base ();

@ISA     = qw(Net::DNS::Resolver::Base);
$VERSION = (qw$LastChangedRevision: 932 $)[1];

use Win32::IPHelper;
use Win32::TieRegistry qw(KEY_READ REG_DWORD);
use Data::Dumper;
sub init {

	my $debug=0;
	my ($class) = @_;

	my $defaults = $class->defaults;


	my $FIXED_INFO={};

	my $ret = Win32::IPHelper::GetNetworkParams($FIXED_INFO);

	if ($ret == 0)
	  {
		  print Dumper $FIXED_INFO if $debug;
	  }
	else
	  {

		  Carp::croak "GetNetworkParams() error %u: %s\n", $ret, Win32::FormatMessage($ret);
	  }


	my @nameservers = map { $_->{'IpAddress'} } @{$FIXED_INFO->{'DnsServersList'}};


	if (@nameservers) {
		# remove blanks and dupes
		my @a;
		my %h;
		foreach my $ns (@nameservers) {
			push @a, $ns unless (!$ns || $h{$ns});
			$h{$ns} = 1;
		}
		$defaults->{'nameservers'} = [map { m/(.*)/ } @a];
	}

	my $domain=$FIXED_INFO->{'DomainName'}||'';
	my $searchlist;


	#
	# The Win32::IPHelper  does not return searchlist. Lets do a best effort attempt to get
	# a searchlist from the registry.

	my $usedevolution = 0;

	my $root = 'HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\Tcpip\Parameters';
	my $reg_tcpip = $Registry->Open($root, {Access => KEY_READ});
	if (!defined $reg_tcpip) {
		# Didn't work, maybe we are on 95/98/Me?
		$root = 'HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\VxD\MSTCP';
		$reg_tcpip = $Registry->Open($root, {Access => KEY_READ});
	}

	if ($domain) {
		$defaults->{'domain'} = $domain;
		$searchlist = $domain;
	}

	if (defined $reg_tcpip){
		$searchlist .= "," if $searchlist; # $domain already in there
		$searchlist .= $reg_tcpip->GetValue('SearchList');
		my ($value, $type) = $reg_tcpip->GetValue('UseDomainNameDevolution');
		$usedevolution = defined $value && $type == REG_DWORD ? hex $value : 0;
	}

	if ($searchlist) {
		# fix devolution if configured, and simultaneously make sure no dups (but keep the order)
		my @a;
		my %h;
		foreach my $entry (split(m/[\s,]+/, lc $searchlist)) {
			push(@a, $entry) unless $h{$entry};
			$h{$entry} = 1;
			if ($usedevolution) {
				# as long there's more than two pieces, cut
				while ($entry =~ m#\..+\.#) {
					$entry =~ s#^[^\.]+\.(.+)$#$1#;
					push(@a, $entry) unless $h{$entry};
					$h{$entry} = 1;
					}
				}
			}
		$defaults->{'searchlist'} = \@a;
	}

	$class->read_env;

	if (!$defaults->{'domain'} && @{$defaults->{'searchlist'}}) {
		$defaults->{'domain'} = $defaults->{'searchlist'}[0];
	} elsif (!@{$defaults->{'searchlist'}} && $defaults->{'domain'}) {
		$defaults->{'searchlist'} = [ $defaults->{'domain'} ];
	}

	print Dumper $defaults if $debug;

}

1;
__END__


=head1 NAME

Net::DNS::Resolver::Win32 - Windows Resolver Class

=head1 SYNOPSIS

 use Net::DNS::Resolver;

=head1 DESCRIPTION

This class implements the windows specific portions of C.

No user serviceable parts inside, see L
for all your resolving needs.

=head1 COPYRIGHT

Copyright (c) 1997-2002 Michael Fuhr.

Portions Copyright (c) 2002-2004 Chris Reinhardt.

Portions Copyright (c) 2009 Olaf Kolkman, NLnet Labs

All rights reserved.  This program is free software; you may redistribute
it and/or modify it under the same terms as Perl itself.

=head1 SEE ALSO

L, L, L

=cut
Net-DNS-0.68/lib/Net/DNS/Resolver/UNIX.pm0000644000175000017500000000307211710626412017027 0ustar  willemwillempackage Net::DNS::Resolver::UNIX;
#
# $Id: UNIX.pm 932 2011-10-26 12:40:48Z willem $
#

use strict;
use vars qw(@ISA $VERSION);

use Net::DNS::Resolver::Base ();

@ISA     = qw(Net::DNS::Resolver::Base);
$VERSION = (qw$LastChangedRevision: 932 $)[1];

my $resolv_conf = '/etc/resolv.conf';
my $dotfile     = '.resolv.conf';

my @config_path;
push(@config_path, $ENV{'HOME'}) if exists $ENV{'HOME'};
push(@config_path, '.');

sub init {
	my ($class) = @_;

	$class->read_config_file($resolv_conf) if -f $resolv_conf && -r _;

	foreach my $dir (@config_path) {
		my $file = "$dir/$dotfile";
		$class->read_config_file($file) if -f $file && -r _ && -o _;
	}

	$class->read_env;

	my $defaults = $class->defaults;

	if (!$defaults->{'domain'} && @{$defaults->{'searchlist'}}) {
		$defaults->{'domain'} = $defaults->{'searchlist'}[0];
	} elsif (!@{$defaults->{'searchlist'}} && $defaults->{'domain'}) {
		$defaults->{'searchlist'} = [ $defaults->{'domain'} ];
	}
}

1;
__END__


=head1 NAME

Net::DNS::Resolver::UNIX - UNIX Resolver Class

=head1 SYNOPSIS

 use Net::DNS::Resolver;

=head1 DESCRIPTION

This class implements the UNIX specific portions of C.

No user serviceable parts inside, see L
for all your resolving needs.

=head1 COPYRIGHT

Copyright (c) 1997-2002 Michael Fuhr.

Portions Copyright (c) 2002-2004 Chris Reinhardt.

All rights reserved.  This program is free software; you may redistribute
it and/or modify it under the same terms as Perl itself.

=head1 SEE ALSO

L, L, L

=cut
Net-DNS-0.68/lib/Net/DNS/Header.pm0000644000175000017500000001655711710626412015647 0ustar  willemwillempackage Net::DNS::Header;

#
# $Id: Header.pm 968 2011-12-09 09:56:05Z willem $
#
use vars qw($VERSION);
$VERSION = (qw$LastChangedRevision: 968 $)[1];


=head1 NAME

Net::DNS::Header - DNS packet header

=head1 SYNOPSIS

    use Net::DNS::Packet;

    $packet = new Net::DNS::Packet;
    $header = $packet->header;


=head1 DESCRIPTION

A C object represents the header portion of a DNS
packet.

=cut


use strict;
use integer;
use Carp;
use Net::DNS;

use constant MAX_ID => 65535;


=head1 METHODS

=head2 new

    $header = new Net::DNS::Header;

C creates a header object appropriate for making a DNS query.

=cut

{
	sub nextid { int rand(MAX_ID); }
}

sub new {
	my $class = shift;

	bless { id	=> nextid(),
		qr	=> 0,
		opcode	=> $Net::DNS::opcodesbyval{0},
		aa	=> 0,
		tc	=> 0,
		rd	=> 1,
		ra	=> 0,
		ad	=> 0,
		cd	=> 0,
		rcode	=> $Net::DNS::rcodesbyval{0},
		qdcount => 0,
		ancount => 0,
		nscount => 0,
		arcount => 0,
		}, $class;
}


=head2 decode

    ($header, $offset) = decode Net::DNS::Header(\$data);

Decodes the header record at the start of a DNS packet.
The argument is a reference to the packet data.

Returns a Net::DNS::Header object and the offset of the next location
in the packet.

Decoding is aborted if the header object cannot be created (e.g.,
corrupt or insufficient data).

=cut

use constant PACKED_LENGTH => length pack 'n C2 n4', (0) x 7;

sub decode {
	my ( $class, $data ) = @_;

	die 'Exception: incomplete data' if length($$data) < PACKED_LENGTH;

	my ( $id, $b2, $b3, $qd, $an, $ns, $ar ) = unpack( 'n C2 n4', $$data );

	my $opval  = ( $b2 >> 3 ) & 0xf;
	my $opcode = $Net::DNS::opcodesbyval{$opval} || $opval;
	my $rval   = $b3 & 0xf;
	my $rcode  = $Net::DNS::rcodesbyval{$rval} || $rval;

	my $self = bless {
		id	=> $id,
		qr	=> ( $b2 >> 7 ) & 0x1,
		opcode	=> $opcode,
		aa	=> ( $b2 >> 2 ) & 0x1,
		tc	=> ( $b2 >> 1 ) & 0x1,
		rd	=> $b2 & 0x1,
		ra	=> ( $b3 >> 7 ) & 0x1,
		ad	=> ( $b3 >> 5 ) & 0x1,
		cd	=> ( $b3 >> 4 ) & 0x1,
		rcode	=> $rcode,
		qdcount => $qd,
		ancount => $an,
		nscount => $ns,
		arcount => $ar
		}, $class;

	return wantarray ? ( $self, PACKED_LENGTH ) : $self;
}


=head2 encode

    $data = $header->encode;

Returns the header data in binary format, appropriate for use in a
DNS query packet.

=cut

sub encode {
	my $self = shift;

	my $opcode = $Net::DNS::opcodesbyname{$self->{opcode}};
	my $rcode  = $Net::DNS::rcodesbyname{$self->{rcode}};

	my $byte2 =
			( $self->{qr} ? 0x80 : 0 ) | ( $opcode << 3 ) | ( $self->{aa} ? 0x04 : 0 ) |
			( $self->{tc} ? 0x02 : 0 ) | ( $self->{rd} ? 0x01 : 0 );

	my $byte3 =
			( $self->{ra} ? 0x80 : 0 ) | ( $self->{ad} ? 0x20 : 0 ) | ( $self->{cd} ? 0x10 : 0 ) |
			( $rcode || 0 );

	pack( 'n C2 n4', $self->{id}, $byte2, $byte3, map { $self->{$_} || 0 } qw(qdcount ancount nscount arcount) );
}


=head2 print

    $header->print;

Prints the header record on the standard output.

=cut

sub print { print &string, "\n"; }


=head2 string

    print $header->string;

Returns a string representation of the header object.

=cut

sub string {
	my $self   = shift;
	my $retval = "";

	$retval .= ";; id = $self->{id}\n";

	if ( $self->{"opcode"} eq "UPDATE" ) {
		$retval .= ";; qr = $self->{qr}	   " . "opcode = $self->{opcode}    " . "rcode = $self->{rcode}\n";

		$retval .=
				  ";; zocount = $self->{qdcount}  "
				. "prcount = $self->{ancount}  "
				. "upcount = $self->{nscount}  "
				. "adcount = $self->{arcount}\n";
	} else {
		$retval .=
				  ";; qr = $self->{qr}	  "
				. "opcode = $self->{opcode}    "
				. "aa = $self->{aa}    "
				. "tc = $self->{tc}    "
				. "rd = $self->{rd}\n";

		$retval .=
				  ";; ra = $self->{ra}	  "
				. "ad = $self->{ad}    "
				. "cd = $self->{cd}    "
				. "rcode  = $self->{rcode}\n";

		$retval .=
				  ";; qdcount = $self->{qdcount}  "
				. "ancount = $self->{ancount}  "
				. "nscount = $self->{nscount}  "
				. "arcount = $self->{arcount}\n";
	}

	return $retval;
}


sub zocount { &qdcount; }
sub prcount { &ancount; }
sub upcount { &nscount; }
sub adcount { &arcount; }


use vars qw($AUTOLOAD);

sub AUTOLOAD {				## Default method
	my $self = shift;

	my $name = $AUTOLOAD;
	$name =~ s/.*://;

	croak "$AUTOLOAD: no such method" unless exists $self->{$name};

	return $self->{$name} unless @_;
	$self->{$name} = shift;
}

sub DESTROY { }				## Avoid tickling AUTOLOAD (in cleanup)


1;
__END__


=head2 id

    print "query id = ", $header->id, "\n";
    $header->id(1234);

Gets or sets the query identification number.


=head2 qr

    print "query response flag = ", $header->qr, "\n";
    $header->qr(0);

Gets or sets the query response flag.


=head2 opcode

    print "query opcode = ", $header->opcode, "\n";
    $header->opcode("UPDATE");

Gets or sets the query opcode (the purpose of the query).


=head2 aa

    print "answer is ", $header->aa ? "" : "non-", "authoritative\n";
    $header->aa(0);

Gets or sets the authoritative answer flag.


=head2 tc

    print "packet is ", $header->tc ? "" : "not ", "truncated\n";
    $header->tc(0);

Gets or sets the truncated packet flag.


=head2 rd

    print "recursion was ", $header->rd ? "" : "not ", "desired\n";
    $header->rd(0);

Gets or sets the recursion desired flag.


=head2 cd

    print "checking was ", $header->cd ? "not" : "", "desired\n";
    $header->cd(0);

Gets or sets the checking disabled flag.


=head2 ra

    print "recursion is ", $header->ra ? "" : "not ", "available\n";
    $header->ra(0);

Gets or sets the recursion available flag.


=head2 ad

    print "The result has ", $header->ad ? "" : "not", "been verified\n"

Relevant in DNSSEC context.

(The AD bit is only set on answers where signatures have been
cryptographically verified or the server is authoritative for the data
and is allowed to set the bit by policy.)


=head2 rcode

    print "query response code = ", $header->rcode, "\n";
    $header->rcode("SERVFAIL");

Gets or sets the query response code (the status of the query).


=head2 qdcount, zocount

    print "# of question records: ", $header->qdcount, "\n";
    $header->qdcount(2);

Gets or sets the number of records in the question section of the packet.
In dynamic update packets, this field is known as C and refers
to the number of RRs in the zone section.


=head2 ancount, prcount

    print "# of answer records: ", $header->ancount, "\n";
    $header->ancount(5);

Gets or sets the number of records in the answer section of the packet.
In dynamic update packets, this field is known as C and refers
to the number of RRs in the prerequisite section.


=head2 nscount, upcount

    print "# of authority records: ", $header->nscount, "\n";
    $header->nscount(2);

Gets or sets the number of records in the authority section of the packet.
In dynamic update packets, this field is known as C and refers
to the number of RRs in the update section.


=head2 arcount, adcount

    print "# of additional records: ", $header->arcount, "\n";
    $header->arcount(3);

Gets or sets the number of records in the additional section of the packet.
In dynamic update packets, this field is known as C.


=head1 COPYRIGHT

Copyright (c)1997-2002 Michael Fuhr.

Portions Copyright (c)2002-2004 Chris Reinhardt.

Portions Copyright (c)2007 Dick Franks.

All rights reserved.

This program is free software; you may redistribute it and/or
modify it under the same terms as Perl itself.

=head1 SEE ALSO

L, L, L,
RFC 1035 Section 4.1.1

Net-DNS-0.68/lib/Net/DNS/RR.pm0000644000175000017500000006304611710626412014775 0ustar  willemwillempackage Net::DNS::RR;

#
# $Id: RR.pm 969 2011-12-13 10:34:39Z willem $
#
use vars qw($VERSION);
$VERSION = (qw$LastChangedRevision: 969 $)[1];


=head1 NAME

Net::DNS::RR - DNS Resource Record base class

=head1 SYNOPSIS

use Net::DNS;

    $rr = new Net::DNS::RR('example.com IN A 192.0.2.99');

    $rr = new Net::DNS::RR(
	    name    => 'example.com'
	    type    => 'A',
	    address => '192.0.2.99'
	    );


=head1 DESCRIPTION

C is the base class for DNS Resource Record (RR) objects.
See also the manual pages for each RR type.

=cut


use strict;
use integer;
use Carp;
use Net::DNS qw (wire2presentation name2labels stripdot);
use Net::DNS::RR::Unknown;


# %RR needs to be available within the scope of the BEGIN block.
# $RR_REGEX is a global just to be on the safe side.
# %_LOADED is used internally for autoloading the RR subclasses.
use vars qw(%RR %_LOADED $RR_REGEX);

BEGIN {

	%RR = map { $_ => 1 } qw(
		A
		AAAA
		AFSDB
		CNAME
		CERT
		DHCID
		DNAME
		EID
		HINFO
		ISDN
		KX
		LOC
		MB
		MG
		MINFO
		MR
		MX
		NAPTR
		NIMLOC
		NS
		NSAP
		NULL
		PTR
		PX
		RP
		RT
		SOA
		SRV
		TKEY
		TSIG
		TXT
		X25
		OPT
		APL
		SSHFP
		HIP
		SPF
		IPSECKEY

	);

	#  Only load DNSSEC if available

	eval {
	    local $SIG{'__DIE__'} = 'DEFAULT';
	    require Net::DNS::RR::SIG;
	};

	unless ($@) {
		$RR{'SIG'} = 1;
		eval {
		    local $SIG{'__DIE__'} = 'DEFAULT';
		    require Net::DNS::RR::NXT;
		};

		unless ($@) {
		    $RR{'NXT'}	= 1;
		} else {
		    die $@;
		}

		eval {
		    local $SIG{'__DIE__'} = 'DEFAULT';
		    require Net::DNS::RR::KEY;
		};

		unless ($@) {
		    $RR{'KEY'} = 1;
		} else {
		    die $@;
		}

	 	eval {
		    local $SIG{'__DIE__'} = 'DEFAULT';
		    require Net::DNS::RR::DS;
		};

	 	unless ($@) {
		    $RR{'DS'} = 1;

		} else {
		    die $@;
		}

	 	eval {
		    local $SIG{'__DIE__'} = 'DEFAULT';
		    require Net::DNS::RR::RRSIG;
		};

	 	unless ($@) {
		    $RR{'RRSIG'} = 1;
		    # If RRSIG is available so should the other DNSSEC types
		    eval {
			local $SIG{'__DIE__'} = 'DEFAULT';
			require Net::DNS::RR::NSEC;
		    };
		    unless ($@) {
		      $RR{'NSEC'} = 1;
		    } else {
		    die $@;
		  }
		    eval {
			local $SIG{'__DIE__'} = 'DEFAULT';
			require Net::DNS::RR::DNSKEY;
		    };

		    unless ($@) {
		      $RR{'DNSKEY'} = 1;
		    } else {
		      die $@;
		    }
		}

	 	eval {
		  local $SIG{'__DIE__'} = 'DEFAULT';
		  require Net::DNS::RR::DLV;
		};

		unless ($@) {
		  $RR{'DLV'} =1;
		} else {
		  # Die only if we are dealing with a version for which DLV is
		  # available
		  die $@ if defined ($Net::DNS::SEC::HAS_DLV) ;

		}

	 	eval {
		  local $SIG{'__DIE__'} = 'DEFAULT';
		  require Net::DNS::RR::NSEC3;
		};

		unless ($@) {
		  $RR{'NSEC3'} =1;
		} else {
		  # Die only if we are dealing with a version for which NSEC3 is		  # available
		  die $@ if defined ($Net::DNS::SEC::HAS_NSEC3);
		}


	 	eval {
		  local $SIG{'__DIE__'} = 'DEFAULT';
		  require Net::DNS::RR::NSEC3PARAM;
		};

		unless ($@) {
		  $RR{'NSEC3PARAM'} =1;
		} else {
		  # Die only if we are dealing with a version for which NSEC3 is
		  # available

		  die $@ if defined($Net::DNS::SEC::SVNVERSION) &&  $Net::DNS::SEC::SVNVERSION > 619;   # In the code since. (for users of the SVN trunk)
		}



    }
}

sub build_regex {
	my $classes = join('|', keys %Net::DNS::classesbyname, 'CLASS\\d+');

	# Longest ones go first, so the regex engine will match AAAA before A.
	my $types   = join('|', sort { length $b <=> length $a } keys %Net::DNS::typesbyname);

	$types .= '|TYPE\\d+';

	$RR_REGEX   = " ^
					\\s*
    	            (\\S+) # name anything non-space will do
    	            \\s*
    	            (\\d+)?
    	            \\s*
    	            ($classes)?
    	            \\s*
    	            ($types)?
    	            \\s*
    	            (.*)
    	            \$";

#	print STDERR "Regex: $RR_REGEX\n";
}


=head1 METHODS

B  Do not assume the RR objects you receive from a query
are of a particular type -- always check the object type before calling
any of its methods.  If you call an unknown method, you will get an
error message and execution will be terminated.


=head2 new (from string)

 $a     = Net::DNS::RR->new("foo.example.com. 86400 A 10.1.2.3");
 $mx    = Net::DNS::RR->new("example.com. 7200 MX 10 mailhost.example.com.");
 $cname = Net::DNS::RR->new("www.example.com 300 IN CNAME www1.example.com");
 $txt   = Net::DNS::RR->new('baz.example.com 3600 HS TXT "text record"');

Returns a C object of the appropriate type and
initialized from the string passed by the user.  The format of the
string is that used in zone files, and is compatible with the string
returned by C<< Net::DNS::RR->string >>.

The name and RR type are required; all other information is optional.
If omitted, the TTL defaults to 0 and the RR class defaults to IN.
Omitting the optional fields is useful for creating the empty RDATA
sections required for certain dynamic update operations.  See the
C manual page for additional examples.

All names must be fully qualified.  The trailing dot (.) is optional.

=head2 new (from hash)

 $rr = Net::DNS::RR->new(
	 name    => "foo.example.com",
	 ttl     => 86400,
	 class   => "IN",
	 type    => "A",
	 address => "10.1.2.3",
 );

 $rr = Net::DNS::RR->new(
	 name => "foo.example.com",
	 type => "A",
 );

Returns an RR object of the appropriate type, or a C
object if the type isn't implemented.  See the manual pages for
each RR type to see what fields the type requires.

The C and C fields are required; all others are optional.
If omitted, C defaults to 0 and C defaults to IN.  Omitting
the optional fields is useful for creating the empty RDATA sections
required for certain dynamic update operations.

The fields are case-insensitive, but starting each with uppercase
is recommended.

=cut



sub new {
	return new_from_string(@_) if @_ == 2;
	return new_from_string(@_) if @_ == 3;
	return new_from_hash(@_);
}


sub new_from_data {
	my $class = shift;
	my ($name, $rrtype, $rrclass, $ttl, $rdlength, $data, $offset) = @_;

	my $self = {	name		=> $name,
			type		=> $rrtype,
			class		=> $rrclass,
			ttl		=> $ttl,
			rdlength	=> $rdlength,
			rdata		=> substr($$data, $offset, $rdlength)
			};

	if ($RR{$rrtype}) {
		my $subclass = $class->_get_subclass($rrtype);
		return $subclass->new($self, $data, $offset);
	} else {
		return Net::DNS::RR::Unknown->new($self, $data, $offset);
	}

}

sub new_from_string {
	my ($class, $rrstring, $update_type) = @_;

	build_regex() unless $RR_REGEX;

	# strip out comments
	# Comments start with a semi collon and run till end of line.
	# However if the semi colon is escaped or inside a character string then we should keep it
	# see e.g. rt.cpan 49035
	my $loopdetection=length($rrstring);
	my $cleanstring;
	while ($rrstring) {

		if ($rrstring=~s/^([^\\;'"]*)//o){       # Anything not special in this context.
			$cleanstring.=$1;
		}
		if ($rrstring=~s/^(\\.)//o){             # Escaped special character
			$cleanstring.=$1;
		}

		if ($rrstring=~s/^((['"]).*(? $name,
		'type'     => $rrtype,
		'class'    => $rrclass,
		'ttl'      => $ttl,
		'rdlength' => 0,
		'rdata'    => '',
	};

	if ($RR{$rrtype} && $rdata !~ m/^\s*\\#/o ) {
		my $subclass = $class->_get_subclass($rrtype);
		return $subclass->new_from_string($self, $rdata);
	} elsif ($RR{$rrtype}) {   # A RR type known to Net::DNS starting with \#
		$rdata =~ m/\\\#\s+(\d+)\s+(.*)$/o;

		my $rdlength = $1;
		my $hexdump  = $2;
		$hexdump =~ s/\s*//og;

		die "$rdata is inconsistent; length does not match content"
			if length($hexdump) != $rdlength*2;

		$rdata = pack('H*', $hexdump);

		return Net::DNS::RR->new_from_data(
			$name,
			$rrtype,
			$rrclass,
			$ttl,
			$rdlength,
			\$rdata,
			length($rdata) - $rdlength
		);
	} elsif ($rdata=~/\s*\\\#\s+\d+\s+/o) {
		#We are now dealing with the truly unknown.
		die 'Expected RFC3597 representation of RDATA'
			unless $rdata =~ m/\\\#\s+(\d+)\s+(.*)$/o;

		my $rdlength = $1;
		my $hexdump  = $2;
		$hexdump =~ s/\s*//og;

		die "$rdata is inconsistent; length does not match content"
			if length($hexdump) != $rdlength*2;

		$rdata = pack('H*', $hexdump);

		return Net::DNS::RR->new_from_data(
			$name,
			$rrtype,
			$rrclass,
			$ttl,
			$rdlength,
			\$rdata,
			length($rdata) - $rdlength
		);
	} else {
		#God knows how to handle these... bless them in the RR class.
		bless $self, $class;
		return $self
	}

}

sub new_from_hash {
	my $class    = shift;
	my %keyval   = @_;
	my $self     = {};



	while ( my ($key, $val) = each %keyval ) {
	        $self->{lc $key} = $val ;
	}

	croak('RR name not specified') unless defined $self->{name};
	croak('RR type not specified') unless defined $self->{type};

	$self->{'ttl'}   ||= 0;
	$self->{'class'} ||= 'IN';

	$self->{'rdlength'} = length $self->{'rdata'}
		if $self->{'rdata'};

	if ($RR{$self->{'type'}}) {
		my $subclass = $class->_get_subclass($self->{'type'});
	    if (uc $self->{'type'} ne 'OPT') {
		        bless $self, $subclass;
			$self->_normalize_dnames();
			return _normalize_rdata($self);

	    } else {
			# Special processing of OPT. Since TTL and CLASS are
			# set by other variables. See Net::DNS::RR::OPT
			# documentation
			return $subclass->new_from_hash($self);
	    }
	} elsif ($self->{'type'} =~ /TYPE\d+/o) {
		bless $self, 'Net::DNS::RR::Unknown';
		return $self;
	} else {
	 	bless $self, $class;
	 	return $self;
	}
}



# Normalizes the content of the rdata so that comparing can be done between
# RRs created via various methods.

# Based on first creating packet format and then parsing it.

sub _normalize_rdata {
	my $self     = shift;



	# There are a bunch of META RR types we do not want to mess with
	return $self if ( ( uc $self ->{'type'} eq "TSIG" )||
			  ( uc $self ->{'type'} eq "TKEY" )
			);


	my $pkt = {	header		=> Net::DNS::Header->new,
			question	=> [],
			answer		=> [],
			authority	=> [],
			additional	=> []	};

	bless $pkt, "Net::DNS::Packet";
	$pkt->push( answer => $self );
	my $pkt2 = Net::DNS::Packet->new( \$pkt->data );
	undef ($self);
	return ($pkt2->answer)[0];
}

# When new_from_hash is used to generate the objects then it may be
# that the names passed are not consistently FQDN or not.  Note that
# the internal storage is without trailing dot.  this function
# normalizes the domain names and is implemented in the records
# themselves if more specific handling is needed

sub _normalize_dnames {
	my $self=shift;
	$self->_normalize_ownername();
}


sub _normalize_ownername {
	my $self=shift;
	return $self->{'name'}=stripdot($self->{'name'});
}


=head2 decode

    ($rrobj, $offset) = Net::DNS::RR->decode(\$data, $offset);

Decodes a DNS resource record at the specified location within a DNS packet.
The first argument is a reference to the packet data.
The second argument is the offset within the packet where the resource record begins.

Returns a Net::DNS::RR object and the offset of the next location in the packet.

Decoding is aborted if the object could not be created (e.g., corrupt or insufficient data).

=cut

use constant RRFIXEDSZ => length pack 'n2 N n', (0) x 4;

sub decode {
	my ($objclass, $data, $offset) = @_;

	my ($name, $index) = Net::DNS::Packet::dn_expand($data, $offset || 0);
	die 'Exception: corrupt or incomplete data' unless $index;

	my $rdindex = $index + RRFIXEDSZ;
	die 'Exception: incomplete data' if length $$data < $rdindex;
	my ($type, $class, $ttl, $rdlength) = unpack("\@$index n2 N n", $$data);

	my $next = $rdindex + $rdlength;
	die 'Exception: incomplete data' if length $$data < $next;

	$type = Net::DNS::typesbyval($type) || $type;

	# Special case for OPT RR where CLASS should be
	# interpreted as 16 bit unsigned (RFC2671, 4.3)
	if ($type ne 'OPT') {
		$class = Net::DNS::classesbyval($class) || $class;
	}
	# else just retain numerical value

	my $self = $objclass->new_from_data($name, $type, $class, $ttl, $rdlength, $data, $rdindex);
	die 'Exception: corrupt or incomplete RR subtype data' unless defined $self;

	return wantarray ? ($self, $next) : $self;
}


=head2 print

    $rr->print;

Prints the record to the standard output.  Calls the B method
to get the RR's string representation.

=cut
#' someone said that emacs gets screwy here.  Who am I to claim otherwise...

sub print {	print &string, "\n"; }

=head2 string

    print $rr->string, "\n";

Returns a string representation of the RR.  Calls the B
method to get the RR-specific data. Domain names arereturned in
RFC1035 format, i.e. all non letter, digit, hyphen characters are
represented as \DDD. Besides, all domain names are expanded to fully
qualified domain names, with trailing dot.  This is in contrast to
accessor methods of individual data elements in RR objects, like
B, which will not return the trailing dot.

=cut

sub string {
	my $self = shift;
	my $data = $self->rdatastr || '; no data';

	join "\t", "$self->{name}.", $self->{ttl}, $self->{class}, $self->{type}, $data;
}

=head2 rdatastr

    $s = $rr->rdatastr;

Returns a string containing RR-specific data.  Subclasses will need
to implement this method.

=cut

sub rdatastr {
	my $self = shift;
	return exists $self->{'rdlength'}
	       ? "; rdlength = $self->{'rdlength'}"
	       : '';
}

=head2 name

    $name = $rr->name;

Returns the record's domain name.

=head2 type

    $type = $rr->type;

Returns the record's type.

=head2 class

    $class = $rr->class;

Returns the record's class.

=cut

# Used to AUTOLOAD this, but apparently some versions of Perl (specifically
# 5.003_07, included with some Linux distributions) would return the
# class the object was blessed into, instead of the RR's class.

sub class {
	my $self = shift;

	if (@_) {
		$self->{'class'} = shift;
	} elsif (!exists $self->{'class'}) {
		Carp::carp('class: no such method');
		return undef;
	}
	return $self->{'class'};
}


=head2 ttl

    $ttl = $rr->ttl;

Returns the record's time-to-live (TTL).

=head2 rdlength

    $rdlength = $rr->rdlength;

Returns the length of the record's data section.

=head2 rdata

    $rdata = $rr->rdata

Returns the record's data section as binary data.

=cut
#'
sub rdata {
	my $self = shift;
	my $retval = undef;

	if (@_ == 2) {
		my ($packet, $offset) = @_;
		$retval = $self->rr_rdata($packet, $offset);
	}
	elsif (exists $self->{'rdata'}) {
		$retval = $self->{'rdata'};
	}

	return $retval;
}

sub rr_rdata {
	my $self = shift;
	return exists $self->{'rdata'} ? $self->{'rdata'} : '';
}


#------------------------------------------------------------------------------
# sub encode
#
# This method is called by Net::DNS::Packet->data to get the binary
# representation of an RR.
#------------------------------------------------------------------------------

sub encode {
	my ( $self, $offset, $hash, $packet ) = @_;
	$offset ||= 0;
	$packet ||= bless {}, qw(Net::DNS::Packet);
	$packet->{compnames} = $hash || {};

	# Don't compress TSIG or TKEY names and don't mess with EDNS0 packets
	my $data;
	if (uc($self->{'type'}) eq 'TSIG' || uc($self->{'type'}) eq 'TKEY') {
		my $tmp_packet = Net::DNS::Packet->new();
		$data = $tmp_packet->dn_comp($self->{'name'}, 0);
		return undef unless defined $data;
	} elsif (uc($self->{'type'}) eq 'OPT') {
		my $tmp_packet = Net::DNS::Packet->new();
		$data = $tmp_packet->dn_comp('', 0);
	} else {
		$data  = $packet->dn_comp($self->{'name'}, $offset);
		return undef unless defined $data;
	}

	my $qtype     = uc($self->{'type'});
	my $qtype_val = ($qtype =~ m/^\d+$/o) ? $qtype : Net::DNS::typesbyname($qtype);
	$qtype_val    = 0 if !defined($qtype_val);

	my $qclass     = uc($self->{'class'});
	my $qclass_val = ($qclass =~ m/^\d+$/o) ? $qclass : Net::DNS::classesbyname($qclass);
	$qclass_val    = 0 if !defined($qclass_val);
	$data .= pack('n', $qtype_val);

	# If the type is OPT then class will need to contain a decimal number
	# containing the UDP payload size. (RFC2671 section 4.3)
	if (uc($self->{'type'}) ne 'OPT') {
	    $data .= pack('n', $qclass_val);
	} else {
	    $data .= pack('n', $self->{'class'});
	}

	$data .= pack('N', $self->{'ttl'});

	$offset += length($data) + &Net::DNS::INT16SZ;	# allow for rdlength

	my $rdata = $self->rdata($packet, $offset);

	$data .= pack('n', length $rdata);
	$data.=$rdata;

	return $data;
}





#------------------------------------------------------------------------------
#  This method is called by SIG objects verify method.
#  It is almost the same as data but needed to get an representation of the
#  packets in wire format withoud domain name compression.
#  It is essential to DNSSEC RFC 2535 section 8
#------------------------------------------------------------------------------

sub canonical {&_canonicaldata}

sub _canonicaldata {
	my $self = shift;
	my $data='';
	{
	    my $name=$self->{'name'};
	    my @dname=Net::DNS::name2labels($name);
	    for (my $i=0;$i<@dname;$i++){
		$data .= pack ('C',length $dname[$i] );
		$data .= lc($dname[$i] );
	    }
	    $data .= pack ('C','0');
	}
	$data .= pack('n', Net::DNS::typesbyname(uc($self->{'type'})));
	$data .= pack('n', Net::DNS::classesbyname(uc($self->{'class'})));
	$data .= pack('N', $self->{'ttl'});


	my $rdata = $self->_canonicalRdata;

	$data .= pack('n', length $rdata);
	$data .= $rdata;
	return $data;


}

# These are methods that are used in the DNSSEC context...  Some RR
# have domain names in them. Verification works only on RRs with
# uncompressed domain names. (Canonical format as in sect 8 of
# RFC2535) _canonicalRdata is overwritten in those RR objects that
# have domain names in the RDATA and _name2wire is used to convert a
# domain name to "wire format"


sub _canonicalRdata {
    my $self=shift;
    my $packet=Net::DNS::Packet->new();
    my $rdata = $self->rr_rdata($packet,0);
    return $rdata;
}





sub _name2wire   {
    my ($self, $name) = @_;

    my $rdata="";
    my $compname = "";
    my @dname = Net::DNS::name2labels($name);


    for (@dname) {
		$rdata .= pack('C', length $_);
		$rdata .= $_ ;
    }

    $rdata .= pack('C', '0');
    return $rdata;
}




use vars qw($AUTOLOAD);

sub AUTOLOAD {
	my ($self) = @_;  # If we do shift here, it will mess up the goto below.
	my ($name) = $AUTOLOAD =~ m/^.*::(.*)$/o;
	if ($name =~ /set_rrsort_func/){
	    return Net::DNS::RR::set_rrsort_func(@_);
	}
	if ($name =~ /get_rrsort_func/){
	    return Net::DNS::RR::get_rrsort_func(@_);
	}
	# XXX -- We should test that we do in fact carp on unknown methods.
	unless (exists $self->{$name}) {
	    my $rr_string = $self->string;
	    Carp::carp(<<"AMEN");

***
***  WARNING!!!  The program has attempted to call the method
***  "$name" for the following RR object:
***
***  $rr_string
***
***  This object does not have a method "$name".  THIS IS A BUG
***  IN THE CALLING SOFTWARE, which has incorrectly assumed that
***  the object would be of a particular type.  The calling
***  software should check the type of each RR object before
***  calling any of its methods.
***
***  Net::DNS has returned undef to the caller.
***

AMEN
return;
	}

	no strict q/refs/;

	# Build a method in the class.
	*{$AUTOLOAD} = sub {
	    my ($self, $new_val) = @_;

	    if (defined $new_val) {
		$self->{$name} = $new_val;
	    }

	    return $self->{$name};
	};

	# And jump over to it.
	goto &{$AUTOLOAD};
}

sub DESTROY {}


#
#  Net::DNS::RR->_get_subclass($type)
#
# Return a subclass, after loading a subclass (if needed)
#
sub _get_subclass {
	my ($class, $type) = @_;

	return unless $type and $RR{$type};

	my $subclass = join('::', $class, $type);

	unless ($_LOADED{$subclass}) {
		eval "require $subclass";
		die $@ if $@;
		$_LOADED{$subclass}++;
	}

	return $subclass;
}




=head1 Sorting of RR arrays

As of version 0.55 there is functionality to help you sort RR
arrays. The sorting is done by Net::DNS::rrsort(), see the
L documentation. This package provides class methods to set
the sorting functions used for a particular RR based on a particular
attribute.


=head2 set_rrsort_func

Net::DNS::RR::SRV->set_rrsort_func("priority",
			       sub {
				   my ($a,$b)=($Net::DNS::a,$Net::DNS::b);
				   $a->priority <=> $b->priority
				   ||
				   $b->weight <=> $a->weight
                     }

Net::DNS::RR::SRV->set_rrsort_func("default_sort",
			       sub {
				   my ($a,$b)=($Net::DNS::a,$Net::DNS::b);
				   $a->priority <=> $b->priority
				   ||
				   $b->weight <=> $a->weight
                     }

set_rrsort_func needs to be called as a class method. The first
argument is the attribute name on which the sorting will need to take
place. If you specify "default_sort" than that is the sort algorithm
that will be used in the case that rrsort() is called without an RR
attribute as argument.

The second argument is a reference to a function that uses the
variables $a and $b global to the C(!!)package for the
sorting. During the sorting $a and $b will contain references to
objects from the class you called the set_prop_sort from. In other
words, you can rest assured that the above sorting function will only
get Net::DNS::RR::SRV objects.

The above example is the sorting function that actually is implemented in
SRV.

=cut



use vars qw(%rrsortfunct);

sub set_rrsort_func{
    my $class=shift;
    my $attribute=shift;
    my $funct=shift;
#    print "Using ".__PACKAGE__."set_rrsort: $class\n";
    my ($type) = $class =~ m/^.*::(.*)$/o;
    $Net::DNS::RR::rrsortfunct{$type}{$attribute}=$funct;
}

sub get_rrsort_func {
    my $class=shift;
    my $attribute=shift;  #can be undefined.
    my $sortsub;
    my ($type) = $class =~ m/^.*::(.*)$/o;


#    print "Using ".__PACKAGE__." get_rrsort: $class ($type,$attribute)\n";
#    use Data::Dumper;
#    print Dumper %Net::DNS::rrsortfunct;

    if (defined($attribute) &&
	exists($Net::DNS::RR::rrsortfunct{$type}) &&
	exists($Net::DNS::RR::rrsortfunct{$type}{$attribute})
	){
	#  The default overwritten by the class variable in Net::DNS
	return $Net::DNS::RR::rrsortfunct{$type}{$attribute};
    }elsif(
	! defined($attribute) &&
	exists($Net::DNS::RR::rrsortfunct{$type}) &&
	exists($Net::DNS::RR::rrsortfunct{$type}{'default_sort'})
	){
	#  The default overwritten by the class variable in Net::DNS
	return $Net::DNS::RR::rrsortfunct{$type}{'default_sort'};
    }
    elsif( defined($attribute) ){

	return sub{
	    my ($a,$b)=($Net::DNS::a,$Net::DNS::b);
	    ( exists($a->{$attribute}) &&
	      $a->{$attribute} <=> $b->{$attribute})
		||
		$a->_canonicaldata() cmp $b->_canonicaldata()
	};
    }else{
	return sub{
	    my ($a,$b)=($Net::DNS::a,$Net::DNS::b);
	    $a->_canonicaldata() cmp $b->_canonicaldata()
	};
    }

    return $sortsub;
}






sub STORABLE_freeze {
	my ($self, $cloning) = @_;

	return if $cloning;

	return ('', {%$self});
}

sub STORABLE_thaw {
	my ($self, $cloning, undef, $data) = @_;

	%{$self}  = %{$data};

	__PACKAGE__->_get_subclass($self->{'type'});

	return $self;
}


#
#	dump
#
#	    $rr->dump;
#
#	Prints a depth-first recursive listing of the record data structure.
#

sub dump {				## print internal data structure
	use Data::Dumper;
	print Dumper(shift);
}


=head1 BUGS

This version of C does little sanity checking on user-created
RR objects.

=head1 COPYRIGHT

Copyright (c)1997-2002 Michael Fuhr.

Portions Copyright (c)2002-2004 Chris Reinhardt.

Portions Copyright (c)2005-2007 Olaf Kolkman

Portions Copyright (c)2007 Dick Franks

All rights reserved.

This program is free software; you may redistribute it and/or
modify it under the same terms as Perl itself.

EDNS0 extensions by Olaf Kolkman.

=head1 SEE ALSO

L, L, L, L,
L, L, L,
RFC 1035 Section 4.1.3

=cut

1;
Net-DNS-0.68/lib/Net/DNS/Resolver.pm0000644000175000017500000005026311710626412016250 0ustar  willemwillempackage Net::DNS::Resolver;
#
# $Id: Resolver.pm 955 2011-11-03 22:56:41Z willem $
#

use strict;
use vars qw($VERSION @ISA);

$VERSION = (qw$LastChangedRevision: 955 $)[1];

BEGIN {
	if ($^O eq 'MSWin32') {
		require Net::DNS::Resolver::Win32;
		@ISA = qw(Net::DNS::Resolver::Win32);

	} elsif ($^O eq 'cygwin') {
		eval { require Net::DNS::Resolver::Win32; };

		unless ($@) {
			@ISA = qw(Net::DNS::Resolver::Win32);
		} else {
			require Net::DNS::Resolver::Cygwin;
			@ISA = qw(Net::DNS::Resolver::Cygwin);
		}

	} else {
		require Net::DNS::Resolver::UNIX;
		@ISA = qw(Net::DNS::Resolver::UNIX);
	}
}

__PACKAGE__->init();

1;

__END__

=head1 NAME

Net::DNS::Resolver - DNS resolver class

=head1 SYNOPSIS

  use Net::DNS;

  my $res = Net::DNS::Resolver->new;

  # Perform a lookup, using the searchlist if appropriate.
  my $answer = $res->search('example.com');

  # Perform a lookup, without the searchlist
  my $answer = $res->query('example.com', 'MX');

  # Perform a lookup, without pre or post-processing
  my $answer = $res->send('example.com', 'MX', 'CH');

  # Send a prebuilt packet
  my $packet = Net::DNS::Packet->new(...);
  my $answer = $res->send($packet);

=head1 DESCRIPTION

Instances of the C class represent resolver objects.
A program can have multiple resolver objects, each maintaining its
own state information such as the nameservers to be queried, whether
recursion is desired, etc.

=head1 METHODS

=head2 new

  # Use the system defaults
  my $res = Net::DNS::Resolver->new;

  # Use my own configuration file
  my $res = Net::DNS::Resolver->new(config_file => '/my/dns.conf');

  # Set options in the constructor
  my $res = Net::DNS::Resolver->new(
  	nameservers => [qw(10.1.1.128 10.1.2.128)],
  	recurse     => 0,
  	debug       => 1,
  );

Returns a resolver object.  If given no arguments, C returns an
object configured to your system's defaults.  On UNIX systems the
defaults are read from the following files, in the order indicated:

    /etc/resolv.conf
    $HOME/.resolv.conf
    ./.resolv.conf

The following keywords are recognized in resolver configuration files:

=over 4

=item domain

The default domain.

=item search

A space-separated list of domains to put in the search list.

=item nameserver

A space-separated list of nameservers to query.

=back

Files except for F must be owned by the effective
userid running the program or they won't be read.  In addition, several
environment variables can also contain configuration information; see
L.

On Windows systems, an attempt is made to determine the system defaults
using the registry.  This is still a work in progress; systems with many
dynamically configured network interfaces may confuse Net::DNS.

You can include a configuration file of your own when creating a
resolver object:

 # Use my own configuration file
 my $res = Net::DNS::Resolver->new(config_file => '/my/dns.conf');

This is supported on both UNIX and Windows.  Values pulled from a custom
configuration file override the the system's defaults, but can still be
overridden by the other arguments to new().

Explicit arguments to new override both the system's defaults and the
values of the custom configuration file, if any.  The following
arguments to new() are supported:

=over 4

=item nameservers

An array reference of nameservers to query.

=item searchlist

An array reference of domains.

=item recurse

=item debug

=item domain

=item port

=item srcaddr

=item srcport

=item tcp_timeout

=item udp_timeout

=item retrans

=item retry

=item usevc

=item stayopen

=item igntc

=item defnames

=item dnsrch

=item persistent_tcp

=item persistent_udp

=item dnssec

=back

For more information on any of these options, please consult the method
of the same name.

=head2 search

    $packet = $res->search('mailhost');
    $packet = $res->search('mailhost.example.com');
    $packet = $res->search('192.168.1.1');
    $packet = $res->search('example.com', 'MX');
    $packet = $res->search('user.passwd.example.com', 'TXT', 'HS');

Performs a DNS query for the given name, applying the searchlist
if appropriate.  The search algorithm is as follows:

=over 4

=item 1.

If the name contains at least one dot, try it as is.

=item 2.

If the name doesn't end in a dot then append each item in
the search list to the name.  This is only done if B
is true.

=item 3.

If the name doesn't contain any dots, try it as is.

=back

The record type and class can be omitted; they default to A and
IN.  If the name looks like an IP address (4 dot-separated numbers),
then an appropriate PTR query will be performed.

Returns a "Net::DNS::Packet" object, or "undef" if no answers were
found.  If you need to examine the response packet whether it contains
any answers or not, use the send() method instead.

=head2 query

    $packet = $res->query('mailhost');
    $packet = $res->query('mailhost.example.com');
    $packet = $res->query('192.168.1.1');
    $packet = $res->query('example.com', 'MX');
    $packet = $res->query('user.passwd.example.com', 'TXT', 'HS');

Performs a DNS query for the given name; the search list is not
applied.  If the name doesn't contain any dots and B
is true then the default domain will be appended.

The record type and class can be omitted; they default to A and
IN.  If the name looks like an IP address (IPv4 or IPv6),
then an appropriate PTR query will be performed.

Returns a "Net::DNS::Packet" object, or "undef" if no answers were
found.  If you need to examine the response packet whether it contains
any answers or not, use the send() method instead.

=head2 send

    $packet = $res->send($packet_object);
    $packet = $res->send('mailhost.example.com');
    $packet = $res->send('example.com', 'MX');
    $packet = $res->send('user.passwd.example.com', 'TXT', 'HS');

Performs a DNS query for the given name.  Neither the searchlist
nor the default domain will be appended.

The argument list can be either a C object or a list
of strings.  The record type and class can be omitted; they default to
A and IN.  If the name looks like an IP address (Ipv4 or IPv6),
then an appropriate PTR query will be performed.

Returns a C object whether there were any answers or not.
Use C<< $packet->header->ancount >> or C<< $packet->answer >> to find out
if there were any records in the answer section.  Returns C if there
was an error.

=head2 axfr

    @zone = $res->axfr;
    @zone = $res->axfr('example.com');
    @zone = $res->axfr('passwd.example.com', 'HS');

Performs a zone transfer from the first nameserver listed in C.
If the zone is omitted, it defaults to the first zone listed in the resolver's
search list.  If the class is omitted, it defaults to IN.

Returns a list of C objects, or C if the zone
transfer failed.

The redundant SOA record that terminates the zone transfer is not
returned to the caller.

See also L and L.

Here's an example that uses a timeout:

    $res->tcp_timeout(10);
    my @zone = $res->axfr('example.com');

    if (@zone) {
        foreach my $rr (@zone) {
            $rr->print;
        }
    } else {
        print 'Zone transfer failed: ', $res->errorstring, "\n";
    }

=head2 axfr_start

    $res->axfr_start;
    $res->axfr_start('example.com');
    $res->axfr_start('example.com', 'HS');

Starts a zone transfer from the first nameserver listed in C.
If the zone is omitted, it defaults to the first zone listed in the resolver's
search list.  If the class is omitted, it defaults to IN.

B:

This method currently returns the C object that will
be used for reading, or C on error.  DO NOT DEPEND ON C
returning a socket object.  THIS MIGHT CHANGE in future releases.

Use C to read the zone records one at a time.

=head2 axfr_next

    $res->axfr_start('example.com');

    while (my $rr = $res->axfr_next) {
	    $rr->print;
    }

Reads records from a zone transfer one at a time.

Returns C at the end of the zone transfer.  The redundant
SOA record that terminates the zone transfer is not returned.

See also L.

=head2 nameservers

    @nameservers = $res->nameservers;
    $res->nameservers('192.168.1.1', '192.168.2.2', '192.168.3.3');

Gets or sets the nameservers to be queried.

Also see the IPv6 transport notes below

=head2 print

    $res->print;

Prints the resolver state on the standard output.

=head2 string

    print $res->string;

Returns a string representation of the resolver state.

=head2 searchlist

    @searchlist = $res->searchlist;
    $res->searchlist('example.com', 'a.example.com', 'b.example.com');

Gets or sets the resolver search list.

=head2 port

    print 'sending queries to port ', $res->port, "\n";
    $res->port(9732);

Gets or sets the port to which we send queries.  This can be useful
for testing a nameserver running on a non-standard port.  The
default is port 53.

=head2 srcport

    print 'sending queries from port ', $res->srcport, "\n";
    $res->srcport(5353);

Gets or sets the port from which we send queries.  The default is 0,
meaning any port.

=head2 srcaddr

    print 'sending queries from address ', $res->srcaddr, "\n";
    $res->srcaddr('192.168.1.1');

Gets or sets the source address from which we send queries.  Convenient
for forcing queries out a specific interfaces on a multi-homed host.
The default is 0.0.0.0, meaning any local address.

=head2 bgsend

    $socket = $res->bgsend($packet_object) || die " $res->errorstring";

    $socket = $res->bgsend('mailhost.example.com');
    $socket = $res->bgsend('example.com', 'MX');
    $socket = $res->bgsend('user.passwd.example.com', 'TXT', 'HS');



Performs a background DNS query for the given name, i.e., sends a
query packet to the first nameserver listed in C<< $res->nameservers >>
and returns immediately without waiting for a response.  The program
can then perform other tasks while waiting for a response from the
nameserver.

The argument list can be either a C object or a list
of strings.  The record type and class can be omitted; they default to
A and IN.  If the name looks like an IP address (4 dot-separated numbers),
then an appropriate PTR query will be performed.

Returns an C object or C on error in which
case the reason for failure can be found through a call to the
errorstring method.

The program must determine when the socket is ready for reading and
call C<< $res->bgread >> to get the response packet.  You can use C<<
$res->bgisready >> or C to find out if the socket is ready
before reading it.

bgsend does not support persistent sockets.
bgsend does not support the usevc option (TCP).

=head2 bgread

    $packet = $res->bgread($socket);
    undef $socket;

Reads the answer from a background query (see L).  The argument
is an C object returned by C.

Returns a C object or C on error.

The programmer should close or destroy the socket object after reading it.

=head2 bgisready

    $socket = $res->bgsend('foo.example.com');
    until ($res->bgisready($socket)) {
        # do some other processing
    }
    $packet = $res->bgread($socket);
    $socket = undef;

Determines whether a socket is ready for reading.  The argument is
an C object returned by C<< $res->bgsend >>.

Returns true if the socket is ready, false if not.

=head2 tsig

    my $tsig = $res->tsig;

    $res->tsig(Net::DNS::RR->new("$key_name TSIG $key"));

    $tsig = Net::DNS::RR->new("$key_name TSIG $key");
    $tsig->fudge(60);
    $res->tsig($tsig);

    $res->tsig($key_name, $key);

    $res->tsig(0);

Get or set the TSIG record used to automatically sign outgoing
queries and updates.  Call with an argument of 0 or '' to turn off
automatic signing.

The default resolver behavior is not to sign any packets.  You must
call this method to set the key if you'd like the resolver to sign
packets automatically.

You can also sign packets manually -- see the C
and C manual pages for examples.  TSIG records
in manually-signed packets take precedence over those that the
resolver would add automatically.

=head2 retrans

    print 'retrans interval: ', $res->retrans, "\n";
    $res->retrans(3);

Get or set the retransmission interval.  The default is 5.

=head2 retry

    print 'number of tries: ', $res->retry, "\n";
    $res->retry(2);

Get or set the number of times to try the query.  The default is 4.

=head2 recurse

    print 'recursion flag: ', $res->recurse, "\n";
    $res->recurse(0);

Get or set the recursion flag.  If this is true, nameservers will
be requested to perform a recursive query.  The default is true.

=head2 defnames

    print 'defnames flag: ', $res->defnames, "\n";
    $res->defnames(0);

Get or set the defnames flag.  If this is true, calls to B will
append the default domain to names that contain no dots.  The default
is true.

=head2 dnsrch

    print 'dnsrch flag: ', $res->dnsrch, "\n";
    $res->dnsrch(0);

Get or set the dnsrch flag.  If this is true, calls to B will
apply the search list.  The default is true.

=head2 debug

    print 'debug flag: ', $res->debug, "\n";
    $res->debug(1);

Get or set the debug flag.  If set, calls to B, B,
and B will print debugging information on the standard output.
The default is false.

=head2 usevc

    print 'usevc flag: ', $res->usevc, "\n";
    $res->usevc(1);

Get or set the usevc flag.  If true, then queries will be performed
using virtual circuits (TCP) instead of datagrams (UDP).  The default
is false.

=head2 tcp_timeout

    print 'TCP timeout: ', $res->tcp_timeout, "\n";
    $res->tcp_timeout(10);

Get or set the TCP timeout in seconds.  A timeout of C means
indefinite.  The default is 120 seconds (2 minutes).

=head2 udp_timeout

    print 'UDP timeout: ', $res->udp_timeout, "\n";
    $res->udp_timeout(10);

Get or set the UDP timeout in seconds.  A timeout of C means
the retry and retrans settings will be just utilized to perform the
retries until they are exhausted.  The default is C.

=head2 persistent_tcp

    print 'Persistent TCP flag: ', $res->persistent_tcp, "\n";
    $res->persistent_tcp(1);

Get or set the persistent TCP setting.  If set to true, Net::DNS
will keep a TCP socket open for each host:port to which it connects.
This is useful if you're using TCP and need to make a lot of queries
or updates to the same nameserver.

This option defaults to false unless you're running under a
SOCKSified Perl, in which case it defaults to true.

=head2 persistent_udp

    print 'Persistent UDP flag: ', $res->persistent_udp, "\n";
    $res->persistent_udp(1);

Get or set the persistent UDP setting.  If set to true, Net::DNS
will keep a single UDP socket open for all queries.
This is useful if you're using UDP and need to make a lot of queries
or updates.

=head2 igntc

    print 'igntc flag: ', $res->igntc, "\n";
    $res->igntc(1);

Get or set the igntc flag.  If true, truncated packets will be
ignored.  If false, truncated packets will cause the query to
be retried using TCP.  The default is false.

=head2 errorstring

    print 'query status: ', $res->errorstring, "\n";

Returns a string containing the status of the most recent query.

=head2 answerfrom

    print 'last answer was from: ', $res->answerfrom, "\n";

Returns the IP address from which we received the last answer in
response to a query.

=head2 answersize

    print 'size of last answer: ', $res->answersize, "\n";

Returns the size in bytes of the last answer we received in
response to a query.


=head2 dnssec

    print "dnssec flag: ", $res->dnssec, "\n";
    $res->dnssec(0);

Enabled DNSSEC this will set the checking disabled flag in the query header
and add EDNS0 data as in RFC2671 and RFC3225

When set to true the answer and additional section of queries from
secured zones will contain DNSKEY, NSEC and RRSIG records.

Setting calling the dnssec method with a non-zero value will set the
UDP packet size to the default value of 2048. If that is to small or
to big for your environment you should call the udppacketsize()
method immeditatly after.

   $res->dnssec(1);    # turns on DNSSEC and sets udp packetsize to 2048
   $res->udppacketsize(1028);   # lowers the UDP pakcet size

The method will Croak::croak with the message "You called the
Net::DNS::Resolver::dnssec() method but do not have Net::DNS::SEC
installed at ..." if you call it without Net::DNS::SEC being in your
@INC path.



=head2 cdflag

    print "checking disabled flag: ", $res->dnssec, "\n";
    $res->dnssec(1);
    $res->cdflag(1);

Sets or gets the CD bit for a dnssec query.  This bit is always zero
for non dnssec queries. When the dnssec is enabled the flag defaults to
0 can be set to 1.



=head2 adflag

    print "checking disabled flag: ", $res->dnssec, "\n";
    $res->dnssec(1);
    $res->adflag(1);

Sets or gets the AD bit for a dnssec query.  This bit is always zero
for non dnssec queries. When the dnssec is enabled the flag defaults
to 1.


=head2 udppacketsize

    print "udppacketsize: ", $res->udppacketsize, "\n";
    $res->udppacketsize(2048);

udppacketsize will set or get the packet size. If set to a value greater than
Net::DNS::PACKETSZ() an EDNS extension will be added indicating support for MTU path
recovery.

Default udppacketsize is Net::DNS::PACKETSZ() (512)

=head1 CUSTOMIZING

Net::DNS::Resolver is actually an empty subclass.  At compile time a
super class is chosen based on the current platform.  A side benefit of
this allows for easy modification of the methods in Net::DNS::Resolver.
You simply add a method to the namespace!

For example, if we wanted to cache lookups:

 package Net::DNS::Resolver;

 my %cache;

 sub search {
	my ($self, @args) = @_;

	return $cache{@args} ||= $self->SUPER::search(@args);
 }


=head1 IPv6 transport

The Net::DNS::Resolver library will use IPv6 transport if the
appropriate libraries (Socket6 and IO::Socket::INET6) are available
and the address the server tries to connect to is an IPv6 address.

The print() will method will report if IPv6 transport is available.

You can use the force_v4() method with a non-zero argument
to force IPv4 transport.

The nameserver() method has IPv6 dependend behavior. If IPv6 is not
available or IPv4 transport has been forced the nameserver() method
will only return IPv4 addresses.

For example

    $res->nameservers('192.168.1.1', '192.168.2.2', '2001:610:240:0:53:0:0:3');
    $res->force_v4(1);
    print join (" ",$res->nameserver());

Will print: 192.168.1.1 192.168.2.2




=head1 ENVIRONMENT

The following environment variables can also be used to configure
the resolver:

=head2 RES_NAMESERVERS

    # Bourne Shell
    RES_NAMESERVERS="192.168.1.1 192.168.2.2 192.168.3.3"
    export RES_NAMESERVERS

    # C Shell
    setenv RES_NAMESERVERS "192.168.1.1 192.168.2.2 192.168.3.3"

A space-separated list of nameservers to query.

=head2 RES_SEARCHLIST

    # Bourne Shell
    RES_SEARCHLIST="example.com sub1.example.com sub2.example.com"
    export RES_SEARCHLIST

    # C Shell
    setenv RES_SEARCHLIST "example.com sub1.example.com sub2.example.com"

A space-separated list of domains to put in the search list.

=head2 LOCALDOMAIN

    # Bourne Shell
    LOCALDOMAIN=example.com
    export LOCALDOMAIN

    # C Shell
    setenv LOCALDOMAIN example.com

The default domain.

=head2 RES_OPTIONS

    # Bourne Shell
    RES_OPTIONS="retrans:3 retry:2 debug"
    export RES_OPTIONS

    # C Shell
    setenv RES_OPTIONS "retrans:3 retry:2 debug"

A space-separated list of resolver options to set.  Options that
take values are specified as I