Net::DNS - Perl interface to the DNS resolver

    print Net::DNS->version, "\n";

    # 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");

    # RRset exists (value-independent)
    $update->push(pre => yxrrset("host.example.com A"));

    # RRset exists (value-dependent)
    $packet->push(pre => yxrrset("host.example.com A 10.1.2.3"));

    $packet->push(pre => nxrrset("host.example.com A"));

    $packet->push(pre => yxdomain("host.example.com"));

    $packet->push(pre => nxdomain("host.example.com"));

    $packet->push(update => rr_add("host.example.com A 10.1.2.3"));

    # Delete an RRset.
    $packet->push(update => rr_del("host.example.com A"));

    # Delete all RRsets.
    $packet->push(update => rr_del("host.example.com"));

    # Delete an RR.
    $packet->push(update => rr_del("host.example.com A 10.1.2.3"));

   use Net::DNS qw(rrsort);

   my @prioritysorted=rrsort("SRV","priority",@rr_array);

  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";
  }

  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";
  }

  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";
  }

  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";
  }

  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;
  }

  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;

  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";
  }

package Net::DNS;
#
# $Id: DNS.pm 829 2009-12-23 15:39:59Z olaf $
#
use strict;


BEGIN { 
    eval { require bytes; }
}



use vars qw(
    $HAVE_XS
    $VERSION
    $SVNVERSION
    $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);
    @EXPORT_OK= qw(name2labels wire2presentation rrsort stripdot);



    
    $VERSION = '0.66';
    $SVNVERSION = (qw$LastChangedRevision: 829 $)[1];




    $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 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
use Carp;



#
# 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 "Net::DNS::typesbyname() argument ($name) is not TYPE###" unless 
        $name =~ m/^\s*TYPE(\d+)\s*$/o;  
    
    my $val = $1;
    
    confess 'Net::DNS::typesbyname() argument larger than ' . 0xffff if $val > 0xffff;
    
    return $val;
}



sub typesbyval {
    my $val = shift;
    confess "Net::DNS::typesbyval() argument is not defined" unless defined $val;
    confess "Net::DNS::typesbyval() argument ($val) is not numeric" unless 
	$val =~ s/^\s*0*(\d+)\s*$/$1/o;

    
    
    return $typesbyval{$val} if $typesbyval{$val};
    
    confess 'Net::DNS::typesbyval() argument larger than '. 0xffff 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 $classesbyname{$name};
    
    confess "Net::DNS::classesbyval() argument is not CLASS### ($name)" unless 
        $name =~ m/^\s*CLASS(\d+)\s*$/o;
    
    my $val = $1;
    
    confess 'Net::DNS::classesbyval() argument larger than '. 0xffff if $val > 0xffff;
    
    return $val;
}



sub classesbyval {
    my $val = shift;
    
    confess "Net::DNS::classesbyname() argument is not numeric ($val)" unless 
	$val =~ s/^\s*0*([0-9]+)\s*$/$1/o;
    
    return $classesbyval{$val} if $classesbyval{$val};
    
    confess 'Net::DNS::classesbyname() argument larger than ' . 0xffff 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;
}

sub yxrrset {
    return Net::DNS::RR->new_from_string(shift, 'yxrrset');
}

sub nxrrset {
    return Net::DNS::RR->new_from_string(shift, 'nxrrset');
}

sub yxdomain {
    return Net::DNS::RR->new_from_string(shift, 'yxdomain');
}

sub nxdomain {
    return Net::DNS::RR->new_from_string(shift, 'nxdomain');
}

sub rr_add {
    return Net::DNS::RR->new_from_string(shift, 'rr_add');
}

sub rr_del {
    return Net::DNS::RR->new_from_string(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 <JMEHNLE@cpan.org>  
	# 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="";
    my $length=length($presentation);
    
    my $i=0;
    
    while ($i < $length ){
	my $char=unpack("x".$i."C1",$presentation);
	if (  $char == ord ('.')){
	    return ($wire,substr($presentation,$i+1));
	}
	if (  $char == ord ('\\')){
	    #backslash found
	    pos($presentation)=$i+1;
	    if ($presentation=~/\G(\d\d\d)/){
		$wire.=pack("C",$1);
		$i+=3;
	    }elsif($presentation=~/\Gx([0..9a..fA..F][0..9a..fA..F])/){
		$wire.=pack("H*",$1);
		$i+=3;
	    }elsif($presentation=~/\G\./){
		$wire.="\.";
		$i+=1;
	    }elsif($presentation=~/\G@/){
		$wire.="@";
		$i+=1;
	    }elsif($presentation=~/\G\(/){
		$wire.="(";
		$i+=1;
	    }elsif($presentation=~/\G\)/){
		$wire.=")";
		$i+=1;
           }elsif($presentation=~/\G\\/){
               $wire.="\\"; 
               $i+=1;
	    }
	}else{
	    $wire .=  pack("C",$char);  
        }
	$i++;
    }
    
    return $wire;
}





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__