Net-DNS-1.50/0000755000175000017500000000000014756035527012171 5ustar willemwillemNet-DNS-1.50/lib/0000755000175000017500000000000014756035527012737 5ustar willemwillemNet-DNS-1.50/lib/Net/0000755000175000017500000000000014756035527013465 5ustar willemwillemNet-DNS-1.50/lib/Net/DNS.pm0000644000175000017500000003724114756035515014453 0ustar willemwillempackage Net::DNS; use strict; use warnings; our $VERSION; $VERSION = '1.50'; $VERSION = eval {$VERSION}; our $SVNVERSION = (qw$Id: DNS.pm 2015 2025-02-21 08:37:21Z willem $)[2]; =head1 NAME Net::DNS - Perl Interface to the Domain Name System =head1 SYNOPSIS use Net::DNS; my $resolver = Net::DNS::Resolver->new(...); my $response = $resolver->send(...); =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 "gethostbyname" and "gethostbyaddr". The programmer should be familiar with the structure of a DNS packet and the zone file presentation format described in RFC1035. =cut use integer; use base qw(Exporter); our @EXPORT = qw(SEQUENTIAL UNIXTIME YYYYMMDDxx yxrrset nxrrset yxdomain nxdomain rr_add rr_del mx rr rrsort); local $SIG{__DIE__}; require Net::DNS::Resolver; require Net::DNS::Packet; require Net::DNS::RR; require Net::DNS::Update; sub version { return $VERSION; } # # rr() # # Usage: # @rr = rr('example.com'); # @rr = rr('example.com', 'A', 'IN'); # @rr = rr($res, 'example.com' ... ); # sub rr { my @arg = @_; my $res = ( ref( $arg[0] ) ? shift @arg : Net::DNS::Resolver->new() ); my $reply = $res->query(@arg); my @list = $reply ? $reply->answer : (); return @list; } # # mx() # # Usage: # @mx = mx('example.com'); # @mx = mx($res, 'example.com'); # sub mx { my @arg = @_; my @res = ( ref( $arg[0] ) ? shift @arg : () ); my ( $name, @class ) = @arg; # This construct is best read backwards. # # First we take the answer section of the packet. # Then we take just the MX records from that list # Then we sort the list by preference # We do this into an array to force list context. # Then we return the list. my @list = sort { $a->preference <=> $b->preference } grep { $_->type eq 'MX' } &rr( @res, $name, 'MX', @class ); return @list; } # # rrsort() # # Usage: # @prioritysorted = rrsort( "SRV", "priority", @rr_array ); # sub rrsort { my @arg = @_; my $rrtype = uc shift @arg; my ( $attribute, @rr ) = @arg; ## NB: attribute is optional ( @rr, $attribute ) = @arg if ref($attribute) =~ /^Net::DNS::RR/; my @extracted = grep { $_->type eq $rrtype } @rr; return @extracted unless scalar @extracted; my $func = "Net::DNS::RR::$rrtype"->get_rrsort_func($attribute); my @sorted = sort $func @extracted; return @sorted; } # # Auxiliary functions to support policy-driven zone serial numbering. # # $successor = $soa->serial(SEQUENTIAL); # $successor = $soa->serial(UNIXTIME); # $successor = $soa->serial(YYYYMMDDxx); # sub SEQUENTIAL { return (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; } # # Auxiliary functions to support dynamic update. # sub yxrrset { my @arg = @_; my $rr = Net::DNS::RR->new(@arg); $rr->ttl(0); $rr->class('ANY') unless $rr->rdata; return $rr; } sub nxrrset { my @arg = @_; my $rr = Net::DNS::RR->new(@arg); return Net::DNS::RR->new( name => $rr->name, type => $rr->type, class => 'NONE' ); } sub yxdomain { my @arg = @_; my ( $domain, @etc ) = map {split} @arg; my $rr = Net::DNS::RR->new( scalar(@etc) ? @arg : ( name => $domain ) ); return Net::DNS::RR->new( name => $rr->name, type => 'ANY', class => 'ANY' ); } sub nxdomain { my @arg = @_; my ( $domain, @etc ) = map {split} @arg; my $rr = Net::DNS::RR->new( scalar(@etc) ? @arg : ( name => $domain ) ); return Net::DNS::RR->new( name => $rr->name, type => 'ANY', class => 'NONE' ); } sub rr_add { my @arg = @_; my $rr = Net::DNS::RR->new(@arg); $rr->{ttl} = 86400 unless defined $rr->{ttl}; return $rr; } sub rr_del { my @arg = @_; my ( $domain, @etc ) = map {split} @arg; my $rr = Net::DNS::RR->new( scalar(@etc) ? @arg : ( name => $domain, type => 'ANY' ) ); $rr->class( $rr->rdata ? 'NONE' : 'ANY' ); $rr->ttl(0); return $rr; } 1; __END__ =head2 Resolver Objects A resolver object is an instance of the L class. A program may 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. A packet object has five sections: =over 3 =item * header, represented by a L object =item * question, a list of no more than one L object =item * answer, a list of L objects =item * authority, a list of L objects =item * additional, a list of L objects =back =head2 Update Objects L is a subclass of L useful for creating dynamic update requests. =head2 Header Object The L object mediates access to the header data which resides within the corresponding L. =head2 Question Object The L object represents the content of the question section of the 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. Do not assume that RR objects will be of the type requested. The type of an RR object must be checked before calling any methods. =head1 METHODS Net::DNS exports methods and auxiliary functions to support DNS updates, zone serial number management, and simple DNS queries. =head2 version use Net::DNS; print Net::DNS->version, "\n"; Returns the version of Net::DNS. =head2 rr # Use a default resolver -- can not get an error string this way. use Net::DNS; my @rr = rr("example.com"); my @rr = rr("example.com", "AAAA"); my @rr = rr("example.com", "AAAA", "IN"); # Use your own resolver object. my $res = Net::DNS::Resolver->new; my @rr = rr($res, "example.com" ... ); my ($ptr) = rr("2001:DB8::dead:beef"); The C method provides simple RR lookup for scenarios where the full flexibility of Net::DNS is not required. Returns a list of L objects for the specified name or an empty list if the query failed or no record was found. See L for more complete examples. =head2 mx # Use a default resolver -- can not get an error string this way. use Net::DNS; my @mx = mx("example.com"); # Use your own resolver object. 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 record was found. This method does not look up address records; it resolves MX only. =head1 Dynamic DNS Update Support The Net::DNS module provides auxiliary functions which support dynamic DNS update requests. $update = Net::DNS::Update->new( 'example.com' ); $update->push( prereq => nxrrset('example.com. AAAA') ); $update->push( update => rr_add('example.com. 86400 AAAA 2001::DB8::F00') ); =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 AAAA") ); Meaning: At least one RR with the specified name and type must exist. # RRset exists (value-dependent) $update->push( pre => yxrrset("host.example.com AAAA 2001:DB8::1") ); Meaning: At least one RR with the specified name and type must exist and must have matching data. Returns a L object or C if the object could not be created. =head2 nxrrset Use this method to add an "RRset does not exist" prerequisite to a dynamic update packet. $update->push( pre => nxrrset("host.example.com AAAA") ); Meaning: No RRs with the specified name and type can exist. Returns a L object or C if the object could not be created. =head2 yxdomain Use this method to add a "name is in use" prerequisite to a dynamic update packet. $update->push( pre => yxdomain("host.example.com") ); Meaning: At least one RR with the specified name must exist. Returns a L object or C if the object could not be created. =head2 nxdomain Use this method to add a "name is not in use" prerequisite to a dynamic update packet. $update->push( pre => nxdomain("host.example.com") ); Meaning: No RR with the specified name can exist. Returns a L object or C if the object could not be created. =head2 rr_add Use this method to add RRs to a zone. $update->push( update => rr_add("host.example.com AAAA 2001:DB8::c001:a1e") ); 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 L object or C if the object could not be created. =head2 rr_del Use this method to delete RRs from a zone. There are three forms: delete all RRsets, delete an RRset, and delete a specific RR. # Delete all RRsets. $update->push( update => rr_del("host.example.com") ); Meaning: Delete all RRs having the specified name. # Delete an RRset. $update->push( update => rr_del("host.example.com AAAA") ); Meaning: Delete all RRs having the specified name and type. # Delete a specific RR. $update->push( update => rr_del("host.example.com AAAA 2001:DB8::dead:beef") ); Meaning: Delete the RR which matches the specified argument. RR objects created by this method should be added to the "update" section of a dynamic update packet. Returns a L object or C if the object could not be created. =head1 Zone Serial Number Management The Net::DNS module provides auxiliary functions which support policy-driven zone serial numbering regimes. $soa->serial(SEQUENTIAL); $soa->serial(YYYMMDDxx); =head2 SEQUENTIAL $successor = $soa->serial( SEQUENTIAL ); The existing serial number is incremented modulo 2**32. =head2 UNIXTIME $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 YYYYMMDDxx $successor = $soa->serial( YYYYMMDDxx ); The 32 bit value returned by the auxiliary C 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. =head1 Sorting of RR arrays C provides functionality to help you sort RR arrays. In most cases this will give you the result that you expect, but you can specify your own sorting method by using the C<< Net::DNS::RR::FOO->set_rrsort_func() >> class method. See L for details. =head2 rrsort use Net::DNS; my @sorted = rrsort( $rrtype, $attribute, @rr_array ); C selects all RRs from the input array that are of the type defined by 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 defined in the code. For instance: my @prioritysorted = rrsort( "SRV", "priority", @rr_array ); returns the SRV records sorted from lowest to highest priority and for equal priorities from highest to lowest 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 is not defined then either the C function or "canonical sorting" (as defined by DNSSEC) will be used. C returns a sorted array containing only elements of the specified RR type. Any other RR types are silently discarded. C returns an empty list when arguments are incorrect. =head1 EXAMPLES The following brief examples illustrate some of the features of Net::DNS. The documentation for individual modules and the demo scripts included with the distribution provide more extensive examples. See L for an example of performing dynamic updates. =head2 Look up host addresses. use Net::DNS; my $res = Net::DNS::Resolver->new; my $reply = $res->search( "www.example.com", "AAAA" ); die "query failed: ", $res->errorstring unless $reply; foreach my $rr ( $reply->answer ) { print $rr->address, "\n" if $rr->can("address"); } =head2 Find the nameservers for a domain. use Net::DNS; my $res = Net::DNS::Resolver->new; my $reply = $res->query( "example.com", "NS"); die "query failed: ", $res->errorstring unless $reply; foreach $rr ( grep {$_->type eq "NS"} $reply->answer ) { print $rr->nsdname, "\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 ); foreach $rr (@mx) { print $rr->preference, "\t", $rr->exchange, "\n"; } =head2 Print domain SOA record in zone file format. use Net::DNS; my $res = Net::DNS::Resolver->new; my $reply = $res->query( "example.com", "SOA" ); die "query failed: ", $res->errorstring unless $reply; foreach my $rr ( $reply->answer ) { $rr->print; } =head2 Perform a zone transfer and print all the records. use Net::DNS; my $res = Net::DNS::Resolver->new( nameservers => ["a.iana-servers.net", "b.iana-servers.net"], tcp_timeout => 20 ); my @zone = $res->axfr("example.com"); warn $res->errorstring if $res->errorstring; foreach $rr (@zone) { $rr->print; } =head2 Perform a background query and print the reply. use Net::DNS; my $res = Net::DNS::Resolver->new; $res->udp_timeout(10); $res->tcp_timeout(20); my $socket = $res->bgsend( "www.example.com", "AAAA" ); while ( $res->bgbusy($socket) ) { # do some work here whilst awaiting the response # ...and some more here } my $packet = $res->bgread($socket); die "query failed: ", $res->errorstring unless $packet; $packet->print; =head1 BUGS Net::DNS 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-2000 Michael Fuhr. Portions Copyright (c)2002,2003 Chris Reinhardt. Portions Copyright (c)2005 Olaf Kolkman (RIPE NCC) Portions Copyright (c)2006 Olaf Kolkman (NLnet Labs) Portions Copyright (c)2014 Dick Franks All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 AUTHOR INFORMATION Net::DNS is maintained at NLnet Labs (www.nlnetlabs.nl) by Willem Toorop and Dick Franks. Between 2005 and 2012 Net::DNS was maintained by Olaf Kolkman. Between 2002 and 2004 Net::DNS was maintained by Chris Reinhardt. Net::DNS was created in 1997 by Michael Fuhr. =head1 SEE ALSO L L L L L L L =cut Net-DNS-1.50/lib/Net/DNS/0000755000175000017500000000000014756035527014111 5ustar willemwillemNet-DNS-1.50/lib/Net/DNS/RR.pm0000644000175000017500000005353414756035515015001 0ustar willemwillempackage Net::DNS::RR; use strict; use warnings; our $VERSION = (qw$Id: RR.pm 2003 2025-01-21 12:06:06Z willem $)[2]; =head1 NAME Net::DNS::RR - DNS resource record base class =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('example.com IN AAAA 2001:DB8::1'); $rr = Net::DNS::RR->new( owner => 'example.com', type => 'AAAA', address => '2001:DB8::1' ); =head1 DESCRIPTION Net::DNS::RR is the base class for DNS Resource Record (RR) objects. See also the manual pages for each specific RR type. =cut use integer; use Carp; use constant LIB => grep { $_ ne '.' } grep { !ref($_) } @INC; use Net::DNS::Parameters qw(%classbyname :class :type); use Net::DNS::DomainName; =head1 METHODS B Do not assume the RR objects you receive from a query are of a particular type. You must 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. =cut sub new { my ( $class, @list ) = @_; my $rr = eval { local $SIG{__DIE__}; scalar @list > 1 ? &_new_hash : &_new_string; }; return $rr if $rr; my @param = map { defined($_) ? split /\s+/ : 'undef' } @list; my $stmnt = substr "$class->new( @param )", 0, 80; croak "${@}in $stmnt\n"; } =head2 new (from string) $aaaa = Net::DNS::RR->new('host.example.com. 86400 AAAA 2001:DB8::1'); $mx = Net::DNS::RR->new('example.com. 7200 MX 10 mailhost.example.com.'); $cname = Net::DNS::RR->new('www.example.com 300 IN CNAME host.example.com'); $txt = Net::DNS::RR->new('txt.example.com 3600 HS TXT "text data"'); Returns an object of the appropriate RR type, or a L object if the type is not implemented. The attribute values are extracted from the string passed by the user. The syntax of the argument string follows the RFC1035 specification for zone files, and is compatible with the result returned by the string method. The owner and RR type are required; all other information is optional. Omitting the optional fields is useful for creating the empty RDATA sections required for certain dynamic update operations. See the L manual page for additional examples. All names are interpreted as fully qualified domain names. The trailing dot (.) is optional. =cut my $PARSE_REGEX = q/("[^"]*")|;[^\n]*|[ \t\n\r\f()]+/; # NB: *not* \s (matches Unicode white space) sub _new_string { my ( $base, $string ) = @_; die 'argument absent or undefined' unless defined $string; die 'non-scalar argument' if ref $string; # parse into quoted strings, contiguous non-whitespace and (discarded) comments local $_ = $string; s/\\\\/\\092/g; # disguise escaped escape s/\\"/\\034/g; # disguise escaped quote s/\\\(/\\040/g; # disguise escaped bracket s/\\\)/\\041/g; # disguise escaped bracket s/\\;/\\059/g; # disguise escaped semicolon my ( $owner, @token ) = grep { defined && length } split /$PARSE_REGEX/o; die 'unable to parse RR string' unless scalar @token; my $t1 = $token[0]; my $t2 = $token[1]; my ( $ttl, $class ); if ( not defined $t2 ) { # @token = ('ANY') if $classbyname{uc $t1}; # } elsif ( $t1 =~ /^\d/ ) { $ttl = shift @token; # [] $class = shift @token if $classbyname{uc $t2} || $t2 =~ /^CLASS\d/i; } elsif ( $classbyname{uc $t1} || $t1 =~ /^CLASS\d/i ) { $class = shift @token; # [] $ttl = shift @token if $t2 =~ /^\d/; } my $type = shift(@token); my $populated = scalar @token; my $self = $base->_subclass( $type, $populated ); # create RR object $self->owner($owner); &class( $self, $class ); # specify CLASS &ttl( $self, $ttl ); # specify TTL return $self unless $populated; # empty RR if ( $#token && $token[0] =~ /^[\\]?#$/ ) { shift @token; # RFC3597 hexadecimal format my $rdlen = shift(@token) || 0; my $rdata = pack 'H*', join( '', @token ); die 'length and hexadecimal data inconsistent' unless $rdlen == length $rdata; $self->rdata($rdata); # unpack RDATA } else { $self->_parse_rdata(@token); # parse arguments } $self->_post_parse(); return $self; } =head2 new (from hash) $rr = Net::DNS::RR->new(%hash); $rr = Net::DNS::RR->new( owner => 'host.example.com', ttl => 86400, class => 'IN', type => 'AAAA', address => '2001:DB8::1' ); $rr = Net::DNS::RR->new( owner => 'txt.example.com', type => 'TXT', txtdata => [ 'one', 'two' ] ); Returns an object of the appropriate RR type, or a L object if the type is not implemented. Consult the relevant manual pages for the usage of type specific attributes. The owner and RR type are required; all other information is optional. Omitting optional attributes is useful for creating the empty RDATA sections required for certain dynamic update operations. =cut my @core = qw(owner name type class ttl rdlength); sub _new_hash { my $base = shift; my %attribute = ( owner => '.', type => 'NULL' ); while ( my $key = shift ) { $attribute{lc $key} = shift; } my ( $owner, $name, $type, $class, $ttl ) = delete @attribute{@core}; my $self = $base->_subclass( $type, scalar(%attribute) ); $self->owner( $name ? $name : $owner ); $self->class($class) if defined $class; # optional CLASS $self->ttl($ttl) if defined $ttl; # optional TTL eval { while ( my ( $attribute, $value ) = each %attribute ) { $self->$attribute( ref($value) eq 'ARRAY' ? @$value : $value ); } }; die ref($self) eq __PACKAGE__ ? "type $type not implemented" : () if $@; $self->_post_parse(); return $self; } =head2 decode ( $rr, $next ) = Net::DNS::RR->decode( \$data, $offset, @opaque ); Decodes a DNS resource record at the specified location within a DNS packet. The argument list consists of a reference to the buffer containing the packet data and offset indicating where resource record begins. Any remaining arguments are passed as opaque data to subordinate decoders and do not form part of the published interface. Returns a C object and the offset of the next record in the packet. An exception is raised if the data buffer contains insufficient or corrupt data. =cut use constant RRFIXEDSZ => length pack 'n2 N n', (0) x 4; sub decode { my ( $base, @argument ) = @_; my ( $owner, $fixed ) = Net::DNS::DomainName1035->decode(@argument); my $index = $fixed + RRFIXEDSZ; my ( $data, $offset, @opaque ) = @argument; die 'corrupt wire-format data' if length $$data < $index; my $self = $base->_subclass( unpack "\@$fixed n", $$data ); $self->{owner} = $owner; @{$self}{qw(class ttl rdlength)} = unpack "\@$fixed x2 n N n", $$data; my $next = $index + $self->{rdlength}; die 'corrupt wire-format data' if length $$data < $next; if ( $next > $index or $self->type eq 'OPT' ) { local $self->{offset} = $offset; eval { $self->_decode_rdata( $data, $index, @opaque ) }; warn $@ if $@; } return wantarray ? ( $self, $next ) : $self; } =head2 encode $data = $rr->encode( $offset, @opaque ); Returns the C in binary format suitable for inclusion in a DNS packet buffer. The offset indicates the intended location within the packet data where the C is to be stored. Any remaining arguments are opaque data which are passed intact to subordinate encoders. =cut sub encode { my ( $self, $offset, @opaque ) = @_; ( $offset, @opaque ) = ( 0x4000, {} ) unless defined $offset; my $owner = $self->{owner}->encode( $offset, @opaque ); my ( $type, $class, $ttl ) = @{$self}{qw(type class ttl)}; my $rdata = $self->_empty ? '' : $self->_encode_rdata( $offset + length($owner) + RRFIXEDSZ, @opaque ); return pack 'a* n2 N n a*', $owner, $type, $class || 1, $ttl || 0, length $rdata, $rdata; } =head2 canonical $data = $rr->canonical; Returns the C in canonical binary format suitable for DNSSEC signature validation. The absence of the associative array argument signals to subordinate encoders that the canonical uncompressed form of embedded domain names is to be used. =cut sub canonical { my $self = shift; my $owner = $self->{owner}->canonical; my ( $type, $class, $ttl ) = @{$self}{qw(type class ttl)}; my $rdata = $self->_empty ? '' : $self->_encode_rdata( length($owner) + RRFIXEDSZ ); return pack 'a* n2 N n a*', $owner, $type, $class || 1, $ttl || 0, length $rdata, $rdata; } =head2 print $rr->print; Prints the resource record to the currently selected output filehandle. Calls the string method to get the formatted RR representation. =cut sub print { print shift->string, "\n"; return; } =head2 string print $rr->string, "\n"; Returns a string representation of the RR using the master file format mandated by RFC1035. All domain names are fully qualified with trailing dot. This differs from RR attribute methods, which omit the trailing dot. =cut sub string { my $self = shift; my $name = $self->{owner}->string; my @ttl = grep {defined} $self->{ttl}; my @core = ( $name, @ttl, $self->class, $self->type ); local $SIG{__DIE__}; my $empty = $self->_empty; my @rdata = $empty ? () : eval { $self->_format_rdata }; carp $@ if $@; my $tab = length($name) < 72 ? "\t" : ' '; my @line = _wrap( join( $tab, @core, '(' ), @rdata, ')' ); my $last = pop(@line); # last or only line $last = join $tab, @core, "@rdata" unless scalar(@line); $self->_annotation('no data') if $empty; return join "\n\t", @line, _wrap( $last, map {"; $_"} $self->_annotation ); } =head2 plain $plain = $rr->plain; Returns a simplified single-line representation of the RR. This facilitates interaction with programs like nsupdate which have rudimentary parsers. =cut sub plain { return join ' ', shift->token; } =head2 token @token = $rr->token; Returns a token list representation of the RR zone file string. =cut sub token { my $self = shift; my @ttl = grep {defined} $self->{ttl}; my @core = ( $self->{owner}->string, @ttl, $self->class, $self->type ); # parse into quoted strings, contiguous non-whitespace and (discarded) comments local $_ = $self->_empty ? '' : join( ' ', $self->_format_rdata ); s/\\\\/\\092/g; # disguise escaped escape s/\\"/\\034/g; # disguise escaped quote s/\\\(/\\040/g; # disguise escaped bracket s/\\\)/\\041/g; # disguise escaped bracket s/\\;/\\059/g; # disguise escaped semicolon return ( @core, grep { defined && length } split /$PARSE_REGEX/o ); } =head2 generic $generic = $rr->generic; Returns the generic RR representation defined in RFC3597. This facilitates creation of zone files containing RRs unrecognised by outdated nameservers and provisioning software. =cut sub generic { my $self = shift; my @ttl = grep {defined} $self->{ttl}; my @class = map {"CLASS$_"} grep {defined} $self->{class}; my @core = ( $self->{owner}->string, @ttl, @class, "TYPE$self->{type}" ); my $data = $self->rdata; my @data = ( '\\#', length($data), split /(\S{32})/, unpack 'H*', $data ); my @line = _wrap( "@core (", @data, ')' ); return join "\n\t", @line if scalar(@line) > 1; return join ' ', @core, @data; } =head2 owner name $name = $rr->owner; Returns the owner name of the record. =cut sub owner { my ( $self, @name ) = @_; for (@name) { $self->{owner} = Net::DNS::DomainName1035->new($_) } return defined wantarray ? $self->{owner}->name : undef; } sub name { return &owner; } ## historical =head2 type $type = $rr->type; Returns the record type. =cut sub type { my ( $self, @value ) = @_; for (@value) { croak 'not possible to change RR->type' } return typebyval( $self->{type} ); } =head2 class $class = $rr->class; Resource record class. =cut sub class { my ( $self, $class ) = @_; return $self->{class} = classbyname($class) if defined $class; return defined $self->{class} ? classbyval( $self->{class} ) : 'IN'; } =head2 ttl $ttl = $rr->ttl; $ttl = $rr->ttl(3600); Resource record time to live in seconds. =cut # The following time units are recognised, but are not part of the # published API. These are required for parsing BIND zone files but # should not be used in other contexts. my %unit = ( W => 604800, D => 86400, H => 3600, M => 60, S => 1 ); sub ttl { my ( $self, $time ) = @_; return $self->{ttl} || 0 unless defined $time; # avoid defining rr->{ttl} my $ttl = 0; my %time = reverse split /(\D)\D*/, $time . 'S'; while ( my ( $u, $t ) = each %time ) { my $scale = $unit{uc $u} || die qq(bad time: $t$u); $ttl += $t * $scale; } return $self->{ttl} = $ttl; } ################################################################################ ## ## Default implementation for unknown RR type ## ################################################################################ sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; return $self->{rdata} = substr $$data, $offset, $self->{rdlength}; } sub _encode_rdata { ## encode rdata as wire-format octet string return shift->{rdata}; } sub _format_rdata { ## format rdata portion of RR string my $rdata = shift->rdata; # RFC3597 unknown RR format return ( '\\#', length($rdata), split /(\S{32})/, unpack 'H*', $rdata ); } sub _parse_rdata { ## parse RR attributes in argument list my $self = shift; die join ' ', 'type', $self->type, 'not implemented' if ref($self) eq __PACKAGE__; die join ' ', 'no zone file representation defined for', $self->type; } sub _post_parse { } ## parser post processing sub _defaults { } ## set attribute default values sub dump { ## print internal data structure my @data = @_; # uncoverable pod require Data::Dumper; local $Data::Dumper::Maxdepth = $Data::Dumper::Maxdepth || 6; local $Data::Dumper::Sortkeys = $Data::Dumper::Sortkeys || 1; local $Data::Dumper::Useqq = $Data::Dumper::Useqq || 1; return print Data::Dumper::Dumper(@data); } sub rdatastr { ## historical RR subtype method my $self = shift; # uncoverable pod $self->_deprecate('prefer $rr->rdstring()'); return $self->rdstring; } =head2 rdata $rr = Net::DNS::RR->new( type => NULL, rdata => 'arbitrary' ); Resource record data section when viewed as opaque octets. =cut sub rdata { my $self = shift; return $self->_empty ? '' : eval { $self->_encode_rdata( 0x4000, {} ) } unless @_; my $data = shift || ''; $self->_decode_rdata( \$data, 0 ) if ( $self->{rdlength} = length $data ); return; } =head2 rdstring $rdstring = $rr->rdstring; Returns a string representation of the RR-specific data. =cut sub rdstring { my $self = shift; local $SIG{__DIE__}; my @rdata = $self->_empty ? () : eval { $self->_format_rdata }; carp $@ if $@; return join "\n\t", _wrap(@rdata); } =head2 rdlength $rdlength = $rr->rdlength; Returns the uncompressed length of the encoded RR-specific data. =cut sub rdlength { return length shift->rdata; } ################################################################################### =head1 Sorting of RR arrays Sorting of RR arrays is done by Net::DNS::rrsort(), see documentation for L. This package provides class methods to set the comparator function used for a particular RR based on its attributes. =head2 set_rrsort_func my $function = sub { ## numerically ascending order $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; }; Net::DNS::RR::MX->set_rrsort_func( 'preference', $function ); Net::DNS::RR::MX->set_rrsort_func( 'default_sort', $function ); set_rrsort_func() must be called as a class method. The first argument is the attribute name on which the sorting is to take place. If you specify "default_sort" then that is the sort algorithm that will be used when get_rrsort_func() is called without an RR attribute as argument. The second argument is a reference to a comparator function that uses the global variables $a and $b in the Net::DNS package. During sorting, the variables $a and $b will contain references to objects of the class whose set_rrsort_func() was called. The above sorting function will only be applied to Net::DNS::RR::MX objects. The above example is the sorting function implemented in MX. =cut our %rrsortfunct; sub set_rrsort_func { my $class = shift; my $attribute = shift; my $function = shift; my ($type) = $class =~ m/::([^:]+)$/; $rrsortfunct{$type}{$attribute} = $function; return; } =head2 get_rrsort_func $function = Net::DNS::RR::MX->get_rrsort_func('preference'); $function = Net::DNS::RR::MX->get_rrsort_func(); get_rrsort_func() returns a reference to the comparator function. =cut my $default = sub { return $Net::DNS::a->canonical() cmp $Net::DNS::b->canonical(); }; sub get_rrsort_func { my $class = shift; my $attribute = shift || 'default_sort'; my ($type) = $class =~ m/::([^:]+)$/; return $rrsortfunct{$type}{$attribute} || return $default; } ################################################################################ # # Net::DNS::RR->_subclass($rrname) # Net::DNS::RR->_subclass($rrname, $default) # # Create a new object blessed into appropriate RR subclass, after # loading the subclass module (if necessary). A subclass with no # corresponding module will be regarded as unknown and blessed # into the RR base class. # # The optional second argument indicates that default values are # to be copied into the newly created object. our %_MINIMAL = ( 255 => bless ['type' => 255], __PACKAGE__ ); our %_LOADED = %_MINIMAL; sub _subclass { my ( $class, $rrname, $default ) = @_; unless ( $_LOADED{$rrname} ) { my $rrtype = typebyname($rrname); unless ( $_LOADED{$rrtype} ) { # load once only local @INC = LIB; my $identifier = typebyval($rrtype); $identifier =~ s/\W/_/g; # kosher Perl identifier my $subclass = join '::', __PACKAGE__, $identifier; unless ( eval "require $subclass" ) { ## no critic ProhibitStringyEval my $perl = Net::DNS::Parameters::_typespec("$rrtype.RRTYPE"); $subclass = join '::', __PACKAGE__, "TYPE$rrtype"; push @INC, sub { # see perldoc -f require my @line = split /\n/, $perl; return ( sub { defined( $_ = shift @line ) } ); }; eval "require $subclass"; ## no critic ProhibitStringyEval } $subclass = __PACKAGE__ if $@; # cache pre-built minimal and populated default object images my @base = ( 'type' => $rrtype ); $_MINIMAL{$rrtype} = bless [@base], $subclass; my $object = bless {@base}, $subclass; $object->_defaults; $_LOADED{$rrtype} = bless [%$object], $subclass; } $_MINIMAL{$rrname} = $_MINIMAL{$rrtype}; $_LOADED{$rrname} = $_LOADED{$rrtype}; } my $prebuilt = $default ? $_LOADED{$rrname} : $_MINIMAL{$rrname}; return bless {@$prebuilt}, ref($prebuilt); # create object } sub _annotation { my ( $self, @note ) = @_; $self->{annotation} = ["@note"] if scalar @note; return wantarray ? @{$self->{annotation} || []} : (); } my %warned; sub _deprecate { my ( undef, @note ) = @_; carp "deprecated method; @note" unless $warned{"@note"}++; return; } my %ignore = map { ( $_ => 1 ) } @core, 'annotation', '#'; sub _empty { my $self = shift; return not( $self->{'#'} ||= scalar grep { !$ignore{$_} } keys %$self ); } sub _wrap { my @text = @_; my $cols = 80; my $coln = 0; my ( @line, @fill ); foreach (@text) { $coln += ( length || next ) + 1; if ( $coln > $cols ) { # start new line push( @line, join ' ', @fill ) if @fill; $coln = length; @fill = (); } $coln = $cols if chomp; # force line break push( @fill, $_ ) if length; } return ( @line, join ' ', @fill ); } ################################################################################ sub DESTROY { } ## Avoid tickling AUTOLOAD (in cleanup) ## no critic sub AUTOLOAD { ## Default method my ($self) = @_; no strict 'refs'; ## no critic ProhibitNoStrict our $AUTOLOAD; my ($method) = reverse split /::/, $AUTOLOAD; for ( my $action = $method ) { ## tolerate mixed-case attribute name tr [A-Z-] [a-z_]; if ( $self->can($action) ) { *{$AUTOLOAD} = sub { shift->$action(@_) }; return &$AUTOLOAD; } } my $oref = ref($self); *{$AUTOLOAD} = sub { }; ## suppress deep recursion croak qq[$self has no class method "$method"] unless $oref; my $string = $self->string; my @object = grep { defined($_) } $oref, $oref->VERSION; my $module = join '::', __PACKAGE__, $self->type; eval("require $module") if $oref eq __PACKAGE__; ## no critic ProhibitStringyEval @_ = ( <<"END" ); *** FATAL PROGRAM ERROR!! Unknown instance method "$method" *** which the program has attempted to call for the object: *** $string *** *** THIS IS A BUG IN THE CALLING SOFTWARE, which incorrectly assumes *** that the object would be of a particular type. The type of an *** object should be checked before calling any of its methods. *** @object $@ END goto &Carp::confess; } 1; __END__ =head1 COPYRIGHT Copyright (c)1997-2001 Michael Fuhr. Portions Copyright (c)2002,2003 Chris Reinhardt. Portions Copyright (c)2005-2007 Olaf Kolkman. Portions Copyright (c)2007,2012 Dick Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L L =cut Net-DNS-1.50/lib/Net/DNS/ZoneFile.pm0000644000175000017500000004137514756035515016171 0ustar willemwillempackage Net::DNS::ZoneFile; use strict; use warnings; our $VERSION = (qw$Id: ZoneFile.pm 2002 2025-01-07 09:57:46Z willem $)[2]; =head1 NAME Net::DNS::ZoneFile - DNS zone file =head1 SYNOPSIS use Net::DNS::ZoneFile; $zonefile = Net::DNS::ZoneFile->new( 'named.example' ); while ( $rr = $zonefile->read ) { $rr->print; } @zone = $zonefile->read; =head1 DESCRIPTION Each Net::DNS::ZoneFile object instance represents a zone file together with any subordinate files introduced by the $INCLUDE directive. Zone file syntax is defined by RFC1035. A program may have multiple zone file objects, each maintaining its own independent parser state information. The parser supports both the $TTL directive defined by RFC2308 and the BIND $GENERATE syntax extension. All RRs in a zone file must have the same class, which may be specified for the first RR encountered and is then propagated automatically to all subsequent records. =cut use integer; use Carp; use base qw(Exporter); our @EXPORT = qw(parse read readfh); use constant UTF8 => scalar eval { ## not UTF-EBCDIC [see Unicode TR#16 3.6] require Encode; Encode::encode_utf8( chr(182) ) eq pack( 'H*', 'C2B6' ); }; require IO::File; require PerlIO; require Net::DNS::Domain; require Net::DNS::RR; =head1 METHODS =head2 new $zonefile = Net::DNS::ZoneFile->new( 'filename', ['example.com'] ); $handle = IO::File->new( 'filename', '<:encoding(ISO8859-7)' ); $zonefile = Net::DNS::ZoneFile->new( $handle, ['example.com'] ); The new() constructor returns a Net::DNS::ZoneFile object which represents the zone file specified in the argument list. The specified file or file handle is open for reading and closed when exhausted or all references to the ZoneFile object cease to exist. The optional second argument specifies $ORIGIN for the zone file. Zone files are presumed to be UTF-8 encoded where that is supported. Alternative character encodings may be specified indirectly by creating a file handle with the desired encoding layer, which is then passed as an argument to new(). The specified encoding is propagated to files introduced by $INCLUDE directives. =cut sub new { my ( $class, $filename, $origin ) = @_; my $self = bless {fileopen => {}}, $class; $self->_origin($origin); if ( ref($filename) ) { $self->{filehandle} = $self->{filename} = $filename; return $self if ref($filename) =~ /IO::File|FileHandle|GLOB|Text/; croak 'argument not a file handle'; } croak 'filename argument undefined' unless $filename; my $discipline = UTF8 ? '<:encoding(UTF-8)' : '<'; $self->{filehandle} = IO::File->new( $filename, $discipline ) or croak "$filename: $!"; $self->{fileopen}->{$filename}++; $self->{filename} = $filename; return $self; } =head2 read $rr = $zonefile->read; @rr = $zonefile->read; When invoked in scalar context, read() returns a Net::DNS::RR object representing the next resource record encountered in the zone file, or undefined if end of data has been reached. When invoked in list context, read() returns the list of Net::DNS::RR objects in the order that they appear in the zone file. Comments and blank lines are silently disregarded. $INCLUDE, $ORIGIN, $TTL and $GENERATE directives are processed transparently. =cut sub read { my ($self) = @_; return &_read unless ref $self; # compatibility interface if (wantarray) { my @zone; # return entire zone eval { local $SIG{__DIE__}; while ( my $rr = $self->_getRR ) { push( @zone, $rr ); } }; croak join ' ', $@, ' file', $self->name, 'line', $self->line, "\n " if $@; return @zone; } my $rr = eval { local $SIG{__DIE__}; $self->_getRR; # return single RR }; croak join ' ', $@, ' file', $self->name, 'line', $self->line, "\n " if $@; return $rr; } =head2 name $filename = $zonefile->name; Returns the name of the current zone file. Embedded $INCLUDE directives will cause this to differ from the filename argument supplied when the object was created. =cut sub name { return shift->{filename}; } =head2 line $line = $zonefile->line; Returns the number of the last line read from the current zone file. =cut sub line { my $self = shift; return $self->{eom} if defined $self->{eom}; return $self->{filehandle}->input_line_number; } =head2 origin $origin = $zonefile->origin; Returns the fully qualified name of the current origin within the zone file. =cut sub origin { my $context = shift->{context}; return &$context( sub { Net::DNS::Domain->new('@') } )->string; } =head2 ttl $ttl = $zonefile->ttl; Returns the default TTL as specified by the $TTL directive. =cut sub ttl { return shift->{TTL}; } =head1 COMPATIBILITY WITH Net::DNS::ZoneFile 1.04 Applications which depended on the defunct Net::DNS::ZoneFile 1.04 CPAN distribution will continue to operate with minimal change using the compatibility interface described below. New application code should use the object-oriented interface. use Net::DNS::ZoneFile; $listref = Net::DNS::ZoneFile->read( $filename ); $listref = Net::DNS::ZoneFile->read( $filename, $include_dir ); $listref = Net::DNS::ZoneFile->readfh( $filehandle ); $listref = Net::DNS::ZoneFile->readfh( $filehandle, $include_dir ); $listref = Net::DNS::ZoneFile->parse( $string ); $listref = Net::DNS::ZoneFile->parse( $string, $include_dir ); $listref = Net::DNS::ZoneFile->parse( \$string ); $listref = Net::DNS::ZoneFile->parse( \$string, $include_dir ); $_->print for @$listref; The optional second argument specifies the default path for filenames. The current working directory is used by default. Although not available in the original implementation, the RR list can be obtained directly by calling any of these methods in list context. @rr = Net::DNS::ZoneFile->read( $filename, $include_dir ); The partial result is returned if an error is encountered by the parser. =head2 read $listref = Net::DNS::ZoneFile->read( $filename ); $listref = Net::DNS::ZoneFile->read( $filename, $include_dir ); read() parses the contents of the specified file and returns a reference to the list of Net::DNS::RR objects. The return value is undefined if an error is encountered by the parser. =cut our $include_dir; ## dynamically scoped sub _filename { ## rebase unqualified filename my $name = shift; return $name if ref($name); ## file handle return $name unless $include_dir; require File::Spec; return $name if File::Spec->file_name_is_absolute($name); return $name if -f $name; ## file in current directory return File::Spec->catfile( $include_dir, $name ); } sub _read { my ($arg1) = @_; shift if !ref($arg1) && $arg1 eq __PACKAGE__; my $filename = shift; local $include_dir = shift; my $zonefile = Net::DNS::ZoneFile->new( _filename($filename) ); my @zone; eval { local $SIG{__DIE__}; my $rr; push( @zone, $rr ) while $rr = $zonefile->_getRR; }; return wantarray ? @zone : \@zone unless $@; carp $@; return wantarray ? @zone : undef; } { package Net::DNS::ZoneFile::Text; ## no critic ProhibitMultiplePackages use overload ( '<>' => 'readline' ); sub new { my ( $class, $data ) = @_; my $self = bless {}, $class; $self->{data} = [split /\n/, ref($data) ? $$data : $data]; return $self; } sub readline { my $self = shift; $self->{line}++; return shift( @{$self->{data}} ); } sub close { shift->{data} = []; return 1; } sub input_line_number { return shift->{line}; } } =head2 readfh $listref = Net::DNS::ZoneFile->readfh( $filehandle ); $listref = Net::DNS::ZoneFile->readfh( $filehandle, $include_dir ); readfh() parses data from the specified file handle and returns a reference to the list of Net::DNS::RR objects. The return value is undefined if an error is encountered by the parser. =cut sub readfh { return &_read; } =head2 parse $listref = Net::DNS::ZoneFile->parse( $string ); $listref = Net::DNS::ZoneFile->parse( $string, $include_dir ); $listref = Net::DNS::ZoneFile->parse( \$string ); $listref = Net::DNS::ZoneFile->parse( \$string, $include_dir ); parse() interprets the text in the argument string and returns a reference to the list of Net::DNS::RR objects. The return value is undefined if an error is encountered by the parser. =cut sub parse { my ($arg1) = @_; shift if $arg1 eq __PACKAGE__; my $string = shift; my @include = grep {defined} shift; return &readfh( Net::DNS::ZoneFile::Text->new($string), @include ); } ######################################## { package Net::DNS::ZoneFile::Generator; ## no critic ProhibitMultiplePackages use overload ( '<>' => 'readline' ); sub new { my ( $class, $range, $template, $line ) = @_; my $self = bless {}, $class; my ( $bound, $step ) = split m#[/]#, $range; # initial iterator state my ( $first, $last ) = split m#[-]#, $bound; $first ||= 0; $last ||= $first; $step ||= 1; # coerce step to match range $step = ( $last < $first ) ? -abs($step) : abs($step); $self->{count} = int( ( $last - $first ) / $step ) + 1; for ($template) { s/\\\$/\\036/g; # disguise escaped dollar s/\$\$/\\036/g; # disguise escaped dollar s/^"(.*)"$/$1/s; # unwrap BIND's quoted template @{$self}{qw(instant step template line)} = ( $first, $step, $_, $line ); } return $self; } sub readline { my $self = shift; return unless $self->{count}-- > 0; # EOF my $instant = $self->{instant}; # update iterator state $self->{instant} += $self->{step}; local $_ = $self->{template}; # copy template while (/\$\{(.*)\}/) { # interpolate ${...} my $s = _format( $instant, split /\,/, $1 ); s/\$\{$1\}/$s/eg; } s/\$/$instant/eg; # interpolate $ s/\\036/\$/g; # reinstate escaped $ return $_; } sub close { shift->{count} = 0; # suppress iterator return 1; } sub input_line_number { return shift->{line}; # fixed: identifies $GENERATE } sub _format { ## convert $GENERATE iteration number to specified format my $number = shift; # per ISC BIND 9.7 my $offset = shift || 0; my $length = shift || 0; my $format = shift || 'd'; my $value = $number + $offset; my $digit = $length || 1; return substr sprintf( "%01.$digit$format", $value ), -$length if $format =~ /[doxX]/; my $nibble = join( '.', split //, sprintf ".%32.32lx", $value ); return reverse lc( substr $nibble, -$length ) if $format =~ /[n]/; return reverse uc( substr $nibble, -$length ) if $format =~ /[N]/; die "unknown $format format"; } } sub _generate { ## expand $GENERATE into input stream my ( $self, $range, $template ) = @_; my $handle = Net::DNS::ZoneFile::Generator->new( $range, $template, $self->line ); $self->{parent} = bless {%$self}, ref($self); # save state, create link delete $self->{latest}; # forget current domain name return $self->{filehandle} = $handle; } my $LEX_REGEX = q/("[^"]*"|"[^"]*$)|;[^\n]*|([()])|[ \t\n\r\f]+/; sub _getline { ## get line from current source my $self = shift; my $fh = $self->{filehandle}; while (<$fh>) { next if /^\s*;/; # discard comment line next unless /\S/; # discard blank line if (/["(]/) { s/\\\\/\\092/g; # disguise escaped escape s/\\"/\\034/g; # disguise escaped quote s/\\\(/\\040/g; # disguise escaped bracket s/\\\)/\\041/g; # disguise escaped bracket s/\\;/\\059/g; # disguise escaped semicolon my @token = grep { defined && length } split /(^\s)|$LEX_REGEX/o; while ( $token[-1] =~ /^"[^"]*$/ ) { # multiline quoted string $_ = pop(@token) . <$fh>; # reparse fragments s/\\\\/\\092/g; # disguise escaped escape s/\\"/\\034/g; # disguise escaped quote s/\\\(/\\040/g; # disguise escaped bracket s/\\\)/\\041/g; # disguise escaped bracket s/\\;/\\059/g; # disguise escaped semicolon push @token, grep { defined && length } split /$LEX_REGEX/o; $_ = join ' ', @token; # reconstitute RR string } if ( grep { $_ eq '(' } @token ) { # concatenate multiline RR until ( grep { $_ eq ')' } @token ) { $_ = pop(@token) . <$fh>; s/\\\\/\\092/g; # disguise escaped escape s/\\"/\\034/g; # disguise escaped quote s/\\\(/\\040/g; # disguise escaped bracket s/\\\)/\\041/g; # disguise escaped bracket s/\\;/\\059/g; # disguise escaped semicolon push @token, grep { defined && length } split /$LEX_REGEX/o; chomp $token[-1] unless $token[-1] =~ /^"[^"]*$/; } $_ = join ' ', @token; # reconstitute RR string } } return $_ unless /^[\$]/; # RR string my @token = grep { defined && length } split /$LEX_REGEX/o; if (/^\$INCLUDE/) { # directive my ( $keyword, @argument ) = @token; die '$INCLUDE incomplete' unless @argument; $fh = $self->_include(@argument); } elsif (/^\$GENERATE/) { # directive my ( $keyword, $range, @template ) = @token; die '$GENERATE incomplete' unless @template; $fh = $self->_generate( $range, "@template" ); } elsif (/^\$ORIGIN/) { # directive my ( $keyword, $origin ) = @token; die '$ORIGIN incomplete' unless defined $origin; $self->_origin($origin); } elsif (/^\$TTL/) { # directive my ( $keyword, $ttl ) = @token; die '$TTL incomplete' unless defined $ttl; $self->{TTL} = Net::DNS::RR::ttl( {}, $ttl ); } else { # unrecognised my ($keyword) = @token; die qq[unknown "$keyword" directive]; } } $self->{eom} = $self->line; # end of file $fh->close(); my $link = $self->{parent} || return; # end of zone %$self = %$link; # end $INCLUDE return $self->_getline; # resume input } sub _getRR { ## get RR from current source my $self = shift; local $_; $self->_getline || return; # line already in $_ my $noname = s/^\s/\@\t/; # placeholder for empty RR name # construct RR object with context specific dynamically scoped $ORIGIN my $context = $self->{context}; my $rr = &$context( sub { Net::DNS::RR->_new_string($_) } ); my $latest = $self->{latest}; # overwrite placeholder $rr->{owner} = $latest->{owner} if $noname && $latest; $self->{class} = $rr->class unless $self->{class}; # propagate RR class $rr->class( $self->{class} ); unless ( defined $self->{TTL} ) { $self->{TTL} = $rr->minimum if $rr->type eq 'SOA'; # default TTL } $rr->{ttl} = $self->{TTL} unless defined $rr->{ttl}; return $self->{latest} = $rr; } sub _include { ## open $INCLUDE file my ( $self, $include, $origin ) = @_; my $filename = _filename($include); die qq(\$INCLUDE $filename: Unexpected recursion) if $self->{fileopen}->{$filename}++; my $discipline = join( ':', '<', PerlIO::get_layers $self->{filehandle} ); my $filehandle = IO::File->new( $filename, $discipline ) or die qq(\$INCLUDE $filename: $!); $self->{parent} = bless {%$self}, ref($self); # save state, create link delete $self->{latest}; # forget current domain name $self->_origin($origin) if $origin; $self->{filename} = $filename; return $self->{filehandle} = $filehandle; } sub _origin { ## change $ORIGIN (scope: current file) my ( $self, $name ) = @_; my $context = $self->{context}; $context = Net::DNS::Domain->origin(undef) unless $context; $self->{context} = &$context( sub { Net::DNS::Domain->origin($name) } ); delete $self->{latest}; # forget previous owner return; } 1; __END__ =head1 ACKNOWLEDGEMENTS This package is designed as an improved and compatible replacement for Net::DNS::ZoneFile 1.04 which was created by Luis Munoz in 2002 as a separate CPAN module. The present implementation is the result of an agreement to merge our two different approaches into one package integrated into Net::DNS. The contribution of Luis Munoz is gratefully acknowledged. Thanks are also due to Willem Toorop for his constructive criticism of the initial version and invaluable assistance during testing. =head1 COPYRIGHT Copyright (c)2011-2012 Dick Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L =cut Net-DNS-1.50/lib/Net/DNS/Header.pm0000644000175000017500000002443514756035515015644 0ustar willemwillempackage Net::DNS::Header; use strict; use warnings; our $VERSION = (qw$Id: Header.pm 2002 2025-01-07 09:57:46Z willem $)[2]; =head1 NAME Net::DNS::Header - DNS packet header =head1 SYNOPSIS use Net::DNS; $packet = Net::DNS::Packet->new(); $header = $packet->header; =head1 DESCRIPTION C represents the header portion of a DNS packet. =cut use integer; use Carp; use Net::DNS::Parameters qw(:opcode :rcode); =head1 METHODS =head2 $packet->header $packet = Net::DNS::Packet->new(); $header = $packet->header; Net::DNS::Header objects emanate from the Net::DNS::Packet header() method, and contain an opaque reference to the parent Packet object. Header objects may be assigned to suitably scoped lexical variables. They should never be stored in global variables or persistent data structures. =head2 string print $packet->header->string; Returns a string representation of the packet header. =cut sub string { my $self = shift; my $id = $self->id; my $qr = $self->qr; my $opcode = $self->opcode; my $rcode = $self->rcode; my $qd = $self->qdcount; my $an = $self->ancount; my $ns = $self->nscount; my $ar = $self->arcount; my $dispid = defined $id ? $id : 'undef'; return <<"QQ" if $opcode eq 'DSO'; ;; id = $dispid qr = $qr ;; opcode = $opcode rcode = $rcode QQ return <<"QQ" if $opcode eq 'UPDATE'; ;; id = $dispid qr = $qr ;; opcode = $opcode rcode = $rcode ;; zocount = $qd prcount = $an ;; upcount = $ns adcount = $ar QQ my $aa = $self->aa; my $tc = $self->tc; my $rd = $self->rd; my $ra = $self->ra; my $zz = $self->z; my $ad = $self->ad; my $cd = $self->cd; my $do = $self->do; my $co = $self->co; return <<"QQ"; ;; id = $dispid ;; qr = $qr aa = $aa tc = $tc rd = $rd opcode = $opcode ;; ra = $ra z = $zz ad = $ad cd = $cd rcode = $rcode ;; do = $do co = $co ;; qdcount = $qd ancount = $an ;; nscount = $ns arcount = $ar QQ } =head2 print $packet->header->print; Prints the string representation of the packet header. =cut sub print { print &string; return; } =head2 id print "query id = ", $packet->header->id, "\n"; $packet->header->id(1234); Gets or sets the query identification number. =cut sub id { my ( $self, @value ) = @_; for (@value) { $$self->{id} = $_ } return $$self->{id}; } =head2 opcode print "query opcode = ", $packet->header->opcode, "\n"; $packet->header->opcode("UPDATE"); Gets or sets the query opcode (the purpose of the query). =cut sub opcode { my ( $self, $arg ) = @_; my $opcode; for ( $$self->{status} ) { return opcodebyval( ( $_ >> 11 ) & 0x0f ) unless defined $arg; $opcode = opcodebyname($arg); $_ = ( $_ & 0x87ff ) | ( $opcode << 11 ); } return $opcode; } =head2 rcode print "query response code = ", $packet->header->rcode, "\n"; $packet->header->rcode("SERVFAIL"); Gets or sets the query response code (the status of the query). =cut sub rcode { my ( $self, $arg ) = @_; my $rcode; for ( $$self->{status} ) { my $opt = $$self->edns; unless ( defined $arg ) { $rcode = ( $opt->rcode & 0xff0 ) | ( $_ & 0x00f ); $opt->rcode($rcode); # write back full 12-bit rcode return $rcode == 16 ? 'BADVERS' : rcodebyval($rcode); } $rcode = rcodebyname($arg); $opt->rcode($rcode); # full 12-bit rcode $_ &= 0xfff0; # low 4-bit rcode $_ |= ( $rcode & 0x000f ); } return $rcode; } =head2 qr print "query response flag = ", $packet->header->qr, "\n"; $packet->header->qr(0); Gets or sets the query response flag. =cut sub qr { my ( $self, @value ) = @_; return $self->_dnsflag( 0x8000, @value ); } =head2 aa print "response is ", $packet->header->aa ? "" : "non-", "authoritative\n"; $packet->header->aa(0); Gets or sets the authoritative answer flag. =cut sub aa { my ( $self, @value ) = @_; return $self->_dnsflag( 0x0400, @value ); } =head2 tc print "packet is ", $packet->header->tc ? "" : "not ", "truncated\n"; $packet->header->tc(0); Gets or sets the truncated packet flag. =cut sub tc { my ( $self, @value ) = @_; return $self->_dnsflag( 0x0200, @value ); } =head2 rd print "recursion was ", $packet->header->rd ? "" : "not ", "desired\n"; $packet->header->rd(0); Gets or sets the recursion desired flag. =cut sub rd { my ( $self, @value ) = @_; return $self->_dnsflag( 0x0100, @value ); } =head2 ra print "recursion is ", $packet->header->ra ? "" : "not ", "available\n"; $packet->header->ra(0); Gets or sets the recursion available flag. =cut sub ra { my ( $self, @value ) = @_; return $self->_dnsflag( 0x0080, @value ); } =head2 z Unassigned bit, should always be zero. =cut sub z { my ( $self, @value ) = @_; return $self->_dnsflag( 0x0040, @value ); } =head2 ad print "The response has ", $packet->header->ad ? "" : "not", "been verified\n"; Relevant in DNSSEC context. (The AD bit is only set on a response where signatures have been cryptographically verified or the server is authoritative for the data and is allowed to set the bit by policy.) =cut sub ad { my ( $self, @value ) = @_; return $self->_dnsflag( 0x0020, @value ); } =head2 cd print "checking was ", $packet->header->cd ? "not" : "", "desired\n"; $packet->header->cd(0); Gets or sets the checking disabled flag. =cut sub cd { my ( $self, @value ) = @_; return $self->_dnsflag( 0x0010, @value ); } =head2 qdcount, zocount print "# of question records: ", $packet->header->qdcount, "\n"; Returns 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. =cut sub qdcount { my ( $self, @value ) = @_; for (@value) { $self->_warn('packet->header->qdcount is read-only') } return $$self->{count}[0] || scalar @{$$self->{question}}; } =head2 ancount, prcount print "# of answer records: ", $packet->header->ancount, "\n"; Returns the number of records in the answer section of the packet which may, in the case of corrupt packets, differ from the actual number of records. In dynamic update packets, this field is known as C and refers to the number of RRs in the prerequisite section. =cut sub ancount { my ( $self, @value ) = @_; for (@value) { $self->_warn('packet->header->ancount is read-only') } return $$self->{count}[1] || scalar @{$$self->{answer}}; } =head2 nscount, upcount print "# of authority records: ", $packet->header->nscount, "\n"; Returns the number of records in the authority section of the packet which may, in the case of corrupt packets, differ from the actual number of records. In dynamic update packets, this field is known as C and refers to the number of RRs in the update section. =cut sub nscount { my ( $self, @value ) = @_; for (@value) { $self->_warn('packet->header->nscount is read-only') } return $$self->{count}[2] || scalar @{$$self->{authority}}; } =head2 arcount, adcount print "# of additional records: ", $packet->header->arcount, "\n"; Returns the number of records in the additional section of the packet which may, in the case of corrupt packets, differ from the actual number of records. In dynamic update packets, this field is known as C. =cut sub arcount { my ( $self, @value ) = @_; for (@value) { $self->_warn('packet->header->arcount is read-only') } return $$self->{count}[3] || scalar @{$$self->{additional}}; } sub zocount { return &qdcount; } sub prcount { return &ancount; } sub upcount { return &nscount; } sub adcount { return &arcount; } =head1 EDNS Protocol Extensions =head2 do, co print "DNSSEC_OK flag was ", $packet->header->do ? "not" : "", "set\n"; $packet->header->do(1); Gets or sets the named EDNS flag. =cut sub do { my ( $self, @value ) = @_; return $self->_ednsflag( 0x8000, @value ); } sub co { my ( $self, @value ) = @_; return $self->_ednsflag( 0x4000, @value ); } =head2 Extended rcode EDNS extended rcodes are handled transparently by $packet->header->rcode(). =head2 UDP packet size $udp_max = $packet->edns->UDPsize; EDNS offers a mechanism to advertise the maximum UDP packet size which can be assembled by the local network stack. =cut sub size { ## historical my ( $self, @value ) = @_; return $$self->edns->UDPsize(@value); } =head2 edns $header = $packet->header; $version = $header->edns->version; @options = $header->edns->options; $option = $header->edns->option(n); $udp_max = $packet->edns->UDPsize; Auxiliary function which provides access to the EDNS protocol extension OPT RR. =cut sub edns { my $self = shift; return $$self->edns; } ######################################## sub _dnsflag { my ( $self, $flag, @value ) = @_; for ( $$self->{status} ) { my $set = $_ | $flag; $_ = ( shift @value ) ? $set : ( $set ^ $flag ) if @value; $flag &= $_; } return $flag ? 1 : 0; } sub _ednsflag { my ( $self, $flag, @value ) = @_; my $edns = $$self->edns; for ( $edns->flags ) { my $set = $_ | $flag; $edns->flags( $_ = ( shift @value ) ? $set : ( $set ^ $flag ) ) if @value; $flag &= $_; } return $flag ? 1 : 0; } my %warned; sub _warn { my ( undef, @note ) = @_; return carp "usage; @note" unless $warned{"@note"}++; } 1; __END__ ######################################## =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. Portions Copyright (c)2002,2003 Chris Reinhardt. Portions Copyright (c)2012,2022 Dick Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut Net-DNS-1.50/lib/Net/DNS/Resolver/0000755000175000017500000000000014756035527015712 5ustar willemwillemNet-DNS-1.50/lib/Net/DNS/Resolver/Base.pm0000644000175000017500000007710514756035515017131 0ustar willemwillempackage Net::DNS::Resolver::Base; use strict; use warnings; our $VERSION = (qw$Id: Base.pm 2011 2025-02-11 15:18:03Z willem $)[2]; # # Implementation notes wrt IPv6 support when using perl before 5.20.0. # # In general we try to be gracious to those stacks that do not have IPv6 support. # The socket code is conditionally compiled depending upon the availability of # the IO::Socket::IP package. # # We have chosen not to use mapped IPv4 addresses, there seem to be issues # with this; as a result we use separate sockets for each family type. # # inet_pton is not available on WIN32, so we only use the getaddrinfo # call to translate IP addresses to socketaddress. # # The configuration options force_v4, force_v6, prefer_v4 and prefer_v6 # are provided to control IPv6 behaviour for test purposes. # # Olaf Kolkman, RIPE NCC, December 2003. # [Revised March 2016, June 2018] use constant OS_SPEC => "Net::DNS::Resolver::$^O"; use constant OS_UNIX => "Net::DNS::Resolver::UNIX"; use constant OS_CONF => grep eval "require $_", OS_SPEC, OS_UNIX; ## no critic use base (OS_CONF)[0]; use constant USE_SOCKET_IP => defined eval 'use IO::Socket::IP 0.38; 1;'; ## no critic require IO::Socket::INET unless USE_SOCKET_IP; use constant IPv6 => USE_SOCKET_IP; # If SOCKSified Perl, use TCP instead of UDP and keep the socket open. use constant SOCKS => scalar eval { require Config; $Config::Config{usesocks}; }; # Allow taint tests to be optimised away when appropriate. use constant TAINT => eval { ${^TAINT} }; use constant TESTS => TAINT && defined eval { require Scalar::Util; }; use integer; use Carp; use IO::File; use IO::Select; use IO::Socket; use Socket; { no strict 'subs'; ## no critic ProhibitNoStrict use constant AI_NUMERICHOST => Socket::AI_NUMERICHOST; use constant IPPROTO_UDP => Socket::IPPROTO_UDP; } use Net::DNS::RR; use Net::DNS::Packet; use constant PACKETSZ => 512; # # Set up a closure to be our class data. # { my $defaults = bless { nameservers => [qw(::1 127.0.0.1)], nameserver4 => ['127.0.0.1'], nameserver6 => ['::1'], port => 53, srcaddr4 => '0.0.0.0', srcaddr6 => '::', srcport => 0, searchlist => [], retrans => 5, retry => 4, usevc => ( SOCKS ? 1 : 0 ), igntc => 0, recurse => 1, defnames => 1, dnsrch => 1, ndots => 1, debug => 0, tcp_timeout => 120, udp_timeout => 30, persistent_tcp => ( SOCKS ? 1 : 0 ), persistent_udp => 0, dnssec => 0, adflag => 0, # see RFC6840, 5.7 cdflag => 0, # see RFC6840, 5.9 udppacketsize => 0, # value bounded below by PACKETSZ force_v4 => 0, force_v6 => 0, prefer_v4 => 0, prefer_v6 => 0, }, __PACKAGE__; sub _defaults { return $defaults; } } my %warned; sub _deprecate { my ( undef, @note ) = @_; carp join ' ', 'deprecated method;', "@note" unless $warned{"@note"}++; return; } sub _untaint { ## no critic # recurses into user list arguments return TAINT ? map { ref($_) ? [_untaint(@$_)] : do { /^(.*)$/; $1 } } @_ : @_; } # These are the attributes that the user may specify in the new() constructor. my %public_attr = ( map { $_ => $_ } keys %{&_defaults}, qw(domain nameserver srcaddr), map { $_ => 0 } qw(nameserver4 nameserver6 srcaddr4 srcaddr6), ); my $initial; sub new { my ( $class, %args ) = @_; my $self; my $base = $class->_defaults; my $init = $initial; $initial ||= [%$base]; if ( my $file = $args{config_file} ) { my $conf = bless {@$initial}, $class; $conf->_read_config_file($file); # user specified config $self = bless {_untaint(%$conf)}, $class; %$base = %$self unless $init; # define default configuration } elsif ($init) { $self = bless {%$base}, $class; } else { $class->_init(); # define default configuration $self = bless {%$base}, $class; } while ( my ( $attr, $value ) = each %args ) { next unless $public_attr{$attr}; my $ref = ref($value); croak "usage: $class->new( $attr => [...] )" if $ref && ( $ref ne 'ARRAY' ); $self->$attr( $ref ? @$value : $value ); } return $self; } my %resolv_conf = ( ## map traditional resolv.conf option names attempts => 'retry', inet6 => 'prefer_v6', timeout => 'retrans', ); my %res_option = ( ## any resolver attribute plus those listed above %public_attr, %resolv_conf, ); sub _option { my ( $self, $name, @value ) = @_; my $attribute = $res_option{lc $name} || return; push @value, 1 unless scalar @value; return $self->$attribute(@value); } sub _read_env { ## read resolver config environment variables my $self = shift; $self->searchlist( map {split} $ENV{LOCALDOMAIN} ) if defined $ENV{LOCALDOMAIN}; $self->nameservers( map {split} $ENV{RES_NAMESERVERS} ) if defined $ENV{RES_NAMESERVERS}; $self->searchlist( map {split} $ENV{RES_SEARCHLIST} ) if defined $ENV{RES_SEARCHLIST}; foreach ( map {split} $ENV{RES_OPTIONS} || '' ) { $self->_option( split m/:/ ); } return; } sub _read_config_file { ## read resolver config file my ( $self, $file ) = @_; my $filehandle = IO::File->new( $file, '<' ) or croak "$file: $!"; my @nameserver; my @searchlist; local $_; while (<$filehandle>) { s/[;#].*$//; # strip comments /^nameserver/ && do { my ( $keyword, @ip ) = grep {defined} split; push @nameserver, @ip; next; }; /^domain/ && do { my ( $keyword, $domain ) = grep {defined} split; $self->domain($domain); next; }; /^search/ && do { my ( $keyword, @domain ) = grep {defined} split; push @searchlist, @domain; next; }; /^option/ && do { my ( $keyword, @option ) = grep {defined} split; foreach (@option) { $self->_option( split m/:/ ); } }; } close($filehandle); $self->nameservers(@nameserver) if @nameserver; $self->searchlist(@searchlist) if @searchlist; return; } sub string { my $self = shift; $self = $self->_defaults unless ref($self); my @nslist = $self->nameservers(); my ($force) = ( grep( { $self->{$_} } qw(force_v6 force_v4) ), 'force_v4' ); my ($prefer) = ( grep( { $self->{$_} } qw(prefer_v6 prefer_v4) ), 'prefer_v4' ); return <{searchlist}} ;; defnames = $self->{defnames} dnsrch = $self->{dnsrch} ;; igntc = $self->{igntc} usevc = $self->{usevc} ;; recurse = $self->{recurse} port = $self->{port} ;; retrans = $self->{retrans} retry = $self->{retry} ;; tcp_timeout = $self->{tcp_timeout} persistent_tcp = $self->{persistent_tcp} ;; udp_timeout = $self->{udp_timeout} persistent_udp = $self->{persistent_udp} ;; ${prefer} = $self->{$prefer} ${force} = $self->{$force} ;; debug = $self->{debug} ndots = $self->{ndots} END } sub print { return print shift->string; } sub searchlist { my ( $self, @domain ) = @_; $self = $self->_defaults unless ref($self); foreach (@domain) { $_ = Net::DNS::Domain->new($_)->name } $self->{searchlist} = \@domain if scalar(@domain); return @{$self->{searchlist}}; } sub domain { return (&searchlist)[0]; } sub nameservers { my ( $self, @ns ) = @_; $self = $self->_defaults unless ref($self); my @ip; foreach my $ns ( grep {defined} @ns ) { if ( _ipv4($ns) || _ipv6($ns) ) { push @ip, $ns; } else { my $defres = ref($self)->new( debug => $self->{debug} ); $defres->{persistent} = $self->{persistent}; my $names = {}; my $packet = $defres->send( $ns, 'A' ); my @iplist = _cname_addr( $packet, $names ); if (IPv6) { $packet = $defres->send( $ns, 'AAAA' ); push @iplist, _cname_addr( $packet, $names ); } my %unique = map { $_ => $_ } @iplist; my @address = values(%unique); # tainted carp "unresolvable name: $ns" unless scalar @address; push @ip, @address; } } if ( scalar(@ns) || !defined(wantarray) ) { my @ipv4 = grep { _ipv4($_) } @ip; my @ipv6 = grep { _ipv6($_) } @ip; my @map4 = map {"::FFFF:$_"} @ipv4; $self->{nameservers} = \@ip; $self->{nameserver4} = \@ipv4; $self->{nameserver6} = \@ipv6; $self->{mapped_IPv4} = \@map4; } my @IPv4 = @{$self->{nameserver4}}; my @IPv6 = IPv6 ? @{$self->{nameserver6}} : (); my @IPlist = @IPv6 ? @{$self->{nameservers}} : @IPv4; @IPlist = ( @IPv6, @IPv4 ) if $self->{prefer_v6}; @IPlist = ( @IPv4, @IPv6 ) if $self->{prefer_v4}; @IPlist = @IPv6 if $self->{force_v6}; @IPlist = @IPv4 if $self->{force_v4}; $self->errorstring('no nameservers') unless @IPlist; return @IPlist; } sub nameserver { return &nameservers; } sub _cname_addr { # TODO 20081217 # This code does not follow CNAME chains, it only looks inside the packet. # Out of bailiwick will fail. my @null; my $packet = shift || return @null; my $names = shift; $names->{lc( $_->qname )}++ foreach $packet->question; $names->{lc( $_->cname )}++ foreach grep { $_->can('cname') } $packet->answer; my @addr = grep { $_->can('address') } $packet->answer; return map { $_->address } grep { $names->{lc( $_->name )} } @addr; } sub replyfrom { return shift->{replyfrom}; } sub answerfrom { return &replyfrom; } # uncoverable pod sub _reset_errorstring { shift->{errorstring} = ''; return; } sub errorstring { my ( $self, $text ) = @_; $self->_diag( 'errorstring:', $self->{errorstring} = $text ) if $text; return $self->{errorstring}; } sub query { my ( $self, @argument ) = @_; my $name = shift(@argument) || '.'; my @sfix = $self->{defnames} && ( $name !~ m/[.:]/ ) ? $self->domain : (); my $fqdn = join '.', $name, @sfix; $self->_diag( 'query(', $fqdn, @argument, ')' ); my $packet = $self->send( $fqdn, @argument ) || return; return $packet->header->ancount ? $packet : undef; } sub search { my ( $self, @argument ) = @_; return $self->query(@argument) unless $self->{dnsrch}; my $name = shift(@argument) || '.'; my $dots = $name =~ tr/././; my @sfix = ( $dots < $self->{ndots} ) ? @{$self->{searchlist}} : (); my ( $one, @more ) = ( $name =~ m/:|\.\d*$/ ) ? () : ( $dots ? ( undef, @sfix ) : @sfix ); foreach my $suffix ( $one, @more ) { my $fqname = $suffix ? join( '.', $name, $suffix ) : $name; $self->_diag( 'search(', $fqname, @argument, ')' ); my $packet = $self->send( $fqname, @argument ) || next; return $packet if $packet->header->ancount; } return; } sub send { my ( $self, @argument ) = @_; my $packet = $self->_make_query_packet(@argument); my $packet_data = $packet->encode; $self->_reset_errorstring; return $self->_send_tcp( $packet, $packet_data ) if $self->{usevc} || length $packet_data > $self->_packetsz; my $reply = $self->_send_udp( $packet, $packet_data ) || return; return $reply if $self->{igntc}; return $reply unless $reply->header->tc; $self->_diag('packet truncated: retrying using TCP'); return $self->_send_tcp( $packet, $packet_data ); } sub _send_tcp { my ( $self, $query, $query_data ) = @_; my $tcp_packet = pack 'n a*', length($query_data), $query_data; my @ns = $self->nameservers(); my $fallback; my $timeout = $self->{tcp_timeout}; foreach my $ip (@ns) { $self->_diag( 'tcp send', "[$ip]" ); my $connection = $self->_create_tcp_socket($ip); $self->errorstring($!); my $select = IO::Select->new( $connection || next ); $connection->send($tcp_packet); $self->errorstring($!); my @ready = $select->can_read($timeout); next unless @ready; # uncoverable branch true my $socket = shift @ready; my $buffer = _read_tcp($socket); $self->{replyfrom} = $ip; $self->_diag( 'packet from', "[$ip]", length($buffer), 'octets' ); my $reply = Net::DNS::Packet->decode( \$buffer, $self->{debug} ); $self->errorstring($@); next unless $self->_accept_reply( $reply, $query ); $reply->from( $socket->peerhost ); if ( $self->{tsig_rr} && !$reply->verify($query) ) { $self->errorstring( $reply->verifyerr ); next; } my $rcode = $reply->header->rcode; return $reply if $rcode eq 'NOERROR'; return $reply if $rcode eq 'NXDOMAIN'; $fallback = $reply; } $self->errorstring( $fallback->header->rcode ) if $fallback; $self->errorstring('query timed out') unless $self->errorstring; return $fallback; } sub _send_udp { my ( $self, $query, $query_data ) = @_; my @ns = $self->nameservers; my $port = $self->{port}; my $retrans = $self->{retrans} || 1; my $retry = $self->{retry} || 1; my $servers = scalar(@ns); my $timeout = $servers ? do { no integer; $retrans / $servers } : 0; my $fallback; # Perform each round of retries. RETRY: for ( 1 .. $retry ) { # assumed to be a small number # Try each nameserver. my $select = IO::Select->new(); NAMESERVER: foreach my $ns (@ns) { # state vector replaces corresponding element of @ns array unless ( ref $ns ) { my $sockaddr = $self->_create_dst_sockaddr( $ns, $port ); my $socket = $self->_create_udp_socket($ns) || next; $ns = [$socket, $ns, $sockaddr]; } my ( $socket, $ip, $sockaddr, $failed ) = @$ns; next if $failed; $self->_diag( 'udp send', "[$ip]:$port" ); $select->add($socket); $socket->send( $query_data, 0, $sockaddr ); $self->errorstring( $$ns[3] = $! ); # handle failure to detect taint inside socket->send() die 'Insecure dependency while running with -T switch' if TESTS && Scalar::Util::tainted($sockaddr); my $reply; while ( my @ready = $select->can_read($timeout) ) { my $socket = shift @ready; my $buffer = _read_udp($socket); $self->{replyfrom} = $ip; $self->_diag( 'packet from', "[$ip]", length($buffer), 'octets' ); my $packet = Net::DNS::Packet->decode( \$buffer, $self->{debug} ); $self->errorstring($@); next unless $self->_accept_reply( $packet, $query ); $packet->from( $socket->peerhost ); $reply = $packet; last; } #SELECT LOOP next unless $reply; if ( $self->{tsig_rr} && !$reply->verify($query) ) { $self->errorstring( $$ns[3] = $reply->verifyerr ); next; } my $rcode = $reply->header->rcode; return $reply if $rcode eq 'NOERROR'; return $reply if $rcode eq 'NXDOMAIN'; $fallback = $reply; $$ns[3] = $rcode; } #NAMESERVER LOOP no integer; $timeout += $timeout; } #RETRY LOOP $self->errorstring( $fallback->header->rcode ) if $fallback; $self->errorstring('query timed out') unless $self->errorstring; return $fallback; } sub bgsend { my ( $self, @argument ) = @_; my $packet = $self->_make_query_packet(@argument); my $packet_data = $packet->encode; $self->_reset_errorstring; return $self->_bgsend_tcp( $packet, $packet_data ) if $self->{usevc} || length $packet_data > $self->_packetsz; return $self->_bgsend_udp( $packet, $packet_data ); } sub _bgsend_tcp { my ( $self, $packet, $packet_data ) = @_; my $tcp_packet = pack 'n a*', length($packet_data), $packet_data; foreach my $ip ( $self->nameservers ) { $self->_diag( 'bgsend', "[$ip]" ); my $socket = $self->_create_tcp_socket($ip); $self->errorstring($!); next unless $socket; $socket->blocking(0); $socket->send($tcp_packet); $self->errorstring($!); $socket->blocking(1); my $expire = time() + $self->{tcp_timeout}; ${*$socket}{net_dns_bg} = [$expire, $packet]; return $socket; } return; } sub _bgsend_udp { my ( $self, $packet, $packet_data ) = @_; my $port = $self->{port}; foreach my $ip ( $self->nameservers ) { my $sockaddr = $self->_create_dst_sockaddr( $ip, $port ); my $socket = $self->_create_udp_socket($ip) || next; $self->_diag( 'bgsend', "[$ip]:$port" ); $socket->send( $packet_data, 0, $sockaddr ); $self->errorstring($!); # handle failure to detect taint inside $socket->send() die 'Insecure dependency while running with -T switch' if TESTS && Scalar::Util::tainted($sockaddr); my $expire = time() + $self->{udp_timeout}; ${*$socket}{net_dns_bg} = [$expire, $packet]; return $socket; } return; } sub bgbusy { ## no critic # overwrites user UDP handle my ( $self, $handle ) = @_; return unless $handle; my $appendix = ${*$handle}{net_dns_bg} ||= [time() + $self->{udp_timeout}]; my ( $expire, $query, $read ) = @$appendix; return if ref($read); return time() < $expire unless IO::Select->new($handle)->can_read(0.02); # limit CPU burn return unless $query; # SpamAssassin 3.4.1 workaround return unless $handle->socktype() == SOCK_DGRAM; my $ans = $self->_bgread($handle); $$appendix[0] = time(); $$appendix[2] = [$ans]; return unless $ans; return if $self->{igntc}; return unless $ans->header->tc; $self->_diag('packet truncated: retrying using TCP'); my $tcp = $self->_bgsend_tcp( $query, $query->encode ) || return; return defined( $_[1] = $tcp ); # caller's UDP handle now TCP } sub bgisready { ## historical __PACKAGE__->_deprecate('prefer ! bgbusy(...)'); # uncoverable pod return !&bgbusy; } sub bgread { 1 while &bgbusy; ## side effect: TCP retry if TC flag set return &_bgread; } sub _bgread { my ( $self, $handle ) = @_; return unless $handle; my $appendix = ${*$handle}{net_dns_bg}; my ( $expire, $query, $read ) = @$appendix; return shift(@$read) if ref($read); return unless IO::Select->new($handle)->can_read(0.2); my $dgram = $handle->socktype() == SOCK_DGRAM; my $buffer = $dgram ? _read_udp($handle) : _read_tcp($handle); my $peerhost = $self->{replyfrom} = $handle->peerhost; $self->_diag( "packet from [$peerhost]", length($buffer), 'octets' ); my $reply = Net::DNS::Packet->decode( \$buffer, $self->{debug} ); $self->errorstring($@); return unless $self->_accept_reply( $reply, $query ); $reply->from($peerhost); return $reply unless $self->{tsig_rr} && !$reply->verify($query); $self->errorstring( $reply->verifyerr ); return; } sub _accept_reply { my ( $self, $reply, $query ) = @_; return unless $reply; my $header = $reply->header; return unless $header->qr; return if $query && ( $header->id != $query->header->id ); return $self->errorstring( $header->rcode ); # historical quirk } sub axfr { ## zone transfer my ( $self, @argument ) = @_; my $zone = scalar(@argument) ? shift @argument : $self->domain; my @class = @argument; my $request = $self->_make_query_packet( $zone, 'AXFR', @class ); return eval { $self->_diag("axfr( $zone @class )"); my ( $select, $verify, @rr, $soa ) = $self->_axfr_start($request); my $iterator = sub { ## iterate over RRs my $rr = shift(@rr); if ( ref($rr) eq 'Net::DNS::RR::SOA' ) { if ($soa) { $select = undef; return if $rr->canonical eq $soa->canonical; croak $self->errorstring('mismatched final SOA'); } $soa = $rr; } unless ( scalar @rr ) { my $reply; # refill @rr ( $reply, $verify ) = $self->_axfr_next( $select, $verify ); @rr = $reply->answer if $reply; } return $rr; }; return $iterator unless wantarray; my @zone; ## subvert iterator to assemble entire zone while ( my $rr = $iterator->() ) { push @zone, $rr, @rr; # copy RRs en bloc @rr = pop(@zone); # leave last one in @rr } return @zone; }; } sub axfr_start { ## historical my ( $self, @argument ) = @_; # uncoverable pod $self->_deprecate('prefer $iterator = $self->axfr(...)'); my $iterator = $self->axfr(@argument); ( $self->{axfr_iter} ) = grep {defined} ( $iterator, sub { } ); return defined($iterator); } sub axfr_next { ## historical my $self = shift; # uncoverable pod $self->_deprecate('prefer $iterator->()'); return $self->{axfr_iter}->(); } sub _axfr_start { my ( $self, $request ) = @_; my $content = $request->encode; my $TCP_msg = pack 'n a*', length($content), $content; my ( $select, $reply, $rcode ); foreach my $ns ( $self->nameservers ) { $self->_diag("axfr send [$ns]"); local $self->{persistent_tcp}; my $socket = $self->_create_tcp_socket($ns); $self->errorstring($!); $select = IO::Select->new( $socket || next ); $socket->send($TCP_msg); $self->errorstring($!); ($reply) = $self->_axfr_next($select); last if ( $rcode = $reply->header->rcode ) eq 'NOERROR'; } croak $self->errorstring unless $reply; $self->errorstring($rcode); # historical quirk my $verify = $request->sigrr ? $request : undef; unless ($verify) { croak $self->errorstring unless $rcode eq 'NOERROR'; return ( $select, $verify, $reply->answer ); } my $verifyok = $reply->verify($verify); croak $self->errorstring( $reply->verifyerr ) unless $verifyok; croak $self->errorstring if $rcode ne 'NOERROR'; return ( $select, $verifyok, $reply->answer ); } sub _axfr_next { my $self = shift; my $select = shift || return; my $verify = shift; my ($socket) = $select->can_read( $self->{tcp_timeout} ); croak $self->errorstring('timed out') unless $socket; my $buffer = _read_tcp($socket); my $packet = Net::DNS::Packet->decode( \$buffer ); croak $@, $self->errorstring('corrupt packet') if $@; return ( $packet, $verify ) unless $verify; my $verifyok = $packet->verify($verify); croak $self->errorstring( $packet->verifyerr ) unless $verifyok; return ( $packet, $verifyok ); } # # Usage: $data = _read_tcp($socket); # sub _read_socket { my ( $socket, $size ) = @_; my $buffer = ''; $socket->recv( $buffer, $size ) if $size; return $buffer; } sub _read_tcp { my $socket = shift; my $buffer = ''; my $header = _read_socket( $socket, 2 ); $header .= _read_socket( $socket, 2 - length $header ); return $buffer if length($header) < 2; # uncoverable branch true my $size = unpack 'n', $header; while ( my $fragment = _read_socket( $socket, $size - length $buffer ) ) { $buffer .= $fragment; } return $buffer; } # # Usage: $data = _read_udp($socket); # sub _read_udp { return _read_socket( shift(), 9000 ); ## payload limit for Ethernet "Jumbo" packet } sub _create_tcp_socket { my ( $self, $ip, @sockopt ) = @_; my $socket; my $sock_key = "TCP[$ip]"; if ( $socket = $self->{persistent}{$sock_key} ) { $self->_diag( 'using persistent socket', $sock_key ); return $socket if $socket->connected; $self->_diag('socket disconnected (trying to connect)'); } my $ip6_addr = IPv6 && _ipv6($ip); $socket = IO::Socket::IP->new( LocalAddr => $ip6_addr ? $self->{srcaddr6} : $self->{srcaddr4}, LocalPort => $self->{srcport}, PeerAddr => $ip, PeerPort => $self->{port}, Proto => 'tcp', Timeout => $self->{tcp_timeout}, GetAddrInfoFlags => AI_NUMERICHOST, @sockopt ) if USE_SOCKET_IP; unless ( USE_SOCKET_IP or $ip6_addr ) { $socket = IO::Socket::INET->new( LocalAddr => $self->{srcaddr4}, LocalPort => $self->{srcport} || undef, PeerAddr => $ip, PeerPort => $self->{port}, Proto => 'tcp', Timeout => $self->{tcp_timeout}, @sockopt ); } $self->{persistent}{$sock_key} = $socket if $self->{persistent_tcp}; return $socket; } sub _create_udp_socket { my ( $self, $ip, @sockopt ) = @_; my $socket; my $sock_key = "UDP[$ip]"; return $socket if $socket = $self->{persistent}{$sock_key}; my $ip6_addr = IPv6 && _ipv6($ip); $socket = IO::Socket::IP->new( LocalAddr => $ip6_addr ? $self->{srcaddr6} : $self->{srcaddr4}, LocalPort => $self->{srcport}, Proto => 'udp', Type => SOCK_DGRAM, GetAddrInfoFlags => AI_NUMERICHOST, @sockopt ) if USE_SOCKET_IP; unless ( USE_SOCKET_IP or $ip6_addr ) { $socket = IO::Socket::INET->new( LocalAddr => $self->{srcaddr4}, LocalPort => $self->{srcport} || undef, Proto => 'udp', Type => SOCK_DGRAM, @sockopt ); } $self->{persistent}{$sock_key} = $socket if $self->{persistent_udp}; return $socket; } my $ip4 = { family => AF_INET, flags => AI_NUMERICHOST, protocol => IPPROTO_UDP, socktype => SOCK_DGRAM }; my $ip6 = { family => AF_INET6, flags => AI_NUMERICHOST, protocol => IPPROTO_UDP, socktype => SOCK_DGRAM }; sub _create_dst_sockaddr { ## create UDP destination sockaddr structure my ( $self, $ip, $port ) = @_; unless (USE_SOCKET_IP) { # NB: errors raised in socket->send return _ipv6($ip) ? undef : sockaddr_in( $port, inet_aton($ip) ); } my @addrinfo = Socket::getaddrinfo( $ip, $port, _ipv6($ip) ? $ip6 : $ip4 ); return ( grep {ref} @addrinfo, {} )[0]->{addr}; } # Lightweight versions of subroutines from Net::IP module, recoded to fix RT#96812 sub _ipv4 { for (shift) { last if m/[^.0-9]/; # dots and digits only return m/\.\d+\./; # dots separated by digits } return; } sub _ipv6 { for (shift) { last unless m/:.*:/; # must contain two colons return 1 unless m/[^:0-9A-Fa-f]/; # colons and hexdigits only return 1 if m/^[:.0-9A-Fa-f]+\%.+$/; # RFC4007 scoped address return m/^[:0-9A-Fa-f]+:[.0-9]+$/; # prefix : dotted digits } return; } sub _make_query_packet { my ( $self, @argument ) = @_; my ($packet) = @argument; unless ( ref($packet) ) { $packet = Net::DNS::Packet->new(@argument); $packet->edns->udpsize( $self->{udppacketsize} ); my $header = $packet->header; $header->ad( $self->{adflag} ); # RFC6840, 5.7 $header->cd( $self->{cdflag} ); # RFC6840, 5.9 $header->do(1) if $self->{dnssec}; $header->rd( $self->{recurse} ); } if ( $self->{tsig_rr} ) { $packet->sign_tsig( $self->{tsig_rr} ) unless $packet->sigrr; } return $packet; } sub dnssec { my ( $self, @argument ) = @_; for (@argument) { $self->udppacketsize(1232); $self->{dnssec} = $_; } return $self->{dnssec}; } sub force_v6 { my ( $self, @value ) = @_; for (@value) { $self->{force_v4} = 0 if $self->{force_v6} = $_ } return $self->{force_v6} ? 1 : 0; } sub force_v4 { my ( $self, @value ) = @_; for (@value) { $self->{force_v6} = 0 if $self->{force_v4} = $_ } return $self->{force_v4} ? 1 : 0; } sub prefer_v6 { my ( $self, @value ) = @_; for (@value) { $self->{prefer_v4} = 0 if $self->{prefer_v6} = $_ } return $self->{prefer_v6} ? 1 : 0; } sub prefer_v4 { my ( $self, @value ) = @_; for (@value) { $self->{prefer_v6} = 0 if $self->{prefer_v4} = $_ } return $self->{prefer_v4} ? 1 : 0; } sub srcaddr { my ( $self, @value ) = @_; for (@value) { my $hashkey = _ipv6($_) ? 'srcaddr6' : 'srcaddr4'; $self->{$hashkey} = $_; } return shift @value; } sub tsig { my ( $self, $arg, @etc ) = @_; return $arg unless $arg; return $arg if ref($arg) eq 'Net::DNS::RR::TSIG'; $self->{tsig_rr} = eval { local $SIG{__DIE__}; require Net::DNS::RR::TSIG; Net::DNS::RR::TSIG->create( $arg, @etc ); }; croak "${@}unable to create TSIG record" if $@; return; } # if ($self->{udppacketsize} > PACKETSZ # then we use EDNS and $self->{udppacketsize} # should be taken as the maximum packet_data length sub _packetsz { my $udpsize = shift->{udppacketsize} || 0; return $udpsize > PACKETSZ ? $udpsize : PACKETSZ; } sub udppacketsize { my ( $self, @value ) = @_; for (@value) { $self->{udppacketsize} = $_ } return $self->_packetsz; } # # Keep this method around. Folk depend on it although it is neither documented nor exported. # sub make_query_packet { ## historical __PACKAGE__->_deprecate('see RT#37104'); # uncoverable pod return &_make_query_packet; } sub _diag { ## debug output return unless shift->{debug}; return print "\n;; @_\n"; } { my $parse_dig = sub { require Net::DNS::ZoneFile; my $dug = Net::DNS::ZoneFile->new( \*DATA ); my @rr = $dug->read; my @auth = grep { $_->type eq 'NS' } @rr; my %auth = map { lc $_->nsdname => 1 } @auth; my %glue; my @glue = grep { $auth{lc $_->name} } @rr; foreach ( grep { $_->can('address') } @glue ) { push @{$glue{lc $_->name}}, $_->address; } return map {@$_} values %glue; }; my @ip; sub _hints { ## default hints @ip = &$parse_dig unless scalar @ip; # once only, on demand splice @ip, 0, 0, splice( @ip, int( rand scalar @ip ) ); # cut deck return @ip; } } sub DESTROY { } ## Avoid tickling AUTOLOAD (in cleanup) sub AUTOLOAD { ## Default method my ($self) = @_; no strict 'refs'; ## no critic ProhibitNoStrict our $AUTOLOAD; my $name = $AUTOLOAD; $name =~ s/.*://; croak qq[unknown method "$name"] unless $public_attr{$name}; *{$AUTOLOAD} = sub { my $self = shift; $self = $self->_defaults unless ref($self); $self->{$name} = shift || 0 if scalar @_; return $self->{$name}; }; return &$AUTOLOAD; } 1; =head1 NAME Net::DNS::Resolver::Base - DNS resolver base 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 METHODS =head2 new, domain, searchlist, nameserver, nameservers, =head2 search, query, send, bgsend, bgbusy, bgread, axfr, =head2 force_v4, force_v6, prefer_v4, prefer_v6, =head2 dnssec, srcaddr, tsig, udppacketsize, =head2 print, string, errorstring, replyfrom See L. =head1 COPYRIGHT Copyright (c)2003,2004 Chris Reinhardt. Portions Copyright (c)2005 Olaf Kolkman. Portions Copyright (c)2014-2017 Dick Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L =cut ######################################## __DATA__ ## DEFAULT HINTS ; <<>> DiG 9.18.20 <<>> @b.root-servers.net . -t NS ; (2 servers found) ;; global options: +cmd ;; Got answer: ;; ->>HEADER<<- opcode: QUERY, status: NOERROR, id: 938 ;; flags: qr aa rd; QUERY: 1, ANSWER: 13, AUTHORITY: 0, ADDITIONAL: 27 ;; WARNING: recursion requested but not available ;; OPT PSEUDOSECTION: ; EDNS: version: 0, flags:; udp: 1232 ;; QUESTION SECTION: ;. IN NS ;; ANSWER SECTION: . 518400 IN NS a.root-servers.net. . 518400 IN NS b.root-servers.net. . 518400 IN NS c.root-servers.net. . 518400 IN NS d.root-servers.net. . 518400 IN NS e.root-servers.net. . 518400 IN NS f.root-servers.net. . 518400 IN NS g.root-servers.net. . 518400 IN NS h.root-servers.net. . 518400 IN NS i.root-servers.net. . 518400 IN NS j.root-servers.net. . 518400 IN NS k.root-servers.net. . 518400 IN NS l.root-servers.net. . 518400 IN NS m.root-servers.net. ;; ADDITIONAL SECTION: a.root-servers.net. 518400 IN A 198.41.0.4 a.root-servers.net. 518400 IN AAAA 2001:503:ba3e::2:30 b.root-servers.net. 518400 IN A 170.247.170.2 b.root-servers.net. 518400 IN AAAA 2801:1b8:10::b c.root-servers.net. 518400 IN A 192.33.4.12 c.root-servers.net. 518400 IN AAAA 2001:500:2::c d.root-servers.net. 518400 IN A 199.7.91.13 d.root-servers.net. 518400 IN AAAA 2001:500:2d::d e.root-servers.net. 518400 IN A 192.203.230.10 e.root-servers.net. 518400 IN AAAA 2001:500:a8::e f.root-servers.net. 518400 IN A 192.5.5.241 f.root-servers.net. 518400 IN AAAA 2001:500:2f::f g.root-servers.net. 518400 IN A 192.112.36.4 g.root-servers.net. 518400 IN AAAA 2001:500:12::d0d h.root-servers.net. 518400 IN A 198.97.190.53 h.root-servers.net. 518400 IN AAAA 2001:500:1::53 i.root-servers.net. 518400 IN A 192.36.148.17 i.root-servers.net. 518400 IN AAAA 2001:7fe::53 j.root-servers.net. 518400 IN A 192.58.128.30 j.root-servers.net. 518400 IN AAAA 2001:503:c27::2:30 k.root-servers.net. 518400 IN A 193.0.14.129 k.root-servers.net. 518400 IN AAAA 2001:7fd::1 l.root-servers.net. 518400 IN A 199.7.83.42 l.root-servers.net. 518400 IN AAAA 2001:500:9f::42 m.root-servers.net. 518400 IN A 202.12.27.33 m.root-servers.net. 518400 IN AAAA 2001:dc3::35 ;; Query time: 19 msec ;; SERVER: 170.247.170.2#53(b.root-servers.net) (UDP) ;; WHEN: Fri Dec 29 22:01:37 GMT 2023 ;; MSG SIZE rcvd: 1003 Net-DNS-1.50/lib/Net/DNS/Resolver/os390.pm0000644000175000017500000001073214756035515017125 0ustar willemwillempackage Net::DNS::Resolver::os390; use strict; use warnings; our $VERSION = (qw$Id: os390.pm 2007 2025-02-08 16:45:23Z willem $)[2]; =head1 NAME Net::DNS::Resolver::os390 - IBM OS/390 resolver class =cut use IO::File; my $path = $ENV{PATH}; local $ENV{PATH} = join ':', grep {$_} qw(/bin /usr/bin), $path; my $sysname = eval {`sysvar SYSNAME 2>/dev/null`} || ''; chomp $sysname; my %RESOLVER_SETUP; ## placeholders for unimplemented search list elements my @dataset = ( ## plausible places to seek resolver configuration $RESOLVER_SETUP{GLOBALTCPIPDATA}, $ENV{RESOLVER_CONFIG}, # MVS dataset or Unix file name "/etc/resolv.conf", $RESOLVER_SETUP{SYSTCPD}, "//TCPIP.DATA", # .TCPIP.DATA "//'${sysname}.TCPPARMS(TCPDATA)'", "//'SYS1.TCPPARMS(TCPDATA)'", $RESOLVER_SETUP{DEFAULTTCPIPDATA}, "//'TCPIP.TCPIP.DATA'" ); my $homedir = $ENV{HOME}; my $dotfile = '.resolv.conf'; my @dotfile = grep { -f $_ && -o $_ } map {"$_/$dotfile"} grep {$_} $homedir, '.'; my %option = ( ## map MVS config option names NSPORTADDR => 'port', RESOLVERTIMEOUT => 'retrans', RESOLVERUDPRETRIES => 'retry', SORTLIST => 'sortlist', ); sub _init { my $defaults = shift->_defaults; my %stop; local $ENV{PATH} = join ':', grep {$_} qw(/bin /usr/bin), $path; foreach my $dataset ( Net::DNS::Resolver::Base::_untaint( grep {$_} @dataset ) ) { eval { local $_; my @nameserver; my @searchlist; my $handle = IO::File->new( qq[cat "$dataset" 2>/dev/null], '-|' ) or die "$dataset: $!"; # "cat" able to read MVS datasets while (<$handle>) { s/[;#].*$//; # strip comment s/^\s+//; # strip leading white space next unless $_; # skip empty line next if m/^\w+:/ && !m/^$sysname:/oi; s/^\w+:\s*//; # discard qualifier m/^(NSINTERADDR|nameserver)/i && do { my ( $keyword, @ip ) = grep {defined} split; push @nameserver, @ip; next; }; m/^(DOMAINORIGIN|domain)/i && do { my ( $keyword, @domain ) = grep {defined} split; $defaults->domain(@domain) unless $stop{domain}++; next; }; m/^search/i && do { my ( $keyword, @domain ) = grep {defined} split; push @searchlist, @domain; next; }; m/^option/i && do { my ( $keyword, @option ) = grep {defined} split; foreach (@option) { my ( $attribute, @value ) = split m/:/; $defaults->_option( $attribute, @value ) unless $stop{$attribute}++; } next; }; m/^RESOLVEVIA/i && do { my ( $keyword, $value ) = grep {defined} split; $defaults->_option( 'usevc', $value eq 'TCP' ) unless $stop{usevc}++; next; }; m/^\w+\s*/ && do { my ( $keyword, @value ) = grep {defined} split; my $attribute = $option{uc $keyword} || next; $defaults->_option( $attribute, @value ) unless $stop{$attribute}++; }; } close($handle); $defaults->nameserver(@nameserver) if @nameserver && !$stop{nameserver}++; $defaults->searchlist(@searchlist) if @searchlist && !$stop{search}++; }; warn $@ if $@; } %$defaults = Net::DNS::Resolver::Base::_untaint(%$defaults); $defaults->_read_config_file($_) foreach @dotfile; $defaults->_read_env; return; } 1; __END__ =head1 SYNOPSIS use Net::DNS::Resolver; =head1 DESCRIPTION This class implements the OS specific portions of C. No user serviceable parts inside, see L for all your resolving needs. =head1 COPYRIGHT Copyright (c)2017 Dick Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L, L, L =cut Net-DNS-1.50/lib/Net/DNS/Resolver/cygwin.pm0000644000175000017500000001145414756035515017552 0ustar willemwillempackage Net::DNS::Resolver::cygwin; use strict; use warnings; our $VERSION = (qw$Id: cygwin.pm 2002 2025-01-07 09:57:46Z willem $)[2]; =head1 NAME Net::DNS::Resolver::cygwin - Cygwin resolver class =cut use IO::File; sub _getregkey { my @key = @_; my $handle = IO::File->new( join( '/', @key ), '<' ) or return ''; my $value = <$handle> || ''; close($handle); $value =~ s/\0+$//; return $value; } sub _init { my $defaults = shift->_defaults; my $dirhandle; 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 $devolution = _getregkey( $root, 'UseDomainNameDevolution' ); my $searchlist = _getregkey( $root, 'SearchList' ); my @searchlist = ( $domain, split m/[\s,]+/, $searchlist ); # This is (probably) adequate on NT4 my @nt4nameservers; foreach ( grep {length} _getregkey( $root, 'NameServer' ), _getregkey( $root, 'DhcpNameServer' ) ) { push @nt4nameservers, split m/[\s,]+/; last; } # 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 @nameservers; my $dnsadapters = join '/', $root, 'DNSRegisteredAdapters'; if ( opendir( $dirhandle, $dnsadapters ) ) { my @adapters = grep { !/^\.\.?$/ } readdir($dirhandle); closedir($dirhandle); foreach my $adapter (@adapters) { my $ns = _getregkey( $dnsadapters, $adapter, 'DNSServerAddresses' ); until ( length($ns) < 4 ) { push @nameservers, join '.', unpack( 'C4', $ns ); substr( $ns, 0, 4 ) = ''; } } } my $interfaces = join '/', $root, 'Interfaces'; if ( opendir( $dirhandle, $interfaces ) ) { my @ifacelist = grep { !/^\.\.?$/ } readdir($dirhandle); closedir($dirhandle); foreach my $iface (@ifacelist) { my $ip = _getregkey( $interfaces, $iface, 'DhcpIPAddress' ) || _getregkey( $interfaces, $iface, 'IPAddress' ); next unless $ip; next if $ip eq '0.0.0.0'; foreach ( grep {length} _getregkey( $interfaces, $iface, 'NameServer' ), _getregkey( $interfaces, $iface, 'DhcpNameServer' ) ) { push @nameservers, split m/[\s,]+/; last; } } } @nameservers = @nt4nameservers unless @nameservers; $defaults->nameservers(@nameservers); # fix devolution if configured, and simultaneously # eliminate duplicate entries (but keep the order) my @list; my %seen; foreach (@searchlist) { s/\.+$//; push( @list, $_ ) unless $seen{lc $_}++; next unless $devolution; # while there are more than two labels, cut while (s#^[^.]+\.(.+\..+)$#$1#) { push( @list, $_ ) unless $seen{lc $_}++; } } $defaults->searchlist(@list); %$defaults = Net::DNS::Resolver::Base::_untaint(%$defaults); $defaults->_read_env; return; } 1; __END__ =head1 SYNOPSIS use Net::DNS::Resolver; =head1 DESCRIPTION This class implements the OS specific portions of C. No user serviceable parts inside, see L for all your resolving needs. =head1 COPYRIGHT Copyright (c)2003 Sidney Markowitz. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L, L, L =cut Net-DNS-1.50/lib/Net/DNS/Resolver/Recurse.pm0000644000175000017500000001403214756035515017655 0ustar willemwillempackage Net::DNS::Resolver::Recurse; use strict; use warnings; our $VERSION = (qw$Id: Recurse.pm 2002 2025-01-07 09:57:46Z willem $)[2]; =head1 NAME Net::DNS::Resolver::Recurse - DNS recursive resolver =head1 SYNOPSIS use Net::DNS::Resolver::Recurse; my $resolver = new Net::DNS::Resolver::Recurse(); $resolver->hints('198.41.0.4'); # A.ROOT-SERVER.NET. my $packet = $resolver->send( 'www.rob.com.au.', 'A' ); =head1 DESCRIPTION This module resolves queries by following the delegation path from the DNS root. =cut use base qw(Net::DNS::Resolver::Base); =head1 METHODS This module inherits almost all the methods from Net::DNS::Resolver. Additional module-specific methods are described below. =head2 hints This method specifies a list of the IP addresses of nameservers to be used to discover the addresses of the root nameservers. $resolver->hints(@ip); If no hints are passed, the priming query is directed to nameservers drawn from a built-in list of IP addresses. =cut my @hints; my $root; sub hints { my ( undef, @argument ) = @_; return @hints unless scalar @argument; undef $root; return @hints = @argument; } =head2 query, search, send The query(), search() and send() methods produce the same result as their counterparts in Net::DNS::Resolver. $packet = $resolver->send( 'www.example.com.', 'A' ); Server-side recursion is suppressed by clearing the recurse flag in query packets and recursive name resolution is performed explicitly. The query() and search() methods are inherited from Net::DNS::Resolver and invoke send() indirectly. =cut sub send { my ( $self, @q ) = @_; my @conf = ( recurse => 0, udppacketsize => 1232 ); return bless( {persistent => {'.' => $root}, %$self, @conf}, ref($self) )->_send(@q); } sub query_dorecursion { ## historical my ($self) = @_; # uncoverable pod $self->_deprecate('prefer $resolver->send(...)'); return &send; } sub _send { my ( $self, @q ) = @_; my $query = $self->_make_query_packet(@q); unless ($root) { $self->_diag('resolver priming query'); $self->nameservers( scalar(@hints) ? @hints : $self->_hints ); $self->_referral( $self->SUPER::send(qw(. NS)) ); $root = $self->{persistent}->{'.'}; } return $self->_recurse( $query, '.' ); } sub _recurse { my ( $self, $query, $apex ) = @_; $self->_diag("using cached nameservers for $apex"); my $cache = $self->{persistent}->{$apex}; my @nslist = keys %$cache; my @glue = grep { $$cache{$_} } @nslist; my @noglue = grep { !$$cache{$_} } @nslist; my $reply; foreach my $ns ( @glue, @noglue ) { if ( my $iplist = $$cache{$ns} ) { $self->nameservers(@$iplist); } else { $self->_diag("recover missing glue for $ns"); next if substr( lc($ns), -length($apex) ) eq $apex; my @ip = $self->nameservers($ns); $$cache{$ns} = \@ip; } $query->header->id(undef); last if $reply = $self->SUPER::send($query); $$cache{$ns} = undef; # park non-responder } $self->_callback($reply); return unless $reply; my $zone = $self->_referral($reply) || return $reply; die '_recurse exceeded depth limit' if $self->{recurse_depth}++ > 50; my $qname = lc( ( $query->question )[0]->qname ); my $suffix = substr( $qname, -length($zone) ); return $zone eq $suffix ? $self->_recurse( $query, $zone ) : undef; } sub _referral { my ( $self, $packet ) = @_; return unless $packet; my @ans = $packet->answer; my @auth = grep { $_->type eq 'NS' } $packet->authority, @ans; return unless scalar(@auth); my $owner = lc( $auth[0]->owner ); my $cache = $self->{persistent}->{$owner}; return scalar(@ans) ? undef : $owner if $cache; $self->_diag("caching nameservers for $owner"); my %addr; my @addr = grep { $_->can('address') } $packet->additional; push @{$addr{lc $_->owner}}, $_->address foreach @addr; my %cache; foreach my $ns ( map { lc( $_->nsdname ) } @auth ) { $cache{$ns} = $addr{$ns}; } $self->{persistent}->{$owner} = \%cache; return scalar(@ans) ? undef : $owner; } =head2 callback This method specifies a code reference to a subroutine, which is then invoked at each stage of the recursive lookup. For example to emulate dig's C<+trace> function: my $coderef = sub { my $packet = shift; printf ";; Received %d bytes from %s\n\n", $packet->answersize, $packet->answerfrom; }; $resolver->callback($coderef); The callback subroutine is not called for queries for missing glue records. =cut sub callback { my ( $self, @argument ) = @_; for ( grep { ref($_) eq 'CODE' } @argument ) { $self->{callback} = $_; } return; } sub _callback { my ( $self, @argument ) = @_; my $callback = $self->{callback}; $callback->(@argument) if $callback; return; } sub recursion_callback { ## historical my ($self) = @_; # uncoverable pod $self->_deprecate('prefer $resolver->callback(...)'); &callback; return; } 1; __END__ =head1 ACKNOWLEDGEMENT This package is an improved and compatible reimplementation of the Net::DNS::Resolver::Recurse.pm created by Rob Brown in 2002, whose contribution is gratefully acknowledged. =head1 COPYRIGHT Copyright (c)2014,2019 Dick Franks. Portions Copyright (c)2002 Rob Brown. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L =cut Net-DNS-1.50/lib/Net/DNS/Resolver/MSWin32.pm0000644000175000017500000000713114756035515017411 0ustar willemwillempackage Net::DNS::Resolver::MSWin32; use strict; use warnings; our $VERSION = (qw$Id: MSWin32.pm 2002 2025-01-07 09:57:46Z willem $)[2]; =head1 NAME Net::DNS::Resolver::MSWin32 - MS Windows resolver class =cut use Carp; use constant WINHLP => defined eval 'require Win32::IPHelper'; ## no critic use constant WINREG => defined eval 'use Win32::TieRegistry qw(KEY_READ REG_DWORD); 1'; ## no critic our $Registry; sub _init { my $defaults = shift->_defaults; my $debug = 0; my $FIXED_INFO = {}; my $err = Win32::IPHelper::GetNetworkParams($FIXED_INFO); croak "GetNetworkParams() error %u: %s\n", $err, Win32::FormatMessage($err) if $err; if ($debug) { require Data::Dumper; print Data::Dumper::Dumper $FIXED_INFO; } my @nameservers = map { $_->{IpAddress} } @{$FIXED_INFO->{DnsServersList}}; $defaults->nameservers( grep {$_} @nameservers ); my $devolution = 0; my $domainname = $FIXED_INFO->{DomainName} || ''; my @searchlist = grep {length} $domainname; if (WINREG) { # The Win32::IPHelper does not return searchlist. # Make best effort attempt to get searchlist from the registry. my @root = qw(HKEY_LOCAL_MACHINE SYSTEM CurrentControlSet Services); my $leaf = join '\\', @root, qw(Tcpip Parameters); my $reg_tcpip = $Registry->Open( $leaf, {Access => KEY_READ} ); unless ( defined $reg_tcpip ) { # Didn't work, Win95/98/Me? $leaf = join '\\', @root, qw(VxD MSTCP); $reg_tcpip = $Registry->Open( $leaf, {Access => KEY_READ} ); } if ( defined $reg_tcpip ) { my $searchlist = $reg_tcpip->GetValue('SearchList') || ''; push @searchlist, split m/[\s,]+/, $searchlist; my ( $value, $type ) = $reg_tcpip->GetValue('UseDomainNameDevolution'); $devolution = defined $value && $type == REG_DWORD ? hex $value : 0; } } # fix devolution if configured, and simultaneously # eliminate duplicate entries (but keep the order) my @list; my %seen; foreach (@searchlist) { s/\.+$//; push( @list, $_ ) unless $seen{lc $_}++; next unless $devolution; # while there are more than two labels, cut while (s#^[^.]+\.(.+\..+)$#$1#) { push( @list, $_ ) unless $seen{lc $_}++; } } $defaults->searchlist(@list); %$defaults = Net::DNS::Resolver::Base::_untaint(%$defaults); $defaults->_read_env; return; } 1; __END__ =head1 SYNOPSIS use Net::DNS::Resolver; =head1 DESCRIPTION This class implements the OS specific portions of C. No user serviceable parts inside, see L for all your resolving needs. =head1 COPYRIGHT Copyright (c)2003 Chris Reinhardt. Portions Copyright (c)2009 Olaf Kolkman, NLnet Labs All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L, L, L =cut Net-DNS-1.50/lib/Net/DNS/Resolver/UNIX.pm0000644000175000017500000000424014756035515017030 0ustar willemwillempackage Net::DNS::Resolver::UNIX; use strict; use warnings; our $VERSION = (qw$Id: UNIX.pm 2007 2025-02-08 16:45:23Z willem $)[2]; =head1 NAME Net::DNS::Resolver::UNIX - Unix resolver class =cut my @config_file = grep { -f $_ && -r $_ } '/etc/resolv.conf'; my $homedir = $ENV{HOME}; my $dotfile = '.resolv.conf'; my @dotfile = grep { -f $_ && -o $_ } map {"$_/$dotfile"} grep {$_} $homedir, '.'; my $path = $ENV{PATH}; local $ENV{PATH} = join ':', grep {$_} qw(/bin /usr/bin), $path; my $uname = eval {`uname -n 2>/dev/null`} || ''; chomp $uname; my ( $host, @domain ) = split /\./, $uname, 2; sub _init { my $defaults = shift->_defaults; $defaults->domain(@domain); $defaults->_read_config_file($_) foreach @config_file; %$defaults = Net::DNS::Resolver::Base::_untaint(%$defaults); $defaults->_read_config_file($_) foreach @dotfile; $defaults->_read_env; return; } 1; __END__ =head1 SYNOPSIS use Net::DNS::Resolver; =head1 DESCRIPTION This class implements the OS specific portions of C. No user serviceable parts inside, see L for all your resolving needs. =head1 COPYRIGHT Copyright (c)2003 Chris Reinhardt. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L, L, L =cut Net-DNS-1.50/lib/Net/DNS/Resolver/os2.pm0000644000175000017500000000401414756035515016747 0ustar willemwillempackage Net::DNS::Resolver::os2; use strict; use warnings; our $VERSION = (qw$Id: os2.pm 2007 2025-02-08 16:45:23Z willem $)[2]; =head1 NAME Net::DNS::Resolver::os2 - OS2 resolver class =cut my $config_file = 'resolv'; my @config_path = ( $ENV{ETC} || '/etc' ); my @config_file = grep { -f $_ && -r $_ } map {"$_/$config_file"} @config_path; my $homedir = $ENV{HOME}; my $dotfile = '.resolv.conf'; my @dotfile = grep { -f $_ && -o $_ } map {"$_/$dotfile"} grep {$_} $homedir, '.'; sub _init { my $defaults = shift->_defaults; $defaults->_read_config_file($_) foreach @config_file; %$defaults = Net::DNS::Resolver::Base::_untaint(%$defaults); $defaults->_read_config_file($_) foreach @dotfile; $defaults->_read_env; return; } 1; __END__ =head1 SYNOPSIS use Net::DNS::Resolver; =head1 DESCRIPTION This class implements the OS specific portions of C. No user serviceable parts inside, see L for all your resolving needs. =head1 COPYRIGHT Copyright (c)2012 Dick Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L, L, L =cut Net-DNS-1.50/lib/Net/DNS/Resolver/android.pm0000644000175000017500000000434714756035515017675 0ustar willemwillempackage Net::DNS::Resolver::android; use strict; use warnings; our $VERSION = (qw$Id: android.pm 2007 2025-02-08 16:45:23Z willem $)[2]; =head1 NAME Net::DNS::Resolver::android - Android resolver class =cut my $config_file = 'resolv.conf'; my @config_path = ( $ENV{ANDROID_ROOT} || '/system' ); my @config_file = grep { -f $_ && -r $_ } map {"$_/etc/$config_file"} @config_path; my $homedir = $ENV{HOME}; my $dotfile = '.resolv.conf'; my @dotfile = grep { -f $_ && -o $_ } map {"$_/$dotfile"} grep {$_} $homedir, '.'; sub _init { my $defaults = shift->_defaults; my @nameserver; for ( 1 .. 4 ) { my $ret = `getprop net.dns$_` || next; chomp $ret; push @nameserver, $ret || next; } $defaults->nameserver(@nameserver) if @nameserver; $defaults->_read_config_file($_) foreach @config_file; %$defaults = Net::DNS::Resolver::Base::_untaint(%$defaults); $defaults->_read_config_file($_) foreach @dotfile; $defaults->_read_env; return; } 1; __END__ =head1 SYNOPSIS use Net::DNS::Resolver; =head1 DESCRIPTION This class implements the OS specific portions of C. No user serviceable parts inside, see L for all your resolving needs. =head1 COPYRIGHT Copyright (c)2014 Dick Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L, L, L =cut Net-DNS-1.50/lib/Net/DNS/FAQ.pod0000644000175000017500000000212414756035515015220 0ustar willemwillem=head1 NAME Net::DNS::FAQ - Frequently Asked Net::DNS Questions =head1 SYNOPSIS perldoc Net::DNS::FAQ =head1 DESCRIPTION This document serves to answer the most frequently asked questions on both the Net::DNS Mailing List and those sent to the author. The latest version of this FAQ can be found at L =head1 GENERAL =head2 What is Net::DNS? Net::DNS is a perl implementation of a DNS resolver. =head1 INSTALLATION =head2 Where can I find Test::More? Test::More is part of the Test-Simple package, by Michael G Schwern. You should be able to find the distribution at L =head1 USAGE =head2 Why does $resolver->query() return undef when the answer section is empty? The short answer is, do not use query(). $resolver->send() will always return the response packet, as long as a response was received. The longer answer is that query() is modeled after the res_query() function from the libresolv C library, which has similar behavior. =head1 VERSION $Id: FAQ.pod 1709 2018-09-07 08:03:09Z willem $ Net-DNS-1.50/lib/Net/DNS/Update.pm0000644000175000017500000001657314756035515015702 0ustar willemwillempackage Net::DNS::Update; use strict; use warnings; our $VERSION = (qw$Id: Update.pm 2003 2025-01-21 12:06:06Z willem $)[2]; =head1 NAME Net::DNS::Update - DNS dynamic update packet =head1 SYNOPSIS use Net::DNS; $update = Net::DNS::Update->new( 'example.com', 'IN' ); $update->push( prereq => nxrrset('host.example.com. AAAA') ); $update->push( update => rr_add('host.example.com. 86400 AAAA 2001::DB8::F00') ); =head1 DESCRIPTION Net::DNS::Update is a subclass of Net::DNS::Packet, to be used for making DNS dynamic updates. Programmers should refer to RFC2136 for dynamic update semantics. =cut use integer; use Carp; use base qw(Net::DNS::Packet); use Net::DNS::Resolver; =head1 METHODS =head2 new $update = Net::DNS::Update->new; $update = Net::DNS::Update->new( 'example.com' ); $update = Net::DNS::Update->new( 'example.com', 'IN' ); Returns a Net::DNS::Update object suitable for performing a DNS dynamic update. Specifically, it creates a packet with the header opcode set to UPDATE and the zone record type to SOA (per RFC 2136, Section 2.3). Programs must use the push() method to add RRs to the prerequisite and update sections before performing the update. Arguments are the zone name and the class. The zone and class may be undefined or omitted and default to the default domain from the resolver configuration and IN respectively. =cut sub new { my ( $class, $zone, @rrclass ) = @_; my ($domain) = grep { defined && length } ( $zone, Net::DNS::Resolver->searchlist ); my $self = __PACKAGE__->SUPER::new( $domain, 'SOA', @rrclass ); my $header = $self->header; $header->opcode('UPDATE'); $header->qr(0); $header->rd(0); return $self; } =head2 push $ancount = $update->push( prereq => $rr ); $nscount = $update->push( update => $rr ); $arcount = $update->push( additional => $rr ); $nscount = $update->push( update => $rr1, $rr2, $rr3 ); $nscount = $update->push( update => @rr ); Adds RRs to the specified section of the update packet. Returns the number of resource records in the specified section. Section names may be abbreviated to the first three characters. =cut sub push { my ( $self, $section, @rr ) = @_; my ($zone) = $self->zone; my $zclass = $zone->zclass; for (@rr) { $_->class( $_->class =~ /ANY|NONE/ ? () : $zclass ) } return $self->SUPER::push( $section, @rr ); } =head2 unique_push $ancount = $update->unique_push( prereq => $rr ); $nscount = $update->unique_push( update => $rr ); $arcount = $update->unique_push( additional => $rr ); $nscount = $update->unique_push( update => $rr1, $rr2, $rr3 ); $nscount = $update->unique_push( update => @rr ); Adds RRs to the specified section of the update packet provided that the RRs are not already present in the same section. Returns the number of resource records in the specified section. Section names may be abbreviated to the first three characters. =cut sub unique_push { my ( $self, $section, @rr ) = @_; my ($zone) = $self->zone; my $zclass = $zone->zclass; for (@rr) { $_->class( $_->class =~ /ANY|NONE/ ? () : $zclass ) } return $self->SUPER::unique_push( $section, @rr ); } 1; __END__ =head1 EXAMPLES The first example below shows a complete program. Subsequent examples show only the creation of the update packet. Although the examples are presented using the string form of RRs, the corresponding ( name => value ) form may also be used. =head2 Add a new host #!/usr/bin/perl use Net::DNS; # Create the update packet. my $update = Net::DNS::Update->new('example.com'); # Prerequisite is that no address records exist for the name. $update->push( pre => nxrrset('host.example.com. A') ); $update->push( pre => nxrrset('host.example.com. AAAA') ); # Add two address records for the name. $update->push( update => rr_add('host.example.com. 86400 A 192.0.2.1') ); $update->push( update => rr_add('host.example.com. 86400 AAAA 2001:DB8::1') ); # Send the update to the zone's primary nameserver. my $resolver = Net::DNS::Resolver->new(); $resolver->nameservers('DNSprimary.example.com'); my $reply = $resolver->send($update); # Did it work? if ($reply) { print 'Update RCODE: ', $reply->header->rcode, "\n"; } else { print 'Update failed: ', $resolver->errorstring, "\n"; } =head2 Add an MX record for a name that already exists my $update = Net::DNS::Update->new('example.com'); $update->push( prereq => yxdomain('example.com') ); $update->push( update => rr_add('example.com MX 10 mailhost.example.com') ); =head2 Add a TXT record for a name that does not exist my $update = Net::DNS::Update->new('example.com'); $update->push( prereq => nxdomain('info.example.com') ); $update->push( update => rr_add('info.example.com TXT "yabba dabba doo"') ); =head2 Delete all A records for a name my $update = Net::DNS::Update->new('example.com'); $update->push( prereq => yxrrset('host.example.com A') ); $update->push( update => rr_del('host.example.com A') ); =head2 Delete all RRs for a name my $update = Net::DNS::Update->new('example.com'); $update->push( prereq => yxdomain('byebye.example.com') ); $update->push( update => rr_del('byebye.example.com') ); =head2 Perform DNS update signed using a key generated by BIND tsig-keygen my $update = Net::DNS::Update->new('example.com'); $update->push( update => rr_add('host.example.com AAAA 2001:DB8::1') ); $update->sign_tsig( $key_file ); my $reply = $resolver->send( $update ); $reply->verify( $update ) || die $reply->verifyerr; =head2 Signing the DNS update using a customised TSIG record $update->sign_tsig( $key_file, fudge => 60 ); =head2 Signing the DNS update using private key generated by BIND dnssec-keygen $update->sign_tsig( "$dir/Khmac-sha512.example.com.+165+01018.private" ); =head2 Signing the DNS update using public key generated by BIND dnssec-keygen $update->sign_tsig( "$dir/Khmac-sha512.example.com.+165+01018.key" ); =head2 Another way to sign a DNS update use Net::DNS::RR::TSIG; my $tsig = create Net::DNS::RR::TSIG( $key_file ); $tsig->fudge(60); my $update = Net::DNS::Update->new('example.com'); $update->push( update => rr_add('host.example.com AAAA 2001:DB8::1') ); $update->push( additional => $tsig ); =head1 COPYRIGHT Copyright (c)1997-2000 Michael Fuhr. Portions Copyright (c)2002,2003 Chris Reinhardt. Portions Copyright (c)2015 Dick Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L L L =cut Net-DNS-1.50/lib/Net/DNS/Mailbox.pm0000644000175000017500000000772414756035515016051 0ustar willemwillempackage Net::DNS::Mailbox; use strict; use warnings; our $VERSION = (qw$Id: Mailbox.pm 2002 2025-01-07 09:57:46Z willem $)[2]; =head1 NAME Net::DNS::Mailbox - DNS mailbox representation =head1 SYNOPSIS use Net::DNS::Mailbox; $mailbox = Net::DNS::Mailbox->new('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. The Net::DNS::Mailbox1035 and Net::DNS::Mailbox2535 packages implement mailbox representation 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 integer; use Carp; use base qw(Net::DNS::DomainName); =head1 METHODS =head2 new $mailbox = Net::DNS::Mailbox->new('John Doe '); $mailbox = Net::DNS::Mailbox->new('john.doe@example.com'); $mailbox = Net::DNS::Mailbox->new('john\.doe.example.com'); Creates a mailbox object representing the RFC822 mail address specified by the character string argument. An encoded domain name is also accepted for backward compatibility with Net::DNS 0.68 and earlier. The argument string consists of printable characters from the 7-bit ASCII repertoire. =cut sub new { my $class = shift; local $_ = shift; croak 'undefined mail address' unless defined $_; s/^.*.*$//g; # strip excess on right s/^\@.+://; # strip deprecated source route s/\\\./\\046/g; # disguise escaped dots my ( $localpart, @domain ) = split /[@.]([^@;:"]*$)/; # split on rightmost @ s/\./\\046/g for $localpart ||= ''; # escape dots in local part return bless __PACKAGE__->SUPER::new( join '.', $localpart, @domain ), $class; } =head2 address $address = $mailbox->address; Returns a character string containing the RFC822 mailbox address corresponding to the encoded domain name representation described in RFC1035 section 8. =cut sub address { return unless defined wantarray; my @label = shift->label; local $_ = shift(@label) || return '<>'; s/\\\\//g; # delete escaped \ s/^\\034(.*)\\034$/"$1"/; # unescape enclosing quotes s/\\\d\d\d//g; # delete non-printable s/\\\./\./g; # unescape dots s/\\//g; # delete escapes return $_ unless scalar(@label); return join '@', $_, join '.', @label; } ######################################## package Net::DNS::Mailbox1035; ## no critic ProhibitMultiplePackages our @ISA = qw(Net::DNS::Mailbox); sub encode { return &Net::DNS::DomainName1035::encode; } package Net::DNS::Mailbox2535; ## no critic ProhibitMultiplePackages our @ISA = qw(Net::DNS::Mailbox); sub encode { return &Net::DNS::DomainName2535::encode; } 1; __END__ ######################################## =head1 COPYRIGHT Copyright (c)2009,2012 Dick Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut Net-DNS-1.50/lib/Net/DNS/Resolver.pm0000644000175000017500000004712214756035515016253 0ustar willemwillempackage Net::DNS::Resolver; use strict; use warnings; our $VERSION = (qw$Id: Resolver.pm 2009 2025-02-10 13:43:50Z willem $)[2]; =head1 NAME Net::DNS::Resolver - DNS resolver class =cut use base qw(Net::DNS::Resolver::Base); 1; __END__ =head1 SYNOPSIS use Net::DNS; $resolver = Net::DNS::Resolver->new(); # Perform a lookup, using the searchlist if appropriate. $reply = $resolver->search( 'example.com' ); # Perform a lookup, without the searchlist $reply = $resolver->query( 'example.com', 'MX' ); # Perform a lookup, without pre or post-processing $reply = $resolver->send( 'example.com', 'MX', 'IN' ); # Send a prebuilt query packet $query = Net::DNS::Packet->new( ... ); $reply = $resolver->send( $query ); =head1 DESCRIPTION Instances of the Net::DNS::Resolver class represent resolver objects. A program may 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 default configuration $resolver = Net::DNS::Resolver->new(); # Use my own configuration file $resolver = Net::DNS::Resolver->new( config_file => '/my/dns.conf' ); # Set options in the constructor $resolver = Net::DNS::Resolver->new( nameservers => [ '2001:DB8::1', 'ns.example.com' ], recurse => 0, debug => 1 ); Returns a resolver object. If no arguments are supplied, C returns an object having the default configuration. On Unix and Linux systems, the default values are read from the following files, in the order indicated: =over F, F<$HOME/.resolv.conf>, F<./.resolv.conf> =back The following keywords are recognised in resolver configuration files: =over =item B IP address of a name server that the resolver should query. =item B The domain suffix to be appended to a short non-absolute name. =item B A space-separated list of domains in the desired search path. =item B A space-separated list of key:value items. =back Except for F, files will only be read if owned by the effective userid running the program. In addition, several environment variables may contain configuration information; see L. Note that the domain and searchlist keywords are mutually exclusive. If both are present, the resulting behaviour is unspecified. If neither is present, the domain is determined from the local hostname. On Windows systems, an attempt is made to determine the system defaults using the registry. Systems with many dynamically configured network interfaces may confuse L. If a custom configuration file is specified at first instantiation, all other configuration files and environment variables are ignored. Explicit arguments to C override the corresponding configuration variables. The argument list consists of a sequence of (name=>value) pairs, each interpreted as an invocation of the corresponding method. =head2 print $resolver->print; Prints the resolver state on the standard output. =head2 query $packet = $resolver->query( 'host' ); $packet = $resolver->query( 'host.example.com' ); $packet = $resolver->query( '2001:DB8::1' ); $packet = $resolver->query( 'example.com', 'MX' ); $packet = $resolver->query( 'annotation.example.com', 'TXT', 'IN' ); Performs a DNS query for the given name; the search list is not applied. If C is true, the default domain will be appended to unqualified names. 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 a query within in-addr.arpa or ip6.arpa will be performed. Returns a L object, or C if no answers were found. The reason for failure may be determined using C. If you need to examine the response packet, whether it contains any answers or not, use the C method instead. =head2 search $packet = $resolver->search( 'host' ); $packet = $resolver->search( 'host.example.com' ); $packet = $resolver->search( '2001:DB8::1' ); $packet = $resolver->search( 'example.com', 'MX' ); $packet = $resolver->search( 'annotation.example.com', 'TXT', 'IN' ); Performs a DNS query for the given name, applying the searchlist if appropriate. The search algorithm is as follows: If the name contains one or more non-terminal dots, perform an initial query using the unmodified name. If the number of dots is less than C, and there is no terminal dot, try appending each suffix in the search list. 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 a query within in-addr.arpa or ip6.arpa will be performed. Returns a L object, or C if no answers were found. The reason for failure may be determined using C. If you need to examine the response packet, whether it contains any answers or not, use the C method instead. =head2 send $packet = $resolver->send( $query ); $packet = $resolver->send( 'host.example.com' ); $packet = $resolver->send( '2001:DB8::1' ); $packet = $resolver->send( 'example.com', 'MX' ); $packet = $resolver->send( 'annotation.example.com', 'TXT', 'IN' ); 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 pre-built query L 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 a query within in-addr.arpa or ip6.arpa will be performed. Returns a L 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 no response was received. =head2 axfr @zone = $resolver->axfr(); @zone = $resolver->axfr( 'example.com' ); @zone = $resolver->axfr( 'example.com', 'IN' ); $iterator = $resolver->axfr(); $iterator = $resolver->axfr( 'example.com' ); $iterator = $resolver->axfr( 'example.com', 'IN' ); $rr = $iterator->(); Performs a zone transfer using the resolver nameservers list, attempted in the order listed. If the zone is omitted, it defaults to the first zone listed in the resolver search list. If the class is omitted, it defaults to IN. When called in list context, C returns a list of L objects. The redundant SOA record that terminates the zone transfer is not returned to the caller. In deferrence to RFC1035(6.3), a complete zone transfer is expected to return all records in the zone or nothing at all. When no resource records are returned by C, the reason for failure may be determined using C. Here is an example that uses a timeout and TSIG verification: $resolver->tcp_timeout( 10 ); $resolver->tsig( $keyfile ); @zone = $resolver->axfr( 'example.com' ); foreach $rr (@zone) { $rr->print; } When called in scalar context, C returns an iterator object. Each invocation of the iterator returns a single L or C when the zone is exhausted. An exception is raised if the zone transfer can not be completed. The redundant SOA record that terminates the zone transfer is not returned to the caller. Here is the example above, implemented using an iterator: $resolver->tcp_timeout( 10 ); $resolver->tsig( $keyfile ); $iterator = $resolver->axfr( 'example.com' ); while ( $rr = $iterator->() ) { $rr->print; } =head2 bgsend $handle = $resolver->bgsend( $packet ) || die $resolver->errorstring; $handle = $resolver->bgsend( 'host.example.com' ); $handle = $resolver->bgsend( '2001:DB8::1' ); $handle = $resolver->bgsend( 'example.com', 'MX' ); $handle = $resolver->bgsend( 'annotation.example.com', 'TXT', 'IN' ); Performs a background DNS query for the given name and returns immediately without waiting for the response. The program can then perform other tasks while awaiting the response from the nameserver. The argument list can be either a L 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 a query within in-addr.arpa or ip6.arpa will be performed. Returns an opaque handle which is passed to subsequent invocations of the C and C methods. Errors are indicated by returning C in which case the reason for failure may be determined using C. The response L object is obtained by calling C. B: Programs should make no assumptions about the nature of the handles returned by C which should be used strictly as described here. =head2 bgread $handle = $resolver->bgsend( 'www.example.com' ); $packet = $resolver->bgread($handle); Reads the response following a background query. The argument is the handle returned by C. Returns a L object or C if no response was received before the timeout interval expired. =head2 bgbusy $handle = $resolver->bgsend( 'foo.example.com' ); while ($resolver->bgbusy($handle)) { ... } $packet = $resolver->bgread($handle); Returns true while awaiting the response or for the transaction to time out. The argument is the handle returned by C. Truncated UDP packets will be retried transparently using TCP while continuing to assert busy to the caller. =head2 debug print 'debug flag: ', $resolver->debug, "\n"; $resolver->debug(1); Get or set the debug flag. If set, calls to C, C, and C will print debugging information on the standard output. The default is false. =head2 defnames print 'defnames flag: ', $resolver->defnames, "\n"; $resolver->defnames(0); Get or set the defnames flag. If true, calls to C will append the default domain to resolve names that are not fully qualified. The default is true. =head2 dnsrch print 'dnsrch flag: ', $resolver->dnsrch, "\n"; $resolver->dnsrch(0); Get or set the dnsrch flag. If true, calls to C will apply the search list to resolve names that are not fully qualified. The default is true. =head2 domain $domain = $resolver->domain; $resolver->domain( 'domain.example' ); Gets or sets the resolver default domain. =head2 igntc print 'igntc flag: ', $resolver->igntc, "\n"; $resolver->igntc(1); Get or set the igntc flag. If true, truncated packets will be ignored. If false, the query will be retried using TCP. The default is false. =head2 nameserver, nameservers @nameservers = $resolver->nameservers(); $resolver->nameservers( '2001:DB8::1', '192.0.2.1' ); $resolver->nameservers( 'ns.domain.example.' ); Gets or sets the nameservers to be queried. Also see the IPv6 transport notes below =head2 persistent_tcp print 'Persistent TCP flag: ', $resolver->persistent_tcp, "\n"; $resolver->persistent_tcp(1); Get or set the persistent TCP setting. If true, L will keep a TCP socket open for each host:port to which it connects. This is useful if you are using TCP and need to make a lot of queries or updates to the same nameserver. The default is false unless you are running a SOCKSified Perl, in which case the default is true. =head2 persistent_udp print 'Persistent UDP flag: ', $resolver->persistent_udp, "\n"; $resolver->persistent_udp(1); Get or set the persistent UDP setting. If true, a L resolver will use the same UDP socket for all queries within each address family. This avoids the cost of creating and tearing down UDP sockets, but also defeats source port randomisation. =head2 port print 'sending queries to port ', $resolver->port, "\n"; $resolver->port(9732); Gets or sets the port to which queries are sent. Convenient for nameserver testing using a non-standard port. The default is port 53. =head2 recurse print 'recursion flag: ', $resolver->recurse, "\n"; $resolver->recurse(0); Get or set the recursion flag. If true, this will direct nameservers to perform a recursive query. The default is true. =head2 retrans print 'retrans interval: ', $resolver->retrans, "\n"; $resolver->retrans(3); Get or set the retransmission interval The default is 5 seconds. =head2 retry print 'number of tries: ', $resolver->retry, "\n"; $resolver->retry(2); Get or set the number of times to try the query. The default is 4. =head2 searchlist @searchlist = $resolver->searchlist; $resolver->searchlist( 'a.example', 'b.example', 'c.example' ); Gets or sets the resolver search list. =head2 srcaddr $resolver->srcaddr('2001::DB8::1'); Sets the source address from which queries are sent. Convenient for forcing queries from a specific interface on a multi-homed host. The default is to use any local address. =head2 srcport $resolver->srcport(5353); Sets the port from which queries are sent. The default is 0, meaning any port. =head2 tcp_timeout print 'TCP timeout: ', $resolver->tcp_timeout, "\n"; $resolver->tcp_timeout(10); Get or set the TCP timeout in seconds. The default is 120 seconds (2 minutes). =head2 udp_timeout print 'UDP timeout: ', $resolver->udp_timeout, "\n"; $resolver->udp_timeout(10); Get or set the bgsend() UDP timeout in seconds. The default is 30 seconds. =head2 udppacketsize print "udppacketsize: ", $resolver->udppacketsize, "\n"; $resolver->udppacketsize(2048); Get or set the UDP packet size. If set to a value not less than the default DNS packet size, an EDNS extension will be added indicating support for large UDP datagrams. =head2 usevc print 'usevc flag: ', $resolver->usevc, "\n"; $resolver->usevc(1); Get or set the usevc flag. If true, queries will be performed using virtual circuits (TCP) instead of datagrams (UDP). The default is false. =head2 replyfrom print 'last response was from: ', $resolver->replyfrom, "\n"; Returns the IP address from which the most recent packet was received in response to a query. =head2 errorstring print 'query status: ', $resolver->errorstring, "\n"; Returns a string containing error information from the most recent DNS protocol interaction. C is meaningful only when interrogated immediately after the corresponding method call. =head2 dnssec print "dnssec flag: ", $resolver->dnssec, "\n"; $resolver->dnssec(0); The dnssec flag causes the resolver to transmit DNSSEC queries and to add a EDNS0 record as required by RFC2671 and RFC3225. The actions of, and response from, the remote nameserver is determined by the settings of the AD and CD flags. Calling the C method with a non-zero value will also set the UDP packet size to the default value of 2048. If that is too small or too big for your environment, you should call the C method immediately after. $resolver->dnssec(1); $resolver->udppacketsize(1250); # adjust UDP packet size A fatal exception will be raised if the C method is called but the L library has not been installed. =head2 adflag $resolver->dnssec(1); $resolver->adflag(1); print "authentication desired flag: ", $resolver->adflag, "\n"; Gets or sets the AD bit for dnssec queries. This bit indicates that the caller is interested in the returned AD (authentic data) bit but does not require any dnssec RRs to be included in the response. The default value is false. =head2 cdflag $resolver->dnssec(1); $resolver->cdflag(1); print "checking disabled flag: ", $resolver->cdflag, "\n"; Gets or sets the CD bit for dnssec queries. This bit indicates that authentication by upstream nameservers should be suppressed. Any dnssec RRs required to execute the authentication procedure should be included in the response. The default value is false. =head2 tsig $resolver->tsig( $keyfile ); $resolver->tsig( $keyfile, fudge => 60 ); $resolver->tsig( $tsig_rr ); $resolver->tsig( undef ); Set the TSIG record used to automatically sign outgoing queries, zone transfers and updates. Automatic signing is disabled if called with undefined arguments. The default resolver behaviour is not to sign any packets. You must call this method to set the key if you would like the resolver to sign and verify packets automatically. Packets can also be signed manually; see the L and L manual pages for examples. TSIG records in manually-signed packets take precedence over those that the resolver would add automatically. =head1 ENVIRONMENT The following environment variables can also be used to configure the resolver: =head2 RES_NAMESERVERS # Bourne Shell RES_NAMESERVERS="2001:DB8::1 192.0.2.1" export RES_NAMESERVERS # C Shell setenv RES_NAMESERVERS "2001:DB8::1 192.0.2.1" A space-separated list of nameservers to query. =head2 RES_SEARCHLIST # Bourne Shell RES_SEARCHLIST="a.example.com b.example.com c.example.com" export RES_SEARCHLIST # C Shell setenv RES_SEARCHLIST "a.example.com b.example.com c.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 inet6" export RES_OPTIONS # C Shell setenv RES_OPTIONS "retrans:3 retry:2 inet6" A space-separated list of resolver options to set. Options that take values are specified as C. =head1 IPv4 TRANSPORT The C, C, C, and C methods with non-zero argument may be used to configure transport selection. The behaviour of the C method illustrates the transport selection mechanism. If, for example, IPv4 transport has been forced, the C method will only return IPv4 addresses: $resolver->nameservers( '192.0.2.1', '192.0.2.2', '2001:DB8::3' ); $resolver->force_v4(1); print join ' ', $resolver->nameservers(); will print 192.0.2.1 192.0.2.2 =head1 CUSTOMISED RESOLVERS 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 can simply add a method to the namespace! For example, if we wanted to cache lookups: package Net::DNS::Resolver; my %cache; sub send { my ( $self, @q ) = @_; return $cache{"@q"} ||= $self->SUPER::send(@q); } =head1 COPYRIGHT Copyright (c)1997-2000 Michael Fuhr. Portions Copyright (c)2002-2004 Chris Reinhardt. Portions Copyright (c)2005 Olaf M. Kolkman, NLnet Labs. Portions Copyright (c)2014,2015 Dick Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L L L L =cut Net-DNS-1.50/lib/Net/DNS/Question.pm0000644000175000017500000002101414756035515016251 0ustar willemwillempackage Net::DNS::Question; use strict; use warnings; our $VERSION = (qw$Id: Question.pm 2002 2025-01-07 09:57:46Z willem $)[2]; =head1 NAME Net::DNS::Question - DNS question record =head1 SYNOPSIS use Net::DNS::Question; $question = Net::DNS::Question->new('example.com', 'AAAA', 'IN'); =head1 DESCRIPTION A Net::DNS::Question object represents a record in the question section of a DNS packet. =cut use integer; use Carp; use Net::DNS::Parameters qw(%classbyname %typebyname :class :type); use Net::DNS::Domain; use Net::DNS::DomainName; =head1 METHODS =head2 new $question = Net::DNS::Question->new('example.com', 'AAAA', 'IN'); $question = Net::DNS::Question->new('example.com', 'A', 'IN'); $question = Net::DNS::Question->new('example.com'); $question = Net::DNS::Question->new('2001::DB8::dead:beef', 'PTR', 'IN'); $question = Net::DNS::Question->new('2001::DB8::dead:beef'); 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 = shift || ''; my $qclass = shift || ''; # tolerate (possibly unknown) type and class in zone file order unless ( exists $classbyname{$qclass} ) { ( $qtype, $qclass ) = ( $qclass, $qtype ) if exists $classbyname{$qtype}; ( $qtype, $qclass ) = ( $qclass, $qtype ) if $qtype =~ /CLASS/; } unless ( exists $typebyname{$qtype} ) { ( $qtype, $qclass ) = ( $qclass, $qtype ) if exists $typebyname{$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->{qname} = Net::DNS::DomainName1035->new($qname); $self->{qtype} = typebyname( $qtype || 'A' ); $self->{qclass} = classbyname( $qclass || 'IN' ); return $self; } =head2 decode $question = Net::DNS::Question->decode(\$data, $offset); ($question, $offset) = Net::DNS::Question->decode(\$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 ( $class, @argument ) = @_; my ( $data, $offset ) = @argument; my $self = bless {}, $class; ( $self->{qname}, $offset ) = Net::DNS::DomainName1035->decode(@argument); my $next = $offset + QFIXEDSZ; die 'corrupt wire-format data' if length $$data < $next; @{$self}{qw(qtype qclass)} = 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, @opaque ) = @_; return pack 'a* n2', $self->{qname}->encode(@opaque), @{$self}{qw(qtype qclass)}; } =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->{qname}->string, $self->qclass, $self->qtype; } =head2 print $object->print; Prints the record to the standard output. Calls the string() method to get the string representation. =cut sub print { print &string, "\n"; return; } =head2 name $name = $question->name; Internationalised domain name corresponding to the qname attribute. Decoding non-ASCII domain names is computationally expensive and undesirable for names which are likely to be used to construct further queries. When required to communicate with humans, the 'proper' domain name should be extracted from a query or reply packet. $query = Net::DNS::Packet->new( $example, 'SOA' ); $reply = $resolver->send($query) or die; ($question) = $reply->question; $name = $question->name; =cut sub name { my ( $self, @argument ) = @_; for (@argument) { croak 'immutable object: argument invalid' } return $self->{qname}->xname; } =head2 qname, zname $qname = $question->qname; $zname = $question->zname; Fully qualified domain name in the form required for a query transmitted to a nameserver. In dynamic update packets, this attribute is known as zname() and refers to the zone name. =cut sub qname { my ( $self, @argument ) = @_; for (@argument) { croak 'immutable object: argument invalid' } return $self->{qname}->name; } sub zname { return &qname; } =head2 qtype, ztype, type $qtype = $question->type; $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, @argument ) = @_; for (@argument) { croak 'immutable object: argument invalid' } return typebyval( $self->{qtype} ); } sub qtype { return &type; } sub ztype { return &type; } =head2 qclass, zclass, class $qclass = $question->class; $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, @argument ) = @_; for (@argument) { croak 'immutable object: argument invalid' } return classbyval( $self->{qclass} ); } sub qclass { return &class; } sub zclass { return &class; } ######################################## sub _dns_addr { ## Map IP address into reverse lookup namespace local $_ = shift; # IP address must contain address characters only s/[%].+$//; # discard RFC4007 scopeid return unless m#^[a-fA-F0-9:./]+$#; my ( $address, $pfxlen ) = split m#/#; # map IPv4 address to in-addr.arpa space if (m#^\d*[.\d]*\d(/\d+)?$#) { my @parse = split /\./, $address; $pfxlen = scalar(@parse) << 3 unless $pfxlen; my $last = $pfxlen > 24 ? 3 : ( $pfxlen - 1 ) >> 3; return join '.', reverse( ( @parse, (0) x 3 )[0 .. $last] ), 'in-addr.arpa.'; } # map IPv6 address to ip6.arpa space return unless m#^[:\w]+:([.\w]*)(/\d+)?$#; my $rhs = $1 || '0'; return _dns_addr($rhs) if m#^[:0]*:0*:[fF]{4}:[^:]+$#; # IPv4 $rhs = sprintf '%x%0.2x:%x%0.2x', map { $_ || 0 } split( /\./, $rhs, 4 ) if /\./; $address =~ s/:[^:]*$/:0$rhs/; my @parse = split /:/, ( reverse "0$address" ), 9; my @xpand = map { /./ ? $_ : ('0') x ( 9 - @parse ) } @parse; # expand :: $pfxlen = ( scalar(@xpand) << 4 ) unless $pfxlen; # implicit length if unspecified my $len = $pfxlen > 124 ? 32 : ( $pfxlen + 3 ) >> 2; my $hex = pack 'A4' x 8, map { $_ . '000' } ('0') x ( 8 - @xpand ), @xpand; return join '.', split( //, substr( $hex, -$len ) ), 'ip6.arpa.'; } 1; __END__ ######################################## =head1 COPYRIGHT Copyright (c)1997-2000 Michael Fuhr. Portions Copyright (c)2002,2003 Chris Reinhardt. Portions Copyright (c)2003,2006-2011 Dick Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut Net-DNS-1.50/lib/Net/DNS/Domain.pm0000644000175000017500000002401014756035515015650 0ustar willemwillempackage Net::DNS::Domain; use strict; use warnings; our $VERSION = (qw$Id: Domain.pm 2002 2025-01-07 09:57:46Z willem $)[2]; =head1 NAME Net::DNS::Domain - DNS domains =head1 SYNOPSIS use Net::DNS::Domain; $domain = Net::DNS::Domain->new('example.com'); $name = $domain->name; =head1 DESCRIPTION The Net::DNS::Domain module implements a class of abstract DNS domain objects with associated class and instance methods. Each domain object instance represents a single DNS domain which has a fixed identity throughout its lifetime. Internally, the primary representation is a (possibly empty) list of ASCII domain name labels, and optional link to an origin domain object topologically closer to the DNS root. The computational expense of Unicode character-set conversion is partially mitigated by use of caches. =cut use integer; use Carp; use constant ASCII => ref eval { require Encode; Encode::find_encoding('ascii'); }; use constant UTF8 => scalar eval { ## not UTF-EBCDIC [see Unicode TR#16 3.6] Encode::encode_utf8( chr(182) ) eq pack( 'H*', 'C2B6' ); }; use constant LIBIDN2 => defined eval { require Net::LibIDN2 }; use constant IDN2FLAG => LIBIDN2 ? &Net::LibIDN2::IDN2_NFC_INPUT + &Net::LibIDN2::IDN2_NONTRANSITIONAL : 0; use constant LIBIDN => LIBIDN2 ? undef : defined eval { require Net::LibIDN }; # perlcc: address of encoding objects must be determined at runtime my $ascii = ASCII ? Encode::find_encoding('ascii') : undef; # Osborn's Law: my $utf8 = UTF8 ? Encode::find_encoding('utf8') : undef; # Variables won't; constants aren't. =head1 METHODS =head2 new $object = Net::DNS::Domain->new('example.com'); Creates a domain object which represents the DNS domain specified by the character string argument. The argument consists of a sequence of labels delimited by dots. A character preceded by \ represents itself, without any special interpretation. Arbitrary 8-bit codes can be represented by \ followed by exactly three decimal digits. Character code points are ASCII, irrespective of the character coding scheme employed by the underlying platform. Argument string literals should be delimited by single quotes to avoid escape sequences being interpreted as octal character codes by the Perl compiler. The character string presentation format follows the conventions for zone files described in RFC1035. Users should be aware that non-ASCII domain names will be transcoded to NFC before encoding, which is an irreversible process. =cut my ( %escape, %unescape ); ## precalculated ASCII escape tables our $ORIGIN; my ( $cache1, $cache2, $limit ) = ( {}, {}, 100 ); sub new { my ( $class, $s ) = @_; croak 'domain identifier undefined' unless defined $s; my $index = join '', $s, $class, $ORIGIN || ''; # cache key my $cache = $$cache1{$index} ||= $$cache2{$index}; # two layer cache return $cache if defined $cache; ( $cache1, $cache2, $limit ) = ( {}, $cache1, 500 ) unless $limit--; # recycle cache my $self = bless {}, $class; $s =~ s/\\\\/\\092/g; # disguise escaped escape $s =~ s/\\\./\\046/g; # disguise escaped dot my $label = $self->{label} = ( $s eq '@' ) ? [] : [split /\056/, _encode_utf8($s)]; foreach (@$label) { croak qq(empty label in "$s") unless length; if ( LIBIDN2 && UTF8 && /[^\000-\177]/ ) { my $rc = 0; $_ = Net::LibIDN2::idn2_to_ascii_8( $_, IDN2FLAG, $rc ); croak Net::LibIDN2::idn2_strerror($rc) unless $_; } if ( LIBIDN && UTF8 && /[^\000-\177]/ ) { $_ = Net::LibIDN::idn_to_ascii( $_, 'utf-8' ); croak 'name contains disallowed character' unless $_; } s/\134([\060-\071]{3})/$unescape{$1}/eg; # restore numeric escapes s/\134([^\134])/$1/g; # restore character escapes s/\134(\134)/$1/g; # restore escaped escapes croak qq(label too long in "$s") if length > 63; } $$cache1{$index} = $self; # cache object reference return $self if $s =~ /\.$/; # fully qualified name $self->{origin} = $ORIGIN || return $self; # dynamically scoped $ORIGIN return $self; } =head2 name $name = $domain->name; Returns the domain name as a character string corresponding to the "common interpretation" to which RFC1034, 3.1, paragraph 9 alludes. Character escape sequences are used to represent a dot inside a domain name label and the escape character itself. Any non-printable code point is represented using the appropriate numerical escape sequence. =cut sub name { my ($self) = @_; return $self->{name} if defined $self->{name}; return unless defined wantarray; my @label = shift->_wire; return $self->{name} = '.' unless scalar @label; for (@label) { s/([^\055\101-\132\141-\172\060-\071])/$escape{$1}/eg; } return $self->{name} = _decode_ascii( join chr(46), @label ); } =head2 fqdn $fqdn = $domain->fqdn; Returns a character string containing the fully qualified domain name, including the trailing dot. =cut sub fqdn { my $name = &name; return $name =~ /[.]$/ ? $name : "$name."; # append trailing dot } =head2 xname $xname = $domain->xname; Interprets an extended name containing Unicode domain name labels encoded as Punycode A-labels. If decoding is not possible, the ACE encoded name is returned. =cut sub xname { my $name = &name; if ( LIBIDN2 && UTF8 && $name =~ /xn--/i ) { my $self = shift; return $self->{xname} if defined $self->{xname}; my $u8 = Net::LibIDN2::idn2_to_unicode_88($name); return $self->{xname} = $u8 ? $utf8->decode($u8) : $name; } if ( LIBIDN && UTF8 && $name =~ /xn--/i ) { my $self = shift; return $self->{xname} if defined $self->{xname}; return $self->{xname} = $utf8->decode( Net::LibIDN::idn_to_unicode $name, 'utf-8' ); } return $name; } =head2 label @label = $domain->label; Identifies the domain by means of a list of domain labels. =cut sub label { my @label = shift->_wire; for (@label) { s/([^\055\101-\132\141-\172\060-\071])/$escape{$1}/eg; _decode_ascii($_); } return @label; } =head2 string $string = $object->string; Returns a character string containing the fully qualified domain name as it appears in a zone file. Characters which are recognised by RFC1035 zone file syntax are represented by the appropriate escape sequence. =cut sub string { return &fqdn } =head2 origin $create = Net::DNS::Domain->origin( $ORIGIN ); $result = &$create( sub{ Net::DNS::RR->new( 'mx MX 10 a' ); } ); $expect = Net::DNS::RR->new( "mx.$ORIGIN. MX 10 a.$ORIGIN." ); Class method which returns a reference to a subroutine wrapper which executes a given constructor in a dynamically scoped context where relative names become descendents of the specified $ORIGIN. =cut my $placebo = sub { my $constructor = shift; &$constructor; }; sub origin { my ( $class, $name ) = @_; my $domain = defined $name ? __PACKAGE__->new($name) : return $placebo; return sub { # closure w.r.t. $domain my $constructor = shift; local $ORIGIN = $domain; # dynamically scoped $ORIGIN &$constructor; } } ######################################## sub _decode_ascii { ## ASCII to perl internal encoding local $_ = shift; # partial transliteration for non-ASCII character encodings tr [\040-\176\000-\377] [ !"#$%&'()*+,\-./0-9:;<=>?@A-Z\[\\\]^_`a-z{|}~?] unless ASCII; my $z = length($_) - length($_); # pre-5.18 taint workaround return ASCII ? substr( $ascii->decode($_), $z ) : $_; } sub _encode_utf8 { ## perl internal encoding to UTF8 local $_ = shift; # partial transliteration for non-ASCII character encodings tr [ !"#$%&'()*+,\-./0-9:;<=>?@A-Z\[\\\]^_`a-z{|}~\000-\377] [\040-\176\077] unless ASCII; my $z = length($_) - length($_); # pre-5.18 taint workaround return ASCII ? substr( ( UTF8 ? $utf8 : $ascii )->encode($_), $z ) : $_; } sub _wire { my $self = shift; my $label = $self->{label}; my $origin = $self->{origin}; return ( @$label, $origin ? $origin->_wire : () ); } %escape = eval { ## precalculated ASCII escape table my %table = map { ( chr($_) => chr($_) ) } ( 0 .. 127 ); foreach my $n ( 0 .. 32, 34, 92, 127 .. 255 ) { # \ddd my $codepoint = sprintf( '%03u', $n ); # transliteration for non-ASCII character encodings $codepoint =~ tr [0-9] [\060-\071]; $table{pack( 'C', $n )} = pack 'C a3', 92, $codepoint; } foreach my $n ( 40, 41, 46, 59 ) { # character escape $table{chr($n)} = pack( 'C2', 92, $n ); } return %table; }; %unescape = eval { ## precalculated numeric escape table my %table; foreach my $n ( 0 .. 255 ) { my $key = sprintf( '%03u', $n ); # transliteration for non-ASCII character encodings $key =~ tr [0-9] [\060-\071]; $table{$key} = pack 'C', $n; } $table{"\060\071\062"} = pack 'C2', 92, 92; # escaped escape 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,2017 Dick Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L =cut Net-DNS-1.50/lib/Net/DNS/Parameters.pm0000644000175000017500000003577014756035515016563 0ustar willemwillempackage Net::DNS::Parameters; ################################################ ## ## Domain Name System (DNS) Parameters ## (last updated 2024-12-10) ## ################################################ use strict; use warnings; our $VERSION = (qw$Id: Parameters.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use integer; use Carp; use base qw(Exporter); our @EXPORT_OK = qw( classbyname classbyval %classbyname typebyname typebyval %typebyname opcodebyname opcodebyval rcodebyname rcodebyval ednsoptionbyname ednsoptionbyval dsotypebyname dsotypebyval ); our %EXPORT_TAGS = ( class => [qw(classbyname classbyval)], type => [qw(typebyname typebyval)], opcode => [qw(opcodebyname opcodebyval)], rcode => [qw(rcodebyname rcodebyval)], ednsoption => [qw(ednsoptionbyname ednsoptionbyval)], dsotype => [qw(dsotypebyname dsotypebyval)], ); # Registry: DNS CLASSes my @classbyname = ( IN => 1, # RFC1035 CH => 3, # Chaosnet HS => 4, # Hesiod NONE => 254, # RFC2136 ANY => 255, # RFC1035 ); our %classbyval = reverse( CLASS0 => 0, @classbyname ); push @classbyname, map { /^\d/ ? $_ : lc($_) } @classbyname; our %classbyname = ( '*' => 255, @classbyname ); # Registry: Resource Record (RR) TYPEs my @typebyname = ( A => 1, # RFC1035 NS => 2, # RFC1035 MD => 3, # RFC1035 MF => 4, # RFC1035 CNAME => 5, # RFC1035 SOA => 6, # RFC1035 MB => 7, # RFC1035 MG => 8, # RFC1035 MR => 9, # RFC1035 NULL => 10, # RFC1035 WKS => 11, # RFC1035 PTR => 12, # RFC1035 HINFO => 13, # RFC1035 MINFO => 14, # RFC1035 MX => 15, # RFC1035 TXT => 16, # RFC1035 RP => 17, # RFC1183 AFSDB => 18, # RFC1183 RFC5864 X25 => 19, # RFC1183 ISDN => 20, # RFC1183 RT => 21, # RFC1183 NSAP => 22, # RFC1706 https://datatracker.ietf.org/doc/status-change-int-tlds-to-historic 'NSAP-PTR' => 23, # RFC1706 https://datatracker.ietf.org/doc/status-change-int-tlds-to-historic SIG => 24, # RFC2536 RFC2931 RFC3110 RFC4034 KEY => 25, # RFC2536 RFC2539 RFC3110 RFC4034 PX => 26, # RFC2163 GPOS => 27, # RFC1712 AAAA => 28, # RFC3596 LOC => 29, # RFC1876 NXT => 30, # RFC2535 RFC3755 EID => 31, # http://ana-3.lcs.mit.edu/~jnc/nimrod/dns.txt NIMLOC => 32, # http://ana-3.lcs.mit.edu/~jnc/nimrod/dns.txt SRV => 33, # RFC2782 ATMA => 34, # http://www.broadband-forum.org/ftp/pub/approved-specs/af-dans-0152.000.pdf NAPTR => 35, # RFC3403 KX => 36, # RFC2230 CERT => 37, # RFC4398 A6 => 38, # RFC2874 RFC3226 RFC6563 DNAME => 39, # RFC6672 SINK => 40, # draft-eastlake-kitchen-sink-02 OPT => 41, # RFC3225 RFC6891 APL => 42, # RFC3123 DS => 43, # RFC4034 SSHFP => 44, # RFC4255 IPSECKEY => 45, # RFC4025 RRSIG => 46, # RFC4034 NSEC => 47, # RFC4034 RFC9077 DNSKEY => 48, # RFC4034 DHCID => 49, # RFC4701 NSEC3 => 50, # RFC5155 RFC9077 NSEC3PARAM => 51, # RFC5155 TLSA => 52, # RFC6698 SMIMEA => 53, # RFC8162 HIP => 55, # RFC8005 NINFO => 56, # RKEY => 57, # TALINK => 58, # CDS => 59, # RFC7344 CDNSKEY => 60, # RFC7344 OPENPGPKEY => 61, # RFC7929 CSYNC => 62, # RFC7477 ZONEMD => 63, # RFC8976 SVCB => 64, # RFC9460 HTTPS => 65, # RFC9460 DSYNC => 66, # draft-ietf-dnsop-generalized-notify-03 SPF => 99, # RFC7208 UINFO => 100, # IANA-Reserved UID => 101, # IANA-Reserved GID => 102, # IANA-Reserved UNSPEC => 103, # IANA-Reserved NID => 104, # RFC6742 L32 => 105, # RFC6742 L64 => 106, # RFC6742 LP => 107, # RFC6742 EUI48 => 108, # RFC7043 EUI64 => 109, # RFC7043 NXNAME => 128, # draft-ietf-dnsop-compact-denial-of-existence-04 TKEY => 249, # RFC2930 TSIG => 250, # RFC8945 IXFR => 251, # RFC1995 AXFR => 252, # RFC1035 RFC5936 MAILB => 253, # RFC1035 MAILA => 254, # RFC1035 ANY => 255, # RFC1035 RFC6895 RFC8482 URI => 256, # RFC7553 CAA => 257, # RFC8659 AVC => 258, # DOA => 259, # draft-durand-doa-over-dns-02 AMTRELAY => 260, # RFC8777 RESINFO => 261, # RFC9606 WALLET => 262, # CLA => 263, # draft-johnson-dns-ipn-cla-07 IPN => 264, # draft-johnson-dns-ipn-cla-07 TA => 32768, # http://www.watson.org/~weiler/INI1999-19.pdf DLV => 32769, # RFC8749 RFC4431 ); our %typebyval = reverse( TYPE0 => 0, @typebyname ); push @typebyname, map { /^\d/ ? $_ : lc($_) } @typebyname; our %typebyname = ( '*' => 255, @typebyname ); # Registry: DNS OpCodes my @opcodebyname = ( QUERY => 0, # RFC1035 IQUERY => 1, # RFC3425 STATUS => 2, # RFC1035 NOTIFY => 4, # RFC1996 UPDATE => 5, # RFC2136 DSO => 6, # RFC8490 ); our %opcodebyval = reverse @opcodebyname; push @opcodebyname, map { /^\d/ ? $_ : lc($_) } @opcodebyname; our %opcodebyname = ( NS_NOTIFY_OP => 4, @opcodebyname ); # Registry: DNS RCODEs my @rcodebyname = ( NOERROR => 0, # RFC1035 FORMERR => 1, # RFC1035 SERVFAIL => 2, # RFC1035 NXDOMAIN => 3, # RFC1035 NOTIMP => 4, # RFC1035 REFUSED => 5, # RFC1035 YXDOMAIN => 6, # RFC2136 RFC6672 YXRRSET => 7, # RFC2136 NXRRSET => 8, # RFC2136 NOTAUTH => 9, # RFC2136 NOTAUTH => 9, # RFC8945 NOTZONE => 10, # RFC2136 DSOTYPENI => 11, # RFC8490 BADVERS => 16, # RFC6891 BADSIG => 16, # RFC8945 BADKEY => 17, # RFC8945 BADTIME => 18, # RFC8945 BADMODE => 19, # RFC2930 BADNAME => 20, # RFC2930 BADALG => 21, # RFC2930 BADTRUNC => 22, # RFC8945 BADCOOKIE => 23, # RFC7873 ); our %rcodebyval = reverse( BADSIG => 16, @rcodebyname ); push @rcodebyname, map { /^\d/ ? $_ : lc($_) } @rcodebyname; our %rcodebyname = @rcodebyname; # Registry: DNS EDNS0 Option Codes (OPT) my @ednsoptionbyname = ( LLQ => 1, # RFC8764 'UPDATE-LEASE' => 2, # RFC-ietf-dnssd-update-lease-08 NSID => 3, # RFC5001 DAU => 5, # RFC6975 DHU => 6, # RFC6975 N3U => 7, # RFC6975 'CLIENT-SUBNET' => 8, # RFC7871 EXPIRE => 9, # RFC7314 COOKIE => 10, # RFC7873 'TCP-KEEPALIVE' => 11, # RFC7828 PADDING => 12, # RFC7830 CHAIN => 13, # RFC7901 'KEY-TAG' => 14, # RFC8145 'EXTENDED-ERROR' => 15, # RFC8914 'CLIENT-TAG' => 16, # draft-bellis-dnsop-edns-tags-01 'SERVER-TAG' => 17, # draft-bellis-dnsop-edns-tags-01 'REPORT-CHANNEL' => 18, # RFC9567 ZONEVERSION => 19, # RFC9660 'UMBRELLA-IDENT' => 20292, # https://developer.cisco.com/docs/cloud-security/#!integrating-network-devic DEVICEID => 26946, # https://developer.cisco.com/docs/cloud-security/#!network-devices-getting-s ); our %ednsoptionbyval = reverse @ednsoptionbyname; push @ednsoptionbyname, map { /^\d/ ? $_ : lc($_) } @ednsoptionbyname; our %ednsoptionbyname = @ednsoptionbyname; # Registry: DNS Header Flags my @dnsflagbyname = ( AA => 0x0400, # RFC1035 TC => 0x0200, # RFC1035 RD => 0x0100, # RFC1035 RA => 0x0080, # RFC1035 AD => 0x0020, # RFC4035 RFC6840 CD => 0x0010, # RFC4035 RFC6840 ); push @dnsflagbyname, map { /^\d/ ? $_ : lc($_) } @dnsflagbyname; our %dnsflagbyname = @dnsflagbyname; # Registry: EDNS Header Flags (16 bits) my @ednsflagbyname = ( DO => 0x8000, # RFC4035 RFC3225 RFC6840 ); push @ednsflagbyname, map { /^\d/ ? $_ : lc($_) } @ednsflagbyname; our %ednsflagbyname = @ednsflagbyname; # Registry: DSO Type Codes my @dsotypebyname = ( KEEPALIVE => 0x0001, # RFC8490 RETRYDELAY => 0x0002, # RFC8490 ENCRYPTIONPADDING => 0x0003, # RFC8490 SUBSCRIBE => 0x0040, # RFC8765 PUSH => 0x0041, # RFC8765 UNSUBSCRIBE => 0x0042, # RFC8765 RECONFIRM => 0x0043, # RFC8765 ); our %dsotypebyval = reverse @dsotypebyname; push @dsotypebyname, map { /^\d/ ? $_ : lc($_) } @dsotypebyname; our %dsotypebyname = @dsotypebyname; # Registry: Extended DNS Error Codes my @dnserrorbyval = ( 0 => 'Other Error', # RFC8914 1 => 'Unsupported DNSKEY Algorithm', # RFC8914 2 => 'Unsupported DS Digest Type', # RFC8914 3 => 'Stale Answer', # RFC8914 RFC8767 4 => 'Forged Answer', # RFC8914 5 => 'DNSSEC Indeterminate', # RFC8914 6 => 'DNSSEC Bogus', # RFC8914 7 => 'Signature Expired', # RFC8914 8 => 'Signature Not Yet Valid', # RFC8914 9 => 'DNSKEY Missing', # RFC8914 10 => 'RRSIGs Missing', # RFC8914 11 => 'No Zone Key Bit Set', # RFC8914 12 => 'NSEC Missing', # RFC8914 13 => 'Cached Error', # RFC8914 14 => 'Not Ready', # RFC8914 15 => 'Blocked', # RFC8914 16 => 'Censored', # RFC8914 17 => 'Filtered', # RFC8914 18 => 'Prohibited', # RFC8914 19 => 'Stale NXDomain Answer', # RFC8914 20 => 'Not Authoritative', # RFC8914 21 => 'Not Supported', # RFC8914 22 => 'No Reachable Authority', # RFC8914 23 => 'Network Error', # RFC8914 24 => 'Invalid Data', # RFC8914 25 => 'Signature Expired before Valid', # https://github.com/NLnetLabs/unbound/pull/604#discussion_r802678343 26 => 'Too Early', # RFC9250 27 => 'Unsupported NSEC3 Iterations Value', # RFC9276 28 => 'Unable to conform to policy', # draft-homburg-dnsop-codcp-00 29 => 'Synthesized', # https://github.com/PowerDNS/pdns/pull/12334 30 => 'Invalid Query Type', # draft-ietf-dnsop-compact-denial-of-existence-04 ); our %dnserrorbyval = @dnserrorbyval; ######## # The following functions are wrappers around similarly named hashes. sub classbyname { my $name = shift; return $classbyname{$name} || $classbyname{uc $name} || return do { croak qq[unknown class "$name"] unless $name =~ m/^(CLASS)?(\d+)/i; my $val = 0 + $2; croak qq[classbyname("$name") out of range] if $val > 0x7fff; return $val; } } sub classbyval { my $arg = shift; return $classbyval{$arg} || return do { my $val = ( $arg += 0 ) & 0x7fff; # MSB used by mDNS croak qq[classbyval($arg) out of range] if $arg > 0xffff; return $classbyval{$arg} = $classbyval{$val} || "CLASS$val"; } } sub typebyname { my $name = shift; return $typebyname{$name} || return do { if ( $name =~ m/^(TYPE)?(\d+)/i ) { my $val = 0 + $2; croak qq[typebyname("$name") out of range] if $val > 0xffff; return $val; } _typespec("$name.RRNAME") unless $typebyname{uc $name}; return $typebyname{uc $name} || croak qq[unknown type "$name"]; } } sub typebyval { my $val = shift; return $typebyval{$val} || return do { $val += 0; croak qq[typebyval($val) out of range] if $val > 0xffff; $typebyval{$val} = "TYPE$val"; _typespec("$val.RRTYPE"); return $typebyval{$val}; } } sub opcodebyname { my $arg = shift; my $val = $opcodebyname{$arg}; return $val if defined $val; return $arg if $arg =~ /^\d/; croak qq[unknown opcode "$arg"]; } sub opcodebyval { my $val = shift; return $opcodebyval{$val} || return "$val"; } sub rcodebyname { my $arg = shift; my $val = $rcodebyname{$arg}; return $val if defined $val; return $arg if $arg =~ /^\d/; croak qq[unknown rcode "$arg"]; } sub rcodebyval { my $val = shift; return $rcodebyval{$val} || return "$val"; } sub ednsoptionbyname { my $arg = shift; my $val = $ednsoptionbyname{$arg}; return $val if defined $val; return $arg if $arg =~ /^\d/; croak qq[unknown option "$arg"]; } sub ednsoptionbyval { my $val = shift; return $ednsoptionbyval{$val} || return "$val"; } sub dsotypebyname { my $arg = shift; my $val = $dsotypebyname{$arg}; return $val if defined $val; return $arg if $arg =~ /^\d/; croak qq[unknown DSO type "$arg"]; } sub dsotypebyval { my $val = shift; return $dsotypebyval{$val} || return "$val"; } use constant EXTLANG => defined eval { require Net::DNS::Extlang }; sub _typespec { my $generate = defined wantarray; return EXTLANG ? eval <<'END' : ''; ## no critic my ($node) = @_; ## draft-levine-dnsextlang my $instance = Net::DNS::Extlang->new(); my $basename = $instance->domain || return ''; require Net::DNS::Resolver; my $resolver = Net::DNS::Resolver->new(); my $response = $resolver->send( "$node.$basename", 'TXT' ) || return ''; foreach my $txt ( grep { $_->type eq 'TXT' } $response->answer ) { my @stanza = $txt->txtdata; my ( $tag, $identifier, @attribute ) = @stanza; next unless defined($tag) && $tag =~ /^RRTYPE=\d+$/; if ( $identifier =~ /^(\w+):(\d+)\W*/ ) { my ( $mnemonic, $rrtype ) = ( uc($1), $2 ); croak qq["$mnemonic" is a CLASS identifier] if $classbyname{$mnemonic}; for ( typebyval($rrtype) ) { next if /^$mnemonic$/i; # duplicate registration croak qq["$mnemonic" conflicts with TYPE$rrtype ($_)] unless /^TYPE\d+$/; my $known = $typebyname{$mnemonic}; croak qq["$mnemonic" conflicts with TYPE$known] if $known; $typebyval{$rrtype} = $mnemonic; $typebyname{$mnemonic} = $rrtype; } } return unless $generate; my $recipe = $instance->xlstorerecord( $identifier, @attribute ); return $instance->compilerr($recipe); } END } 1; __END__ =head1 NAME Net::DNS::Parameters - DNS parameter assignments =head1 SYNOPSIS use Net::DNS::Parameters; =head1 DESCRIPTION Net::DNS::Parameters is a Perl package representing the DNS parameter allocation (key,value) tables as recorded in the definitive registry maintained and published by IANA. =head1 FUNCTIONS =head2 classbyname, typebyname, opcodebyname, rcodebyname, ednsoptionbyname, dsotypebyname Access functions which return the numerical code corresponding to the given mnemonic. =head2 classbyval, typebyval, opcodebyval, rcodebyval, ednsoptionbyval, dsotypebyval Access functions which return the canonical mnemonic corresponding to the given numerical code. =head1 COPYRIGHT Copyright (c)2012,2016 Dick Franks. Portions Copyright (c)1997 Michael Fuhr. Portions Copyright (c)2003 Olaf Kolkman. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L, L, L =cut Net-DNS-1.50/lib/Net/DNS/Nameserver.pm0000644000175000017500000005365314756035515016567 0ustar willemwillempackage Net::DNS::Nameserver; use strict; use warnings; our $VERSION = (qw$Id: Nameserver.pm 2002 2025-01-07 09:57:46Z willem $)[2]; =head1 NAME Net::DNS::Nameserver - DNS server class =head1 SYNOPSIS use Net::DNS::Nameserver; my $nameserver = Net::DNS::Nameserver->new( LocalAddr => ['::1', '127.0.0.1'], LocalPort => 15353, ZoneFile => 'filename' ); my $nameserver = Net::DNS::Nameserver->new( LocalAddr => '10.1.2.3', LocalPort => 15353, ReplyHandler => \&reply_handler ); $nameserver->start_server($timeout); $nameserver->stop_server; =head1 DESCRIPTION Net::DNS::Nameserver offers a simple mechanism for instantiation of customised DNS server objects intended to provide test responses to queries emanating from a client resolver. It is not, nor will it ever be, a general-purpose DNS nameserver implementation. See L below for further details. =cut use integer; use Carp; use Net::DNS; use Net::DNS::ZoneFile; use IO::Select; use IO::Socket::IP; use IO::Socket; use Socket; use constant SOCKOPT => eval { my @sockopt; push @sockopt, eval '[SOL_SOCKET, SO_REUSEADDR]'; ## no critic push @sockopt, eval '[SOL_SOCKET, SO_REUSEPORT]'; ## no critic my $filter = sub { # check that options safe to use return eval { IO::Socket::IP->new( Proto => "udp", Sockopts => [shift], Type => SOCK_DGRAM ) } }; return grep { &$filter($_) } @sockopt; # without any guarantee that they work! }; use constant DEFAULT_ADDR => qw(::1 127.0.0.1); use constant DEFAULT_PORT => 15353; use constant POSIX => defined eval 'use POSIX ":sys_wait_h"; 1'; ## no critic use constant MSWin => scalar( $^O =~ /MSWin/i ); #------------------------------------------------------------------------------ # Constructor. #------------------------------------------------------------------------------ sub new { my ( $class, %config ) = @_; my %self = ( LocalAddr => [DEFAULT_ADDR], LocalPort => [DEFAULT_PORT], Truncate => 1, %config ); my $self = bless \%self, $class; $self->_ReadZoneFile( $self{ZoneFile} ) if exists $self{ZoneFile}; croak 'No reply handler!' unless ref( $self{ReplyHandler} ) eq "CODE"; # local server addresses need to be accepted by a resolver my $LocalAddr = $self{LocalAddr}; my $resolver = Net::DNS::Resolver->new( nameservers => $LocalAddr ); $resolver->force_v4( $self{Force_IPv4} ); $resolver->force_v6( $self{Force_IPv6} ); $self{LocalAddr} = [$resolver->nameservers]; return $self; } #------------------------------------------------------------------------------ # _ReadZoneFile - Read zone file used by default reply handler #------------------------------------------------------------------------------ sub _ReadZoneFile { my ( $self, $file ) = @_; my $zonefile = Net::DNS::ZoneFile->new($file); my $RRhash = $self->{index} = {}; my $RRlist = []; my @zonelist; while ( my $rr = $zonefile->read ) { push @{$RRhash->{lc $rr->owner}}, $rr; # Warning: Nasty trick abusing SOA to reference zone RR list if ( $rr->type eq 'SOA' ) { $RRlist = $rr->{RRlist} = []; push @zonelist, lc $rr->owner; } else { push @$RRlist, $rr; } } $self->{namelist} = [sort { length($b) <=> length($a) } keys %$RRhash]; $self->{zonelist} = [sort { length($b) <=> length($a) } @zonelist]; $self->{ReplyHandler} = sub { $self->_ReplyHandler(@_) }; return; } #------------------------------------------------------------------------------ # _ReplyHandler - Default reply handler serving RRs from zone file #------------------------------------------------------------------------------ sub _ReplyHandler { my ( $self, $qname, $qclass, $qtype, $peerhost, $query, $conn ) = @_; my $RRhash = $self->{index}; my $rcode; my %headermask; my @ans; my @auth; if ( $qtype eq 'AXFR' ) { my $RRlist = $RRhash->{lc $qname} || []; my ($soa) = grep { $_->type eq 'SOA' } @$RRlist; if ($soa) { $rcode = 'NOERROR'; push @ans, $soa, @{$soa->{RRlist}}, $soa; } else { $rcode = 'NOTAUTH'; } return ( $rcode, \@ans, [], [], {}, {} ); } my @RRname = @{$self->{namelist}}; # pre-sorted, longest first { my $RRlist = $RRhash->{lc $qname} || []; # hash, then linear search my @match = @$RRlist; # assume $qclass always 'IN' if ( scalar(@match) ) { # exact match $rcode = 'NOERROR'; } elsif ( grep {/\.$qname$/i} @RRname ) { # empty non-terminal $rcode = 'NOERROR'; # [NODATA] } else { $rcode = 'NXDOMAIN'; foreach ( grep {/^[*][.]/} @RRname ) { my $wildcard = $_; # match wildcard per RFC4592 s/^\*//; # delete leading asterisk s/([.?*+])/\\$1/g; # escape dots and regex quantifiers next unless $qname =~ /[.]?([^.]+$_)$/i; my $cover = $1; # check for name covering wildcard next if grep {/[.]?$cover$/i} @RRname; my ($q) = $query->question; # synthesise RR at qname foreach my $rr ( @{$RRhash->{$wildcard}} ) { my $clone = bless( {%$rr}, ref($rr) ); $clone->{owner} = $q->{qname}; push @match, $clone; } $rcode = 'NOERROR'; last; } } push @ans, my @cname = grep { $_->type eq 'CNAME' } @match; $qname = $_->cname for @cname; redo if @cname; push @ans, @match if $qtype eq 'ANY'; # traditional, now out of favour push @ans, grep { $_->type eq $qtype } @match; unless (@ans) { foreach ( @{$self->{zonelist}} ) { my $RRlist = $RRhash->{lc $_}; s/([.?*+])/\\$1/g; # escape dots and regex quantifiers next unless $qname =~ /[^.]+[.]$_[.]?$/i; push @auth, grep { $_->type eq 'SOA' } @$RRlist; last; } } $headermask{aa} = 1; } return ( $rcode, \@ans, \@auth, [], \%headermask, {} ); } #------------------------------------------------------------------------------ # _make_reply - Make a reply packet. #------------------------------------------------------------------------------ sub _make_reply { my ( $self, $query, $sock ) = @_; my $verbose = $self->{Verbose}; unless ($query) { my $empty = Net::DNS::Packet->new(); # create empty reply packet my $reply = $empty->reply(); $reply->header->rcode("FORMERR"); return $reply; } if ( $query->header->qr() ) { print "ERROR: invalid packet (qr set), dropping\n" if $verbose; return; } my $reply = $query->reply(); my $header = $reply->header; my $headermask; my $optionmask; my $opcode = $query->header->opcode; my $qdcount = $query->header->qdcount; unless ($qdcount) { $header->rcode("NOERROR"); } elsif ( $qdcount > 1 ) { $header->rcode("FORMERR"); } else { my ($qr) = $query->question; my $qname = $qr->qname; my $qtype = $qr->qtype; my $qclass = $qr->qclass; print $qr->string, "\n" if $verbose; my $conn = { peerhost => my $peer = $sock->peerhost, peerport => $sock->peerport, protocol => $sock->protocol, sockhost => $sock->sockhost, sockport => $sock->sockport }; my ( $rcode, $ans, $auth, $add ); my @arglist = ( $qname, $qclass, $qtype, $peer, $query, $conn ); if ( $opcode eq "QUERY" ) { ( $rcode, $ans, $auth, $add, $headermask, $optionmask ) = &{$self->{ReplyHandler}}(@arglist); } elsif ( $opcode eq "NOTIFY" ) { #RFC1996 if ( ref $self->{NotifyHandler} eq "CODE" ) { ( $rcode, $ans, $auth, $add, $headermask, $optionmask ) = &{$self->{NotifyHandler}}(@arglist); } else { $rcode = "NOTIMP"; } } elsif ( $opcode eq "UPDATE" ) { #RFC2136 if ( ref $self->{UpdateHandler} eq "CODE" ) { ( $rcode, $ans, $auth, $add, $headermask, $optionmask ) = &{$self->{UpdateHandler}}(@arglist); } else { $rcode = "NOTIMP"; } } else { print "ERROR: opcode $opcode unsupported\n" if $verbose; $rcode = "FORMERR"; } if ( !defined($rcode) ) { print "remaining silent\n" if $verbose; return; } $header->rcode($rcode); push @{$reply->{answer}}, @$ans if $ans; push @{$reply->{authority}}, @$auth if $auth; push @{$reply->{additional}}, @$add if $add; } while ( my ( $key, $value ) = each %{$headermask || {}} ) { $header->$key($value); } while ( my ( $option, $value ) = each %{$optionmask || {}} ) { $reply->edns->option( $option, $value ); } $header->print if $verbose && ( $headermask || $optionmask ); return $reply; } #------------------------------------------------------------------------------ # _TCP_connection - Handle a TCP connection. #------------------------------------------------------------------------------ sub _TCP_connection { my ( $self, $socket, $buffer ) = @_; my $verbose = $self->{Verbose}; my $query = Net::DNS::Packet->new( \$buffer ); if ($@) { print "Error decoding query packet: $@\n" if $verbose; undef $query; ## force FORMERR reply } my $reply = $self->_make_reply( $query, $socket ); die 'Failed to create reply' unless defined $reply; my $segment = $reply->data; my $length = length $segment; if ($verbose) { print "TCP response (2 + $length octets) - "; print $socket->send( pack 'na*', $length, $segment ) ? "sent" : "failed: $!", "\n"; } else { $socket->send( pack 'na*', $length, $segment ); } return; } sub _read_tcp { my ( $socket, $verbose ) = @_; my $header = ''; local $! = 0; my $n = sysread( $socket, $header, 2 ); unless ( defined $n ) { redo if $!{EINTR}; ## retry if aborted by signal die "sysread: $!"; } return '' if $n == 0; return '' if length($header) < 2; my $msglen = unpack 'n', $header; my $buffer = ''; while ( $msglen > ( my $len = length $buffer ) ) { local $! = 0; my $n = sysread( $socket, $buffer, ( $msglen - $len ), $len ); unless ( defined $n ) { redo if $!{EINTR}; ## retry if aborted by signal die "sysread: $!"; } last if $n == 0; ## client closed (or lied) per RT#151240 } if ($verbose) { my $peer = $socket->peerhost; my $port = $socket->peerport; my $size = length $buffer; print "Received $size octets from [$peer] port $port\n"; } return $buffer; } #------------------------------------------------------------------------------ # _UDP_connection - Handle a UDP connection. #------------------------------------------------------------------------------ sub _UDP_connection { my ( $self, $socket, $buffer ) = @_; my $verbose = $self->{Verbose}; my $query = Net::DNS::Packet->new( \$buffer ); if ($@) { print "Error decoding query packet: $@\n" if $verbose; undef $query; ## force FORMERR reply } my $reply = $self->_make_reply( $query, $socket ); die 'Failed to create reply' unless defined $reply; my @UDPsize = ( $query && $self->{Truncate} ) ? $query->edns->UDPsize || 512 : (); if ($verbose) { my $response = $reply->data(@UDPsize); print 'UDP response (', length($response), ' octets) - '; print $socket->send($response) ? "sent" : "failed: $!", "\n"; } else { $socket->send( $reply->data(@UDPsize) ); } return; } sub _read_udp { my ( $socket, $verbose ) = @_; my $buffer = ''; $socket->recv( $buffer, 9000 ); ## payload limit for Ethernet "Jumbo" packet if ($verbose) { my $peer = $socket->peerhost; my $port = $socket->peerport; my $size = length $buffer; print "Received $size octets from [$peer] port $port\n"; } return $buffer; } #------------------------------------------------------------------------------ # Socket mechanics. #------------------------------------------------------------------------------ use constant DEBUG => $ENV{DEBUG} ? 1 : 0; sub _logmsg { warn( join '', "$0 $$: @_ at ", scalar localtime(), "\n" ); return } sub _TCP_socket { my ( $ip, $port ) = @_; my $socket = IO::Socket::IP->new( LocalAddr => $ip, LocalPort => $port, Sockopt => [SOCKOPT], Proto => "tcp", Listen => SOMAXCONN, Type => SOCK_STREAM ) or die "can't setup TCP socket: $!"; _logmsg "TCP server [$ip] port $port" if DEBUG; return $socket; } sub _TCP_server { my ( $self, $ip, $port, $timeout ) = @_; my $listen = _TCP_socket( $ip, $port ); my $select = IO::Select->new($listen); my $expired; my $terminate = sub { $expired++ }; local $SIG{ALRM} = $terminate; local $SIG{TERM} = $terminate; alarm $timeout; until ($expired) { local $! = 0; scalar( my @ready = $select->can_read(2) ) or do { redo if $!{EINTR}; ## retry if aborted by signal last if $!; }; foreach my $socket (@ready) { if ( $socket == $listen ) { $select->add( $listen->accept ); next; } if ( my $buffer = _read_tcp( $socket, $self->{Verbose} ) ) { _spawn( sub { $self->_TCP_connection( $socket, $buffer ) } ); } else { close($socket); $select->remove($socket); } } sleep(0) if MSWin; } return; } sub _UDP_socket { my ( $ip, $port ) = @_; my $socket = IO::Socket::IP->new( LocalAddr => $ip, LocalPort => $port, Sockopt => [SOCKOPT], Proto => "udp", Type => SOCK_DGRAM ) or die "can't setup UDP socket: $!"; _logmsg "UDP server [$ip] port $port" if DEBUG; return $socket; } sub _UDP_server { my ( $self, $ip, $port, $timeout ) = @_; my $socket = _UDP_socket( $ip, $port ); my $select = IO::Select->new($socket); my $expired; my $terminate = sub { $expired++ }; local $SIG{ALRM} = $terminate; local $SIG{TERM} = $terminate; alarm $timeout; until ($expired) { local $! = 0; scalar( my @ready = $select->can_read(2) ) or do { redo if $!{EINTR}; ## retry if aborted by signal last if $!; }; foreach my $client (@ready) { my $buffer = _read_udp( $client, $self->{Verbose} ); _spawn( sub { $self->_UDP_connection( $client, $buffer ) } ); } sleep(0) if MSWin; } return; } #------------------------------------------------------------------------------ # Process mechanics. #------------------------------------------------------------------------------ my $noop = sub { }; sub _spawn { my $coderef = shift; unless ( defined( my $pid = fork() ) ) { die "cannot fork: $!"; } elsif ($pid) { _logmsg "begat $pid" if DEBUG; return $pid; ## parent } # else ... local $SIG{TERM} = $noop; local $SIG{CHLD} = \&_reaper; $coderef->(); ## child exit; } sub _reaper { local ( $!, $? ); ## protect error and exit status $SIG{CHLD} = \&_reaper; ## no critic sysV semantics while ( abs( my $pid = waitpid( -1, POSIX ? WNOHANG : 0 ) ) > 1 ) { _logmsg "reaped $pid" if DEBUG; } return; } our @pid; my $pid = $$; sub start_server { my ( $self, $timeout ) = @_; $timeout ||= 600; croak 'Attempt to start ', ref($self), ' in a subprocess' unless $$ == $pid; _logmsg('start server') if DEBUG; foreach my $ip ( @{$self->{LocalAddr}} ) { my $port = $self->{LocalPort}; push @pid, _spawn sub { $self->_TCP_server( $ip, $port, $timeout ) }; push @pid, _spawn sub { $self->_UDP_server( $ip, $port, $timeout ) }; } return; } sub stop_server { _logmsg('stop server') if DEBUG; kill 'TERM', @pid; return; } END { local ( $!, $? ); ## protect error and exit status while ( abs( my $pid = waitpid( -1, 0 ) ) > 1 ) { _logmsg "reaped $pid" if DEBUG; } _logmsg "terminated" if DEBUG; } 1; __END__ =head1 METHODS =head2 new $nameserver = Net::DNS::Nameserver->new( LocalAddr => ['::1', '127.0.0.1'], LocalPort => 15353, ZoneFile => "filename" ); $nameserver = Net::DNS::Nameserver->new( LocalAddr => '10.1.2.3', LocalPort => 15353, ReplyHandler => \&reply_handler, Verbose => 1, Truncate => 0 ); Instantiates a Net::DNS::Nameserver object. An exception is raised if the object could not be created. Each instance is configured using the following optional arguments: =over 4 =item LocalAddr IP address on which to listen. Defaults to the local loopback address. =item LocalPort Port on which to listen. =item ZoneFile Name of file containing RRs accessed using the internal reply-handling subroutine. =item ReplyHandler Reference to customised reply-handling subroutine. =item NotifyHandler Reference to reply-handling subroutine for queries with opcode NOTIFY (RFC1996). =item UpdateHandler Reference to reply-handling subroutine for queries with opcode UPDATE (RFC2136). =item Verbose Report internal activity. Defaults to 0 (off). =item Truncate Truncates UDP packets that are too big for the reply. Defaults to 1 (on). =back The LocalAddr attribute may alternatively be specified as an array of IP addresses to listen to. The ReplyHandler subroutine is passed the query name, query class, query type, peerhost, query record, and connection descriptor. It must either return the response code and references to the answer, authority, and additional sections of the response, or undef to leave the query unanswered. Common response codes are: =over 4 =item NOERROR No error =item FORMERR Format error =item SERVFAIL Server failure =item NXDOMAIN Non-existent domain (name doesn't exist) =item NOTIMP Not implemented =item REFUSED Query refused =back For advanced usage it may also contain a headermask containing an hashref with the settings for the C, C, and C header bits. The argument is of the form: {ad => 1, aa => 0, ra => 1} EDNS options may be specified in a similar manner using the optionmask: {$optioncode => $value, $optionname => $value} See RFC1035 and IANA DNS parameters file for more information: The nameserver will listen for both UDP and TCP connections. On linux and other Unix-like systems, unprivileged users are denied access to ports below 1024. UDP reply truncation functionality was introduced in Net::DNS 0.66. The size limit is determined by the EDNS0 size advertised in the query, otherwise 512 is used. If you want to do packet truncation yourself you should set Truncate=>0 and truncate the reply packet in the code of the ReplyHandler. =head2 start_server $ns->start_server( ); Starts a server process for each of the specified UDP and TCP sockets which continuously responds to user connections. The timeout parameter specifies the time the server is to remain active. If called with no parameter a default timeout of 10 minutes is applied. =head2 stop_server $ns->stop_server(); Terminates all server processes in an orderly fashion. =head1 EXAMPLES =head2 Example 1: Test script with embedded nameserver The following example is a self-contained test script which queries DNS zonefile data served by an embedded Net::DNS::Nameserver instance. use strict; use warnings; use Test::More; plan skip_all => 'Net::DNS::Nameserver not available' unless eval { require Net::DNS::Nameserver } and Net::DNS::Nameserver->can('start_server'); plan tests => 2; my $resolver = Net::DNS::Resolver->new( nameserver => ['::1', '127.0.0.1'], port => 15353 ); my $ns = Net::DNS::Nameserver->new( LocalAddr => [$resolver->nameserver], LocalPort => $resolver->port, Verbose => 0, ZoneFile => \*DATA ) or die "couldn't create nameserver object"; $ns->start_server(10); my $reply = $resolver->send(qw(example.com SOA)); is( ref($reply), 'Net::DNS::Packet', 'received reply packet' ); my ($rr) = $reply->answer; is( $rr->type, 'SOA', 'answer contains SOA record' ); $ns->stop_server(); exit; __DATA__ $ORIGIN example.com. @ IN SOA mname rname 2023 2h 1h 2w 1h www IN A 93.184.216.34 =head2 Example 2: Free-standing customised DNS nameserver The following example will listen on port 15353 and respond to all queries for A records with the IP address 10.1.2.3. All other queries will be answered with NXDOMAIN. Authority and additional sections are left empty. The $peerhost variable catches the IP address of the peer host, so that additional filtering on a per-host basis may be applied. use strict; use warnings; use Net::DNS::Nameserver; sub reply_handler { my ( $qname, $qclass, $qtype, $peerhost, $query, $conn ) = @_; my ( $rcode, @ans, @auth, @add ); print "Received query from $peerhost to " . $conn->{sockhost} . "\n"; $query->print; if ( $qtype eq "A" && $qname eq "foo.example.com" ) { my ( $ttl, $rdata ) = ( 3600, "10.1.2.3" ); my $rr = Net::DNS::RR->new("$qname $ttl $qclass $qtype $rdata"); push @ans, $rr; $rcode = "NOERROR"; } elsif ( $qname eq "foo.example.com" ) { $rcode = "NOERROR"; } else { $rcode = "NXDOMAIN"; } # mark the answer as authoritative (by setting the 'aa' flag) my $headermask = {aa => 1}; # specify EDNS options { option => value } my $optionmask = {}; return ( $rcode, \@ans, \@auth, \@add, $headermask, $optionmask ); } my $ns = Net::DNS::Nameserver->new( LocalPort => 15353, ReplyHandler => \&reply_handler, Verbose => 1 ) or die "couldn't create nameserver object"; $ns->start_server(60); exit; # leaving nameserver processes running for 60 seconds =head1 BUGS Limitations in perl make it impossible to guarantee that replies to UDP queries from Net::DNS::Nameserver are sent from the IP-address to which the query was directed, the source address being chosen by the operating system based upon its notion of "closest address". This limitation is mitigated to some extent by creating a separate socket and subprocess for each IP address. =head1 COPYRIGHT Copyright (c)2000 Michael Fuhr. Portions Copyright (c)2002-2004 Chris Reinhardt. Portions Copyright (c)2005 Robert Martin-Legene. Portions Copyright (c)2005-2009 O.M.Kolkman, RIPE NCC. Portions Copyright (c)2017-2024 R.W.Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L L L =cut __END__ Net-DNS-1.50/lib/Net/DNS/DomainName.pm0000644000175000017500000001633314756035515016462 0ustar willemwillempackage Net::DNS::DomainName; use strict; use warnings; our $VERSION = (qw$Id: DomainName.pm 2005 2025-01-28 13:22:10Z willem $)[2]; =head1 NAME Net::DNS::DomainName - DNS name representation =head1 SYNOPSIS use Net::DNS::DomainName; $object = Net::DNS::DomainName->new('example.com'); $name = $object->name; $data = $object->encode; ( $object, $next ) = Net::DNS::DomainName->decode( \$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. All other behaviour 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 base qw(Net::DNS::Domain); use integer; use Carp; =head1 METHODS =head2 new $object = Net::DNS::DomainName->new('example.com'); Creates a domain name object which identifies the domain specified by the character string argument. =head2 decode $object = Net::DNS::DomainName->decode( \$buffer, $offset, $hash ); ( $object, $next ) = Net::DNS::DomainName->decode( \$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 $label = []; my $self = bless {label => $label}, shift; my $buffer = shift; # reference to data buffer my $offset = shift || 0; # offset within buffer my $linked = shift; # caller's compression index my $cache = $linked; $cache->{$offset} = $self; # hashed objectref by offset my $buflen = length $$buffer; my $index = $offset; while ( $index < $buflen ) { my $header = unpack( "\@$index C", $$buffer ) || return wantarray ? ( $self, ++$index ) : $self; if ( $header < 0x40 ) { # non-terminal label push @$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; croak 'invalid compression pointer' unless $linked; # uncoverable condition false $self->{origin} = $cache->{$link} ||= __PACKAGE__->decode( $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 { return join '', map { pack 'C a*', length($_), $_ } shift->_wire, ''; } =head2 canonical $data = $object->canonical; Returns the canonical wire-format representation of the domain name as defined in RFC2535(8.1). =cut sub canonical { my @label = shift->_wire; for (@label) { tr /\101-\132/\141-\172/; } return join '', map { pack 'C a*', length($_), $_ } @label, ''; } ######################################## package Net::DNS::DomainName1035; ## no critic ProhibitMultiplePackages our @ISA = 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. $data = $object->encode( $offset, $hash ); The 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. Note that RFC3597 implies that only the RR types defined in RFC1035(3.3) are eligible for compression of domain names occuring in RDATA. If the hash reference is undefined, encode() returns the lower case 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 || return $self->canonical; # hashed offset by name 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; } return $data .= pack 'x'; } ######################################## package Net::DNS::DomainName2535; ## no critic ProhibitMultiplePackages our @ISA = 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. $data = $object->encode( $offset, $hash ); The 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 names already encoded within the packet. If the hash reference is undefined, encode() returns the lower case uncompressed canonical representation defined in RFC2535(8.1). Note that RFC3597, and latterly RFC4034, specifies that the lower case canonical form is to be used for RR types defined prior to RFC3597. =cut sub encode { my ( $self, $offset, $hash ) = @_; return $self->canonical unless defined $hash; my $name = join '.', my @labels = $self->_wire; $hash->{$name} = $offset if $offset < 0x4000; return join '', map { pack 'C a*', length($_), $_ } @labels, ''; } 1; __END__ ######################################## =head1 COPYRIGHT Copyright (c)2009-2011 Dick Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L L =cut Net-DNS-1.50/lib/Net/DNS/Text.pm0000644000175000017500000001713414756035515015376 0ustar willemwillempackage Net::DNS::Text; use strict; use warnings; our $VERSION = (qw$Id: Text.pm 2002 2025-01-07 09:57:46Z willem $)[2]; =head1 NAME Net::DNS::Text - DNS text representation =head1 SYNOPSIS use Net::DNS::Text; $object = Net::DNS::Text->new('example'); $string = $object->string; $object = Net::DNS::Text->decode( \$data, $offset ); ( $object, $next ) = Net::DNS::Text->decode( \$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 integer; use Carp; use constant ASCII => ref eval { require Encode; Encode::find_encoding('ascii'); }; use constant UTF8 => scalar eval { ## not UTF-EBCDIC [see Unicode TR#16 3.6] Encode::encode_utf8( chr(182) ) eq pack( 'H*', 'C2B6' ); }; =head1 METHODS =head2 new $object = Net::DNS::Text->new('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 ( %escape, %escapeUTF8, %unescape ); ## precalculated escape tables sub new { my $self = bless [], shift; local $_ = &_encode_utf8; s/^\042(.*)\042$/$1/s; # strip paired quotes s/\134([\060-\071]{3})/$unescape{$1}/eg; # restore numeric escapes s/\134([^\134])/$1/g; # restore character escapes s/\134\134/\134/g; # restore escaped escapes while ( length $_ > 255 ) { my $chunk = substr( $_, 0, 255 ); # carve into chunks $chunk =~ s/[\300-\377][\200-\277]*$//; push @$self, $chunk; substr( $_, 0, length $chunk ) = ''; } push @$self, $_; return $self; } =head2 decode $object = Net::DNS::Text->decode( \$buffer, $offset ); ( $object, $next ) = Net::DNS::Text->decode( \$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 $class = shift; my $buffer = shift; # reference to data buffer my $offset = shift || 0; # offset within buffer my $size = shift; # specify size of unbounded text unless ( defined $size ) { $size = unpack "\@$offset C", $$buffer; $offset++; } my $next = $offset + $size; croak 'corrupt wire-format data' if $next > length $$buffer; my $self = bless [unpack( "\@$offset a$size", $$buffer )], $class; 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; return join '', map { pack( 'C a*', length $_, $_ ) } @$self; } =head2 raw $data = $object->raw; Returns the wire-format encoded representation of the text object without the explicit length field. =cut sub raw { my $self = shift; return join '', map { pack( 'a*', $_ ) } @$self; } =head2 value $value = $text->value; Character string representation of the text object. =cut sub value { return unless defined wantarray; my $self = shift; return _decode_utf8( join '', @$self ); } =head2 string $string = $text->string; Conditionally quoted RFC1035 zone file representation of the text object. =cut sub string { my $self = shift; my @s = map { split '', $_ } @$self; # escape special and ASCII non-printable my $s = _decode_utf8( join '', map { $escape{$_} } @s ); return $s =~ /[ \t\n\r\f(),;]|^$/ ? qq("$s") : $s; # quote special characters and empty string } =head2 unicode $string = $text->unicode; Conditionally quoted Unicode representation of the text object. =cut sub unicode { my $self = shift; my @s = map { split '', $_ } @$self; # escape special and non-printable my $s = _decode_utf8( join '', map { $escapeUTF8{$_} } @s ); return $s =~ /[ \t\n\r\f();]|^$/ ? qq("$s") : $s; # quote special characters and empty string } ######################################## # perlcc: address of encoding objects must be determined at runtime my $ascii = ASCII ? Encode::find_encoding('ascii') : undef; # Osborn's Law: my $utf8 = UTF8 ? Encode::find_encoding('utf8') : undef; # Variables won't; constants aren't. sub _decode_utf8 { ## UTF-8 to perl internal encoding local $_ = shift; # partial transliteration for non-ASCII character encodings tr [\040-\176\000-\377] [ !"#$%&'()*+,\-./0-9:;<=>?@A-Z\[\\\]^_`a-z{|}~?] unless ASCII; my $z = length($_) - length($_); # pre-5.18 taint workaround return ASCII ? substr( ( UTF8 ? $utf8 : $ascii )->decode($_), $z ) : $_; } sub _encode_utf8 { ## perl internal encoding to UTF-8 local $_ = shift; croak 'argument undefined' unless defined $_; # partial transliteration for non-ASCII character encodings tr [ !"#$%&'()*+,\-./0-9:;<=>?@A-Z\[\\\]^_`a-z{|}~] [\040-\176] unless ASCII; my $z = length($_) - length($_); # pre-5.18 taint workaround return ASCII ? substr( ( UTF8 ? $utf8 : $ascii )->encode($_), $z ) : $_; } %escape = eval { ## precalculated ASCII escape table my %table = map { ( chr($_) => chr($_) ) } ( 0 .. 127 ); foreach my $n ( 0 .. 31, 34, 92, 127 .. 255 ) { # numerical escape my $codepoint = sprintf( '%03u', $n ); # transliteration for non-ASCII character encodings $codepoint =~ tr [0-9] [\060-\071]; $table{chr($n)} = pack 'C a3', 92, $codepoint; } return %table; }; %escapeUTF8 = eval { ## precalculated UTF-8 escape table my @octet = UTF8 ? ( 128 .. 191, 194 .. 254 ) : (); return ( %escape, map { ( chr($_) => chr($_) ) } @octet ); }; %unescape = eval { ## precalculated numeric escape table my %table; foreach my $n ( 0 .. 255 ) { my $key = sprintf( '%03u', $n ); # transliteration for non-ASCII character encodings $key =~ tr [0-9] [\060-\071]; $table{$key} = pack 'C', $n; } $table{"\060\071\062"} = pack 'C2', 92, 92; # escaped escape 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. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/Packet.pm0000644000175000017500000005364714756035515015672 0ustar willemwillempackage Net::DNS::Packet; use strict; use warnings; our $VERSION = (qw$Id: Packet.pm 2003 2025-01-21 12:06:06Z willem $)[2]; =head1 NAME Net::DNS::Packet - DNS protocol packet =head1 SYNOPSIS use Net::DNS::Packet; $query = Net::DNS::Packet->new( 'example.com', 'MX', 'IN' ); $reply = $resolver->send( $query ); =head1 DESCRIPTION A Net::DNS::Packet object represents a DNS protocol packet. =cut use integer; use Carp; use Net::DNS::Parameters qw(:dsotype); use constant UDPSZ => 512; BEGIN { require Net::DNS::Header; require Net::DNS::Question; require Net::DNS::RR; } =head1 METHODS =head2 new $packet = Net::DNS::Packet->new( 'example.com' ); $packet = Net::DNS::Packet->new( 'example.com', 'MX', 'IN' ); $packet = Net::DNS::Packet->new(); If passed a domain, type, and class, new() creates a Net::DNS::Packet object which is suitable for making a DNS query for the specified information. The type and class may be omitted; they default to A and IN. If called with an empty argument list, new() creates an empty packet. =cut sub new { my ( $class, @arg ) = @_; return &decode if ref $arg[0]; my $self = bless { status => 0, question => [], answer => [], authority => [], additional => [], }, $class; $self->{question} = [Net::DNS::Question->new(@arg)] if scalar @arg; return $self; } =head2 decode $packet = Net::DNS::Packet->decode( \$data ); $packet = Net::DNS::Packet->decode( \$data, 1 ); # debug $packet = Net::DNS::Packet->new( \$data ... ); A new packet object is created by decoding the DNS packet data contained in the scalar referenced by the first argument. The optional second boolean argument enables debugging output. Returns undef if unable to create a packet object. Decoding errors, including data corruption and truncation, are collected in the $@ ($EVAL_ERROR) variable. ( $packet, $length ) = Net::DNS::Packet->decode( \$data ); If called in array context, returns a packet object and the number of octets successfully decoded. Note that the number of RRs in each section of the packet may differ from the corresponding header value if the data has been truncated or corrupted during transmission. =cut use constant HEADER_LENGTH => length pack 'n6', (0) x 6; sub decode { my $class = shift; my $data = shift; my $debug = shift || 0; my $offset = 0; my $self; eval { local $SIG{__DIE__}; my $length = length $$data; die 'corrupt wire-format data' if $length < HEADER_LENGTH; # header section my ( $id, $status, @count ) = unpack 'n6', $$data; my ( $qd, $an, $ns, $ar ) = @count; $self = bless { id => $id, status => $status, count => [@count], question => [], answer => [], authority => [], additional => [], replysize => $length }, $class; # question/zone section my $hash = {}; my $record; $offset = HEADER_LENGTH; while ( $qd-- ) { ( $record, $offset ) = Net::DNS::Question->decode( $data, $offset, $hash ); CORE::push( @{$self->{question}}, $record ); } # RR sections while ( $an-- ) { ( $record, $offset ) = Net::DNS::RR->decode( $data, $offset, $hash ); CORE::push( @{$self->{answer}}, $record ); } while ( $ns-- ) { ( $record, $offset ) = Net::DNS::RR->decode( $data, $offset, $hash ); CORE::push( @{$self->{authority}}, $record ); } while ( $ar-- ) { ( $record, $offset ) = Net::DNS::RR->decode( $data, $offset, $hash ); CORE::push( @{$self->{additional}}, $record ); } return unless $offset == HEADER_LENGTH; return unless $self->header->opcode eq 'DSO'; $self->{dso} = []; my $limit = $length - 4; while ( $offset < $limit ) { my ( $t, $l, $v ) = unpack "\@$offset n2a*", $$data; CORE::push( @{$self->{dso}}, [$t, substr( $v, 0, $l )] ); $offset += ( $l + 4 ); } }; if ($debug) { local $@ = $@; print $@ if $@; eval { $self->print }; } return wantarray ? ( $self, $offset ) : $self; } =head2 encode $data = $packet->encode; $data = $packet->encode( $size ); Returns the packet data in binary format, suitable for sending as a query or update request to a nameserver. Truncation may be specified using a non-zero optional size argument. =cut sub data { return &encode; # uncoverable pod } sub encode { my ( $self, $size ) = @_; my $edns = $self->edns; # EDNS support my @addl = grep { !$_->isa('Net::DNS::RR::OPT') } @{$self->{additional}}; $self->{additional} = [$edns, @addl] if $edns->_specified; return $self->truncate($size) if $size; my @part = qw(question answer authority additional); my @size = map { scalar @{$self->{$_}} } @part; my $data = pack 'n6', $self->_quid, $self->{status}, @size; $self->{count} = []; my $hash = {}; # packet body foreach my $component ( map { @{$self->{$_}} } @part ) { $data .= $component->encode( length $data, $hash, $self ); } return $data; } =head2 header $header = $packet->header; Constructor method which returns a Net::DNS::Header object which represents the header section of the packet. =cut sub header { my $self = shift; return bless \$self, q(Net::DNS::Header); } =head2 edns $version = $packet->edns->version; $UDPsize = $packet->edns->size; Auxiliary function which provides access to the EDNS protocol extension OPT RR. =cut sub edns { my $self = shift; my $link = \$self->{xedns}; ($$link) = grep { $_->isa(qw(Net::DNS::RR::OPT)) } @{$self->{additional}} unless $$link; $$link = Net::DNS::RR->new( type => 'OPT' ) unless $$link; return $$link; } =head2 reply $reply = $query->reply( $UDPmax ); Constructor method which returns a new reply packet. The optional UDPsize argument is the maximum UDP packet size which can be reassembled by the local network stack, and is advertised in response to an EDNS query. =cut sub reply { my ( $query, @UDPmax ) = @_; my $qheadr = $query->header; croak 'erroneous qr flag in query packet' if $qheadr->qr; my $reply = Net::DNS::Packet->new(); my $header = $reply->header; $header->qr(1); # reply with same id, opcode and question $header->id( $qheadr->id ); $header->opcode( $qheadr->opcode ); my @question = $query->question; $reply->{question} = [@question]; $header->rcode('FORMERR'); # no RCODE considered sinful! $header->rd( $qheadr->rd ); # copy these flags into reply $header->cd( $qheadr->cd ); return $reply unless grep { $_->isa('Net::DNS::RR::OPT') } @{$query->{additional}}; my $edns = $reply->edns(); CORE::push( @{$reply->{additional}}, $edns ); $edns->udpsize(@UDPmax); return $reply; } =head2 question, zone @question = $packet->question; Returns a list of Net::DNS::Question objects representing the question section of the packet. In dynamic update packets, this section is known as zone() and specifies the DNS zone to be updated. =cut sub question { my @qr = @{shift->{question}}; return @qr; } sub zone { return &question } =head2 answer, pre, prerequisite @answer = $packet->answer; Returns a list of Net::DNS::RR objects representing the answer section of the packet. In dynamic update packets, this section is known as pre() or prerequisite() and specifies the RRs or RRsets which must or must not preexist. =cut sub answer { my @rr = @{shift->{answer}}; return @rr; } sub pre { return &answer } sub prerequisite { return &answer } =head2 authority, update @authority = $packet->authority; Returns a list of Net::DNS::RR objects representing the authority section of the packet. In dynamic update packets, this section is known as update() and specifies the RRs or RRsets to be added or deleted. =cut sub authority { my @rr = @{shift->{authority}}; return @rr; } sub update { return &authority } =head2 additional @additional = $packet->additional; Returns a list of Net::DNS::RR objects representing the additional section of the packet. =cut sub additional { my @rr = @{shift->{additional}}; return @rr; } =head2 print $packet->print; Prints the entire packet to the currently selected output filehandle using the master file format mandated by RFC1035. =cut sub print { print &string; return; } =head2 string print $packet->string; Returns a string representation of the packet. =cut sub string { my $self = shift; my $header = $self->header; my $opcode = $header->opcode; my $packet = $header->qr ? 'Response' : 'Query'; my $server = $self->{replyfrom}; my $length = $self->{replysize}; my $origin = $server ? ";; $packet received from [$server] $length octets\n" : ""; my @record = ( "$origin;; HEADER SECTION", $header->string ); if ( $opcode eq 'DSO' ) { CORE::push( @record, ";; DSO SECTION" ); foreach ( @{$self->{dso}} ) { my ( $t, $v ) = @$_; CORE::push( @record, sprintf( ";;\t%s\t%s", dsotypebyval($t), unpack( 'H*', $v ) ) ); } return join "\n", @record, "\n"; } my $edns = $self->edns; CORE::push( @record, $edns->string ) if $edns->_specified; my @section = $opcode eq 'UPDATE' ? qw(ZONE PREREQUISITE UPDATE) : qw(QUESTION ANSWER AUTHORITY); my @question = $self->question; my $qdcount = scalar @question; my $qds = $qdcount != 1 ? 's' : ''; CORE::push( @record, ";; $section[0] SECTION ($qdcount record$qds)", map { ';; ' . $_->string } @question ); my @answer = $self->answer; my $ancount = scalar @answer; my $ans = $ancount != 1 ? 's' : ''; CORE::push( @record, "\n;; $section[1] SECTION ($ancount record$ans)", map { $_->string } @answer ); my @authority = $self->authority; my $nscount = scalar @authority; my $nss = $nscount != 1 ? 's' : ''; CORE::push( @record, "\n;; $section[2] SECTION ($nscount record$nss)", map { $_->string } @authority ); my @additional = $self->additional; my $arcount = scalar @additional; my $ars = $arcount != 1 ? 's' : ''; my $EDNSmarker = join ' ', qq[;; {\t"EDNS-VERSION":], $edns->version, qq[}]; CORE::push( @record, "\n;; ADDITIONAL SECTION ($arcount record$ars)" ); CORE::push( @record, map { ( $_ eq $edns ) ? $EDNSmarker : $_->string } @additional ); return join "\n", @record, "\n"; } =head2 from print "packet received from ", $packet->from, "\n"; Returns the IP address from which this packet was received. This method will return undef for user-created packets. =cut sub from { my ( $self, @argument ) = @_; for (@argument) { $self->{replyfrom} = $_ } return $self->{replyfrom}; } sub answerfrom { return &from; } # uncoverable pod =head2 size print "packet size: ", $packet->size, " octets\n"; Returns the size of the packet in octets as it was received from a nameserver. This method will return undef for user-created packets (use length($packet->data) instead). =cut sub size { return shift->{replysize}; } sub answersize { return &size; } # uncoverable pod =head2 push $ancount = $packet->push( prereq => $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. Section names may be abbreviated to the first three characters. =cut sub push { my ( $self, $section, @rr ) = @_; my $list = $self->_section($section); return CORE::push( @$list, @rr ); } =head2 unique_push $ancount = $packet->unique_push( prereq => $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 are not already present in the same section. Returns the number of resource records in the specified section. Section names may be abbreviated to the first three characters. =cut sub unique_push { my ( $self, $section, @rr ) = @_; my $list = $self->_section($section); my %unique = map { ( bless( {%$_, ttl => 0}, ref $_ )->canonical => $_ ) } @rr, @$list; return scalar( @$list = values %unique ); } =head2 pop my $rr = $packet->pop( 'pre' ); my $rr = $packet->pop( 'update' ); my $rr = $packet->pop( 'additional' ); Removes a single RR from the specified section of the packet. =cut sub pop { my $self = shift; my $list = $self->_section(shift); return CORE::pop(@$list); } my %_section = ( ## section name abbreviation table 'ans' => 'answer', 'pre' => 'answer', 'aut' => 'authority', 'upd' => 'authority', 'add' => 'additional' ); sub _section { ## returns array reference for section my $self = shift; my $name = shift; my $list = $_section{unpack 'a3', $name} || $name; return $self->{$list} ||= []; } =head2 sign_tsig $query = Net::DNS::Packet->new( 'www.example.com', 'A' ); $query->sign_tsig( $keyfile, fudge => 60 ); $reply = $res->send( $query ); $reply->verify( $query ) || die $reply->verifyerr; Attaches a TSIG resource record object, which will be used to sign the packet (see RFC 2845). The TSIG record can be customised by optional additional arguments to sign_tsig() or by calling the appropriate Net::DNS::RR::TSIG methods. If you wish to create a TSIG record using a non-standard algorithm, you will have to create it yourself. In all cases, the TSIG name must uniquely identify the key shared between the parties, and the algorithm name must identify the signing function to be used with the specified key. $tsig = Net::DNS::RR->new( name => 'tsig.example', type => 'TSIG', algorithm => 'custom-algorithm', key => '', sig_function => sub { my ($key, $data) = @_; ... } ); $query->sign_tsig( $tsig ); The response to an inbound request is signed by presenting the request in place of the key parameter. $response = $request->reply; $response->sign_tsig( $request, @options ); Multi-packet transactions are signed by chaining the sign_tsig() calls together as follows: $opaque = $packet1->sign_tsig( 'Kexample.+165+13281.private' ); $opaque = $packet2->sign_tsig( $opaque ); $opaque = $packet3->sign_tsig( $opaque ); The opaque intermediate object references returned during multi-packet signing are not intended to be accessed by the end-user application. Any such access is expressly forbidden. Note that a TSIG record is added to every packet; this implementation does not support the suppressed signature scheme described in RFC2845. =cut sub sign_tsig { my ( $self, @argument ) = @_; return eval { local $SIG{__DIE__}; require Net::DNS::RR::TSIG; my $tsig = Net::DNS::RR::TSIG->create(@argument); $self->push( 'additional' => $tsig ); return $tsig; } || return croak "$@\nTSIG: unable to sign packet"; } =head2 verify and verifyerr $reply->verify($query) || die $reply->verifyerr; Verify TSIG signature of a reply to the corresponding query. $opaque = $packet1->verify( $query ) || die $packet1->verifyerr; $opaque = $packet2->verify( $opaque ); $verifed = $packet3->verify( $opaque ) || die $packet3->verifyerr; Verify TSIG signature of a multi-packet reply to the corresponding query. The opaque intermediate object references returned by verify() at each stage will be undefined (Boolean false) if verification fails. Testing at every stage is not necessary, which produces a BADSIG error on the final packet in the absence of more specific information. Access to the objects themselves, if they exist, is expressly forbidden. =cut sub verify { my ( $self, @argument ) = @_; my $sig = $self->sigrr; return $sig ? $sig->verify( $self, @argument ) : shift @argument; } sub verifyerr { my $sig = shift->sigrr; return $sig ? $sig->vrfyerrstr : 'not signed'; } =head2 sign_sig0 SIG0 support is provided through the Net::DNS::RR::SIG class. The requisite cryptographic components are not integrated into Net::DNS but reside in the Net::DNS::SEC distribution available from CPAN. $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'); Execution will be terminated if Net::DNS::SEC is not available. =head2 verify SIG0 $packet->verify( $keyrr ) || die $packet->verifyerr; $packet->verify( [$keyrr, ...] ) || die $packet->verifyerr; Verify SIG0 packet signature against one or more specified KEY RRs. =cut sub sign_sig0 { my $self = shift; my $karg = shift; return eval { local $SIG{__DIE__}; my $sig0; if ( ref($karg) eq 'Net::DNS::RR::SIG' ) { $sig0 = $karg; } else { require Net::DNS::RR::SIG; $sig0 = Net::DNS::RR::SIG->create( '', $karg ); } $self->push( 'additional' => $sig0 ); return $sig0; } || return croak "$@\nSIG0: unable to sign packet"; } =head2 sigrr $sigrr = $packet->sigrr() || die 'unsigned packet'; The sigrr method returns the signature RR from a signed packet or undefined if the signature is absent. =cut sub sigrr { my $self = shift; my ($sig) = reverse $self->additional; return unless $sig; for ( $sig->type ) { return $sig if /TSIG|SIG/; } return; } ######################################## =head2 truncate The truncate method takes a maximum length as argument and then tries to truncate the packet and set the TC bit according to the rules of RFC2181 Section 9. The smallest length limit that is honoured 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, for which 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 developed from a contribution by Aaron Crane via rt.cpan.org 33547 sub truncate { my $self = shift; my $size = shift || UDPSZ; my $sigrr = $self->sigrr; $size = UDPSZ unless $size > UDPSZ; $size -= $sigrr->_size if $sigrr; my $data = pack 'x' x HEADER_LENGTH; # header placeholder $self->{count} = []; my $tc; my $hash = {}; foreach my $section ( map { $self->{$_} } qw(question answer authority) ) { my @list; foreach my $item (@$section) { my $component = $item->encode( length $data, $hash ); last if length($data) + length($component) > $size; last if $tc; $data .= $component; CORE::push @list, $item; } $tc++ if scalar(@list) < scalar(@$section); @$section = @list; } $self->header->tc(1) if $tc; # only set if truncated here my %rrset; my @order; foreach my $item ( grep { ref($_) ne ref($sigrr) } $self->additional ) { my $name = $item->{owner}->canonical; my $class = $item->{class} || 0; my $key = pack 'nna*', $class, $item->{type}, $name; CORE::push @order, $key unless $rrset{$key}; CORE::push @{$rrset{$key}}, $item; } my @list; foreach my $key (@order) { my $component = ''; my @item = @{$rrset{$key}}; foreach my $item (@item) { $component .= $item->encode( length $data, $hash ); } last if length($data) + length($component) > $size; $data .= $component; CORE::push @list, @item; } if ($sigrr) { $data .= $sigrr->encode( length $data, $hash, $self ); CORE::push @list, $sigrr; } $self->{'additional'} = \@list; my @part = qw(question answer authority additional); my @size = map { scalar @{$self->{$_}} } @part; return pack 'n6 a*', $self->_quid, $self->{status}, @size, substr( $data, HEADER_LENGTH ); } ######################################## sub dump { ## print internal data structure my @data = @_; # uncoverable pod require Data::Dumper; local $Data::Dumper::Maxdepth = $Data::Dumper::Maxdepth || 3; local $Data::Dumper::Sortkeys = $Data::Dumper::Sortkeys || 1; local $Data::Dumper::Useqq = $Data::Dumper::Useqq || 1; print Data::Dumper::Dumper(@data); return; } my ( $cache1, $cache2, $limit ); sub _quid { ## generate (short-term) unique query ID my $self = shift; my $id = $self->{id}; $cache1->{$id}++ if $id; # cache non-zero ID return $id if defined $id; ( $cache2, $cache1, $limit ) = ( $cache1, {0 => 1}, 50 ) unless $limit--; $id = int rand(0xffff); # two layer ID cache $id = int rand(0xffff) while $cache1->{$id}++ + exists( $cache2->{$id} ); return $self->{id} = $id; } 1; __END__ =head1 COPYRIGHT Copyright (c)1997-2000 Michael Fuhr. Portions Copyright (c)2002-2004 Chris Reinhardt. Portions Copyright (c)2002-2009 Olaf Kolkman Portions Copyright (c)2007-2019 Dick Franks All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/0000755000175000017500000000000014756035527014434 5ustar willemwillemNet-DNS-1.50/lib/Net/DNS/RR/SPF.pm0000644000175000017500000000470014756035515015420 0ustar willemwillempackage Net::DNS::RR::SPF; use strict; use warnings; our $VERSION = (qw$Id: SPF.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR::TXT); =head1 NAME Net::DNS::RR::SPF - DNS SPF resource record =cut use integer; sub spfdata { my ( $self, @argument ) = @_; my @spf = shift->char_str_list(@argument); return wantarray ? @spf : join '', @spf; } sub txtdata { return &spfdata; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name SPF spfdata ...'); =head1 DESCRIPTION Class for DNS Sender Policy Framework (SPF) resource records. SPF records inherit most of the properties of the Net::DNS::RR::TXT class. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 spfdata =head2 txtdata $string = $rr->spfdata; @list = $rr->spfdata; $rr->spfdata( @list ); When invoked in scalar context, spfdata() returns the policy text as a single string, with text elements concatenated without intervening spaces. In a list context, spfdata() returns a list of the text elements. =head1 COPYRIGHT Copyright (c)2005 Olaf Kolkman, NLnet Labs. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/NULL.pm0000644000175000017500000000406614756035515015547 0ustar willemwillempackage Net::DNS::RR::NULL; use strict; use warnings; our $VERSION = (qw$Id: NULL.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::NULL - DNS NULL resource record =cut 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name NULL \# length hexdata ...'); =head1 DESCRIPTION Class for DNS null (NULL) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 rdlength $rdlength = $rr->rdlength; Returns the length of the record data section. =head2 rdata $rdata = $rr->rdata; $rr->rdata( $rdata ); Returns the record data section as binary data. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/RRSIG.pm0000644000175000017500000005702114756035515015662 0ustar willemwillempackage Net::DNS::RR::RRSIG; use strict; use warnings; our $VERSION = (qw$Id: RRSIG.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::RRSIG - DNS RRSIG resource record =cut use integer; use Carp; use Time::Local; use Net::DNS::Parameters qw(:type); use constant DEBUG => 0; use constant UTIL => defined eval { require Scalar::Util; }; eval { require MIME::Base64 }; ## IMPORTANT: MUST NOT include crypto packages in metadata (strong crypto prohibited in many territories) use constant DNSSEC => defined $INC{'Net/DNS/SEC.pm'}; ## Discover how we got here, without exposing any crypto my @index; if (DNSSEC) { foreach my $class ( map {"Net::DNS::SEC::$_"} qw(Private RSA DSA ECDSA EdDSA Digest SM2) ) { my @algorithms = eval join '', qw(r e q u i r e), " $class; ${class}::_index()"; ## no critic push @index, map { ( $_ => $class ) } @algorithms; } croak 'Net::DNS::SEC version not supported' unless scalar(@index); } my %DNSSEC_verify = @index; my %DNSSEC_siggen = @index; my @deprecated = ( 1, 3, 6, 12 ); # RFC8624 delete @DNSSEC_siggen{@deprecated}; my @field = qw(typecovered algorithm labels orgttl sigexpiration siginception keytag); sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; my $limit = $offset + $self->{rdlength}; @{$self}{@field} = unpack "\@$offset n C2 N3 n", $$data; ( $self->{signame}, $offset ) = Net::DNS::DomainName->decode( $data, $offset + 18, @opaque ); $self->{sigbin} = substr $$data, $offset, $limit - $offset; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $signame = $self->{signame}; return pack 'n C2 N3 n a* a*', @{$self}{@field}, $signame->canonical, $self->sigbin; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $signame = $self->{signame}; my @sig64 = split /\s+/, MIME::Base64::encode( $self->sigbin ); my @rdata = ( map( { $self->$_ } @field ), $signame->string, @sig64 ); $rdata[3] .= "\n"; return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; foreach ( @field, qw(signame) ) { $self->$_( shift @argument ) } $self->signature(@argument); return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->sigval(30); return; } sub typecovered { my ( $self, @value ) = @_; for (@value) { $self->{typecovered} = typebyname($_) } my $typecode = $self->{typecovered}; return defined $typecode ? typebyval($typecode) : undef; } sub algorithm { my ( $self, $arg ) = @_; unless ( ref($self) ) { ## class method or simple function my $argn = pop; return $argn =~ /[^0-9]/ ? _algbyname($argn) : _algbyval($argn); } return $self->{algorithm} unless defined $arg; return _algbyval( $self->{algorithm} ) if $arg =~ /MNEMONIC/i; return $self->{algorithm} = _algbyname($arg); } sub labels { my ( $self, @value ) = @_; for (@value) { $self->{labels} = 0 + $_ } return $self->{labels} || 0; } sub orgttl { my ( $self, @value ) = @_; for (@value) { $self->{orgttl} = 0 + $_ } return $self->{orgttl} || 0; } sub sigexpiration { my ( $self, @value ) = @_; for (@value) { $self->{sigexpiration} = _string2time($_) } my $time = $self->{sigexpiration}; return unless defined wantarray && defined $time; return UTIL ? Scalar::Util::dualvar( $time, _time2string($time) ) : _time2string($time); } sub siginception { my ( $self, @value ) = @_; for (@value) { $self->{siginception} = _string2time($_) } my $time = $self->{siginception}; return unless defined wantarray && defined $time; return UTIL ? Scalar::Util::dualvar( $time, _time2string($time) ) : _time2string($time); } sub sigex { return &sigexpiration; } ## historical sub sigin { return &siginception; } ## historical sub sigval { my ( $self, @value ) = @_; no integer; return ( $self->{sigval} ) = map { int( 86400 * $_ ) } @value; } sub keytag { my ( $self, @value ) = @_; for (@value) { $self->{keytag} = 0 + $_ } return $self->{keytag} || 0; } sub signame { my ( $self, @value ) = @_; for (@value) { $self->{signame} = Net::DNS::DomainName->new($_) } return $self->{signame} ? $self->{signame}->name : undef; } sub sig { my ( $self, @value ) = @_; return MIME::Base64::encode( $self->sigbin(), "" ) unless scalar @value; return $self->sigbin( MIME::Base64::decode( join "", @value ) ); } sub sigbin { my ( $self, @value ) = @_; for (@value) { $self->{sigbin} = $_ } return $self->{sigbin} || ""; } sub signature { return &sig; } sub create { unless (DNSSEC) { croak qq[No "use Net::DNS::SEC" declaration in application code]; } else { my ( $class, $rrsetref, $priv_key, %etc ) = @_; $rrsetref = [$rrsetref] unless ref($rrsetref) eq 'ARRAY'; my $RR = $rrsetref->[0]; croak '$rrsetref is not reference to RR array' unless ref($RR) =~ /^Net::DNS::RR/; # All the TTLs need to be the same in the data RRset. my $ttl = $RR->ttl; croak 'RRs in RRset do not have same TTL' if grep { $_->ttl != $ttl } @$rrsetref; my $private = ref($priv_key) ? $priv_key : Net::DNS::SEC::Private->new($priv_key); croak 'unable to parse private key' unless ref($private) eq 'Net::DNS::SEC::Private'; my @label = grep { $_ ne chr(42) } $RR->{owner}->_wire; # count labels my $self = Net::DNS::RR->new( name => $RR->name, type => 'RRSIG', class => 'IN', ttl => $ttl, typecovered => $RR->type, labels => scalar @label, orgttl => $ttl, siginception => time(), algorithm => $private->algorithm, keytag => $private->keytag, signame => $private->signame, ); while ( my ( $attribute, $value ) = each %etc ) { $self->$attribute($value); } $self->{sigexpiration} = $self->{siginception} + $self->{sigval} unless $self->{sigexpiration}; my $sigdata = $self->_CreateSigData($rrsetref); $self->_CreateSig( $sigdata, $private ); return $self; } } sub verify { # Reminder... # $rrsetref must be a reference to an array of RR objects. # $keyref is either a key object or a reference to an array of key objects. unless (DNSSEC) { croak qq[No "use Net::DNS::SEC" declaration in application code]; } else { my ( $self, $rrsetref, $keyref ) = @_; croak '$keyref argument is scalar or undefined' unless ref($keyref); print '$keyref argument is ', ref($keyref), "\n" if DEBUG; if ( ref($keyref) eq "ARRAY" ) { # We will iterate over the supplied key list and # return when there is a successful verification. # If not, continue so that we survive key-id collision. print "Iterating over ", scalar(@$keyref), " keys\n" if DEBUG; my @error; foreach my $keyrr (@$keyref) { my $result = $self->verify( $rrsetref, $keyrr ); return $result if $result; my $error = $self->{vrfyerrstr}; my $keyid = $keyrr->keytag; push @error, "key $keyid: $error"; print "key $keyid: $error\n" if DEBUG; next; } $self->{vrfyerrstr} = join "\n", @error; return 0; } elsif ( $keyref->isa('Net::DNS::RR::DNSKEY') ) { print "Validating using key with keytag: ", $keyref->keytag, "\n" if DEBUG; } else { croak join ' ', ref($keyref), 'can not be used as DNSSEC key'; } $rrsetref = [$rrsetref] unless ref($rrsetref) eq 'ARRAY'; my $RR = $rrsetref->[0]; croak '$rrsetref not a reference to array of RRs' unless ref($RR) =~ /^Net::DNS::RR/; if (DEBUG) { print "\n ---------------------- RRSIG DEBUG --------------------"; print "\n SIG:\t", $self->string; print "\n KEY:\t", $keyref->string; print "\n -------------------------------------------------------\n"; } $self->{vrfyerrstr} = ''; unless ( $self->algorithm == $keyref->algorithm ) { $self->{vrfyerrstr} = 'algorithm does not match'; return 0; } unless ( $self->keytag == $keyref->keytag ) { $self->{vrfyerrstr} = 'keytag does not match'; return 0; } my $sigdata = $self->_CreateSigData($rrsetref); $self->_VerifySig( $sigdata, $keyref ) || return 0; # time to do some time checking. my $t = time; if ( _ordered( $self->{sigexpiration}, $t ) ) { $self->{vrfyerrstr} = join ' ', 'Signature expired at', $self->sigexpiration; return 0; } elsif ( _ordered( $t, $self->{siginception} ) ) { $self->{vrfyerrstr} = join ' ', 'Signature valid from', $self->siginception; return 0; } return 1; } } #END verify sub vrfyerrstr { my $self = shift; return $self->{vrfyerrstr}; } ######################################## { my @algbyname = ( 'DELETE' => 0, # [RFC4034][RFC4398][RFC8078] 'RSAMD5' => 1, # [RFC3110][RFC4034] 'DH' => 2, # [RFC2539] 'DSA' => 3, # [RFC3755][RFC2536] ## Reserved => 4, # [RFC6725] 'RSASHA1' => 5, # [RFC3110][RFC4034] 'DSA-NSEC3-SHA1' => 6, # [RFC5155] 'RSASHA1-NSEC3-SHA1' => 7, # [RFC5155] 'RSASHA256' => 8, # [RFC5702] ## Reserved => 9, # [RFC6725] 'RSASHA512' => 10, # [RFC5702] ## Reserved => 11, # [RFC6725] 'ECC-GOST' => 12, # [RFC5933] 'ECDSAP256SHA256' => 13, # [RFC6605] 'ECDSAP384SHA384' => 14, # [RFC6605] 'ED25519' => 15, # [RFC8080] 'ED448' => 16, # [RFC8080] 'SM2SM3' => 17, # [RFC-cuiling-dnsop-sm2-alg-15] 'ECC-GOST12' => 23, # [RFC-makarenko-gost2012-dnssec-05] 'INDIRECT' => 252, # [RFC4034] 'PRIVATEDNS' => 253, # [RFC4034] 'PRIVATEOID' => 254, # [RFC4034] ## Reserved => 255, # [RFC4034] ); my %algbyval = reverse @algbyname; foreach (@algbyname) { s/[\W_]//g; } # strip non-alphanumerics my @algrehash = map { /^\d/ ? ($_) x 3 : uc($_) } @algbyname; my %algbyname = @algrehash; # work around broken cperl sub _algbyname { my $arg = shift; my $key = uc $arg; # synthetic key $key =~ s/[\W_]//g; # strip non-alphanumerics my $val = $algbyname{$key}; return $val if defined $val; return $key =~ /^\d/ ? $arg : croak qq[unknown algorithm $arg]; } sub _algbyval { my $value = shift; return $algbyval{$value} || return $value; } } sub _CreateSigData { # This method creates the data string that will be signed. # See RFC4034(6) and RFC6840(5.1) on how this string is constructed # This method is called by the method that creates a signature # and by the method that verifies the signature. It is assumed # that the creation method has checked that all the TTLs are # the same for the rrsetref and that sig->orgttl has been set # to the TTL of the data. This method will set the datarr->ttl # to the sig->orgttl for all the RR in the rrsetref. if (DNSSEC) { my ( $self, $rrsetref ) = @_; print "_CreateSigData\n" if DEBUG; my $sigdata = pack 'n C2 N3 n a*', @{$self}{@field}, $self->{signame}->canonical; print "\npreamble\t", unpack( 'H*', $sigdata ), "\n" if DEBUG; my $owner = $self->{owner}; # create wildcard domain name my $limit = $self->{labels}; my @label = $owner->_wire; shift @label while scalar @label > $limit; my $wild = bless {label => \@label}, ref($owner); # DIY to avoid wrecking name cache my $suffix = $wild->canonical; unshift @label, chr(42); # asterisk my @RR = map { bless( {%$_}, ref($_) ) } @$rrsetref; # shallow RR clone my $rr = $RR[0]; my $class = $rr->class; my $type = $rr->type; my $ttl = $self->orgttl; my %table; foreach my $RR (@RR) { my $ident = $RR->{owner}->canonical; my $match = substr $ident, -length($suffix); croak 'RRs in RRset have different NAMEs' if $match ne $suffix; croak 'RRs in RRset have different TYPEs' if $type ne $RR->type; croak 'RRs in RRset have different CLASS' if $class ne $RR->class; $RR->ttl($ttl); # reset TTL my $offset = 10 + length($suffix); # RDATA offset if ( $ident ne $match ) { $RR->{owner} = $wild; $offset += 2; print "\nsubstituting wildcard name: ", $RR->name if DEBUG; } # For sorting we create a hash table of canonical data keyed on RDATA my $canonical = $RR->canonical; $table{substr $canonical, $offset} = $canonical; } $sigdata = join '', $sigdata, map { $table{$_} } sort keys %table; if (DEBUG) { my $i = 0; foreach my $rdata ( sort keys %table ) { print "\n>>> ", $i++, "\tRDATA:\t", unpack 'H*', $rdata; print "\nRR: ", unpack( 'H*', $table{$rdata} ), "\n"; } print "\n sigdata:\t", unpack( 'H*', $sigdata ), "\n"; } return $sigdata; } } sub _CreateSig { if (DNSSEC) { my ( $self, @argument ) = @_; my $algorithm = $self->algorithm; return eval { my $class = $DNSSEC_siggen{$algorithm}; die "algorithm $algorithm not supported\n" unless $class; $self->sigbin( $class->sign(@argument) ); } || return croak "${@}signature generation failed"; } } sub _VerifySig { if (DNSSEC) { my ( $self, @argument ) = @_; my $algorithm = $self->algorithm; my $returnval = eval { my $class = $DNSSEC_verify{$algorithm}; die "algorithm $algorithm not supported\n" unless $class; $class->verify( @argument, $self->sigbin ); }; unless ($returnval) { $self->{vrfyerrstr} = "${@}signature verification failed"; print "\n", $self->{vrfyerrstr}, "\n" if DEBUG; return 0; } # uncoverable branch true # unexpected return value from EVP_DigestVerify croak "internal error in algorithm $algorithm verification" unless $returnval == 1; print "\nalgorithm $algorithm verification successful\n" if DEBUG; return $returnval; } } sub _ordered() { ## irreflexive 32-bit partial ordering my ( $n1, $n2 ) = @_; return 0 unless defined $n2; # ( any, undef ) return 1 unless defined $n1; # ( undef, any ) # unwise to assume 64-bit arithmetic, or that 32-bit integer overflow goes unpunished use integer; # fold, leaving $n2 non-negative $n1 = ( $n1 & 0xFFFFFFFF ) ^ ( $n2 & 0x80000000 ); # -2**31 <= $n1 < 2**32 $n2 = ( $n2 & 0x7FFFFFFF ); # 0 <= $n2 < 2**31 return $n1 < $n2 ? ( $n1 > ( $n2 - 0x80000000 ) ) : ( $n2 < ( $n1 - 0x80000000 ) ); } my $y1998 = timegm( 0, 0, 0, 1, 0, 1998 ); my $y2026 = timegm( 0, 0, 0, 1, 0, 2026 ); my $y2082 = $y2026 << 1; my $y2054 = $y2082 - $y1998; my $m2026 = int( 0x80000000 - $y2026 ); my $m2054 = int( 0x80000000 - $y2054 ); my $t2082 = int( $y2082 & 0x7FFFFFFF ); my $t2100 = 1960058752; sub _string2time { ## parse time specification string my $arg = shift; return int($arg) if length($arg) < 12; my ( $y, $m, @dhms ) = unpack 'a4 a2 a2 a2 a2 a2', $arg . '00'; if ( $arg lt '20380119031408' ) { # calendar folding return timegm( reverse(@dhms), $m - 1, $y ) if $y < 2026; return timegm( reverse(@dhms), $m - 1, $y - 56 ) + $y2026; } elsif ( $y > 2082 ) { my $z = timegm( reverse(@dhms), $m - 1, $y - 84 ); # expunge 29 Feb 2100 return $z < 1456790400 ? $z + $y2054 : $z + $y2054 - 86400; } return ( timegm( reverse(@dhms), $m - 1, $y - 56 ) + $y2054 ) - $y1998; } sub _time2string { ## format time specification string my $arg = shift; my $ls31 = int( $arg & 0x7FFFFFFF ); if ( $arg & 0x80000000 ) { if ( $ls31 > $t2082 ) { $ls31 += 86400 unless $ls31 < $t2100; # expunge 29 Feb 2100 my ( $yy, $mm, @dhms ) = reverse( ( gmtime( $ls31 + $m2054 ) )[0 .. 5] ); return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1984, $mm + 1, @dhms; } my ( $yy, $mm, @dhms ) = reverse( ( gmtime( $ls31 + $m2026 ) )[0 .. 5] ); return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1956, $mm + 1, @dhms; } elsif ( $ls31 > $y2026 ) { my ( $yy, $mm, @dhms ) = reverse( ( gmtime( $ls31 - $y2026 ) )[0 .. 5] ); return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1956, $mm + 1, @dhms; } my ( $yy, $mm, @dhms ) = reverse( ( gmtime $ls31 )[0 .. 5] ); return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1900, $mm + 1, @dhms; } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name RRSIG typecovered algorithm labels orgttl sigexpiration siginception keytag signame signature'); use Net::DNS::SEC; $sigrr = Net::DNS::RR::RRSIG->create( \@rrset, $keypath, sigex => 20241230010101, sigin => 20241201010101 ); $sigrr->verify( \@rrset, $keyrr ) || die $sigrr->vrfyerrstr; =head1 DESCRIPTION Class for DNS digital signature (RRSIG) resource records. In addition to the regular methods inherited from Net::DNS::RR the class contains a method to sign RRsets using private keys (create) and a method for verifying signatures over RRsets (verify). The RRSIG RR is an implementation of RFC4034. See L for an implementation of SIG0 (RFC2931). =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 typecovered $typecovered = $rr->typecovered; The typecovered field identifies the type of the RRset that is covered by this RRSIG record. =head2 algorithm $algorithm = $rr->algorithm; The algorithm number field identifies the cryptographic algorithm used to create the signature. algorithm() may also be invoked as a class method or simple function to perform mnemonic and numeric code translation. =head2 labels $labels = $rr->labels; $rr->labels( $labels ); The labels field specifies the number of labels in the original RRSIG RR owner name. =head2 orgttl $orgttl = $rr->orgttl; $rr->orgttl( $orgttl ); The original TTL field specifies the TTL of the covered RRset as it appears in the authoritative zone. =head2 sigexpiration and siginception times =head2 sigex sigin sigval $expiration = $rr->sigexpiration; $expiration = $rr->sigexpiration( $value ); $inception = $rr->siginception; $inception = $rr->siginception( $value ); The signature expiration and inception fields specify a validity time interval for the signature. The value may be specified by a string with format 'yyyymmddhhmmss' or a Perl time() value. Return values are dual-valued, providing either a string value or numerical Perl time() value. =head2 keytag $keytag = $rr->keytag; $rr->keytag( $keytag ); The keytag field contains the key tag value of the DNSKEY RR that validates this signature. =head2 signame $signame = $rr->signame; $rr->signame( $signame ); The signer name field value identifies the owner name of the DNSKEY RR that a validator is supposed to use to validate this signature. =head2 signature =head2 sig $sig = $rr->sig; $rr->sig( $sig ); The Signature field contains the cryptographic signature that covers the RRSIG RDATA (excluding the Signature field) and the RRset specified by the RRSIG owner name, RRSIG class, and RRSIG type covered fields. =head2 sigbin $sigbin = $rr->sigbin; $rr->sigbin( $sigbin ); Binary representation of the cryptographic signature. =head2 create Create a signature over a RR set. use Net::DNS::SEC; $keypath = '/home/olaf/keys/Kbla.foo.+001+60114.private'; $sigrr = Net::DNS::RR::RRSIG->create( \@rrsetref, $keypath ); $sigrr = Net::DNS::RR::RRSIG->create( \@rrsetref, $keypath, sigex => 20241230010101, sigin => 20241201010101 ); $sigrr->print; # Alternatively use Net::DNS::SEC::Private $private = Net::DNS::SEC::Private->new($keypath); $sigrr= Net::DNS::RR::RRSIG->create( \@rrsetref, $private ); create() is an alternative constructor for a RRSIG RR object. This method returns an RRSIG with the signature over the subject rrset (an array of RRs) made with the private key stored in the key file. The first argument is a reference to an array that contains the RRset that needs to be signed. The second argument is a string which specifies the path to a file containing the private key as generated by dnssec-keygen. The optional remaining arguments consist of ( name => value ) pairs as follows: sigex => 20241230010101, # signature expiration sigin => 20241201010101, # signature inception sigval => 30, # validity window (days) ttl => 3600 The sigin and sigex values may be specified as Perl time values or as a string with the format 'yyyymmddhhmmss'. The default for sigin is the time of signing. The sigval argument specifies the signature validity window in days ( sigex = sigin + sigval ). By default the signature is valid for 30 days. By default the TTL matches the RRset that is presented for signing. =head2 verify $verify = $sigrr->verify( $rrsetref, $keyrr ); $verify = $sigrr->verify( $rrsetref, [$keyrr, $keyrr2, $keyrr3] ); $rrsetref contains a reference to an array of RR objects and the method verifies the RRset against the signature contained in the $sigrr object itself using the public key in $keyrr. The second argument can either be a Net::DNS::RR::KEYRR object or a reference to an array of such objects. Verification will return successful as soon as one of the keys in the array leads to positive validation. Returns 0 on error and sets $sig->vrfyerrstr =head2 vrfyerrstr $verify = $sigrr->verify( $rrsetref, $keyrr ); print $sigrr->vrfyerrstr unless $verify; $sigrr->verify( $rrsetref, $keyrr ) || die $sigrr->vrfyerrstr; =head1 KEY GENERATION Private key files and corresponding public DNSKEY records are most conveniently generated using dnssec-keygen, a program that comes with the ISC BIND distribution. dnssec-keygen -a 10 -b 2048 rsa.example. dnssec-keygen -a 13 -f ksk ecdsa.example. dnssec-keygen -a 13 ecdsa.example. Do not change the name of the private key file. The create method uses the filename as generated by dnssec-keygen to determine the keyowner, algorithm, and the keyid (keytag). =head1 REMARKS The code is not optimised for speed. It is probably not suitable to be used for signing large zones. If this code is still around in 2100 (not a leap year) you will need to check for proper handling of times after 28th February. =head1 ACKNOWLEDGMENTS Although their original code may have disappeared following redesign of Net::DNS, Net::DNS::SEC and the OpenSSL API, the following individual contributors deserve to be recognised for their significant influence on the development of the RRSIG package. Andy Vaskys (Network Associates Laboratories) supplied code for RSA. T.J. Mather provided support for the DSA algorithm. Dick Franks added support for elliptic curve and Edwards curve algorithms. Mike McCauley created the Crypt::OpenSSL::ECDSA perl extension module specifically for this development. =head1 COPYRIGHT Copyright (c)2001-2005 RIPE NCC, Olaf M. Kolkman Copyright (c)2007-2008 NLnet Labs, Olaf M. Kolkman Portions Copyright (c)2014 Dick Franks All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/EUI48.pm0000644000175000017500000000627414756035515015576 0ustar willemwillempackage Net::DNS::RR::EUI48; use strict; use warnings; our $VERSION = (qw$Id: EUI48.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::EUI48 - DNS EUI48 resource record =cut use integer; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; $self->{address} = unpack "\@$offset a6", $$data; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'a6', $self->{address}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return $self->address; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->address(@argument); return; } sub address { my ( $self, $address ) = @_; $self->{address} = pack 'C6', map { hex($_) } split /[:-]/, $address if $address; return defined(wantarray) ? join( '-', unpack 'H2H2H2H2H2H2', $self->{address} ) : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name IN EUI48 address'); $rr = Net::DNS::RR->new( name => 'example.com', type => 'EUI48', address => '00-00-5e-00-53-2a' ); =head1 DESCRIPTION DNS resource records for 48-bit Extended Unique Identifier (EUI48). The EUI48 resource record is used to represent IEEE Extended Unique Identifiers used in various layer-2 networks, ethernet for example. EUI48 addresses SHOULD NOT be published in the public DNS. RFC7043 describes potentially severe privacy implications resulting from indiscriminate publication of link-layer addresses in the DNS. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 address The address field is a 6-octet layer-2 address in network byte order. The presentation format is hexadecimal separated by "-". =head1 COPYRIGHT Copyright (c)2013 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/NS.pm0000644000175000017500000000570214756035515015313 0ustar willemwillempackage Net::DNS::RR::NS; use strict; use warnings; our $VERSION = (qw$Id: NS.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::NS - DNS NS resource record =cut use integer; use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, @argument ) = @_; $self->{nsdname} = Net::DNS::DomainName1035->decode(@argument); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, @argument ) = @_; my $nsdname = $self->{nsdname}; return $nsdname->encode(@argument); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $nsdname = $self->{nsdname}; return $nsdname->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->nsdname(@argument); return; } sub nsdname { my ( $self, @value ) = @_; for (@value) { $self->{nsdname} = Net::DNS::DomainName1035->new($_) } return $self->{nsdname} ? $self->{nsdname}->name : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name NS nsdname'); $rr = Net::DNS::RR->new( name => 'example.com', type => 'NS', nsdname => 'ns.example.com', ); =head1 DESCRIPTION Class for DNS Name Server (NS) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 nsdname $nsdname = $rr->nsdname; $rr->nsdname( $nsdname ); A domain name which specifies a host which should be authoritative for the specified class and domain. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/L64.pm0000644000175000017500000000750014756035515015336 0ustar willemwillempackage Net::DNS::RR::L64; use strict; use warnings; our $VERSION = (qw$Id: L64.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::L64 - DNS L64 resource record =cut use integer; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; @{$self}{qw(preference locator64)} = unpack "\@$offset n a8", $$data; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'n a8', $self->{preference}, $self->{locator64}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return join ' ', $self->preference, $self->locator64; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(preference locator64)) { $self->$_( shift @argument ) } return; } sub preference { my ( $self, @value ) = @_; for (@value) { $self->{preference} = 0 + $_ } return $self->{preference} || 0; } sub locator64 { my $self = shift; my $prfx = shift; $self->{locator64} = pack 'n4', map { hex($_) } split /:/, $prfx if defined $prfx; return $self->{locator64} ? sprintf( '%x:%x:%x:%x', unpack 'n4', $self->{locator64} ) : undef; } my $function = sub { ## sort RRs in numerically ascending order. return $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; }; __PACKAGE__->set_rrsort_func( 'preference', $function ); __PACKAGE__->set_rrsort_func( 'default_sort', $function ); 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name IN L64 preference locator64'); $rr = Net::DNS::RR->new( name => 'example.com', type => 'L64', preference => 10, locator64 => '2001:0DB8:1140:1000' ); =head1 DESCRIPTION Class for DNS 64-bit Locator (L64) resource records. The L64 resource record is used to hold 64-bit Locator values for ILNPv6-capable nodes. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 preference $preference = $rr->preference; $rr->preference( $preference ); A 16 bit unsigned integer in network byte order that indicates the relative preference for this L64 record among other L64 records associated with this owner name. Lower values are preferred over higher values. =head2 locator64 $locator64 = $rr->locator64; The Locator64 field is an unsigned 64-bit integer in network byte order that has the same syntax and semantics as a 64-bit IPv6 routing prefix. =head1 COPYRIGHT Copyright (c)2012 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/OPT.pm0000644000175000017500000004275014756035515015441 0ustar willemwillempackage Net::DNS::RR::OPT; use strict; use warnings; our $VERSION = (qw$Id: OPT.pm 2005 2025-01-28 13:22:10Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::OPT - DNS OPT resource record =cut use integer; use Carp; use Net::DNS::Parameters qw(:rcode :ednsoption); use constant UTIL => scalar eval { require Scalar::Util; Scalar::Util->can('isdual') }; use constant OPT => Net::DNS::Parameters::typebyname qw(OPT); require Net::DNS::DomainName; require Net::DNS::RR::A; require Net::DNS::RR::AAAA; require Net::DNS::Text; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $class = delete $self->{class}; # OPT redefines CLASS and TTL fields $self->udpsize($class) if defined $class; my $ttl = delete $self->{ttl}; $self->_ttl($ttl) if defined $ttl; my $limit = $offset + $self->{rdlength} - 4; while ( $offset <= $limit ) { my ( $code, $length ) = unpack "\@$offset nn", $$data; my $value = unpack "\@$offset x4 a$length", $$data; my @value = map { ref($_) ? @$_ : defined($_) ? $_ : () } $self->{option}{$code}, $value; $self->{option}{$code} = ( scalar(@value) == 1 ) ? $value : \@value; $offset += $length + 4; } return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $option = $self->{option} || {}; my @option = $self->options; foreach my $item (@option) { my @value = map { ref($_) ? @$_ : $_ } $option->{$item}; $item = join '', map { pack( 'nna*', $item, length($_), $_ ) } @value; } return join '', @option; } sub encode { ## override RR method my $self = shift; my $data = $self->_encode_rdata; return pack 'C n n N na*', 0, OPT, $self->udpsize, $self->_ttl, length($data), $data; } sub string { ## override RR method my @line = split /[\r\n]+/, shift->json; return join '', map {";;$_\n"} @line; } sub class { ## override RR method my ( $self, @value ) = @_; $self->_deprecate(qq[please use "UDPsize()"]); return $self->udpsize(@value); } sub ttl { ## override RR method my ( $self, @value ) = @_; $self->_deprecate(qq[please use "flags()", "rcode()" or "version()"]); return $self->_ttl(@value); } sub _ttl { my ( $self, @value ) = @_; for (@value) { @{$self}{qw(rcode version flags)} = unpack 'C2n', pack( 'N', $_ ); $self->{rcode} = $self->{rcode} << 4; return; } return unpack 'N', pack( 'C2n', $self->rcode >> 4, $self->version, $self->flags ); } sub generic { ## override RR method my $self = shift; local $self->{class} = $self->udpsize; my @xttl = ( $self->rcode >> 4, $self->version, $self->flags ); local $self->{ttl} = unpack 'N', pack( 'C2n', @xttl ); return $self->SUPER::generic; } sub token { ## override RR method return grep { !m/^[()]$/ } split /\s+/, &generic; } sub json { my $self = shift; # uncoverable pod my $version = $self->version; unless ( $version == 0 ) { my $content = unpack 'H*', $self->encode; return <<"QQ"; { "EDNS-VERSION": $version, "BASE16": "$content" } QQ } my $flags = $self->flags; my $rcode = $self->rcode; my $size = $self->udpsize; my @format = map { join( "\n\t\t\t", $self->_format_option($_) ) } $self->options; my @indent = scalar(@format) ? "\n\t\t" : (); my @option = join ",\n\t\t", @format; return <<"QQ"; { "EDNS-VERSION": $version, "FLAGS": $flags, "RCODE": $rcode, "UDPSIZE": $size, "OPTIONS": [@indent@option ] } QQ } sub version { my ( $self, @value ) = @_; for (@value) { $self->{version} = 0 + $_ } return $self->{version} || 0; } sub udpsize { my ( $self, @value ) = @_; # uncoverable pod for (@value) { $self->{udpsize} = ( $_ > 512 ) ? $_ : 0 } return $self->{udpsize} || 0; } sub size { my ( $self, @value ) = @_; # uncoverable pod $self->_deprecate(qq[size() is an alias of "UDPsize()"]); return $self->udpsize(@value); } sub rcode { my ( $self, @value ) = @_; for (@value) { $self->{rcode} = ( $_ < 16 ) ? 0 : $_ } # discard non-EDNS rcodes 1 .. 15 return $self->{rcode} || 0; } sub flags { my ( $self, @value ) = @_; for (@value) { $self->{flags} = 0 + $_ } return $self->{flags} || 0; } sub options { my $self = shift; my $option = $self->{option} || {}; @{$self->{index}} = sort { $a <=> $b } keys %$option unless defined $self->{index}; return @{$self->{index}}; } sub option { my ( $self, $name, @value ) = @_; my $number = ednsoptionbyname($name); return $self->_get_option($number) unless scalar @value; my $value = $self->_set_option( $number, @value ); return $@ ? croak( ( split /\sat/i, $@ )[0] ) : $value; } ######################################## sub _get_option { my ( $self, $number ) = @_; my $options = $self->{option} || {}; my @payload = map { ref($_) ? @$_ : $_ } $options->{$number}; return shift @payload unless wantarray; my $optname = ednsoptionbyval($number); my $package = join '::', __PACKAGE__, $optname; $package =~ s/-/_/g; my $structured = $package->can('_decompose'); foreach my $value (@payload) { my @value; if ( length $value ) { @value = eval { $package->_decompose($value) } if $structured; @value = {BASE16 => unpack 'H*', $value} unless scalar @value; warn $@ if $@; } else { @value = $structured ? {'OPTION-LENGTH' => 0} : ''; } $value = {$optname => @value}; } return @payload; } sub _set_option { my ( $self, $number, @value ) = @_; my ($arg) = @value; my $options = $self->{option} || {}; delete $options->{$number}; delete $self->{index}; delete $self->{option} unless scalar( keys %$options ); return unless defined $arg; $self->{option} = $options; if ( ref($arg) eq 'HASH' ) { for ( keys %$arg ) { $$arg{uc $_} = $$arg{$_} } # tolerate mixed case my $length = $$arg{'OPTION-LENGTH'}; my $octets = $$arg{'OPTION-DATA'}; $octets = pack 'H*', $$arg{'BASE16'} if defined $$arg{'BASE16'}; $octets = '' if defined($length) && $length == 0; return $options->{$number} = $octets if defined $octets; } my $option = ednsoptionbyval($number); my $package = join '::', __PACKAGE__, $option; $package =~ s/-/_/g; return eval { $options->{$number} = $package->_compose(@value) } if length($arg) && $package->can('_compose'); croak "unable to compose option $number" if ref($arg); return $options->{$number} = $arg; } sub _specified { my $self = shift; return scalar grep { $self->{$_} } qw(udpsize flags rcode option); } sub _format_option { my ( $self, $number ) = @_; my @option = $self->_get_option($number); return map { Net::DNS::RR::_wrap( _JSONify($_) ) } @option; } sub _JSONify { my $value = shift; return 'null' unless defined $value; if ( ref($value) eq 'HASH' ) { my @tags = sort keys %$value; my $tail = pop @tags; for ( $$value{BASE16} ) { $_ = pack( 'U0a*', $_ ) if defined } # mark as UTF-8 my @body = map { my @x = ( qq("$_":), _JSONify( $$value{$_} ) ); $x[-1] .= ','; @x } @tags; push @body, ( qq("$tail":), _JSONify( $$value{$tail} ) ); $body[0] = '{' . $body[0]; $body[-1] .= '}'; return @body; } if ( ref($value) eq 'ARRAY' ) { my @array = @$value; my @tail = map { _JSONify($_) } grep {defined} pop @array; my @body = map { my @x = _JSONify($_); $x[-1] .= ','; @x } @array; return ( '[', @body, @tail, ']' ); } my $string = "$value"; ## stringify, then use isdual() as discriminant return $string if UTIL && Scalar::Util::isdual($value); # native numeric representation for ($string) { unless ( utf8::is_utf8($value) ) { return $_ if /^-?\d+$/; # integer (string representation) return $_ if /^-?\d+\.\d+$/; # non-integer return $_ if /^-?\d+(\.\d+)?e[+-]\d\d?$/i; } s/\\/\\\\/g; # escaped escape s/^"(.*)"$/$1/; # strip enclosing quotes s/"/\\"/g; # escape interior quotes } return qq("$string"); } ## no critic ProhibitMultiplePackages package Net::DNS::RR::OPT::NSID; # RFC5001 sub _compose { my ( undef, @argument ) = map { ref($_) ? %$_ : $_ } @_; return pack 'H*', pop @argument; } sub _decompose { return pack 'U0a*', unpack 'H*', pop @_ } # mark as UTF-8 package Net::DNS::RR::OPT::DAU; # RFC6975 sub _compose { my ( undef, @argument ) = map { ref($_) ? @$_ : $_ } @_; return pack 'C*', @argument; } sub _decompose { return [unpack 'C*', pop @_] } package Net::DNS::RR::OPT::DHU; # RFC6975 our @ISA = qw(Net::DNS::RR::OPT::DAU); package Net::DNS::RR::OPT::N3U; # RFC6975 our @ISA = qw(Net::DNS::RR::OPT::DAU); package Net::DNS::RR::OPT::CLIENT_SUBNET; # RFC7871 my %family = qw(1 Net::DNS::RR::A 2 Net::DNS::RR::AAAA); my @field8 = qw(FAMILY SOURCE-PREFIX SCOPE-PREFIX ADDRESS); sub _compose { shift @_; my %argument = ( map( ( $_ => 0 ), @field8 ), map { ref($_) ? %$_ : $_ } @_ ); my $family = $family{$argument{FAMILY}} || die 'unrecognised address family'; my $bitmask = $argument{'SOURCE-PREFIX'}; my $address = bless( {}, $family )->address( $argument{ADDRESS} ); return pack 'a* B*', pack( 'nC2', @argument{@field8} ), unpack "B$bitmask", $address; } sub _decompose { my %object; @object{@field8} = unpack 'nC2a*', pop @_; my $family = $family{$object{FAMILY}} || die 'unrecognised address family'; for ( $object{ADDRESS} ) { $_ = bless( {address => $_}, $family )->address; s/:[:0]+$/::/; } return \%object; } package Net::DNS::RR::OPT::EXPIRE; # RFC7314 sub _compose { my ( undef, @argument ) = map { ref($_) ? %$_ : $_ } @_; return pack 'N', pop @argument; } sub _decompose { my $argument = pop @_; return {'EXPIRE-TIMER' => unpack 'N', $argument}; } package Net::DNS::RR::OPT::COOKIE; # RFC7873 my @field10 = qw(CLIENT SERVER); sub _compose { my ( undef, @argument ) = @_; for ( ref( $argument[0] ) ) { /HASH/ && ( @argument = @{$argument[0]}{@field10} ); /ARRAY/ && ( @argument = @{$argument[0]} ); } return pack 'a8a*', map { pack 'H*', $_ || '' } @argument; } sub _decompose { my %object; @object{@field10} = map { pack 'U0a*', $_ } unpack 'H16H*', pop @_; # mark as UTF-8 return \%object; } package Net::DNS::RR::OPT::TCP_KEEPALIVE; # RFC7828 sub _compose { my ( undef, @argument ) = map { ref($_) ? %$_ : $_ } @_; return pack 'n', pop @argument; } sub _decompose { my $argument = pop @_; return {'TIMEOUT' => unpack 'n', $argument}; } package Net::DNS::RR::OPT::PADDING; # RFC7830 sub _compose { my ( undef, @argument ) = map { ref($_) ? %$_ : $_ } @_; my $length = pop(@argument) || 0; return pack "x$length"; } sub _decompose { my $argument = pop @_; return {'OPTION-LENGTH' => length $argument} if $argument =~ /^\000*$/; return {'BASE16' => unpack 'H*', $argument}; } package Net::DNS::RR::OPT::CHAIN; # RFC7901 sub _compose { my ( undef, @argument ) = map { ref($_) ? %$_ : $_ } @_; return Net::DNS::DomainName->new( pop @argument )->encode; } sub _decompose { my $argument = pop @_; return {'CLOSEST-TRUST-POINT' => Net::DNS::DomainName->decode( \$argument )->string}; } package Net::DNS::RR::OPT::KEY_TAG; # RFC8145 sub _compose { my ( undef, @argument ) = map { ref($_) ? @$_ : $_ } @_; return pack 'n*', @argument; } sub _decompose { return [unpack 'n*', pop @_] } package Net::DNS::RR::OPT::EXTENDED_ERROR; # RFC8914 sub _compose { my ( undef, @arg ) = @_; my %arg = ref( $arg[0] ) ? %{$arg[0]} : @arg; my $text = join '', Net::DNS::RR::OPT::_JSONify( $arg{'EXTRA-TEXT'} || '' ); return pack 'na*', $arg{'INFO-CODE'}, Net::DNS::Text->new($text)->raw; } sub _decompose { my ( $code, $text ) = unpack 'na*', pop @_; my $error = $Net::DNS::Parameters::dnserrorbyval{$code}; my @error = defined($error) ? ( 'ERROR' => $error ) : (); my $extra = Net::DNS::Text->decode( \$text, 0, length $text ); for ( $extra->value ) { last unless /^[\[\{]/; s/([\$\@])/\\$1/g; ## Here be dragons! my $REGEX = q/("[^"]*"|[\[\]{}:,]|[-0-9.Ee+]+)|\s+|(.)/; my @split = grep { defined && length } split /$REGEX/o; my $value = eval join( ' ', 'no integer;', map { s/^:$/=>/; $_ } @split ); return {'INFO-CODE' => $code, @error, 'EXTRA-TEXT' => $value} if ref($value); } return {'INFO-CODE' => $code, @error, 'EXTRA-TEXT' => $extra->value}; } package Net::DNS::RR::OPT::REPORT_CHANNEL; # RFC9567 sub _compose { my ( undef, @argument ) = map { ref($_) ? %$_ : $_ } @_; return Net::DNS::DomainName->new( pop @argument )->encode; } sub _decompose { my $argument = pop @_; return {'AGENT-DOMAIN' => Net::DNS::DomainName->decode( \$argument )->string}; } package Net::DNS::RR::OPT::ZONEVERSION; # RFC9660 my @field19 = qw(LABELCOUNT TYPE VERSION); sub _compose { my ( undef, @argument ) = @_; for ( ref( $argument[0] ) ) { /HASH/ && ( @argument = @{$argument[0]}{@field19} ); /ARRAY/ && ( @argument = @{$argument[0]} ); } return scalar(@argument) ? pack( 'C2H*', @argument ) : ''; } sub _decompose { my %object; my ( $l, $t, $v ) = unpack 'C2H*', pop @_; @object{@field19} = ( $l, $t, pack 'U0a*', $v ); # mark hex data as UTF-8 return \%object; } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; my $packet = Net::DNS::Packet->new( ... ); $packet->header->do(1); # extended header flag $packet->edns->UDPsize(1232); # UDP payload size $packet->edns->option( 'NSID' => {'OPTION-DATA' => 'rawbytes'} ); $packet->edns->option( 'DAU' => [8, 10, 13, 14, 15, 16] ); $packet->edns->option( 'TCP-KEEPALIVE' => 200 ); $packet->edns->option( 'EXTENDED-ERROR' => {'INFO-CODE' => 123} ); $packet->edns->option( '65023' => {'BASE16' => '076578616d706c6500'} ); $packet->edns->print; ;; { "EDNS-VERSION": 0, ;; "FLAGS": 32768, ;; "RCODE": 0, ;; "UDPSIZE": 1232, ;; "OPTIONS": [ ;; {"NSID": "7261776279746573"}, ;; {"DAU": [ 8, 10, 13, 14, 15, 16 ]}, ;; {"TCP-KEEPALIVE": {"TIMEOUT": 200}}, ;; {"EXTENDED-ERROR": {"INFO-CODE": 123, "EXTRA-TEXT": ""}}, ;; {"65023": {"BASE16": "076578616d706c6500"}} ] ;; } =head1 DESCRIPTION EDNS OPT pseudo resource record. The OPT record supports EDNS protocol extensions and is not intended to be created, accessed or modified directly by user applications. All EDNS features are performed indirectly by operations on the objects returned by the $packet->header and $packet->edns creator methods. The underlying mechanisms are, or should be, entirely hidden from the user. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 version $version = $packet->edns->version; The version of EDNS supported by this OPT record. =head2 UDPsize $size = $packet->edns->UDPsize; $packet->edns->UDPsize($size); UDPsize() advertises the maximum size (octets) of UDP packet that can be reassembled in the network stack of the originating host. =head2 rcode $extended_rcode = $packet->header->rcode; The 12 bit extended RCODE. The most significant 8 bits are obtained from the OPT record. The least significant 4 bits reside in the packet header. =head2 flags $do = $packet->header->do; $packet->header->do(1); $edns_flags = $packet->edns->flags; 16 bit field containing EDNS extended header flags. =head2 options my @options = $packet->edns->options; When called in a list context, options() returns a list of option codes found in the OPT record. =head2 option my $octets = $packet->edns->option('COOKIE'); my $base16 = unpack 'H*', $octets; When called in a scalar context with a single argument, option() returns the value of the specified option as an uninterpreted octet string. The method returns undef if the option is absent. $packet->edns->option( 'COOKIE' => {'OPTION-DATA' => $octets} ); $packet->edns->option( '10' => {'BASE16' => $base16} ); An option can be added or replaced by providing the (name,value) pair. The option is deleted if the value is undefined. my ($structure) = $packet->edns->option("DAU"); my $array = $$structure{"DAU"}; my @algorithms = @$array; my ($structure) = $packet->edns->option(15); my $table = $$structure{"EXTENDED-ERROR"}; my $info_code = $$table{'INFO-CODE'}; my $extra_text = $$table{'EXTRA-TEXT'}; When called in a list context with a single argument, option() returns a structured representation of the specified option. Similar forms of array or hash syntax may be used to construct the option value: $packet->edns->option( 'DAU' => [8, 10, 13, 14, 15, 16] ); $packet->edns->option( 'EXTENDED-ERROR' => { 'INFO-CODE' => 123, 'EXTRA-TEXT' => "" } ); =head1 COPYRIGHT Copyright (c)2001,2002 RIPE NCC. Author Olaf M. Kolkman. Portions Copyright (c)2012,2017-2024 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/DNAME.pm0000644000175000017500000000561414756035515015621 0ustar willemwillempackage Net::DNS::RR::DNAME; use strict; use warnings; our $VERSION = (qw$Id: DNAME.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::DNAME - DNS DNAME resource record =cut use integer; use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, @argument ) = @_; $self->{target} = Net::DNS::DomainName2535->decode(@argument); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, @argument ) = @_; my $target = $self->{target}; return $target->encode(@argument); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $target = $self->{target}; return $target->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->target(@argument); return; } sub target { my ( $self, @value ) = @_; for (@value) { $self->{target} = Net::DNS::DomainName2535->new($_) } return $self->{target} ? $self->{target}->name : undef; } sub dname { return ⌖ } # uncoverable pod 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name DNAME target'); =head1 DESCRIPTION Class for DNS Non-Terminal Name Redirection (DNAME) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 target $target = $rr->target; $rr->target( $target ); Redirection target domain name which is to be substituted for its owner as a suffix of a domain name. =head1 COPYRIGHT Copyright (c)2002 Andreas Gustafsson. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/RP.pm0000644000175000017500000000761314756035515015317 0ustar willemwillempackage Net::DNS::RR::RP; use strict; use warnings; our $VERSION = (qw$Id: RP.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::RP - DNS RP resource record =cut use integer; use Net::DNS::DomainName; use Net::DNS::Mailbox; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; ( $self->{mbox}, $offset ) = Net::DNS::Mailbox2535->decode( $data, $offset, @opaque ); $self->{txtdname} = Net::DNS::DomainName2535->decode( $data, $offset, @opaque ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, $offset, @opaque ) = @_; my $txtdname = $self->{txtdname}; my $rdata = $self->{mbox}->encode( $offset, @opaque ); $rdata .= $txtdname->encode( $offset + length($rdata), @opaque ); return $rdata; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @rdata = ( $self->{mbox}->string, $self->{txtdname}->string ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(mbox txtdname)) { $self->$_( shift @argument ) } return; } sub mbox { my ( $self, @value ) = @_; for (@value) { $self->{mbox} = Net::DNS::Mailbox2535->new($_) } return $self->{mbox} ? $self->{mbox}->address : undef; } sub txtdname { my ( $self, @value ) = @_; for (@value) { $self->{txtdname} = Net::DNS::DomainName2535->new($_) } return $self->{txtdname} ? $self->{txtdname}->name : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name RP mbox txtdname'); =head1 DESCRIPTION Class for DNS Responsible Person (RP) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 mbox $mbox = $rr->mbox; $rr->mbox( $mbox ); A domain name which specifies the mailbox for the person responsible for this domain. The format in master files uses the DNS encoding convention for mailboxes, identical to that used for the RNAME mailbox field in the SOA RR. The root domain name (just ".") may be specified to indicate that no mailbox is available. =head2 txtdname $txtdname = $rr->txtdname; $rr->txtdname( $txtdname ); A domain name identifying TXT RRs. A subsequent query can be performed to retrieve the associated TXT records. This provides a level of indirection so that the entity can be referred to from multiple places in the DNS. The root domain name (just ".") may be specified to indicate that there is no associated TXT RR. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/EUI64.pm0000644000175000017500000000630614756035515015570 0ustar willemwillempackage Net::DNS::RR::EUI64; use strict; use warnings; our $VERSION = (qw$Id: EUI64.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::EUI64 - DNS EUI64 resource record =cut use integer; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; $self->{address} = unpack "\@$offset a8", $$data; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'a8', $self->{address}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return $self->address; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->address(@argument); return; } sub address { my ( $self, $address ) = @_; $self->{address} = pack 'C8', map { hex($_) } split /[:-]/, $address if $address; return defined(wantarray) ? join '-', unpack( 'H2H2H2H2H2H2H2H2', $self->{address} ) : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name IN EUI64 address'); $rr = Net::DNS::RR->new( name => 'example.com', type => 'EUI64', address => '00-00-5e-ef-10-00-00-2a' ); =head1 DESCRIPTION DNS resource records for 64-bit Extended Unique Identifier (EUI64). The EUI64 resource record is used to represent IEEE Extended Unique Identifiers used in various layer-2 networks, ethernet for example. EUI64 addresses SHOULD NOT be published in the public DNS. RFC7043 describes potentially severe privacy implications resulting from indiscriminate publication of link-layer addresses in the DNS. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 address The address field is a 8-octet layer-2 address in network byte order. The presentation format is hexadecimal separated by "-". =head1 COPYRIGHT Copyright (c)2013 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/NSEC3.pm0000644000175000017500000003073214756035515015607 0ustar willemwillempackage Net::DNS::RR::NSEC3; use strict; use warnings; our $VERSION = (qw$Id: NSEC3.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR::NSEC); =head1 NAME Net::DNS::RR::NSEC3 - DNS NSEC3 resource record =cut use integer; use base qw(Exporter); our @EXPORT_OK = qw(name2hash); use Carp; require Net::DNS::DomainName; eval { require Digest::SHA }; ## optional for simple Net::DNS RR sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $limit = $offset + $self->{rdlength}; my $ssize = unpack "\@$offset x4 C", $$data; my ( $algorithm, $flags, $iterations, $saltbin ) = unpack "\@$offset CCnx a$ssize", $$data; @{$self}{qw(algorithm flags iterations saltbin)} = ( $algorithm, $flags, $iterations, $saltbin ); $offset += 5 + $ssize; my $hsize = unpack "\@$offset C", $$data; $self->{hnxtname} = unpack "\@$offset x a$hsize", $$data; $offset += 1 + $hsize; $self->{typebm} = substr $$data, $offset, ( $limit - $offset ); $self->{hashfn} = _hashfn( $algorithm, $iterations, $saltbin ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $salt = $self->saltbin; my $hash = $self->{hnxtname}; return pack 'CCn C a* C a* a*', $self->algorithm, $self->flags, $self->iterations, length($salt), $salt, length($hash), $hash, $self->{typebm}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @rdata = ( $self->algorithm, $self->flags, $self->iterations, $self->salt || '-', $self->hnxtname, $self->typelist ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; my $alg = $self->algorithm( shift @argument ); $self->flags( shift @argument ); my $iter = $self->iterations( shift @argument ); my $salt = shift @argument; $self->salt($salt) unless $salt eq '-'; $self->hnxtname( shift @argument ); $self->typelist(@argument); $self->{hashfn} = _hashfn( $alg, $iter, $self->{saltbin} ); return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->_parse_rdata( 1, 0, 0, '' ); return; } sub algorithm { my ( $self, $arg ) = @_; unless ( ref($self) ) { ## class method or simple function my $argn = pop; return $argn =~ /[^0-9]/ ? _digestbyname($argn) : _digestbyval($argn); } return $self->{algorithm} unless defined $arg; return _digestbyval( $self->{algorithm} ) if $arg =~ /MNEMONIC/i; return $self->{algorithm} = _digestbyname($arg); } sub flags { my ( $self, @value ) = @_; for (@value) { $self->{flags} = 0 + $_ } return $self->{flags} || 0; } sub optout { my ( $self, @value ) = @_; if ( scalar @value ) { for ( $self->{flags} |= 0x01 ) { $_ ^= 0x01 unless shift @value; } } return $self->{flags} & 0x01; } sub iterations { my ( $self, @value ) = @_; for (@value) { $self->{iterations} = 0 + $_ } return $self->{iterations} || 0; } sub salt { my ( $self, @value ) = @_; return unpack "H*", $self->saltbin() unless scalar @value; my @hex = map { /^"*([\dA-Fa-f]*)"*$/ || croak("corrupt hex"); $1 } @value; return $self->saltbin( pack "H*", join "", @hex ); } sub saltbin { my ( $self, @value ) = @_; for (@value) { $self->{saltbin} = $_ } return $self->{saltbin} || ""; } sub hnxtname { my ( $self, @name ) = @_; for (@name) { $self->{hnxtname} = _decode_base32hex($_) } return defined(wantarray) ? _encode_base32hex( $self->{hnxtname} ) : undef; } sub match { my ( $self, $name ) = @_; my ($owner) = $self->{owner}->label; my $ownerhash = _decode_base32hex($owner); my $hashfn = $self->{hashfn}; return $ownerhash eq &$hashfn($name); } sub covers { my ( $self, $name ) = @_; my ( $owner, @zone ) = $self->{owner}->label; my $ownerhash = _decode_base32hex($owner); my $nexthash = $self->{hnxtname}; my @label = Net::DNS::DomainName->new($name)->label; my @close = @label; foreach (@zone) { pop(@close) } # strip zone labels return if lc($name) ne lc( join '.', @close, @zone ); # out of zone my $hashfn = $self->{hashfn}; foreach (@close) { my $hash = &$hashfn( join '.', @label ); my $cmp1 = $hash cmp $ownerhash; last unless $cmp1; # stop at provable encloser return 1 if ( $cmp1 + ( $nexthash cmp $hash ) ) == 2; shift @label; } return; } sub encloser { my ( $self, $qname ) = @_; my ( $owner, @zone ) = $self->{owner}->label; my $ownerhash = _decode_base32hex($owner); my $nexthash = $self->{hnxtname}; my @label = Net::DNS::DomainName->new($qname)->label; my @close = @label; foreach (@zone) { pop(@close) } # strip zone labels return if lc($qname) ne lc( join '.', @close, @zone ); # out of zone my $hashfn = $self->{hashfn}; my $encloser = $qname; foreach (@close) { my $nextcloser = $encloser; shift @label; my $hash = &$hashfn( $encloser = join '.', @label ); next if $hash ne $ownerhash; $self->{nextcloser} = $nextcloser; # next closer name $self->{wildcard} = "*.$encloser"; # wildcard at provable encloser return $encloser; # provable encloser } return; } sub nextcloser { return shift->{nextcloser}; } sub wildcard { return shift->{wildcard}; } ######################################## my @digestbyname = ( 'SHA-1' => 1, # [RFC3658] ); my @digestalias = ( 'SHA' => 1 ); my %digestbyval = reverse @digestbyname; foreach (@digestbyname) { s/[\W_]//g; } # strip non-alphanumerics my @digestrehash = map { /^\d/ ? ($_) x 3 : uc($_) } @digestbyname; my %digestbyname = ( @digestalias, @digestrehash ); # work around broken cperl sub _digestbyname { my $arg = shift; my $key = uc $arg; # synthetic key $key =~ s/[\W_]//g; # strip non-alphanumerics my $val = $digestbyname{$key}; croak qq[unknown algorithm $arg] unless defined $val; return $val; } sub _digestbyval { my $value = shift; return $digestbyval{$value} || return $value; } my %digest = ( '1' => scalar( eval { Digest::SHA->new(1) } ), # RFC3658 ); sub _decode_base32hex { local $_ = shift || ''; tr [0-9A-Va-v\060-\071\101-\126\141-\166] [\000-\037\012-\037\000-\037\012-\037]; my $l = ( 5 * length ) & ~7; return pack "B$l", join '', map { unpack( 'x3a5', unpack 'B8', $_ ) } split //; } sub _encode_base32hex { my @split = grep {length} split /(\S{5})/, unpack 'B*', shift; local $_ = join '', map { pack( 'B*', "000$_" ) } @split; tr [\000-\037] [0-9a-v]; return $_; } my ( $cache1, $cache2, $limit ) = ( {}, {}, 10 ); sub _hashfn { my $hashalg = shift; my $iterations = shift || 0; my $salt = shift || ''; my $hash = $digest{$hashalg}; return sub { croak "algorithm $hashalg not supported" } unless $hash; my $clone = $hash->clone; my $key_adjunct = pack 'Cna*', $hashalg, $iterations, $salt; return sub { my $name = Net::DNS::DomainName->new(shift)->canonical; my $key = join '', $name, $key_adjunct; my $cache = $$cache1{$key} ||= $$cache2{$key}; # two layer cache return $cache if defined $cache; ( $cache1, $cache2, $limit ) = ( {}, $cache1, 50 ) unless $limit--; # recycle cache $clone->add($name); $clone->add($salt); my $digest = $clone->digest; my $count = $iterations; while ( $count-- ) { $clone->add($digest); $clone->add($salt); $digest = $clone->digest; } return $$cache1{$key} = $digest; }; } sub hashalgo { return &algorithm; } # uncoverable pod sub name2hash { my $hashalg = shift; # uncoverable pod my $name = shift; my $iterations = shift || 0; my $salt = pack 'H*', shift || ''; my $hash = _hashfn( $hashalg, $iterations, $salt ); return _encode_base32hex( &$hash($name) ); } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name NSEC3 algorithm flags iterations salt hnxtname'); =head1 DESCRIPTION Class for DNSSEC NSEC3 resource records. The NSEC3 Resource Record (RR) provides authenticated denial of existence for DNS Resource Record Sets. The NSEC3 RR lists RR types present at the original owner name of the NSEC3 RR. It includes the next hashed owner name in the hash order of the zone. The complete set of NSEC3 RRs in a zone indicates which RRSets exist for the original owner name of the RR and form a chain of hashed owner names in the zone. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 algorithm $algorithm = $rr->algorithm; $rr->algorithm( $algorithm ); The 8-bit algorithm field is represented as an unsigned decimal integer, but may be specified using the algorithm mnemonic. algorithm() may also be invoked as a class method or simple function to perform mnemonic and numeric code translation. =head2 flags $flags = $rr->flags; $rr->flags( $flags ); The Flags field is an unsigned decimal integer interpreted as eight concatenated Boolean values. =over 4 =item optout $rr->optout(1); if ( $rr->optout ) { ... } Boolean Opt Out flag. =back =head2 iterations $iterations = $rr->iterations; $rr->iterations( $iterations ); The Iterations field is represented as an unsigned decimal integer. The value is between 0 and 65535, inclusive. =head2 salt $salt = $rr->salt; $rr->salt( $salt ); The Salt field is represented as a contiguous sequence of hexadecimal digits. A "-" (unquoted) is used in string format to indicate that the salt field is absent. =head2 saltbin $saltbin = $rr->saltbin; $rr->saltbin( $saltbin ); The Salt field as a sequence of octets. =head2 hnxtname $hnxtname = $rr->hnxtname; $rr->hnxtname( $hnxtname ); The Next Hashed Owner Name field points to the next node that has authoritative data or contains a delegation point NS RRset. =head2 typelist @typelist = $rr->typelist; $typelist = $rr->typelist; $rr->typelist( @typelist ); typelist() identifies the RRset types that exist at the domain name matched by the NSEC3 RR. When called in scalar context, the list is interpolated into a string. =head2 typemap $exists = $rr->typemap($rrtype); typemap() returns a Boolean true value if the specified RRtype occurs in the type bitmap of the NSEC3 record. =head2 match $matched = $rr->match( 'example.foo' ); match() returns a Boolean true value if the hash of the domain name argument matches the hashed owner name of the NSEC3 RR. =head2 covers $covered = $rr->covers( 'example.foo' ); covers() returns a Boolean true value if the hash of the domain name argument, or ancestor of that name, falls between the owner name and the next hashed owner name of the NSEC3 RR. =head2 encloser, nextcloser, wildcard $encloser = $rr->encloser( 'example.foo' ); print "encloser: $encloser\n" if $encloser; encloser() returns the name of a provable encloser of the query name argument obtained from the NSEC3 RR. nextcloser() returns the next closer name, which is one label longer than the closest encloser. This is only valid after encloser() has returned a valid domain name. wildcard() returns the unexpanded wildcard name from which the next closer name was possibly synthesised. This is only valid after encloser() has returned a valid domain name. =head1 COPYRIGHT Copyright (c)2017,2018 Dick Franks Portions Copyright (c)2007,2008 NLnet Labs. Author Olaf M. Kolkman All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/CDS.pm0000644000175000017500000000456414756035515015411 0ustar willemwillempackage Net::DNS::RR::CDS; use strict; use warnings; our $VERSION = (qw$Id: CDS.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR::DS); =head1 NAME Net::DNS::RR::CDS - DNS CDS resource record =cut use integer; sub algorithm { my ( $self, $arg ) = @_; return $self->SUPER::algorithm($arg) if $arg; return $self->SUPER::algorithm() unless defined $arg; @{$self}{qw(keytag algorithm digtype digestbin)} = ( 0, 0, 0, chr(0) ); return; } sub digtype { my ( $self, $arg ) = @_; return $self->SUPER::digtype($arg) if $arg; return $self->SUPER::digtype(); } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name CDS keytag algorithm digtype digest'); =head1 DESCRIPTION DNS Child DS resource record This is a clone of the DS record and inherits all properties of the Net::DNS::RR::DS class. Please see the L perl documentation for details. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head1 COPYRIGHT Copyright (c)2014,2017 Dick Franks All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/MX.pm0000644000175000017500000000752214756035515015321 0ustar willemwillempackage Net::DNS::RR::MX; use strict; use warnings; our $VERSION = (qw$Id: MX.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::MX - DNS MX resource record =cut use integer; use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; $self->{preference} = unpack( "\@$offset n", $$data ); $self->{exchange} = Net::DNS::DomainName1035->decode( $data, $offset + 2, @opaque ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, @argument ) = @_; my ( $offset, @opaque ) = @argument; my $exchange = $self->{exchange}; return pack 'n a*', $self->preference, $exchange->encode( $offset + 2, @opaque ); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $exchange = $self->{exchange}; return join ' ', $self->preference, $exchange->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(preference exchange)) { $self->$_( shift @argument ) } return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->preference(10); return; } sub preference { my ( $self, @value ) = @_; for (@value) { $self->{preference} = 0 + $_ } return $self->{preference} || 0; } sub exchange { my ( $self, @value ) = @_; for (@value) { $self->{exchange} = Net::DNS::DomainName1035->new($_) } return $self->{exchange} ? $self->{exchange}->name : undef; } my $function = sub { ## sort RRs in numerically ascending order. return $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; }; __PACKAGE__->set_rrsort_func( 'preference', $function ); __PACKAGE__->set_rrsort_func( 'default_sort', $function ); 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name MX preference exchange'); =head1 DESCRIPTION DNS Mail Exchanger (MX) resource record =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 preference $preference = $rr->preference; $rr->preference( $preference ); A 16 bit integer which specifies the preference given to this RR among others at the same owner. Lower values are preferred. =head2 exchange $exchange = $rr->exchange; $rr->exchange( $exchange ); A domain name which specifies a host willing to act as a mail exchange for the owner name. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. Portions Copyright (c)2005 Olaf Kolkman, NLnet Labs. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/TLSA.pm0000644000175000017500000001244314756035515015536 0ustar willemwillempackage Net::DNS::RR::TLSA; use strict; use warnings; our $VERSION = (qw$Id: TLSA.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::TLSA - DNS TLSA resource record =cut use integer; use Carp; use constant BABBLE => defined eval { require Digest::BubbleBabble }; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $next = $offset + $self->{rdlength}; @{$self}{qw(usage selector matchingtype)} = unpack "\@$offset C3", $$data; $offset += 3; $self->{certbin} = substr $$data, $offset, $next - $offset; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'C3 a*', @{$self}{qw(usage selector matchingtype certbin)}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; $self->_annotation( $self->babble ) if BABBLE; my @cert = split /(\S{64})/, $self->cert; my @rdata = ( $self->usage, $self->selector, $self->matchingtype, @cert ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(usage selector matchingtype)) { $self->$_( shift @argument ) } $self->cert(@argument); return; } sub usage { my ( $self, @value ) = @_; for (@value) { $self->{usage} = 0 + $_ } return $self->{usage} || 0; } sub selector { my ( $self, @value ) = @_; for (@value) { $self->{selector} = 0 + $_ } return $self->{selector} || 0; } sub matchingtype { my ( $self, @value ) = @_; for (@value) { $self->{matchingtype} = 0 + $_ } return $self->{matchingtype} || 0; } sub cert { my ( $self, @value ) = @_; return unpack "H*", $self->certbin() unless scalar @value; my @hex = map { /^"*([\dA-Fa-f]*)"*$/ || croak("corrupt hex"); $1 } @value; return $self->certbin( pack "H*", join "", @hex ); } sub certbin { my ( $self, @value ) = @_; for (@value) { $self->{certbin} = $_ } return $self->{certbin} || ""; } sub certificate { return &cert; } sub babble { return BABBLE ? Digest::BubbleBabble::bubblebabble( Digest => shift->certbin ) : ''; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name TLSA usage selector matchingtype certificate'); =head1 DESCRIPTION The Transport Layer Security Authentication (TLSA) DNS resource record is used to associate a TLS server certificate or public key with the domain name where the record is found, forming a "TLSA certificate association". The semantics of how the TLSA RR is interpreted are described in RFC6698. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 usage $usage = $rr->usage; $rr->usage( $usage ); 8-bit integer value which specifies the provided association that will be used to match the certificate presented in the TLS handshake. =head2 selector $selector = $rr->selector; $rr->selector( $selector ); 8-bit integer value which specifies which part of the TLS certificate presented by the server will be matched against the association data. =head2 matchingtype $matchingtype = $rr->matchingtype; $rr->matchingtype( $matchingtype ); 8-bit integer value which specifies how the certificate association is presented. =head2 certificate =head2 cert $cert = $rr->cert; $rr->cert( $cert ); Hexadecimal representation of the certificate data. =head2 certbin $certbin = $rr->certbin; $rr->certbin( $certbin ); Binary representation of the certificate data. =head2 babble print $rr->babble; The babble() method returns the 'BubbleBabble' representation of the digest if the Digest::BubbleBabble package is available, otherwise an empty string is returned. BubbleBabble represents a message digest as a string of plausible words, to make the digest easier to verify. The "words" are not necessarily real words, but they look more like words than a string of hex characters. The 'BubbleBabble' string is appended as a comment when the string method is called. =head1 COPYRIGHT Copyright (c)2012 Willem Toorop, NLnet Labs. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/ZONEMD.pm0000644000175000017500000001065214756035515015767 0ustar willemwillempackage Net::DNS::RR::ZONEMD; use strict; use warnings; our $VERSION = (qw$Id: ZONEMD.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::ZONEMD - DNS ZONEMD resource record =cut use integer; use Carp; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $rdata = substr $$data, $offset, $self->{rdlength}; @{$self}{qw(serial scheme algorithm digestbin)} = unpack 'NC2a*', $rdata; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'NC2a*', @{$self}{qw(serial scheme algorithm digestbin)}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @digest = split /(\S{64})/, $self->digest || qq(""); my @rdata = ( @{$self}{qw(serial scheme algorithm)}, @digest ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(serial scheme algorithm)) { $self->$_( shift @argument ) } $self->digest(@argument); return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->_parse_rdata( 0, 1, 1, '' ); return; } sub serial { my ( $self, @value ) = @_; for (@value) { $self->{serial} = 0 + $_ } return $self->{serial} || 0; } sub scheme { my ( $self, @value ) = @_; for (@value) { $self->{scheme} = 0 + $_ } return $self->{scheme} || 0; } sub algorithm { my ( $self, @value ) = @_; for (@value) { $self->{algorithm} = 0 + $_ } return $self->{algorithm} || 0; } sub digest { my ( $self, @value ) = @_; return unpack "H*", $self->digestbin() unless scalar @value; my @hex = map { /^"*([\dA-Fa-f]*)"*$/ || croak("corrupt hex"); $1 } @value; return $self->digestbin( pack "H*", join "", @hex ); } sub digestbin { my ( $self, @value ) = @_; for (@value) { $self->{digestbin} = $_ } return $self->{digestbin} || ""; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new("example.com. ZONEMD 2018031500 1 1 FEBE3D4CE2EC2FFA4BA99D46CD69D6D29711E55217057BEE 7EB1A7B641A47BA7FED2DD5B97AE499FAFA4F22C6BD647DE"); =head1 DESCRIPTION Class for DNS Zone Message Digest (ZONEMD) resource record. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 serial $serial = $rr->serial; $rr->serial( $serial ); Unsigned 32-bit integer zone serial number. =head2 scheme $scheme = $rr->scheme; $rr->scheme( $scheme ); The scheme field is an 8-bit unsigned integer that identifies the methods by which data is collated and presented as input to the hashing function. =head2 algorithm $algorithm = $rr->algorithm; $rr->algorithm( $algorithm ); The algorithm field is an 8-bit unsigned integer that identifies the cryptographic hash algorithm used to construct the digest. =head2 digest $digest = $rr->digest; $rr->digest( $digest ); Hexadecimal representation of the digest over the zone content. =head2 digestbin $digestbin = $rr->digestbin; $rr->digestbin( $digestbin ); Binary representation of the digest over the zone content. =head1 COPYRIGHT Copyright (c)2019 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/AAAA.pm0000644000175000017500000000765414756035515015466 0ustar willemwillempackage Net::DNS::RR::AAAA; use strict; use warnings; our $VERSION = (qw$Id: AAAA.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::AAAA - DNS AAAA resource record =cut use integer; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; $self->{address} = unpack "\@$offset a16", $$data; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'a16', $self->{address}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return $self->address_short; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->address(@argument); return; } sub address_long { my $addr = pack 'a*@16', grep {defined} shift->{address}; return sprintf '%x:%x:%x:%x:%x:%x:%x:%x', unpack 'n8', $addr; } sub address_short { my $addr = pack 'a*@16', grep {defined} shift->{address}; local $_ = sprintf ':%x:%x:%x:%x:%x:%x:%x:%x:', unpack 'n8', $addr; s/(:0[:0]+:)(?!.+:0\1)/::/; # squash longest zero sequence s/^:// unless /^::/; # prune LH : s/:$// unless /::$/; # prune RH : return $_; } sub address { my ( $self, $addr ) = @_; return address_long($self) unless defined $addr; my @parse = split /:/, "0$addr"; if ( (@parse)[$#parse] =~ /\./ ) { # embedded IPv4 my @ip4 = split /\./, pop(@parse); my $rhs = pop(@ip4); my @ip6 = map { /./ ? hex($_) : (0) x ( 7 - @parse ) } @parse; return $self->{address} = pack 'n6 C4', @ip6, @ip4, (0) x ( 3 - @ip4 ), $rhs; } # Note: pack() masks overlarge values, mostly without warning. my @expand = map { /./ ? hex($_) : (0) x ( 9 - @parse ) } @parse; return $self->{address} = pack 'n8', @expand; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name IN AAAA address'); $rr = Net::DNS::RR->new( name => 'example.com', type => 'AAAA', address => '2001:DB8::8:800:200C:417A' ); =head1 DESCRIPTION Class for DNS IPv6 Address (AAAA) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 address $IPv6_address = $rr->address; Returns the text representation of the IPv6 address. =head2 address_long $IPv6_address = $rr->address_long; Returns the text representation specified in RFC3513, 2.2(1). =head2 address_short $IPv6_address = $rr->address_short; Returns the textual form of address recommended by RFC5952. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. Portions Copyright (c)2003 Chris Reinhardt. Portions Copyright (c)2012 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/APL.pm0000644000175000017500000001435714756035515015415 0ustar willemwillempackage Net::DNS::RR::APL; use strict; use warnings; our $VERSION = (qw$Id: APL.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::APL - DNS APL resource record =cut use integer; use Carp; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $limit = $offset + $self->{rdlength}; my $aplist = $self->{aplist} = []; while ( $offset < $limit ) { my $xlen = unpack "\@$offset x3 C", $$data; my $size = ( $xlen & 0x7F ); my $item = bless {}, 'Net::DNS::RR::APL::Item'; $item->{negate} = $xlen - $size; @{$item}{qw(family prefix address)} = unpack "\@$offset n C x a$size", $$data; $offset += $size + 4; push @$aplist, $item; } croak('corrupt APL data') unless $offset == $limit; # more or less FUBAR return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my @rdata; my $aplist = $self->{aplist}; foreach (@$aplist) { my $address = $_->{address}; $address =~ s/[\000]+$//; # strip trailing null octets my $xlength = ( $_->{negate} ? 0x80 : 0 ) | length($address); push @rdata, pack 'n C2 a*', @{$_}{qw(family prefix)}, $xlength, $address; } return join '', @rdata; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $aplist = $self->{aplist}; my @rdata = map { $_->string } @$aplist; return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->aplist(@argument); return; } sub aplist { my ( $self, @argument ) = @_; while ( scalar @argument ) { # parse apitem strings last unless $argument[0] =~ m#[!:./]#; local $_ = shift @argument; m#^(!?)(\d+):(.+)/(\d+)$#; my $n = $1 ? 1 : 0; my $f = $2 || 0; my $a = $3; my $p = $4 || 0; $self->aplist( negate => $n, family => $f, address => $a, prefix => $p ); } my $aplist = $self->{aplist} ||= []; if ( my %argval = @argument ) { # parse attribute=value list my $item = bless {}, 'Net::DNS::RR::APL::Item'; while ( my ( $attribute, $value ) = each %argval ) { $item->$attribute($value) unless $attribute eq 'address'; } $item->address( $argval{address} ); # address must be last push @$aplist, $item; } my @ap = @$aplist; return unless defined wantarray; return wantarray ? @ap : join ' ', map { $_->string } @ap; } ######################################## package Net::DNS::RR::APL::Item; ## no critic ProhibitMultiplePackages use Net::DNS::RR::A; use Net::DNS::RR::AAAA; my %family = qw(1 Net::DNS::RR::A 2 Net::DNS::RR::AAAA); sub negate { my ( $self, @value ) = @_; for (@value) { return $self->{negate} = $_ } return $self->{negate}; } sub family { my ( $self, @value ) = @_; for (@value) { $self->{family} = 0 + $_ } return $self->{family} || 0; } sub prefix { my ( $self, @value ) = @_; for (@value) { $self->{prefix} = 0 + $_ } return $self->{prefix} || 0; } sub address { my ( $self, @value ) = @_; my $family = $family{$self->family} || die 'unknown address family'; return bless( {%$self}, $family )->address unless scalar @value; my $bitmask = $self->prefix; my $address = bless( {}, $family )->address( shift @value ); return $self->{address} = pack "B$bitmask", unpack 'B*', $address; } sub string { my $self = shift; my $not = $self->{negate} ? '!' : ''; my ( $family, $address, $prefix ) = ( $self->family, $self->address, $self->prefix ); return "$not$family:$address/$prefix"; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name IN APL aplist'); =head1 DESCRIPTION DNS Address Prefix List (APL) record =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 aplist @aplist = $rr->aplist; @aplist = $rr->aplist( '1:192.168.32.0/21', '!1:192.168.38.0/28' ); @aplist = $rr->aplist( '1:224.0.0.0/4', '2:FF00:0:0:0:0:0:0:0/8' ); @aplist = $rr->aplist( negate => 1, family => 1, address => '192.168.38.0', prefix => 28, ); Ordered, possibly empty, list of address prefix items. Additional items, if present, are appended to the existing list with neither prefix aggregation nor reordering. =head2 Net::DNS::RR::APL::Item Each element of the prefix list is a Net::DNS::RR::APL::Item object which is inextricably bound to the APL record which created it. =head2 negate $rr->negate(1); if ( $rr->negate ) { ... } Boolean attribute indicating the prefix to be an address range exclusion. =head2 family $family = $rr->family; $rr->family( $family ); Address family discriminant. =head2 prefix $prefix = $rr->prefix; $rr->prefix( $prefix ); Number of bits comprising the address prefix. =head2 address $address = $object->address; Address portion of the prefix list item. =head2 string $string = $object->string; Returns the prefix list item in the form required in zone files. =head1 COPYRIGHT Copyright (c)2008 Olaf Kolkman, NLnet Labs. Portions Copyright (c)2011,2017 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/NAPTR.pm0000644000175000017500000001344214756035515015657 0ustar willemwillempackage Net::DNS::RR::NAPTR; use strict; use warnings; our $VERSION = (qw$Id: NAPTR.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::NAPTR - DNS NAPTR resource record =cut use integer; use Net::DNS::DomainName; use Net::DNS::Text; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; @{$self}{qw(order preference)} = unpack "\@$offset n2", $$data; ( $self->{flags}, $offset ) = Net::DNS::Text->decode( $data, $offset + 4 ); ( $self->{service}, $offset ) = Net::DNS::Text->decode( $data, $offset ); ( $self->{regexp}, $offset ) = Net::DNS::Text->decode( $data, $offset ); $self->{replacement} = Net::DNS::DomainName2535->decode( $data, $offset, @opaque ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, $offset, @opaque ) = @_; my $rdata = pack 'n2', @{$self}{qw(order preference)}; $rdata .= $self->{flags}->encode; $rdata .= $self->{service}->encode; $rdata .= $self->{regexp}->encode; $rdata .= $self->{replacement}->encode( $offset + length($rdata), @opaque ); return $rdata; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @order = @{$self}{qw(order preference)}; my @rdata = ( @order, map { $_->string } @{$self}{qw(flags service regexp replacement)} ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; foreach (qw(order preference flags service regexp replacement)) { $self->$_( shift @argument ) } return; } sub order { my ( $self, @value ) = @_; for (@value) { $self->{order} = 0 + $_ } return $self->{order} || 0; } sub preference { my ( $self, @value ) = @_; for (@value) { $self->{preference} = 0 + $_ } return $self->{preference} || 0; } sub flags { my ( $self, @value ) = @_; for (@value) { $self->{flags} = Net::DNS::Text->new($_) } return $self->{flags} ? $self->{flags}->value : undef; } sub service { my ( $self, @value ) = @_; for (@value) { $self->{service} = Net::DNS::Text->new($_) } return $self->{service} ? $self->{service}->value : undef; } sub regexp { my ( $self, @value ) = @_; for (@value) { $self->{regexp} = Net::DNS::Text->new($_) } return $self->{regexp} ? $self->{regexp}->value : undef; } sub replacement { my ( $self, @value ) = @_; for (@value) { $self->{replacement} = Net::DNS::DomainName2535->new($_) } return $self->{replacement} ? $self->{replacement}->name : undef; } my $function = sub { my ( $a, $b ) = ( $Net::DNS::a, $Net::DNS::b ); return $a->{order} <=> $b->{order} || $a->{preference} <=> $b->{preference}; }; __PACKAGE__->set_rrsort_func( 'order', $function ); __PACKAGE__->set_rrsort_func( 'default_sort', $function ); 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name NAPTR ( order preference flags service regexp replacement )'); =head1 DESCRIPTION DNS Naming Authority Pointer (NAPTR) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 order $order = $rr->order; $rr->order( $order ); A 16-bit unsigned integer specifying the order in which the NAPTR records must be processed to ensure the correct ordering of rules. Low numbers are processed before high numbers. =head2 preference $preference = $rr->preference; $rr->preference( $preference ); A 16-bit unsigned integer that specifies the order in which NAPTR records with equal "order" values should be processed, low numbers being processed before high numbers. =head2 flags $flags = $rr->flags; $rr->flags( $flags ); A string containing flags to control aspects of the rewriting and interpretation of the fields in the record. Flags are single characters from the set [A-Z0-9]. =head2 service $service = $rr->service; $rr->service( $service ); Specifies the service(s) available down this rewrite path. It may also specify the protocol used to communicate with the service. =head2 regexp $regexp = $rr->regexp; $rr->regexp; A string containing a substitution expression that is applied to the original string held by the client in order to construct the next domain name to lookup. =head2 replacement $replacement = $rr->replacement; $rr->replacement( $replacement ); The next NAME to query for NAPTR, SRV, or address records depending on the value of the flags field. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. Portions Copyright (c)2005 Olaf Kolkman, NLnet Labs. Based on code contributed by Ryan Moats. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/MINFO.pm0000644000175000017500000000772114756035515015646 0ustar willemwillempackage Net::DNS::RR::MINFO; use strict; use warnings; our $VERSION = (qw$Id: MINFO.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::MINFO - DNS MINFO resource record =cut use integer; use Net::DNS::Mailbox; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; ( $self->{rmailbx}, $offset ) = Net::DNS::Mailbox1035->decode( $data, $offset, @opaque ); ( $self->{emailbx}, $offset ) = Net::DNS::Mailbox1035->decode( $data, $offset, @opaque ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, @argument ) = @_; my ( $offset, @opaque ) = @argument; my $rdata = $self->{rmailbx}->encode(@argument); $rdata .= $self->{emailbx}->encode( $offset + length $rdata, @opaque ); return $rdata; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @rdata = ( $self->{rmailbx}->string, $self->{emailbx}->string ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(rmailbx emailbx)) { $self->$_( shift @argument ) } return; } sub rmailbx { my ( $self, @value ) = @_; for (@value) { $self->{rmailbx} = Net::DNS::Mailbox1035->new($_) } return $self->{rmailbx} ? $self->{rmailbx}->address : undef; } sub emailbx { my ( $self, @value ) = @_; for (@value) { $self->{emailbx} = Net::DNS::Mailbox1035->new($_) } return $self->{emailbx} ? $self->{emailbx}->address : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR('name MINFO rmailbx emailbx'); =head1 DESCRIPTION Class for DNS Mailbox Information (MINFO) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 rmailbx $rmailbx = $rr->rmailbx; $rr->rmailbx( $rmailbx ); A domain name which specifies a mailbox which is responsible for the mailing list or mailbox. If this domain name names the root, the owner of the MINFO RR is responsible for itself. Note that many existing mailing lists use a mailbox X-request to identify the maintainer of mailing list X, e.g., Msgroup-request for Msgroup. This field provides a more general mechanism. =head2 emailbx $emailbx = $rr->emailbx; $rr->emailbx( $emailbx ); A domain name which specifies a mailbox which is to receive error messages related to the mailing list or mailbox specified by the owner of the MINFO RR (similar to the ERRORS-TO: field which has been proposed). If this domain name names the root, errors should be returned to the sender of the message. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/ISDN.pm0000644000175000017500000000665714756035515015542 0ustar willemwillempackage Net::DNS::RR::ISDN; use strict; use warnings; our $VERSION = (qw$Id: ISDN.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::ISDN - DNS ISDN resource record =cut use integer; use Net::DNS::Text; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; ( $self->{address}, $offset ) = Net::DNS::Text->decode( $data, $offset ); ( $self->{sa}, $offset ) = Net::DNS::Text->decode( $data, $offset ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $address = $self->{address}; return join '', $address->encode, $self->{sa}->encode; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $address = $self->{address}; return join ' ', $address->string, $self->{sa}->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->address( shift @argument ); $self->sa(@argument); return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->sa(''); return; } sub address { my ( $self, @value ) = @_; for (@value) { $self->{address} = Net::DNS::Text->new($_) } return $self->{address} ? $self->{address}->value : undef; } sub sa { my ( $self, @value ) = @_; for (@value) { $self->{sa} = Net::DNS::Text->new($_) } return $self->{sa} ? $self->{sa}->value : undef; } sub ISDNaddress { return &address; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name ISDN ISDNaddress sa'); =head1 DESCRIPTION Class for DNS ISDN resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 ISDNaddress =head2 address $address = $rr->address; $rr->address( $address ); The ISDN-address is a string of characters, normally decimal digits, beginning with the E.163 country code and ending with the DDI if any. =head2 sa $sa = $rr->sa; $rr->sa( $sa ); The optional subaddress (SA) is a string of hexadecimal digits. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/IPSECKEY.pm0000644000175000017500000001532014756035515016204 0ustar willemwillempackage Net::DNS::RR::IPSECKEY; use strict; use warnings; our $VERSION = (qw$Id: IPSECKEY.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::IPSECKEY - DNS IPSECKEY resource record =cut use integer; use Carp; use Net::DNS::DomainName; use Net::DNS::RR::A; use Net::DNS::RR::AAAA; use constant BASE64 => defined eval { require MIME::Base64 }; my %wireformat = ( 0 => 'C3 a0 a*', 1 => 'C3 a4 a*', 2 => 'C3 a16 a*', 3 => 'C3 a* a*', ); sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; my $limit = $offset + $self->{rdlength}; @{$self}{qw(precedence gatetype algorithm)} = unpack "\@$offset C3", $$data; $offset += 3; my $gatetype = $self->{gatetype}; if ( not $gatetype ) { delete $self->{gateway}; # no gateway } elsif ( $gatetype == 1 ) { $self->{gateway} = unpack "\@$offset a4", $$data; $offset += 4; } elsif ( $gatetype == 2 ) { $self->{gateway} = unpack "\@$offset a16", $$data; $offset += 16; } elsif ( $gatetype == 3 ) { my $name; ( $name, $offset ) = Net::DNS::DomainName->decode( $data, $offset, @opaque ); $self->{gateway} = $name->encode; } else { die "unknown gateway type ($gatetype)"; } $self->keybin( substr $$data, $offset, $limit - $offset ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $gatetype = $self->gatetype; my $gateway = $self->{gateway} || ''; my $precedence = $self->precedence; my $algorithm = $self->algorithm; my $keybin = $self->keybin; return pack $wireformat{$gatetype}, $precedence, $gatetype, $algorithm, $gateway, $keybin; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return $self->SUPER::_format_rdata() unless BASE64; my @rdata = map { $self->$_ } qw(precedence gatetype algorithm); my @base64 = split /\s+/, MIME::Base64::encode( $self->keybin ); push @rdata, ( $self->gateway, @base64 ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; foreach (qw(precedence gatetype algorithm gateway)) { $self->$_( shift @argument ) } $self->key(@argument); return; } sub precedence { my ( $self, @value ) = @_; for (@value) { $self->{precedence} = 0 + $_ } return $self->{precedence} || 0; } sub gatetype { return shift->{gatetype} || 0; } sub algorithm { my ( $self, @value ) = @_; for (@value) { $self->{algorithm} = 0 + $_ } return $self->{algorithm} || 0; } sub gateway { my ( $self, @value ) = @_; for (@value) { /^\.*$/ && do { $self->{gatetype} = 0; delete $self->{gateway}; # no gateway last; }; /:.*:/ && do { $self->{gatetype} = 2; $self->{gateway} = Net::DNS::RR::AAAA::address( {}, $_ ); last; }; /\.\d+$/ && do { $self->{gatetype} = 1; $self->{gateway} = Net::DNS::RR::A::address( {}, $_ ); last; }; /\..+/ && do { $self->{gatetype} = 3; $self->{gateway} = Net::DNS::DomainName->new($_)->encode; last; }; croak 'unrecognised gateway type'; } if ( defined wantarray ) { my $gateway = $self->{gateway}; for ( $self->gatetype ) { /^1$/ && return Net::DNS::RR::A::address( {address => $gateway} ); /^2$/ && return Net::DNS::RR::AAAA::address( {address => $gateway} ); /^3$/ && return Net::DNS::DomainName->decode( \$gateway )->name; } return wantarray ? '.' : undef; } return; } sub key { my ( $self, @value ) = @_; return MIME::Base64::encode( $self->keybin(), "" ) unless scalar @value; return $self->keybin( MIME::Base64::decode( join "", @value ) ); } sub keybin { my ( $self, @value ) = @_; for (@value) { $self->{keybin} = $_ } return $self->{keybin} || ""; } sub pubkey { return &key; } my $function = sub { ## sort RRs in numerically ascending order. return $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; }; __PACKAGE__->set_rrsort_func( 'preference', $function ); __PACKAGE__->set_rrsort_func( 'default_sort', $function ); 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name IPSECKEY precedence gatetype algorithm gateway key'); =head1 DESCRIPTION DNS IPSEC Key Storage (IPSECKEY) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 precedence $precedence = $rr->precedence; $rr->precedence( $precedence ); This is an 8-bit precedence for this record. Gateways listed in IPSECKEY records with lower precedence are to be attempted first. =head2 gatetype $gatetype = $rr->gatetype; The gateway type field indicates the format of the information that is stored in the gateway field. =head2 algorithm $algorithm = $rr->algorithm; $rr->algorithm( $algorithm ); The algorithm type field identifies the public keys cryptographic algorithm and determines the format of the public key field. =head2 gateway $gateway = $rr->gateway; $rr->gateway( $gateway ); The gateway field indicates a gateway to which an IPsec tunnel may be created in order to reach the entity named by this resource record. =head2 pubkey =head2 key $key = $rr->key; $rr->key( $key ); Base64 representation of the optional public key block for the resource record. =head2 keybin $keybin = $rr->keybin; $rr->keybin( $keybin ); Binary representation of the public key block for the resource record. =head1 COPYRIGHT Copyright (c)2007 Olaf Kolkman, NLnet Labs. Portions Copyright (c)2012,2015 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/RT.pm0000644000175000017500000000740114756035515015316 0ustar willemwillempackage Net::DNS::RR::RT; use strict; use warnings; our $VERSION = (qw$Id: RT.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::RT - DNS RT resource record =cut use integer; use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; $self->{preference} = unpack( "\@$offset n", $$data ); $self->{intermediate} = Net::DNS::DomainName2535->decode( $data, $offset + 2, @opaque ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, $offset, @opaque ) = @_; return pack 'n a*', $self->preference, $self->{intermediate}->encode( $offset + 2, @opaque ); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return join ' ', $self->preference, $self->{intermediate}->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(preference intermediate)) { $self->$_( shift @argument ) } return; } sub preference { my ( $self, @value ) = @_; for (@value) { $self->{preference} = 0 + $_ } return $self->{preference} || 0; } sub intermediate { my ( $self, @value ) = @_; for (@value) { $self->{intermediate} = Net::DNS::DomainName2535->new($_) } return $self->{intermediate} ? $self->{intermediate}->name : undef; } my $function = sub { ## sort RRs in numerically ascending order. return $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; }; __PACKAGE__->set_rrsort_func( 'preference', $function ); __PACKAGE__->set_rrsort_func( 'default_sort', $function ); 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name RT preference intermediate'); =head1 DESCRIPTION Class for DNS Route Through (RT) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 preference $preference = $rr->preference; $rr->preference( $preference ); A 16 bit integer representing the preference of the route. Smaller numbers indicate more preferred routes. =head2 intermediate $intermediate = $rr->intermediate; $rr->intermediate( $intermediate ); The domain name of a host which will serve as an intermediate in reaching the host specified by the owner name. The DNS RRs associated with the intermediate host are expected to include at least one A, X25, or ISDN record. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/LOC.pm0000644000175000017500000001760114756035515015411 0ustar willemwillempackage Net::DNS::RR::LOC; use strict; use warnings; our $VERSION = (qw$Id: LOC.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::LOC - DNS LOC resource record =cut use integer; use Carp; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $version = $self->{version} = unpack "\@$offset C", $$data; @{$self}{qw(size hp vp latitude longitude altitude)} = unpack "\@$offset xC3N3", $$data; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'C4N3', @{$self}{qw(version size hp vp latitude longitude altitude)}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my ( $altitude, @precision ) = map { $self->$_() . 'm' } qw(altitude size hp vp); my $precision = join ' ', @precision; for ($precision) { s/^1m 10000m 10m$//; s/ 10000m 10m$//; s/ 10m$//; } return ( $self->latitude, '', $self->longitude, '', $altitude, $precision ); } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; my @lat; while ( scalar @argument ) { my $this = shift @argument; push( @lat, $this ); last if $this =~ /[NSns]/; } $self->latitude(@lat); my @long; while ( scalar @argument ) { my $this = shift @argument; push( @long, $this ); last if $this =~ /[EWew]/; } $self->longitude(@long); foreach my $attr (qw(altitude size hp vp)) { $self->$attr(@argument); shift @argument; } return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->{version} = 0; $self->size(1); $self->hp(10000); $self->vp(10); return; } sub latitude { my ( $self, @value ) = @_; $self->{latitude} = _encode_angle(@value) if scalar @value; return _decode_angle( $self->{latitude} || return, 'N', 'S' ); } sub longitude { my ( $self, @value ) = @_; $self->{longitude} = _encode_angle(@value) if scalar @value; return _decode_angle( $self->{longitude} || return, 'E', 'W' ); } sub altitude { my ( $self, @value ) = @_; $self->{altitude} = _encode_alt(@value) if scalar @value; return _decode_alt( $self->{altitude} ); } sub size { my ( $self, @value ) = @_; $self->{size} = _encode_prec(@value) if scalar @value; return _decode_prec( $self->{size} ); } sub hp { my ( $self, @value ) = @_; $self->{hp} = _encode_prec(@value) if scalar @value; return _decode_prec( $self->{hp} ); } sub horiz_pre { return &hp; } # uncoverable pod sub vp { my ( $self, @value ) = @_; $self->{vp} = _encode_prec(@value) if scalar @value; return _decode_prec( $self->{vp} ); } sub vert_pre { return &vp; } # uncoverable pod sub latlon { my ( $self, @argument ) = @_; my @lat = @argument; my ( undef, @long ) = @argument; return ( scalar $self->latitude(@lat), scalar $self->longitude(@long) ); } sub version { return shift->{version}; } ######################################## no integer; use constant ALTITUDE0 => 10000000; use constant ORDINATE0 => 0x80000000; sub _decode_angle { my ( $msec, $N, $S ) = @_; return int( 0.5 + ( $msec - ORDINATE0 ) / 0.36 ) / 10000000 unless wantarray; use integer; my $abs = abs( $msec - ORDINATE0 ); my $deg = int( $abs / 3600000 ); my $min = int( $abs / 60000 ) % 60; no integer; my $sec = ( $abs % 60000 ) / 1000; return ( $deg, $min, $sec, ( $msec < ORDINATE0 ? $S : $N ) ); } sub _encode_angle { my @ang = @_; @ang = split /[\s\260'"]+/, shift @ang unless scalar @ang > 1; my $ang = ( 0 + shift @ang ) * 3600000; my $neg = ( @ang ? pop @ang : '' ) =~ /[SWsw]/; $ang += ( @ang ? shift @ang : 0 ) * 60000; $ang += ( @ang ? shift @ang : 0 ) * 1000; return int( 0.5 + ( $neg ? ORDINATE0 - $ang : ORDINATE0 + $ang ) ); } sub _decode_alt { my $cm = ( shift || ALTITUDE0 ) - ALTITUDE0; return 0.01 * $cm; } sub _encode_alt { ( my $argument = shift ) =~ s/[Mm]$//; $argument += 0; return int( 0.5 + ALTITUDE0 + 100 * $argument ); } my @power10 = ( 0.01, 0.1, 1, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6, 1e7, 1e8, 0, 0, 0, 0, 0 ); sub _decode_prec { my $argument = shift || 0; my $mantissa = $argument >> 4; return $mantissa * $power10[$argument & 0x0F]; } sub _encode_prec { ( my $argument = shift ) =~ s/[Mm]$//; my $exponent = 0; until ( $argument < $power10[1 + $exponent] ) { $exponent++ } my $mantissa = int( 0.5 + $argument / $power10[$exponent] ); return ( $mantissa & 0xF ) << 4 | $exponent; } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name LOC latitude longitude altitude size hp vp'); =head1 DESCRIPTION DNS geographical location (LOC) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 latitude $latitude = $rr->latitude; ($deg, $min, $sec, $ns ) = $rr->latitude; $rr->latitude( 42.357990 ); $rr->latitude( 42, 21, 28.764, 'N' ); $rr->latitude( '42 21 28.764 N' ); When invoked in scalar context, latitude is returned in degrees, a negative ordinate being south of the equator. When invoked in list context, latitude is returned as a list of separate degree, minute, and second values followed by N or S as appropriate. Optional replacement values may be represented as single value, list or formatted string. Trailing zero values are optional. =head2 longitude $longitude = $rr->longitude; ($deg, $min, $sec, $ew ) = $rr->longitude; $rr->longitude( -71.014338 ); $rr->longitude( 71, 0, 51.617, 'W' ); $rr->longitude( '71 0 51.617 W' ); When invoked in scalar context, longitude is returned in degrees, a negative ordinate being west of the prime meridian. When invoked in list context, longitude is returned as a list of separate degree, minute, and second values followed by E or W as appropriate. =head2 altitude $altitude = $rr->altitude; Represents altitude, in metres, relative to the WGS 84 reference spheroid used by GPS. =head2 size $size = $rr->size; Represents the diameter, in metres, of a sphere enclosing the described entity. =head2 hp $hp = $rr->hp; Represents the horizontal precision of the data expressed as the diameter, in metres, of the circle of error. =head2 vp $vp = $rr->vp; Represents the vertical precision of the data expressed as the total spread, in metres, of the distribution of possible values. =head2 latlon ($lat, $lon) = $rr->latlon; $rr->latlon($lat, $lon); Representation of the latitude and longitude coordinate pair as signed floating-point degrees. =head2 version $version = $rr->version; Version of LOC protocol. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. Portions Copyright (c)2011 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/NSEC.pm0000644000175000017500000001777214756035515015535 0ustar willemwillempackage Net::DNS::RR::NSEC; use strict; use warnings; our $VERSION = (qw$Id: NSEC.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::NSEC - DNS NSEC resource record =cut use integer; use Net::DNS::DomainName; use Net::DNS::Parameters qw(:type); sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $limit = $offset + $self->{rdlength}; ( $self->{nxtdname}, $offset ) = Net::DNS::DomainName->decode( $data, $offset ); $self->{typebm} = substr $$data, $offset, $limit - $offset; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $nxtdname = $self->{nxtdname}; return join '', $nxtdname->encode(), $self->{typebm}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $nxtdname = $self->{nxtdname}; return ( $nxtdname->string(), $self->typelist ); } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->nxtdname( shift @argument ); $self->typelist(@argument); return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->_parse_rdata('.'); return; } sub nxtdname { my ( $self, @value ) = @_; for (@value) { $self->{nxtdname} = Net::DNS::DomainName->new($_) } return $self->{nxtdname} ? $self->{nxtdname}->name : undef; } sub typelist { my ( $self, @argument ) = @_; if ( scalar(@argument) || !defined(wantarray) ) { $self->{typebm} = &_type2bm(@argument); return; } my @type = &_bm2type( $self->{typebm} ); return wantarray ? (@type) : "@type"; } sub typemap { my ( $self, $type ) = @_; my $number = typebyname($type); my $window = $number >> 8; my $bitnum = $number & 255; my $typebm = $self->{typebm} || return; my @bitmap; my $index = 0; while ( $index < length $typebm ) { my ( $block, $size ) = unpack "\@$index C2", $typebm; $bitmap[$block] = unpack "\@$index xxa$size", $typebm; $index += $size + 2; } my @bit = split //, unpack 'B*', ( $bitmap[$window] || return ); return $bit[$bitnum]; } sub match { my ( $self, $qname ) = @_; my $name = Net::DNS::DomainName->new($qname)->canonical; return $name eq $self->{owner}->canonical; } sub covers { my ( $self, $qname ) = @_; my $name = join chr(0), reverse Net::DNS::DomainName->new($qname)->_wire; my $this = join chr(0), reverse $self->{owner}->_wire; my $next = join chr(0), reverse $self->{nxtdname}->_wire; foreach ( $name, $this, $next ) {tr /\101-\132/\141-\172/} return ( $name cmp $this ) + ( "$next\001" cmp $name ) == 2 unless $next gt $this; return ( $name cmp $this ) + ( $next cmp $name ) == 2; } sub encloser { my ( $self, $qname ) = @_; my @label = Net::DNS::Domain->new($qname)->label; my @owner = $self->{owner}->label; my $depth = scalar(@owner); my $next; while ( scalar(@label) > $depth ) { $next = shift @label; } return unless defined $next; my $nextcloser = join( '.', $next, @label ); return if lc($nextcloser) ne lc( join '.', $next, @owner ); $self->{nextcloser} = $nextcloser; $self->{wildcard} = join( '.', '*', @label ); return $self->owner; } sub nextcloser { return shift->{nextcloser}; } sub wildcard { return shift->{wildcard}; } ######################################## sub _type2bm { my @typelist = @_; my @typearray; foreach my $typename ( map { split() } @typelist ) { my $number = typebyname($typename); my $window = $number >> 8; my $bitnum = $number & 255; my $octet = $bitnum >> 3; my $bit = $bitnum & 7; $typearray[$window][$octet] |= 0x80 >> $bit; } my $bitmap = ''; my $window = 0; foreach (@typearray) { if ( my $pane = $typearray[$window] ) { my @content = map { $_ || 0 } @$pane; $bitmap .= pack 'CC C*', $window, scalar(@content), @content; } $window++; } return $bitmap; } sub _bm2type { my @empty; my $bitmap = shift || return @empty; my $index = 0; my $limit = length $bitmap; my @typelist; while ( $index < $limit ) { my ( $block, $size ) = unpack "\@$index C2", $bitmap; my $typenum = $block << 8; foreach my $octet ( unpack "\@$index xxC$size", $bitmap ) { my $i = $typenum += 8; my @name; while ($octet) { --$i; unshift @name, typebyval($i) if $octet & 1; $octet = $octet >> 1; } push @typelist, @name; } $index += $size + 2; } return @typelist; } sub typebm { ## historical my ( $self, @typebm ) = @_; # uncoverable pod for (@typebm) { $self->{typebm} = $_ } $self->_deprecate('prefer $rr->typelist() or $rr->typemap()'); return $self->{typebm}; } sub covered { ## historical my ( $self, @argument ) = @_; # uncoverable pod return $self->covers(@argument); } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new( 'name NSEC nxtdname typelist' ); =head1 DESCRIPTION Class for DNSSEC NSEC resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 nxtdname $nxtdname = $rr->nxtdname; $rr->nxtdname( $nxtdname ); The Next Domain field contains the next owner name (in the canonical ordering of the zone) that has authoritative data or contains a delegation point NS RRset. =head2 typelist @typelist = $rr->typelist; $typelist = $rr->typelist; typelist() identifies the RRset types that exist at the NSEC RR owner name. When called in scalar context, the list is interpolated into a string. =head2 typemap $exists = $rr->typemap($rrtype); typemap() returns a Boolean true value if the specified RRtype occurs in the type bitmap of the NSEC record. =head2 match $matched = $rr->match( 'example.foo' ); match() returns a Boolean true value if the canonical form of the name argument matches the canonical owner name of the NSEC RR. =head2 covers $covered = $rr->covers( 'example.foo' ); covers() returns a Boolean true value if the canonical form of the name, or one of its ancestors, falls between the owner name and the nxtdname field of the NSEC record. =head2 encloser, nextcloser, wildcard $encloser = $rr->encloser( 'example.foo' ); print "encloser: $encloser\n" if $encloser; encloser() returns the name of a provable encloser of the query name argument obtained from the NSEC RR. nextcloser() returns the next closer name, which is one label longer than the closest encloser. This is only valid after encloser() has returned a valid domain name. wildcard() returns the unexpanded wildcard name from which the next closer name was possibly synthesised. This is only valid after encloser() has returned a valid domain name. =head1 COPYRIGHT Copyright (c)2001-2005 RIPE NCC. Author Olaf M. Kolkman Portions Copyright (c)2018-2019 Dick Franks All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/KX.pm0000644000175000017500000000716414756035515015321 0ustar willemwillempackage Net::DNS::RR::KX; use strict; use warnings; our $VERSION = (qw$Id: KX.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::KX - DNS KX resource record =cut use integer; use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; $self->{preference} = unpack( "\@$offset n", $$data ); $self->{exchange} = Net::DNS::DomainName2535->decode( $data, $offset + 2, @opaque ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, $offset, @opaque ) = @_; my $exchange = $self->{exchange}; return pack 'n a*', $self->preference, $exchange->encode( $offset + 2, @opaque ); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $exchange = $self->{exchange}; return join ' ', $self->preference, $exchange->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(preference exchange)) { $self->$_( shift @argument ) } return; } sub preference { my ( $self, @value ) = @_; for (@value) { $self->{preference} = 0 + $_ } return $self->{preference} || 0; } sub exchange { my ( $self, @value ) = @_; for (@value) { $self->{exchange} = Net::DNS::DomainName2535->new($_) } return $self->{exchange} ? $self->{exchange}->name : undef; } my $function = sub { ## sort RRs in numerically ascending order. $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; }; __PACKAGE__->set_rrsort_func( 'preference', $function ); __PACKAGE__->set_rrsort_func( 'default_sort', $function ); 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name KX preference exchange'); =head1 DESCRIPTION DNS Key Exchange Delegation (KX) record =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 preference $preference = $rr->preference; $rr->preference( $preference ); A 16 bit integer which specifies the preference given to this RR among others at the same owner. Lower values are preferred. =head2 exchange $exchange = $rr->exchange; $rr->exchange( $exchange ); A domain name which specifies a host willing to act as a key exchange for the owner name. =head1 COPYRIGHT Copyright (c)2009 Olaf Kolkman, NLnet Labs. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/SSHFP.pm0000644000175000017500000001134314756035515015654 0ustar willemwillempackage Net::DNS::RR::SSHFP; use strict; use warnings; our $VERSION = (qw$Id: SSHFP.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::SSHFP - DNS SSHFP resource record =cut use integer; use Carp; use constant BABBLE => defined eval { require Digest::BubbleBabble }; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $size = $self->{rdlength} - 2; @{$self}{qw(algorithm fptype fpbin)} = unpack "\@$offset C2 a$size", $$data; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'C2 a*', @{$self}{qw(algorithm fptype fpbin)}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; $self->_annotation( $self->babble ) if BABBLE; my @fprint = split /(\S{64})/, $self->fp; my @rdata = ( $self->algorithm, $self->fptype, @fprint ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(algorithm fptype)) { $self->$_( shift @argument ) } $self->fp(@argument); return; } sub algorithm { my ( $self, @value ) = @_; for (@value) { $self->{algorithm} = 0 + $_ } return $self->{algorithm} || 0; } sub fptype { my ( $self, @value ) = @_; for (@value) { $self->{fptype} = 0 + $_ } return $self->{fptype} || 0; } sub fp { my ( $self, @value ) = @_; return unpack "H*", $self->fpbin() unless scalar @value; my @hex = map { /^"*([\dA-Fa-f]*)"*$/ || croak("corrupt hex"); $1 } @value; return $self->fpbin( pack "H*", join "", @hex ); } sub fpbin { my ( $self, @value ) = @_; for (@value) { $self->{fpbin} = $_ } return $self->{fpbin} || ""; } sub babble { return BABBLE ? Digest::BubbleBabble::bubblebabble( Digest => shift->fpbin ) : ''; } sub fingerprint { return &fp; } ## historical 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name SSHFP algorithm fptype fp'); =head1 DESCRIPTION DNS SSH Fingerprint (SSHFP) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 algorithm $algorithm = $rr->algorithm; $rr->algorithm( $algorithm ); The 8-bit algorithm number describes the algorithm used to construct the public key. =head2 fptype $fptype = $rr->fptype; $rr->fptype( $fptype ); The 8-bit fingerprint type number describes the message-digest algorithm used to calculate the fingerprint of the public key. =head2 fingerprint =head2 fp $fp = $rr->fp; $rr->fp( $fp ); Hexadecimal representation of the fingerprint digest. =head2 fpbin $fpbin = $rr->fpbin; $rr->fpbin( $fpbin ); Returns opaque octet string representing the fingerprint digest. =head2 babble print $rr->babble; The babble() method returns the 'BabbleBubble' representation of the fingerprint if the Digest::BubbleBabble package is available, otherwise an empty string is returned. Bubble babble represents a message digest as a string of "real" words, to make the fingerprint easier to remember. The "words" are not necessarily real words, but they look more like words than a string of hex characters. Bubble babble fingerprinting is used by the SSH2 suite (and consequently by Net::SSH::Perl, the Perl SSH implementation) to display easy-to-remember key fingerprints. The 'BubbleBabble' string is appended as a comment when the string method is called. =head1 COPYRIGHT Copyright (c)2007 Olaf Kolkman, NLnet Labs. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/DSYNC.pm0000644000175000017500000001013414756035515015646 0ustar willemwillempackage Net::DNS::RR::DSYNC; use strict; use warnings; our $VERSION = (qw$Id: DSYNC.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::DSYNC - DNS DSYNC resource record =cut use integer; use Net::DNS::Parameters qw(:type); use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; @{$self}{qw(rrtype scheme port)} = unpack "\@$offset nCn", $$data; $self->{target} = Net::DNS::DomainName->decode( $data, $offset + 5, @opaque ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $target = $self->{target}; return pack 'nCn a*', @{$self}{qw(rrtype scheme port)}, $target->encode; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @params = map { $self->$_ } qw(rrtype scheme port); my $target = $self->{target}; return ( @params, $target->string ); } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->$_( shift @argument ) foreach qw(rrtype scheme port target); return; } sub rrtype { my ( $self, @value ) = @_; for (@value) { $self->{rrtype} = typebyname($_) } my $typecode = $self->{rrtype}; return defined $typecode ? typebyval($typecode) : undef; } sub scheme { my ( $self, @value ) = @_; for (@value) { $self->{scheme} = 0 + $_ } return $self->{scheme} || 0; } sub port { my ( $self, @value ) = @_; for (@value) { $self->{port} = 0 + $_ } return $self->{port} || 0; } sub target { my ( $self, @value ) = @_; for (@value) { $self->{target} = Net::DNS::DomainName->new($_) } return $self->{target} ? $self->{target}->name : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name DSYNC rrtype scheme port target'); =head1 DESCRIPTION Class for DNS Generalized Notify (DSYNC) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 rrtype $rrtype = $rr->rrtype; $rr->rrtype($rrtype); The type of generalized NOTIFY for which this DSYNC RR defines the desired target address. =head2 scheme $scheme = $rr->scheme; $rr->scheme( $scheme ); The scheme indicates the mode used for locating the notification address. This is an 8 bit unsigned integer. Records with value 0 (null scheme) are ignored by consumers. =head2 port $port = $rr->port; $rr->port( $port ); The port on the host providing the notification service. This is a 16 bit unsigned integer. =head2 target $target = $rr->target; $rr->target( $target ); The domain name of the target host providing the service which listens for notifications of the specified type. This name MUST resolve to one or more address records. =head1 COPYRIGHT Copyright (c)2024 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L draft-ietf-dnsop-generalized-notify =cut Net-DNS-1.50/lib/Net/DNS/RR/PX.pm0000644000175000017500000001041314756035515015315 0ustar willemwillempackage Net::DNS::RR::PX; use strict; use warnings; our $VERSION = (qw$Id: PX.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::PX - DNS PX resource record =cut use integer; use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; $self->{preference} = unpack( "\@$offset n", $$data ); ( $self->{map822}, $offset ) = Net::DNS::DomainName2535->decode( $data, $offset + 2, @opaque ); ( $self->{mapx400}, $offset ) = Net::DNS::DomainName2535->decode( $data, $offset, @opaque ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, $offset, @opaque ) = @_; my $mapx400 = $self->{mapx400}; my $rdata = pack( 'n', $self->{preference} ); $rdata .= $self->{map822}->encode( $offset + 2, @opaque ); $rdata .= $mapx400->encode( $offset + length($rdata), @opaque ); return $rdata; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @rdata = ( $self->preference, $self->{map822}->string, $self->{mapx400}->string ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(preference map822 mapx400)) { $self->$_( shift @argument ) } return; } sub preference { my ( $self, @value ) = @_; for (@value) { $self->{preference} = 0 + $_ } return $self->{preference} || 0; } sub map822 { my ( $self, @value ) = @_; for (@value) { $self->{map822} = Net::DNS::DomainName2535->new($_) } return $self->{map822} ? $self->{map822}->name : undef; } sub mapx400 { my ( $self, @value ) = @_; for (@value) { $self->{mapx400} = Net::DNS::DomainName2535->new($_) } return $self->{mapx400} ? $self->{mapx400}->name : undef; } my $function = sub { ## sort RRs in numerically ascending order. return $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; }; __PACKAGE__->set_rrsort_func( 'preference', $function ); __PACKAGE__->set_rrsort_func( 'default_sort', $function ); 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name PX preference map822 mapx400'); =head1 DESCRIPTION Class for DNS X.400 Mail Mapping Information (PX) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 preference $preference = $rr->preference; $rr->preference( $preference ); A 16 bit integer which specifies the preference given to this RR among others at the same owner. Lower values are preferred. =head2 map822 $map822 = $rr->map822; $rr->map822( $map822 ); A domain name element containing , the RFC822 part of the MIXER Conformant Global Address Mapping. =head2 mapx400 $mapx400 = $rr->mapx400; $rr->mapx400( $mapx400 ); A element containing the value of derived from the X.400 part of the MIXER Conformant Global Address Mapping. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/CERT.pm0000644000175000017500000001506714756035515015535 0ustar willemwillempackage Net::DNS::RR::CERT; use strict; use warnings; our $VERSION = (qw$Id: CERT.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::CERT - DNS CERT resource record =cut use integer; use Carp; use MIME::Base64; my %certtype = ( PKIX => 1, # X.509 as per PKIX SPKI => 2, # SPKI certificate PGP => 3, # OpenPGP packet IPKIX => 4, # The URL of an X.509 data object ISPKI => 5, # The URL of an SPKI certificate IPGP => 6, # The fingerprint and URL of an OpenPGP packet ACPKIX => 7, # Attribute Certificate IACPKIX => 8, # The URL of an Attribute Certificate URI => 253, # URI private OID => 254, # OID private ); sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; @{$self}{qw(certtype keytag algorithm)} = unpack "\@$offset n2 C", $$data; $self->{certbin} = substr $$data, $offset + 5, $self->{rdlength} - 5; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack "n2 C a*", $self->certtype, $self->keytag, $self->algorithm, $self->{certbin}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @param = ( $self->certtype, $self->keytag, $self->algorithm ); my @rdata = ( @param, split /\s+/, encode_base64( $self->{certbin} ) ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; foreach (qw(certtype keytag algorithm)) { $self->$_( shift @argument ); } $self->cert(@argument); return; } sub certtype { my ( $self, @value ) = @_; return $self->{certtype} unless scalar @value; my $certtype = shift @value; return $self->{certtype} = $certtype unless $certtype =~ /\D/; my $typenum = $certtype{$certtype}; $typenum || croak qq[unknown certtype $certtype]; return $self->{certtype} = $typenum; } sub keytag { my ( $self, @value ) = @_; for (@value) { $self->{keytag} = 0 + $_ } return $self->{keytag} || 0; } sub algorithm { my ( $self, $arg ) = @_; return $self->{algorithm} unless defined $arg; return _algbyval( $self->{algorithm} ) if uc($arg) eq 'MNEMONIC'; return $self->{algorithm} = _algbyname($arg); } sub certificate { return &certbin; } sub certbin { my ( $self, @value ) = @_; for (@value) { $self->{certbin} = $_ } return $self->{certbin} || ""; } sub cert { my ( $self, @value ) = @_; return MIME::Base64::encode( $self->certbin(), "" ) unless scalar @value; return $self->certbin( MIME::Base64::decode( join "", @value ) ); } sub format { return &certtype; } # uncoverable pod sub tag { return &keytag; } # uncoverable pod ######################################## { my @algbyname = ( 'DELETE' => 0, # [RFC4034][RFC4398][RFC8078] 'RSAMD5' => 1, # [RFC3110][RFC4034] 'DH' => 2, # [RFC2539] 'DSA' => 3, # [RFC3755][RFC2536] ## Reserved => 4, # [RFC6725] 'RSASHA1' => 5, # [RFC3110][RFC4034] 'DSA-NSEC3-SHA1' => 6, # [RFC5155] 'RSASHA1-NSEC3-SHA1' => 7, # [RFC5155] 'RSASHA256' => 8, # [RFC5702] ## Reserved => 9, # [RFC6725] 'RSASHA512' => 10, # [RFC5702] ## Reserved => 11, # [RFC6725] 'ECC-GOST' => 12, # [RFC5933] 'ECDSAP256SHA256' => 13, # [RFC6605] 'ECDSAP384SHA384' => 14, # [RFC6605] 'ED25519' => 15, # [RFC8080] 'ED448' => 16, # [RFC8080] 'SM2SM3' => 17, # [RFC-cuiling-dnsop-sm2-alg-15] 'ECC-GOST12' => 23, # [RFC-makarenko-gost2012-dnssec-05] 'INDIRECT' => 252, # [RFC4034] 'PRIVATEDNS' => 253, # [RFC4034] 'PRIVATEOID' => 254, # [RFC4034] ## Reserved => 255, # [RFC4034] ); my %algbyval = reverse @algbyname; foreach (@algbyname) { s/[\W_]//g; } # strip non-alphanumerics my @algrehash = map { /^\d/ ? ($_) x 3 : uc($_) } @algbyname; my %algbyname = @algrehash; # work around broken cperl sub _algbyname { my $arg = shift; my $key = uc $arg; # synthetic key $key =~ s/[\W_]//g; # strip non-alphanumerics my $val = $algbyname{$key}; return $val if defined $val; return $key =~ /^\d/ ? $arg : croak qq[unknown algorithm $arg]; } sub _algbyval { my $value = shift; return $algbyval{$value} || return $value; } } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name IN CERT certtype keytag algorithm cert'); =head1 DESCRIPTION Class for DNS Certificate (CERT) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 certtype $certtype = $rr->certtype; Returns the certtype code for the certificate (in numeric form). =head2 keytag $keytag = $rr->keytag; $rr->keytag( $keytag ); Returns the key tag for the public key in the certificate =head2 algorithm $algorithm = $rr->algorithm; Returns the algorithm used by the certificate (in numeric form). =head2 certificate =head2 certbin $certbin = $rr->certbin; $rr->certbin( $certbin ); Binary representation of the certificate. =head2 cert $cert = $rr->cert; $rr->cert( $cert ); Base64 representation of the certificate. =head1 COPYRIGHT Copyright (c)2002 VeriSign, Mike Schiraldi All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/PTR.pm0000644000175000017500000000551114756035515015436 0ustar willemwillempackage Net::DNS::RR::PTR; use strict; use warnings; our $VERSION = (qw$Id: PTR.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::PTR - DNS PTR resource record =cut use integer; use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, @argument ) = @_; $self->{ptrdname} = Net::DNS::DomainName1035->decode(@argument); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, @argument ) = @_; my $ptrdname = $self->{ptrdname}; return $ptrdname->encode(@argument); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $ptrdname = $self->{ptrdname}; return $ptrdname->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->ptrdname(@argument); return; } sub ptrdname { my ( $self, @value ) = @_; for (@value) { $self->{ptrdname} = Net::DNS::DomainName1035->new($_) } return $self->{ptrdname} ? $self->{ptrdname}->name : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name PTR ptrdname'); =head1 DESCRIPTION Class for DNS Pointer (PTR) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 ptrdname $ptrdname = $rr->ptrdname; $rr->ptrdname( $ptrdname ); A domain name which points to some location in the domain name space. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/HIP.pm0000644000175000017500000001241014756035515015405 0ustar willemwillempackage Net::DNS::RR::HIP; use strict; use warnings; our $VERSION = (qw$Id: HIP.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::HIP - DNS HIP resource record =cut use integer; use Carp; use Net::DNS::DomainName; use MIME::Base64; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my ( $hitlen, $pklen ) = unpack "\@$offset Cxn", $$data; @{$self}{qw(algorithm hitbin keybin)} = unpack "\@$offset xCxx a$hitlen a$pklen", $$data; my $limit = $offset + $self->{rdlength}; $offset += 4 + $hitlen + $pklen; $self->{servers} = []; while ( $offset < $limit ) { my $item; ( $item, $offset ) = Net::DNS::DomainName->decode( $data, $offset ); push @{$self->{servers}}, $item; } croak('corrupt HIP data') unless $offset == $limit; # more or less FUBAR return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $hit = $self->hitbin; my $key = $self->keybin; my $nos = pack 'C2n a* a*', length($hit), $self->algorithm, length($key), $hit, $key; return join '', $nos, map { $_->encode } @{$self->{servers}}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $base64 = MIME::Base64::encode( $self->{keybin}, '' ); my @server = map { $_->string } @{$self->{servers}}; my @rdata = ( $self->algorithm, $self->hit, $base64, @server ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; foreach (qw(algorithm hit key)) { $self->$_( shift @argument ) } $self->servers(@argument); return; } sub algorithm { my ( $self, @value ) = @_; for (@value) { $self->{algorithm} = 0 + $_ } return $self->{algorithm} || 0; } sub hit { my ( $self, @value ) = @_; return unpack "H*", $self->hitbin() unless scalar @value; my @hex = map { /^"*([\dA-Fa-f]*)"*$/ || croak("corrupt hex"); $1 } @value; return $self->hitbin( pack "H*", join "", @hex ); } sub hitbin { my ( $self, @value ) = @_; for (@value) { $self->{hitbin} = $_ } return $self->{hitbin} || ""; } sub key { my ( $self, @value ) = @_; return MIME::Base64::encode( $self->keybin(), "" ) unless scalar @value; return $self->keybin( MIME::Base64::decode( join "", @value ) ); } sub keybin { my ( $self, @value ) = @_; for (@value) { $self->{keybin} = $_ } return $self->{keybin} || ""; } sub servers { my ( $self, @names ) = @_; my $servers = $self->{servers} ||= []; for (@names) { push @$servers, Net::DNS::DomainName->new($_) } return defined(wantarray) ? map( { $_->name } @$servers ) : (); } sub rendezvousservers { ## historical my @servers = &servers; # uncoverable pod return \@servers; } sub pkalgorithm { ## historical return &algorithm; # uncoverable pod } sub pubkey { ## historical return &key; # uncoverable pod } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name IN HIP algorithm hit key servers'); =head1 DESCRIPTION Class for DNS Host Identity Protocol (HIP) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 algorithm $algorithm = $rr->algorithm; $rr->algorithm( $algorithm ); The PK algorithm field indicates the public key cryptographic algorithm and the implied public key field format. The values are those defined for the IPSECKEY algorithm type [RFC4025]. =head2 hit $hit = $rr->hit; $rr->hit( $hit ); The hexadecimal representation of the host identity tag. =head2 hitbin $hitbin = $rr->hitbin; $rr->hitbin( $hitbin ); The binary representation of the host identity tag. =head2 key $key = $rr->key; $rr->key( $key ); The MIME Base64 representation of the public key. =head2 keybin $keybin = $rr->keybin; $rr->keybin( $keybin ); The binary representation of the public key. =head2 servers @servers = $rr->servers; Optional list of domain names of rendezvous servers. =head1 COPYRIGHT Copyright (c)2009 Olaf Kolkman, NLnet Labs All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/LP.pm0000644000175000017500000000764114756035515015312 0ustar willemwillempackage Net::DNS::RR::LP; use strict; use warnings; our $VERSION = (qw$Id: LP.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::LP - DNS LP resource record =cut use integer; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; $self->{preference} = unpack( "\@$offset n", $$data ); $self->{target} = Net::DNS::DomainName->decode( $data, $offset + 2 ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $target = $self->{target}; return pack 'n a*', $self->preference, $target->encode(); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $target = $self->{target}; return join ' ', $self->preference, $target->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(preference target)) { $self->$_( shift @argument ) } return; } sub preference { my ( $self, @value ) = @_; for (@value) { $self->{preference} = 0 + $_ } return $self->{preference} || 0; } sub target { my ( $self, @value ) = @_; for (@value) { $self->{target} = Net::DNS::DomainName->new($_) } return $self->{target} ? $self->{target}->name : undef; } sub FQDN { return shift->{target}->fqdn; } sub fqdn { return shift->{target}->fqdn; } my $function = sub { ## sort RRs in numerically ascending order. return $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; }; __PACKAGE__->set_rrsort_func( 'preference', $function ); __PACKAGE__->set_rrsort_func( 'default_sort', $function ); 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name IN LP preference FQDN'); =head1 DESCRIPTION Class for DNS Locator Pointer (LP) resource records. The LP DNS resource record (RR) is used to hold the name of a subnetwork for ILNP. The name is an FQDN which can then be used to look up L32 or L64 records. LP is, effectively, a Locator Pointer to L32 and/or L64 records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 preference $preference = $rr->preference; $rr->preference( $preference ); A 16 bit unsigned integer in network byte order that indicates the relative preference for this LP record among other LP records associated with this owner name. Lower values are preferred over higher values. =head2 FQDN, fqdn =head2 target $target = $rr->target; $rr->target( $target ); The FQDN field contains the DNS target name that is used to reference L32 and/or L64 records. =head1 COPYRIGHT Copyright (c)2012 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/DNSKEY.pm0000644000175000017500000002236114756035515015770 0ustar willemwillempackage Net::DNS::RR::DNSKEY; use strict; use warnings; our $VERSION = (qw$Id: DNSKEY.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::DNSKEY - DNS DNSKEY resource record =cut use integer; use Carp; use constant BASE64 => defined eval { require MIME::Base64 }; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $rdata = substr $$data, $offset, $self->{rdlength}; @{$self}{qw(flags protocol algorithm keybin)} = unpack 'n C2 a*', $rdata; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'n C2 a*', @{$self}{qw(flags protocol algorithm keybin)}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @rdata = @{$self}{qw(flags protocol algorithm)}; if ( my $keybin = $self->keybin ) { $self->_annotation( 'keytag', $self->keytag ); return $self->SUPER::_format_rdata() unless BASE64; push @rdata, split /\s+/, MIME::Base64::encode($keybin); } else { push @rdata, '""'; } return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->flags( shift @argument ); $self->protocol( shift @argument ); my $algorithm = shift @argument; $self->key(@argument) if $algorithm; $self->algorithm($algorithm); return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->flags(256); $self->protocol(3); $self->algorithm(1); $self->keybin(''); return; } sub flags { my ( $self, @value ) = @_; for (@value) { $self->{flags} = 0 + $_ } return $self->{flags} || 0; } sub zone { my ( $self, @value ) = @_; if ( scalar @value ) { for ( $self->{flags} |= 0x0100 ) { $_ ^= 0x0100 unless shift @value; } } return $self->{flags} & 0x0100; } sub revoke { my ( $self, @value ) = @_; if ( scalar @value ) { for ( $self->{flags} |= 0x0080 ) { $_ ^= 0x0080 unless shift @value; } } return $self->{flags} & 0x0080; } sub sep { my ( $self, @value ) = @_; if ( scalar @value ) { for ( $self->{flags} |= 0x0001 ) { $_ ^= 0x0001 unless shift @value; } } return $self->{flags} & 0x0001; } sub protocol { my ( $self, @value ) = @_; for (@value) { $self->{protocol} = 0 + $_ } return $self->{protocol} || 0; } sub algorithm { my ( $self, $arg ) = @_; unless ( ref($self) ) { ## class method or simple function my $argn = pop; return $argn =~ /\D/ ? _algbyname($argn) : _algbyval($argn); } return $self->{algorithm} unless defined $arg; return _algbyval( $self->{algorithm} ) if uc($arg) eq 'MNEMONIC'; return $self->{algorithm} = _algbyname($arg) || die _algbyname('') # disallow algorithm(0) } sub key { my ( $self, @value ) = @_; return MIME::Base64::encode( $self->keybin(), "" ) unless scalar @value; return $self->keybin( MIME::Base64::decode( join "", @value ) ); } sub keybin { my ( $self, @value ) = @_; for (@value) { $self->{keybin} = $_ } return $self->{keybin} || ""; } sub publickey { my ( $self, @value ) = @_; return $self->key(@value); } sub privatekeyname { my $self = shift; my $name = $self->signame; return sprintf 'K%s+%03d+%05d.private', $name, $self->algorithm, $self->keytag; } sub signame { my $self = shift; return lc $self->{owner}->fqdn; } sub keylength { my $self = shift; my $keybin = $self->keybin || return; local $_ = _algbyval( $self->{algorithm} ); if (/^RSA/) { # Modulus length, see RFC 3110 if ( my $exp_length = unpack 'C', $keybin ) { return ( length($keybin) - $exp_length - 1 ) << 3; } else { $exp_length = unpack 'x n', $keybin; return ( length($keybin) - $exp_length - 3 ) << 3; } } elsif (/^DSA/) { # Modulus length, see RFC 2536 my $T = unpack 'C', $keybin; return ( $T << 6 ) + 512; } return length($keybin) << 2; ## ECDSA / EdDSA } sub keytag { my $self = shift; my $keybin = $self->{keybin} || return; # RFC4034 Appendix B.1: most significant 16 bits of least significant 24 bits return unpack 'n', substr $keybin, -3 if $self->{algorithm} == 1; # RFC4034 Appendix B my $od = length($keybin) & 1; my $rd = pack "n C2 a* x$od", @{$self}{qw(flags protocol algorithm)}, $keybin; my $ac = 0; $ac += $_ for unpack 'n*', $rd; $ac += ( $ac >> 16 ); return $ac & 0xFFFF; } ######################################## { my @algbyname = ( 'DELETE' => 0, # [RFC4034][RFC4398][RFC8078] 'RSAMD5' => 1, # [RFC3110][RFC4034] 'DH' => 2, # [RFC2539] 'DSA' => 3, # [RFC3755][RFC2536] ## Reserved => 4, # [RFC6725] 'RSASHA1' => 5, # [RFC3110][RFC4034] 'DSA-NSEC3-SHA1' => 6, # [RFC5155] 'RSASHA1-NSEC3-SHA1' => 7, # [RFC5155] 'RSASHA256' => 8, # [RFC5702] ## Reserved => 9, # [RFC6725] 'RSASHA512' => 10, # [RFC5702] ## Reserved => 11, # [RFC6725] 'ECC-GOST' => 12, # [RFC5933] 'ECDSAP256SHA256' => 13, # [RFC6605] 'ECDSAP384SHA384' => 14, # [RFC6605] 'ED25519' => 15, # [RFC8080] 'ED448' => 16, # [RFC8080] 'SM2SM3' => 17, # [RFC-cuiling-dnsop-sm2-alg-15] 'ECC-GOST12' => 23, # [RFC-makarenko-gost2012-dnssec-05] 'INDIRECT' => 252, # [RFC4034] 'PRIVATEDNS' => 253, # [RFC4034] 'PRIVATEOID' => 254, # [RFC4034] ## Reserved => 255, # [RFC4034] ); my %algbyval = reverse @algbyname; foreach (@algbyname) { s/[\W_]//g; } # strip non-alphanumerics my @algrehash = map { /^\d/ ? ($_) x 3 : uc($_) } @algbyname; my %algbyname = @algrehash; # work around broken cperl sub _algbyname { my $arg = shift; my $key = uc $arg; # synthetic key $key =~ s/[\W_]//g; # strip non-alphanumerics my $val = $algbyname{$key}; return $val if defined $val; return $key =~ /^\d/ ? $arg : croak qq[unknown algorithm $arg]; } sub _algbyval { my $value = shift; return $algbyval{$value} || return $value; } } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name DNSKEY flags protocol algorithm publickey'); =head1 DESCRIPTION Class for DNSSEC Key (DNSKEY) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 flags $flags = $rr->flags; $rr->flags( $flags ); Unsigned 16-bit number representing Boolean flags. =over 4 =item zone $rr->zone(1); if ( $rr->zone ) { ... } Boolean ZONE flag. =back =over 4 =item revoke $rr->revoke(1); if ( $rr->revoke ) { ... } Boolean REVOKE flag. =back =over 4 =item sep $rr->sep(1); if ( $rr->sep ) { ... } Boolean Secure Entry Point (SEP) flag. =back =head2 protocol $protocol = $rr->protocol; $rr->protocol( $protocol ); The 8-bit protocol number. This field MUST have value 3. =head2 algorithm $algorithm = $rr->algorithm; $rr->algorithm( $algorithm ); The 8-bit algorithm number describes the public key algorithm. algorithm() may also be invoked as a class method or simple function to perform mnemonic and numeric code translation. =head2 publickey =head2 key $key = $rr->key; $rr->key( $key ); Base64 representation of the public key material. =head2 keybin $keybin = $rr->keybin; $rr->keybin( $keybin ); Opaque octet string representing the public key material. =head2 privatekeyname $privatekeyname = $rr->privatekeyname; Returns the name of the privatekey as it would be generated by the BIND dnssec-keygen program. The format of that name being: K++.private =head2 signame $signame = $rr->signame; Returns the canonical signer name of the privatekey. =head2 keylength Returns the length (in bits) of the modulus calculated from the key text. =head2 keytag print "keytag = ", $rr->keytag, "\n"; Returns the 16-bit numerical key tag of the key. (RFC2535 4.1.6) =head1 COPYRIGHT Copyright (c)2003-2005 RIPE NCC. Author Olaf M. Kolkman All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/NID.pm0000644000175000017500000000737114756035515015411 0ustar willemwillempackage Net::DNS::RR::NID; use strict; use warnings; our $VERSION = (qw$Id: NID.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::NID - DNS NID resource record =cut use integer; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; @{$self}{qw(preference nodeid)} = unpack "\@$offset n a8", $$data; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'n a8', $self->{preference}, $self->{nodeid}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return join ' ', $self->preference, $self->nodeid; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(preference nodeid)) { $self->$_( shift @argument ) } return; } sub preference { my ( $self, @value ) = @_; for (@value) { $self->{preference} = 0 + $_ } return $self->{preference} || 0; } sub nodeid { my ( $self, $idnt ) = @_; $self->{nodeid} = pack 'n4', map { hex($_) } split /:/, $idnt if defined $idnt; return $self->{nodeid} ? join( ':', unpack 'H4H4H4H4', $self->{nodeid} ) : undef; } my $function = sub { ## sort RRs in numerically ascending order. return $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; }; __PACKAGE__->set_rrsort_func( 'preference', $function ); __PACKAGE__->set_rrsort_func( 'default_sort', $function ); 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name IN NID preference nodeid'); =head1 DESCRIPTION Class for DNS Node Identifier (NID) resource records. The Node Identifier (NID) DNS resource record is used to hold values for Node Identifiers that will be used for ILNP-capable nodes. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 preference $preference = $rr->preference; $rr->preference( $preference ); A 16 bit unsigned integer in network byte order that indicates the relative preference for this NID record among other NID records associated with this owner name. Lower values are preferred over higher values. =head2 nodeid $nodeid = $rr->nodeid; The NodeID field is an unsigned 64-bit value in network byte order. The text representation uses the same syntax (i.e., groups of 4 hexadecimal digits separated by a colons) that is already used for IPv6 interface identifiers. =head1 COPYRIGHT Copyright (c)2012 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/TXT.pm0000644000175000017500000000737214756035515015457 0ustar willemwillempackage Net::DNS::RR::TXT; use strict; use warnings; our $VERSION = (qw$Id: TXT.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =encoding utf8 =head1 NAME Net::DNS::RR::TXT - DNS TXT resource record =cut use integer; use Carp; use Net::DNS::Text; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $limit = $self->{rdlength}; my $rdata = substr $$data, $offset, $limit; my $array = $self->{txtdata} = []; my $index = 0; while ( $index < $limit ) { ( my $text, $index ) = Net::DNS::Text->decode( \$rdata, $index ); push @$array, $text; } return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $txtdata = $self->{txtdata}; return join '', map { $_->encode } @$txtdata; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $txtdata = $self->{txtdata}; return ( map { $_->unicode } @$txtdata ); } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->{txtdata} = [map { Net::DNS::Text->new($_) } @argument]; return; } sub txtdata { my ( $self, @value ) = @_; $self->{txtdata} = [map { Net::DNS::Text->new($_) } @value] if scalar @value; my $txtdata = $self->{txtdata} || []; return ( map { $_->value } @$txtdata ) if wantarray; return defined(wantarray) ? join( ' ', map { $_->value } @$txtdata ) : ''; } sub char_str_list { return my @txt = &txtdata } # uncoverable pod 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new( 'name TXT txtdata ...' ); $rr = Net::DNS::RR->new( name => 'name', type => 'TXT', txtdata => 'single text string' ); $rr = Net::DNS::RR->new( name => 'name', type => 'TXT', txtdata => [ 'multiple', 'strings', ... ] ); use utf8; $rr = Net::DNS::RR->new( 'jp TXT 古池や　蛙飛込む　水の音' ); =head1 DESCRIPTION Class for DNS Text (TXT) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 txtdata $string = $rr->txtdata; @list = $rr->txtdata; $rr->txtdata( @list ); When invoked in scalar context, txtdata() returns a concatenation of the descriptive text elements each separated by a single space character. In a list context, txtdata() returns a list of the text elements. =head1 COPYRIGHT Copyright (c)2011 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/KEY.pm0000644000175000017500000000453514756035515015426 0ustar willemwillempackage Net::DNS::RR::KEY; use strict; use warnings; our $VERSION = (qw$Id: KEY.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR::DNSKEY); =head1 NAME Net::DNS::RR::KEY - DNS KEY resource record =cut sub _defaults { ## specify RR attribute default values my $self = shift; $self->algorithm(1); $self->flags(0); $self->protocol(3); return; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name KEY flags protocol algorithm publickey'); =head1 DESCRIPTION DNS KEY resource record This is a clone of the DNSKEY record and inherits all properties of the Net::DNS::RR::DNSKEY class. Please see the L documentation for details. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head1 COPYRIGHT Copyright (c)2005 Olaf Kolkman, NLnet Labs. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/NSEC3PARAM.pm0000644000175000017500000001154614756035515016372 0ustar willemwillempackage Net::DNS::RR::NSEC3PARAM; use strict; use warnings; our $VERSION = (qw$Id: NSEC3PARAM.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::NSEC3PARAM - DNS NSEC3PARAM resource record =cut use integer; use Carp; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $size = unpack "\@$offset x4 C", $$data; @{$self}{qw(algorithm flags iterations saltbin)} = unpack "\@$offset CCnx a$size", $$data; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $salt = $self->saltbin; return pack 'CCnCa*', @{$self}{qw(algorithm flags iterations)}, length($salt), $salt; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return join ' ', $self->algorithm, $self->flags, $self->iterations, $self->salt || '-'; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(algorithm flags iterations)) { $self->$_( shift @argument ) } my $salt = shift @argument; $self->salt($salt) unless $salt eq '-'; return; } sub algorithm { my ( $self, @value ) = @_; for (@value) { $self->{algorithm} = 0 + $_ } return $self->{algorithm} || 0; } sub flags { my ( $self, @value ) = @_; for (@value) { $self->{flags} = 0 + $_ } return $self->{flags} || 0; } sub iterations { my ( $self, @value ) = @_; for (@value) { $self->{iterations} = 0 + $_ } return $self->{iterations} || 0; } sub salt { my ( $self, @value ) = @_; return unpack "H*", $self->saltbin() unless scalar @value; my @hex = map { /^"*([\dA-Fa-f]*)"*$/ || croak("corrupt hex"); $1 } @value; return $self->saltbin( pack "H*", join "", @hex ); } sub saltbin { my ( $self, @value ) = @_; for (@value) { $self->{saltbin} = $_ } return $self->{saltbin} || ""; } ######################################## sub hashalgo { return &algorithm; } # uncoverable pod ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name NSEC3PARAM algorithm flags iterations salt'); =head1 DESCRIPTION Class for DNSSEC NSEC3PARAM resource records. The NSEC3PARAM RR contains the NSEC3 parameters (hash algorithm, flags, iterations and salt) needed to calculate hashed ownernames. The presence of an NSEC3PARAM RR at a zone apex indicates that the specified parameters may be used by authoritative servers to choose an appropriate set of NSEC3 records for negative responses. The NSEC3PARAM RR is not used by validators or resolvers. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 algorithm $algorithm = $rr->algorithm; $rr->algorithm( $algorithm ); The 8-bit algorithm field is represented as an unsigned decimal integer. =head2 flags $flags = $rr->flags; $rr->flags( $flags ); The Flags field is an unsigned decimal integer interpreted as eight concatenated Boolean values. =head2 iterations $iterations = $rr->iterations; $rr->iterations( $iterations ); The Iterations field is represented as an unsigned decimal integer. The value is between 0 and 65535, inclusive. =head2 salt $salt = $rr->salt; $rr->salt( $salt ); The Salt field is represented as a contiguous sequence of hexadecimal digits. A "-" (unquoted) is used in string format to indicate that the salt field is absent. =head2 saltbin $saltbin = $rr->saltbin; $rr->saltbin( $saltbin ); The Salt field as a sequence of octets. =head1 COPYRIGHT Copyright (c)2007,2008 NLnet Labs. Author Olaf M. Kolkman All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/MB.pm0000644000175000017500000000537514756035515015277 0ustar willemwillempackage Net::DNS::RR::MB; use strict; use warnings; our $VERSION = (qw$Id: MB.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::MB - DNS MB resource record =cut use integer; use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, @argument ) = @_; $self->{madname} = Net::DNS::DomainName1035->decode(@argument); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, @argument ) = @_; return $self->{madname}->encode(@argument); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return $self->{madname}->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->madname(@argument); return; } sub madname { my ( $self, @value ) = @_; for (@value) { $self->{madname} = Net::DNS::DomainName1035->new($_) } return $self->{madname} ? $self->{madname}->name : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name MB madname'); =head1 DESCRIPTION Class for DNS Mailbox (MB) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 madname $madname = $rr->madname; $rr->madname( $madname ); A domain name which specifies a host which has the specified mailbox. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/OPENPGPKEY.pm0000644000175000017500000000607114756035515016454 0ustar willemwillempackage Net::DNS::RR::OPENPGPKEY; use strict; use warnings; our $VERSION = (qw$Id: OPENPGPKEY.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::OPENPGPKEY - DNS OPENPGPKEY resource record =cut use integer; use MIME::Base64; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $length = $self->{rdlength}; $self->keybin( substr $$data, $offset, $length ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'a*', $self->keybin; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @base64 = split /\s+/, encode_base64( $self->keybin ); return @base64; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->key(@argument); return; } sub key { my ( $self, @value ) = @_; return MIME::Base64::encode( $self->keybin(), "" ) unless scalar @value; return $self->keybin( MIME::Base64::decode( join "", @value ) ); } sub keybin { my ( $self, @value ) = @_; for (@value) { $self->{keybin} = $_ } return $self->{keybin} || ""; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name OPENPGPKEY key'); =head1 DESCRIPTION Class for OpenPGP Key (OPENPGPKEY) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 key $key = $rr->key; $rr->key( $key ); Base64 encoded representation of the OpenPGP public key material. =head2 keybin $keybin = $rr->keybin; $rr->keybin( $keybin ); OpenPGP public key material consisting of a single OpenPGP transferable public key in RFC4880 format. =head1 COPYRIGHT Copyright (c)2014 Dick Franks All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/CNAME.pm0000644000175000017500000000575214756035515015623 0ustar willemwillempackage Net::DNS::RR::CNAME; use strict; use warnings; our $VERSION = (qw$Id: CNAME.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::CNAME - DNS CNAME resource record =cut use integer; use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, @argument ) = @_; $self->{cname} = Net::DNS::DomainName1035->decode(@argument); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, @argument ) = @_; my $cname = $self->{cname}; return $cname->encode(@argument); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $cname = $self->{cname}; return $cname->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->cname(@argument); return; } sub cname { my ( $self, @value ) = @_; for (@value) { $self->{cname} = Net::DNS::DomainName1035->new($_) } return $self->{cname} ? $self->{cname}->name : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name CNAME cname'); $rr = Net::DNS::RR->new( name => 'alias.example.com', type => 'CNAME', cname => 'example.com', ); =head1 DESCRIPTION Class for DNS Canonical Name (CNAME) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 cname $cname = $rr->cname; $rr->cname( $cname ); A domain name which specifies the canonical or primary name for the owner. The owner name is an alias. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. Portions Copyright (c)2002-2003 Chris Reinhardt. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/SOA.pm0000644000175000017500000002002314756035515015406 0ustar willemwillempackage Net::DNS::RR::SOA; use strict; use warnings; our $VERSION = (qw$Id: SOA.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::SOA - DNS SOA resource record =cut use integer; use Net::DNS::DomainName; use Net::DNS::Mailbox; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; ( $self->{mname}, $offset ) = Net::DNS::DomainName1035->decode( $data, $offset, @opaque ); ( $self->{rname}, $offset ) = Net::DNS::Mailbox1035->decode( $data, $offset, @opaque ); @{$self}{qw(serial refresh retry expire minimum)} = unpack "\@$offset N5", $$data; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, @argument ) = @_; my ( $offset, @opaque ) = @argument; my $rname = $self->{rname}; my $rdata = $self->{mname}->encode(@argument); $rdata .= $rname->encode( $offset + length($rdata), @opaque ); $rdata .= pack 'N5', $self->serial, @{$self}{qw(refresh retry expire minimum)}; return $rdata; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $mname = $self->{mname}->string; my $rname = $self->{rname}->string; my $serial = $self->serial; my $spacer = length "$serial" > 7 ? "" : "\t"; return ($mname, $rname, join( "\n\t\t\t\t", "\t\t\t$serial$spacer\t;serial", "$self->{refresh}\t\t;refresh", "$self->{retry}\t\t;retry", "$self->{expire}\t\t;expire", "$self->{minimum}\t\t;minimum\n" ) ); } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(mname rname)) { $self->$_( shift @argument ) } $self->serial( shift @argument ) if scalar @argument; # possibly undefined for (qw(refresh retry expire minimum)) { last unless scalar @argument; $self->$_( Net::DNS::RR::ttl( {}, shift @argument ) ); } return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->_parse_rdata(qw(. . 0 4h 1h 3w 1h)); delete $self->{serial}; return; } sub mname { my ( $self, @value ) = @_; for (@value) { $self->{mname} = Net::DNS::DomainName1035->new($_) } return $self->{mname} ? $self->{mname}->name : undef; } sub rname { my ( $self, @value ) = @_; for (@value) { $self->{rname} = Net::DNS::Mailbox1035->new($_) } return $self->{rname} ? $self->{rname}->address : undef; } sub serial { my ( $self, @value ) = @_; return $self->{serial} || 0 unless scalar @value; # current/default value my $value = shift @value; # replace if in sequence return $self->{serial} = ( $value & 0xFFFFFFFF ) if _ordered( $self->{serial}, $value ); # unwise to assume 64-bit arithmetic, or that 32-bit integer overflow goes unpunished my $serial = 0xFFFFFFFF & ( $self->{serial} || 0 ); return $self->{serial} = 0x80000000 if $serial == 0x7FFFFFFF; # wrap return $self->{serial} = 0x00000000 if $serial == 0xFFFFFFFF; # wrap return $self->{serial} = $serial + 1; # increment } sub refresh { my ( $self, @value ) = @_; for (@value) { $self->{refresh} = 0 + $_ } return $self->{refresh} || 0; } sub retry { my ( $self, @value ) = @_; for (@value) { $self->{retry} = 0 + $_ } return $self->{retry} || 0; } sub expire { my ( $self, @value ) = @_; for (@value) { $self->{expire} = 0 + $_ } return $self->{expire} || 0; } sub minimum { my ( $self, @value ) = @_; for (@value) { $self->{minimum} = 0 + $_ } return $self->{minimum} || 0; } ######################################## sub _ordered() { ## irreflexive 32-bit partial ordering my ( $n1, $n2 ) = @_; return 0 unless defined $n2; # ( any, undef ) return 1 unless defined $n1; # ( undef, any ) # unwise to assume 64-bit arithmetic, or that 32-bit integer overflow goes unpunished use integer; # fold, leaving $n2 non-negative $n1 = ( $n1 & 0xFFFFFFFF ) ^ ( $n2 & 0x80000000 ); # -2**31 <= $n1 < 2**32 $n2 = ( $n2 & 0x7FFFFFFF ); # 0 <= $n2 < 2**31 return $n1 < $n2 ? ( $n1 > ( $n2 - 0x80000000 ) ) : ( $n2 < ( $n1 - 0x80000000 ) ); } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name SOA mname rname 0 14400 3600 1814400 3600'); =head1 DESCRIPTION Class for DNS Start of Authority (SOA) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 mname $mname = $rr->mname; $rr->mname( $mname ); The domain name of the name server that was the original or primary source of data for this zone. =head2 rname $rname = $rr->rname; $rr->rname( $rname ); The mailbox which identifies the person responsible for maintaining this zone. =head2 serial $serial = $rr->serial; $serial = $rr->serial(value); Unsigned 32 bit version number of the original copy of the zone. Zone transfers preserve this value. RFC1982 defines a strict (irreflexive) partial ordering for zone serial numbers. The serial number will be incremented unless the replacement value argument satisfies the ordering constraint. =head2 refresh $refresh = $rr->refresh; $rr->refresh( $refresh ); A 32 bit time interval before the zone should be refreshed. =head2 retry $retry = $rr->retry; $rr->retry( $retry ); A 32 bit time interval that should elapse before a failed refresh should be retried. =head2 expire $expire = $rr->expire; $rr->expire( $expire ); A 32 bit time value that specifies the upper limit on the time interval that can elapse before the zone is no longer authoritative. =head2 minimum $minimum = $rr->minimum; $rr->minimum( $minimum ); The unsigned 32 bit minimum TTL field that should be exported with any RR from this zone. =head1 Zone Serial Number Management The internal logic of the serial() method offers support for several widely used zone serial numbering policies. =head2 Strictly Sequential $successor = $soa->serial( SEQUENTIAL ); The existing serial number is incremented modulo 2**32 because the value returned by the auxiliary SEQUENTIAL() function can never satisfy the serial number ordering constraint. =head2 Date Encoded $successor = $soa->serial( YYYYMMDDxx ); The 32 bit value returned by the auxiliary YYYYMMDDxx() function will be used if it satisfies the ordering constraint, otherwise the serial number will be incremented as above. Serial number increments must be limited to 100 per day for the date information to remain useful. =head2 Time Encoded $successor = $soa->serial( UNIXTIME ); The 32 bit value returned by the auxiliary UNIXTIME() function will used if it satisfies the ordering constraint, otherwise the existing serial number will be incremented as above. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. Portions Copyright (c)2003 Chris Reinhardt. Portions Copyright (c)2010,2012 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/X25.pm0000644000175000017500000000552514756035515015354 0ustar willemwillempackage Net::DNS::RR::X25; use strict; use warnings; our $VERSION = (qw$Id: X25.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::X25 - DNS X25 resource record =cut use integer; use Net::DNS::Text; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; $self->{address} = Net::DNS::Text->decode( $data, $offset ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return $self->{address}->encode; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return $self->{address}->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->address(@argument); return; } sub address { my ( $self, @value ) = @_; for (@value) { $self->{address} = Net::DNS::Text->new($_) } return $self->{address} ? $self->{address}->value : undef; } sub PSDNaddress { return &address; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name X25 PSDNaddress'); =head1 DESCRIPTION Class for DNS X25 resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 PSDNaddress =head2 address $address = $rr->address; $rr->address( $address ); The PSDN-address is a string of decimal digits, beginning with the 4 digit DNIC (Data Network Identification Code), as specified in X.121. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/SIG.pm0000644000175000017500000005352414756035515015422 0ustar willemwillempackage Net::DNS::RR::SIG; use strict; use warnings; our $VERSION = (qw$Id: SIG.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::SIG - DNS SIG resource record =cut use integer; use Carp; use Time::Local; use Net::DNS::Parameters qw(:type); use constant DEBUG => 0; use constant UTIL => defined eval { require Scalar::Util; }; eval { require MIME::Base64 }; ## IMPORTANT: MUST NOT include crypto packages in metadata (strong crypto prohibited in many territories) use constant DNSSEC => defined $INC{'Net/DNS/SEC.pm'}; ## Discover how we got here, without exposing any crypto my @index; if (DNSSEC) { foreach my $class ( map {"Net::DNS::SEC::$_"} qw(Private RSA DSA ECDSA EdDSA Digest SM2) ) { my @algorithms = eval join '', qw(r e q u i r e), " $class; ${class}::_index()"; ## no critic push @index, map { ( $_ => $class ) } @algorithms; } croak 'Net::DNS::SEC version not supported' unless scalar(@index); } my %DNSSEC_verify = @index; my %DNSSEC_siggen = @index; my @field = qw(typecovered algorithm labels orgttl sigexpiration siginception keytag); sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; my $limit = $offset + $self->{rdlength}; @{$self}{@field} = unpack "\@$offset n C2 N3 n", $$data; ( $self->{signame}, $offset ) = Net::DNS::DomainName->decode( $data, $offset + 18, @opaque ); $self->{sigbin} = substr $$data, $offset, $limit - $offset; croak('misplaced or corrupt SIG') unless $limit == length $$data; my $raw = substr $$data, 0, $self->{offset}++; $self->{rawref} = \$raw; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, $offset, @opaque ) = @_; my $signame = $self->{signame}; if ( DNSSEC && !$self->{sigbin} ) { my ( undef, $packet ) = @opaque; my $private = delete $self->{private}; # one shot is all you get my $sigdata = $self->_CreateSigData($packet); $self->_CreateSig( $sigdata, $private || die 'missing key reference' ); } return pack 'n C2 N3 n a* a*', @{$self}{@field}, $signame->canonical, $self->sigbin; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $sname = $self->{signame} || return ''; my @sig64 = split /\s+/, MIME::Base64::encode( $self->sigbin ); my @rdata = ( map( { $self->$_ } @field ), $sname->string, @sig64 ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; foreach ( @field, qw(signame) ) { $self->$_( shift @argument ) } $self->signature(@argument); return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->class('ANY'); $self->typecovered('TYPE0'); $self->algorithm(1); $self->labels(0); $self->orgttl(0); $self->sigval(10); return; } sub typecovered { my ( $self, @value ) = @_; # uncoverable pod for (@value) { $self->{typecovered} = typebyname($_) } my $typecode = $self->{typecovered}; return defined $typecode ? typebyval($typecode) : undef; } sub algorithm { my ( $self, $arg ) = @_; unless ( ref($self) ) { ## class method or simple function my $argn = pop; return $argn =~ /[^0-9]/ ? _algbyname($argn) : _algbyval($argn); } return $self->{algorithm} unless defined $arg; return _algbyval( $self->{algorithm} ) if $arg =~ /MNEMONIC/i; return $self->{algorithm} = _algbyname($arg); } sub labels { return shift->{labels} = 0; # uncoverable pod } sub orgttl { return shift->{orgttl} = 0; # uncoverable pod } sub sigexpiration { my ( $self, @value ) = @_; for (@value) { $self->{sigexpiration} = _string2time($_) } my $time = $self->{sigexpiration}; return unless defined wantarray && defined $time; return UTIL ? Scalar::Util::dualvar( $time, _time2string($time) ) : _time2string($time); } sub siginception { my ( $self, @value ) = @_; for (@value) { $self->{siginception} = _string2time($_) } my $time = $self->{siginception}; return unless defined wantarray && defined $time; return UTIL ? Scalar::Util::dualvar( $time, _time2string($time) ) : _time2string($time); } sub sigex { return &sigexpiration; } ## historical sub sigin { return &siginception; } ## historical sub sigval { my ( $self, @value ) = @_; no integer; ( $self->{sigval} ) = map { int( 60.0 * $_ ) } @value; return; } sub keytag { my ( $self, @value ) = @_; for (@value) { $self->{keytag} = 0 + $_ } return $self->{keytag} || 0; } sub signame { my ( $self, @value ) = @_; for (@value) { $self->{signame} = Net::DNS::DomainName2535->new($_) } return $self->{signame} ? $self->{signame}->name : undef; } sub sig { my ( $self, @value ) = @_; return MIME::Base64::encode( $self->sigbin(), "" ) unless scalar @value; return $self->sigbin( MIME::Base64::decode( join "", @value ) ); } sub sigbin { my ( $self, @value ) = @_; for (@value) { $self->{sigbin} = $_ } return $self->{sigbin} || ""; } sub signature { return &sig; } sub create { unless (DNSSEC) { croak qq[No "use Net::DNS::SEC" declaration in application code]; } else { my ( $class, $data, $priv_key, %etc ) = @_; my $private = ref($priv_key) ? $priv_key : ( Net::DNS::SEC::Private->new($priv_key) ); croak 'Unable to parse private key' unless ref($private) eq 'Net::DNS::SEC::Private'; my $self = Net::DNS::RR->new( type => 'SIG', typecovered => 'TYPE0', siginception => time(), algorithm => $private->algorithm, keytag => $private->keytag, signame => $private->signame, ); while ( my ( $attribute, $value ) = each %etc ) { $self->$attribute($value); } $self->{sigexpiration} = $self->{siginception} + $self->{sigval} unless $self->{sigexpiration}; $self->_CreateSig( $self->_CreateSigData($data), $private ) if $data; $self->{private} = $private unless $data; # mark packet for SIG0 generation return $self; } } sub verify { # Reminder... # $dataref may be either a data string or a reference to a # Net::DNS::Packet object. # # $keyref is either a key object or a reference to an array # of keys. unless (DNSSEC) { croak qq[No "use Net::DNS::SEC" declaration in application code]; } else { my ( $self, $dataref, $keyref ) = @_; if ( my $isa = ref($dataref) ) { print '$dataref argument is ', $isa, "\n" if DEBUG; croak '$dataref must be scalar or a Net::DNS::Packet' unless $isa =~ /Net::DNS/ && $dataref->isa('Net::DNS::Packet'); } print '$keyref argument is of class ', ref($keyref), "\n" if DEBUG; if ( ref($keyref) eq "ARRAY" ) { # We will iterate over the supplied key list and # return when there is a successful verification. # If not, continue so that we survive key-id collision. print "Iterating over ", scalar(@$keyref), " keys\n" if DEBUG; my @error; foreach my $keyrr (@$keyref) { my $result = $self->verify( $dataref, $keyrr ); return $result if $result; my $error = $self->{vrfyerrstr}; my $keyid = $keyrr->keytag; push @error, "key $keyid: $error"; print "key $keyid: $error\n" if DEBUG; next; } $self->{vrfyerrstr} = join "\n", @error; return 0; } elsif ( $keyref->isa('Net::DNS::RR::DNSKEY') ) { print "Validating using key with keytag: ", $keyref->keytag, "\n" if DEBUG; } else { croak join ' ', ref($keyref), 'can not be used as SIG0 key'; } croak "SIG typecovered is TYPE$self->{typecovered}" if $self->{typecovered}; if (DEBUG) { print "\n ---------------------- SIG DEBUG ----------------------"; print "\n SIG:\t", $self->string; print "\n KEY:\t", $keyref->string; print "\n -------------------------------------------------------\n"; } $self->{vrfyerrstr} = ''; unless ( $self->algorithm == $keyref->algorithm ) { $self->{vrfyerrstr} = 'algorithm does not match'; return 0; } unless ( $self->keytag == $keyref->keytag ) { $self->{vrfyerrstr} = 'keytag does not match'; return 0; } # The data that is to be verified my $sigdata = $self->_CreateSigData($dataref); my $verified = $self->_VerifySig( $sigdata, $keyref ) || return 0; # time to do some time checking. my $t = time; if ( _ordered( $self->{sigexpiration}, $t ) ) { $self->{vrfyerrstr} = join ' ', 'Signature expired at', $self->sigexpiration; return 0; } elsif ( _ordered( $t, $self->{siginception} ) ) { $self->{vrfyerrstr} = join ' ', 'Signature valid from', $self->siginception; return 0; } return 1; } } #END verify sub vrfyerrstr { return shift->{vrfyerrstr}; } ######################################## { my @algbyname = ( 'DELETE' => 0, # [RFC4034][RFC4398][RFC8078] 'RSAMD5' => 1, # [RFC3110][RFC4034] 'DH' => 2, # [RFC2539] 'DSA' => 3, # [RFC3755][RFC2536] ## Reserved => 4, # [RFC6725] 'RSASHA1' => 5, # [RFC3110][RFC4034] 'DSA-NSEC3-SHA1' => 6, # [RFC5155] 'RSASHA1-NSEC3-SHA1' => 7, # [RFC5155] 'RSASHA256' => 8, # [RFC5702] ## Reserved => 9, # [RFC6725] 'RSASHA512' => 10, # [RFC5702] ## Reserved => 11, # [RFC6725] 'ECC-GOST' => 12, # [RFC5933] 'ECDSAP256SHA256' => 13, # [RFC6605] 'ECDSAP384SHA384' => 14, # [RFC6605] 'ED25519' => 15, # [RFC8080] 'ED448' => 16, # [RFC8080] 'SM2SM3' => 17, # [RFC-cuiling-dnsop-sm2-alg-15] 'ECC-GOST12' => 23, # [RFC-makarenko-gost2012-dnssec-05] 'INDIRECT' => 252, # [RFC4034] 'PRIVATEDNS' => 253, # [RFC4034] 'PRIVATEOID' => 254, # [RFC4034] ## Reserved => 255, # [RFC4034] ); my %algbyval = reverse @algbyname; foreach (@algbyname) { s/[\W_]//g; } # strip non-alphanumerics my @algrehash = map { /^\d/ ? ($_) x 3 : uc($_) } @algbyname; my %algbyname = @algrehash; # work around broken cperl sub _algbyname { my $arg = shift; my $key = uc $arg; # synthetic key $key =~ s/[\W_]//g; # strip non-alphanumerics my $val = $algbyname{$key}; return $val if defined $val; return $key =~ /^\d/ ? $arg : croak qq[unknown algorithm $arg]; } sub _algbyval { my $value = shift; return $algbyval{$value} || return $value; } } { my %siglen = ( 1 => 128, 3 => 41, 5 => 256, 6 => 41, 7 => 256, 8 => 256, 10 => 256, 12 => 64, 13 => 64, 14 => 96, 15 => 64, 16 => 114, ); sub _size { ## estimate encoded size my $self = shift; my $clone = bless {%$self}, ref($self); # shallow clone $clone->sigbin( 'x' x $siglen{$self->algorithm} ); return length $clone->encode(); } } sub _CreateSigData { if (DNSSEC) { my ( $self, $message ) = @_; if ( ref($message) ) { die 'missing packet reference' unless $message->isa('Net::DNS::Packet'); my @unsigned = grep { ref($_) ne ref($self) } @{$message->{additional}}; local $message->{additional} = \@unsigned; # remake header image my @part = qw(question answer authority additional); my @size = map { scalar @{$message->{$_}} } @part; my $rref = delete $self->{rawref}; my $data = $rref ? $$rref : $message->encode; my ( $id, $status ) = unpack 'n2', $data; my $hbin = pack 'n6 a*', $id, $status, @size; $message = $hbin . substr $data, length $hbin; } my $sigdata = pack 'n C2 N3 n a*', @{$self}{@field}, $self->{signame}->encode; print "\npreamble\t", unpack( 'H*', $sigdata ), "\nrawdata\t", unpack( 'H100', $message ), " ...\n" if DEBUG; return join '', $sigdata, $message; } } sub _CreateSig { if (DNSSEC) { my ( $self, @argument ) = @_; my $algorithm = $self->algorithm; return eval { my $class = $DNSSEC_siggen{$algorithm}; die "algorithm $algorithm not supported\n" unless $class; $self->sigbin( $class->sign(@argument) ); } || return croak "${@}signature generation failed"; } } sub _VerifySig { if (DNSSEC) { my ( $self, @argument ) = @_; my $algorithm = $self->algorithm; my $returnval = eval { my $class = $DNSSEC_verify{$algorithm}; die "algorithm $algorithm not supported\n" unless $class; $class->verify( @argument, $self->sigbin ); }; unless ($returnval) { $self->{vrfyerrstr} = "${@}signature verification failed"; print "\n", $self->{vrfyerrstr}, "\n" if DEBUG; return 0; } # uncoverable branch true # unexpected return value from EVP_DigestVerify croak "internal error in algorithm $algorithm verification" unless $returnval == 1; print "\nalgorithm $algorithm verification successful\n" if DEBUG; return $returnval; } } sub _ordered() { ## irreflexive 32-bit partial ordering my ( $n1, $n2 ) = @_; return 0 unless defined $n2; # ( any, undef ) return 1 unless defined $n1; # ( undef, any ) # unwise to assume 64-bit arithmetic, or that 32-bit integer overflow goes unpunished use integer; # fold, leaving $n2 non-negative $n1 = ( $n1 & 0xFFFFFFFF ) ^ ( $n2 & 0x80000000 ); # -2**31 <= $n1 < 2**32 $n2 = ( $n2 & 0x7FFFFFFF ); # 0 <= $n2 < 2**31 return $n1 < $n2 ? ( $n1 > ( $n2 - 0x80000000 ) ) : ( $n2 < ( $n1 - 0x80000000 ) ); } my $y1998 = timegm( 0, 0, 0, 1, 0, 1998 ); my $y2026 = timegm( 0, 0, 0, 1, 0, 2026 ); my $y2082 = $y2026 << 1; my $y2054 = $y2082 - $y1998; my $m2026 = int( 0x80000000 - $y2026 ); my $m2054 = int( 0x80000000 - $y2054 ); my $t2082 = int( $y2082 & 0x7FFFFFFF ); my $t2100 = 1960058752; sub _string2time { ## parse time specification string my $arg = shift; return int($arg) if length($arg) < 12; my ( $y, $m, @dhms ) = unpack 'a4 a2 a2 a2 a2 a2', $arg . '00'; if ( $arg lt '20380119031408' ) { # calendar folding return timegm( reverse(@dhms), $m - 1, $y ) if $y < 2026; return timegm( reverse(@dhms), $m - 1, $y - 56 ) + $y2026; } elsif ( $y > 2082 ) { my $z = timegm( reverse(@dhms), $m - 1, $y - 84 ); # expunge 29 Feb 2100 return $z < 1456790400 ? $z + $y2054 : $z + $y2054 - 86400; } return ( timegm( reverse(@dhms), $m - 1, $y - 56 ) + $y2054 ) - $y1998; } sub _time2string { ## format time specification string my $arg = shift; my $ls31 = int( $arg & 0x7FFFFFFF ); if ( $arg & 0x80000000 ) { if ( $ls31 > $t2082 ) { $ls31 += 86400 unless $ls31 < $t2100; # expunge 29 Feb 2100 my ( $yy, $mm, @dhms ) = reverse( ( gmtime( $ls31 + $m2054 ) )[0 .. 5] ); return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1984, $mm + 1, @dhms; } my ( $yy, $mm, @dhms ) = reverse( ( gmtime( $ls31 + $m2026 ) )[0 .. 5] ); return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1956, $mm + 1, @dhms; } elsif ( $ls31 > $y2026 ) { my ( $yy, $mm, @dhms ) = reverse( ( gmtime( $ls31 - $y2026 ) )[0 .. 5] ); return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1956, $mm + 1, @dhms; } my ( $yy, $mm, @dhms ) = reverse( ( gmtime $ls31 )[0 .. 5] ); return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1900, $mm + 1, @dhms; } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name SIG typecovered algorithm labels orgttl sigexpiration siginception keytag signame signature'); use Net::DNS::SEC; $sigrr = Net::DNS::RR::SIG->create( $string, $keypath, sigval => 10 # minutes ); $sigrr->verify( $string, $keyrr ) || die $sigrr->vrfyerrstr; $sigrr->verify( $packet, $keyrr ) || die $sigrr->vrfyerrstr; =head1 DESCRIPTION Class for DNS digital signature (SIG) resource records. In addition to the regular methods inherited from Net::DNS::RR the class contains a method to sign packets and scalar data strings using private keys (create) and a method for verifying signatures. The SIG RR is an implementation of RFC2931. See L for an implementation of RFC4034. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 algorithm $algorithm = $rr->algorithm; The algorithm number field identifies the cryptographic algorithm used to create the signature. algorithm() may also be invoked as a class method or simple function to perform mnemonic and numeric code translation. =head2 sigexpiration and siginception times =head2 sigex sigin sigval $expiration = $rr->sigexpiration; $expiration = $rr->sigexpiration( $value ); $inception = $rr->siginception; $inception = $rr->siginception( $value ); The signature expiration and inception fields specify a validity time interval for the signature. The value may be specified by a string with format 'yyyymmddhhmmss' or a Perl time() value. Return values are dual-valued, providing either a string value or numerical Perl time() value. =head2 keytag $keytag = $rr->keytag; $rr->keytag( $keytag ); The keytag field contains the key tag value of the KEY RR that validates this signature. =head2 signame $signame = $rr->signame; $rr->signame( $signame ); The signer name field value identifies the owner name of the KEY RR that a validator is supposed to use to validate this signature. =head2 signature =head2 sig $sig = $rr->sig; $rr->sig( $sig ); The Signature field contains the cryptographic signature that covers the SIG RDATA (excluding the Signature field) and the subject data. =head2 sigbin $sigbin = $rr->sigbin; $rr->sigbin( $sigbin ); Binary representation of the cryptographic signature. =head2 create Create a signature over scalar data. use Net::DNS::SEC; $keypath = '/home/olaf/keys/Kbla.foo.+001+60114.private'; $sigrr = Net::DNS::RR::SIG->create( $data, $keypath ); $sigrr = Net::DNS::RR::SIG->create( $data, $keypath, sigval => 10 ); $sigrr->print; # Alternatively use Net::DNS::SEC::Private $private = Net::DNS::SEC::Private->new($keypath); $sigrr= Net::DNS::RR::SIG->create( $data, $private ); create() is an alternative constructor for a SIG RR object. This method returns a SIG with the signature over the data made with the private key stored in the key file. The first argument is a scalar that contains the data to be signed. The second argument is a string which specifies the path to a file containing the private key as generated using dnssec-keygen, a program that comes with the ISC BIND distribution. The optional remaining arguments consist of ( name => value ) pairs as follows: sigin => 20241201010101, # signature inception sigex => 20241201011101, # signature expiration sigval => 10, # validity window (minutes) The sigin and sigex values may be specified as Perl time values or as a string with the format 'yyyymmddhhmmss'. The default for sigin is the time of signing. The sigval argument specifies the signature validity window in minutes ( sigex = sigin + sigval ). By default the signature is valid for 10 minutes. =head2 verify $verify = $sigrr->verify( $data, $keyrr ); $verify = $sigrr->verify( $data, [$keyrr, $keyrr2, $keyrr3] ); The verify() method performs SIG0 verification of the specified data against the signature contained in the $sigrr object itself using the public key in $keyrr. If a reference to a Net::DNS::Packet is supplied, the method performs a SIG0 verification on the packet data. The second argument can either be a Net::DNS::RR::KEYRR object or a reference to an array of such objects. Verification will return successful as soon as one of the keys in the array leads to positive validation. Returns false on error and sets $sig->vrfyerrstr =head2 vrfyerrstr $sig0 = $packet->sigrr || die 'not signed'; print $sig0->vrfyerrstr unless $sig0->verify( $packet, $keyrr ); $sigrr->verify( $packet, $keyrr ) || die $sigrr->vrfyerrstr; =head1 KEY GENERATION Private key files and corresponding public DNSKEY records are most conveniently generated using dnssec-keygen, a program that comes with the ISC BIND distribution. dnssec-keygen -a 10 -b 2048 rsa.example. dnssec-keygen -a 13 -f ksk ecdsa.example. dnssec-keygen -a 13 ecdsa.example. Do not change the name of the private key file. The create method uses the filename as generated by dnssec-keygen to determine the keyowner, algorithm, and the keyid (keytag). =head1 REMARKS The code is not optimised for speed. If this code is still around in 2100 (not a leap year) you will need to check for proper handling of times after 28th February. =head1 ACKNOWLEDGMENTS Although their original code may have disappeared following redesign of Net::DNS, Net::DNS::SEC and the OpenSSL API, the following individual contributors deserve to be recognised for their significant influence on the development of the SIG package. Andy Vaskys (Network Associates Laboratories) supplied code for RSA. T.J. Mather provided support for the DSA algorithm. =head1 COPYRIGHT Copyright (c)2001-2005 RIPE NCC, Olaf M. Kolkman Copyright (c)2007-2008 NLnet Labs, Olaf M. Kolkman Portions Copyright (c)2014 Dick Franks All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L L L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/GPOS.pm0000644000175000017500000000761214756035515015545 0ustar willemwillempackage Net::DNS::RR::GPOS; use strict; use warnings; our $VERSION = (qw$Id: GPOS.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::GPOS - DNS GPOS resource record =cut use integer; use Carp; use Net::DNS::Text; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $limit = $offset + $self->{rdlength}; for (qw(latitude longitude altitude)) { my $text; ( $text, $offset ) = Net::DNS::Text->decode( $data, $offset ); $self->$_( $text->value ); } croak('corrupt GPOS data') unless $offset == $limit; # more or less FUBAR return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return join '', map { Net::DNS::Text->new($_)->encode } @{$self}{qw(latitude longitude altitude)}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return map { Net::DNS::Text->new($_)->string } @{$self}{qw(latitude longitude altitude)}; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->latitude( shift @argument ); $self->longitude( shift @argument ); $self->altitude(@argument); return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->_parse_rdata(qw(0.0 0.0 0.0)); return; } sub latitude { my ( $self, @value ) = @_; for (@value) { return $self->{latitude} = _fp($_) } return $self->{latitude}; } sub longitude { my ( $self, @value ) = @_; for (@value) { return $self->{longitude} = _fp($_) } return $self->{longitude}; } sub altitude { my ( $self, @value ) = @_; for (@value) { return $self->{altitude} = _fp($_) } return $self->{altitude}; } ######################################## sub _fp { no integer; return sprintf( '%1.10g', 0.0 + shift ); } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name GPOS latitude longitude altitude'); =head1 DESCRIPTION Class for DNS Geographical Position (GPOS) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 latitude $latitude = $rr->latitude; $rr->latitude( $latitude ); Floating-point representation of latitude, in degrees. =head2 longitude $longitude = $rr->longitude; $rr->longitude( $longitude ); Floating-point representation of longitude, in degrees. =head2 altitude $altitude = $rr->altitude; $rr->altitude( $altitude ); Floating-point representation of altitude, in metres. =head1 COPYRIGHT Copyright (c)1997,1998 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/AMTRELAY.pm0000644000175000017500000001456114756035515016214 0ustar willemwillempackage Net::DNS::RR::AMTRELAY; use strict; use warnings; our $VERSION = (qw$Id: AMTRELAY.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::AMTRELAY - DNS AMTRELAY resource record =cut use integer; use Carp; use Net::DNS::DomainName; use Net::DNS::RR::A; use Net::DNS::RR::AAAA; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $size = $self->{rdlength} - 2; @{$self}{qw(precedence relaytype relay)} = unpack "\@$offset C2 a$size", $$data; for ( $self->relaytype ) { /^3$/ && return $self->{relay} = Net::DNS::DomainName->decode( $data, $offset + 2 ); /^2$/ && return $self->{relay} = pack( 'a16', $self->{relay} ); /^1$/ && return $self->{relay} = pack( 'a4', $self->{relay} ); } $self->{relay} = ''; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; for ( $self->relaytype ) { /^3$/ && return pack( 'C2 a*', @{$self}{qw(precedence relaytype)}, $self->{relay}->encode ); /^2$/ && return pack( 'C2 a16', @{$self}{qw(precedence relaytype relay)} ); /^1$/ && return pack( 'C2 a4', @{$self}{qw(precedence relaytype relay)} ); } return pack( 'C2', @{$self}{qw(precedence relaytype)} ); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @rdata = map { $self->$_ } qw(precedence dbit relaytype relay); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; foreach (qw(precedence dbit relaytype relay)) { $self->$_( shift @argument ); } return; } sub _defaults { ## specify RR attribute default values my $self = shift; @{$self}{qw(precedence relaytype relay)} = ( 0, 0, '' ); return; } sub precedence { my ( $self, @value ) = @_; for (@value) { $self->{precedence} = 0 + $_ } return $self->{precedence} || 0; } sub dbit { my ( $self, @value ) = @_; # uncoverable pod for (@value) { $self->{relaytype} = $self->relaytype | ( $_ ? 0x80 : 0 ) } return ( $self->{relaytype} || 0 ) >> 7; } sub d { return &dbit } # uncoverable pod sub relaytype { my ( $self, @value ) = @_; for (@value) { $self->{relaytype} = $self->dbit ? ( 0x80 | $_ ) : $_ } return 0x7f & ( $self->{relaytype} || 0 ); } sub relay { my ( $self, @value ) = @_; for (@value) { /^\.*$/ && do { $self->relaytype(0); $self->{relay} = ''; # no relay last; }; /:.*:/ && do { $self->relaytype(2); $self->{relay} = Net::DNS::RR::AAAA::address( {}, $_ ); last; }; /\.\d+$/ && do { $self->relaytype(1); $self->{relay} = Net::DNS::RR::A::address( {}, $_ ); last; }; /\..+/ && do { $self->relaytype(3); $self->{relay} = Net::DNS::DomainName->new($_); last; }; croak 'unrecognised relay type'; } if ( defined wantarray ) { for ( $self->relaytype ) { /^1$/ && return Net::DNS::RR::A::address( {address => $self->{relay}} ); /^2$/ && return Net::DNS::RR::AAAA::address( {address => $self->{relay}} ); /^3$/ && return wantarray ? $self->{relay}->string : $self->{relay}->name; } } return wantarray ? '.' : undef; } my $function = sub { ## sort RRs in numerically ascending order. $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; }; __PACKAGE__->set_rrsort_func( 'preference', $function ); __PACKAGE__->set_rrsort_func( 'default_sort', $function ); 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('owner AMTRELAY precedence Dbit relaytype relay'); =head1 DESCRIPTION AMTRELAY resource record designed to permit DNS Reverse IP AMT Discovery (DRIAD), a mechanism for AMT gateways to discover AMT relays that are capable of forwarding multicast traffic from a known source IP address. AMT (Automatic Multicast Tunneling) is defined in RFC7450 and provides a method to transport multicast traffic over a unicast tunnel in order to traverse network segments that are not multicast capable. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 precedence $precedence = $rr->precedence; $rr->precedence( $precedence ); 8-bit integer which indicates relative precedence within the RRset. Relays listed in AMTRELAY records with lower precedence are to be attempted first. =head2 Dbit, Discovery Optional $Dbit = $rr->Dbit; $rr->Dbit(1); Boolean field which indicates that the gateway MAY send an AMT Request message directly to the discovered relay address without first sending an AMT Discovery message. =head2 relaytype $relaytype = $rr->relaytype; The relaytype type field indicates the format of the information that is stored in the relay field. The following values are defined: =over 4 0: The relay field is empty (0 bytes). 1: The relay field contains a 4-octet IPv4 address. 2: The relay field contains a 16-octet IPv6 address. 3: The relay field contains a wire-encoded domain name. =back =head2 relay $relay = $rr->relay; $rr->relay( $relay ); The relay field is the address or domain name of the AMT relay. It is formatted according to the relaytype field. =head1 COPYRIGHT Copyright (c)2020 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/AFSDB.pm0000644000175000017500000000664614756035515015622 0ustar willemwillempackage Net::DNS::RR::AFSDB; use strict; use warnings; our $VERSION = (qw$Id: AFSDB.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::AFSDB - DNS AFSDB resource record =cut use integer; use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; $self->{subtype} = unpack "\@$offset n", $$data; $self->{hostname} = Net::DNS::DomainName2535->decode( $data, $offset + 2, @opaque ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, $offset, @opaque ) = @_; my $hostname = $self->{hostname}; return pack 'n a*', $self->subtype, $hostname->encode( $offset + 2, @opaque ); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $hostname = $self->{hostname}; return join ' ', $self->subtype, $hostname->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(subtype hostname)) { $self->$_( shift @argument ) } return; } sub subtype { my ( $self, @value ) = @_; for (@value) { $self->{subtype} = 0 + $_ } return $self->{subtype} || 0; } sub hostname { my ( $self, @value ) = @_; for (@value) { $self->{hostname} = Net::DNS::DomainName2535->new($_) } return $self->{hostname} ? $self->{hostname}->name : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name AFSDB subtype hostname'); =head1 DESCRIPTION Class for DNS AFS Data Base (AFSDB) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 subtype $subtype = $rr->subtype; $rr->subtype( $subtype ); A 16 bit integer which indicates the service offered by the listed host. =head2 hostname $hostname = $rr->hostname; $rr->hostname( $hostname ); The hostname field is a domain name of a host that has a server for the cell named by the owner name of the RR. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. Portions Copyright (c)2002,2003 Chris Reinhardt. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/CSYNC.pm0000644000175000017500000001064514756035515015654 0ustar willemwillempackage Net::DNS::RR::CSYNC; use strict; use warnings; our $VERSION = (qw$Id: CSYNC.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::CSYNC - DNS CSYNC resource record =cut use integer; use Net::DNS::RR::NSEC; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $limit = $offset + $self->{rdlength}; @{$self}{qw(soaserial flags)} = unpack "\@$offset Nn", $$data; $offset += 6; $self->{typebm} = substr $$data, $offset, $limit - $offset; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'N n a*', $self->soaserial, $self->flags, $self->{typebm}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @rdata = ( $self->soaserial, $self->flags, $self->typelist ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->soaserial( shift @argument ); $self->flags( shift @argument ); $self->typelist(@argument); return; } sub soaserial { my ( $self, @value ) = @_; for (@value) { $self->{soaserial} = 0 + $_ } return $self->{soaserial} || 0; } sub flags { my ( $self, @value ) = @_; for (@value) { $self->{flags} = 0 + $_ } return $self->{flags} || 0; } sub immediate { my ( $self, @value ) = @_; if ( scalar @value ) { for ( $self->{flags} |= 0x0001 ) { $_ ^= 0x0001 unless shift @value; } } return $self->{flags} & 0x0001; } sub soaminimum { my ( $self, @value ) = @_; if ( scalar @value ) { for ( $self->{flags} |= 0x0002 ) { $_ ^= 0x0002 unless shift @value; } } return $self->{flags} & 0x0002; } sub typelist { return &Net::DNS::RR::NSEC::typelist; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name CSYNC SOAserial flags typelist'); =head1 DESCRIPTION Class for DNSSEC CSYNC resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 SOAserial =head2 soaserial $soaserial = $rr->soaserial; $rr->soaserial( $soaserial ); The SOA Serial field contains a copy of the 32-bit SOA serial number from the child zone. =head2 flags $flags = $rr->flags; $rr->flags( $flags ); The flags field contains 16 bits of boolean flags that define operations which affect the processing of the CSYNC record. =over 4 =item immediate $rr->immediate(1); if ( $rr->immediate ) { ... } If not set, a parental agent must not process the CSYNC record until the zone administrator approves the operation through an out-of-band mechanism. =back =over 4 =item soaminimum $rr->soaminimum(1); if ( $rr->soaminimum ) { ... } If set, a parental agent querying child authoritative servers must not act on data from zones advertising an SOA serial number less than the SOAserial value. =back =head2 typelist @typelist = $rr->typelist; $typelist = $rr->typelist; The type list indicates the record types to be processed by the parental agent. When called in scalar context, the list is interpolated into a string. =head1 COPYRIGHT Copyright (c)2015 Dick Franks All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/DELEG.pm0000644000175000017500000000446714756035515015622 0ustar willemwillempackage Net::DNS::RR::DELEG; use strict; use warnings; our $VERSION = (qw$Id: DELEG.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR::SVCB); =head1 NAME Net::DNS::RR::DELEG - DNS DELEG resource record =cut 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('alias DELEG 0 target'); $rr = Net::DNS::RR->new('child DELEG 1 nameserver ipv6hint=2001:db8::f00'); =head1 DESCRIPTION DNS DELEG resource record The DELEG record appears in, and is logically a part of, the parent zone to mark the delegation point for a child zone. It advertises, directly or indirectly, transport methods available for connection to nameservers serving the child zone. The DELEG class is derived from, and inherits all properties of, the Net::DNS::RR::SVCB class. Please see the L documentation for details. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head1 COPYRIGHT Copyright (c)2024 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/MG.pm0000644000175000017500000000544314756035515015300 0ustar willemwillempackage Net::DNS::RR::MG; use strict; use warnings; our $VERSION = (qw$Id: MG.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::MG - DNS MG resource record =cut use integer; use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, @argument ) = @_; $self->{mgmname} = Net::DNS::DomainName1035->decode(@argument); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, @argument ) = @_; return $self->{mgmname}->encode(@argument); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return $self->{mgmname}->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->mgmname(@argument); return; } sub mgmname { my ( $self, @value ) = @_; for (@value) { $self->{mgmname} = Net::DNS::DomainName1035->new($_) } return $self->{mgmname} ? $self->{mgmname}->name : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name MG mgmname'); =head1 DESCRIPTION Class for DNS Mail Group (MG) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 mgmname $mgmname = $rr->mgmname; $rr->mgmname( $mgmname ); A domain name which specifies a mailbox which is a member of the mail group specified by the owner name. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/URI.pm0000644000175000017500000001036014756035515015426 0ustar willemwillempackage Net::DNS::RR::URI; use strict; use warnings; our $VERSION = (qw$Id: URI.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::URI - DNS URI resource record =cut use integer; use Net::DNS::Text; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $limit = $offset + $self->{rdlength}; @{$self}{qw(priority weight)} = unpack( "\@$offset n2", $$data ); $offset += 4; $self->{target} = Net::DNS::Text->decode( $data, $offset, $limit - $offset ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $target = $self->{target}; return pack 'n2 a*', @{$self}{qw(priority weight)}, $target->raw; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $target = $self->{target}; my @rdata = ( $self->priority, $self->weight, $target->string ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(priority weight target)) { $self->$_( shift @argument ) } return; } sub priority { my ( $self, @value ) = @_; for (@value) { $self->{priority} = 0 + $_ } return $self->{priority} || 0; } sub weight { my ( $self, @value ) = @_; for (@value) { $self->{weight} = 0 + $_ } return $self->{weight} || 0; } sub target { my ( $self, @value ) = @_; for (@value) { $self->{target} = Net::DNS::Text->new($_) } return $self->{target} ? $self->{target}->value : undef; } # order RRs by numerically increasing priority, decreasing weight my $function = sub { my ( $a, $b ) = ( $Net::DNS::a, $Net::DNS::b ); return $a->{priority} <=> $b->{priority} || $b->{weight} <=> $a->{weight}; }; __PACKAGE__->set_rrsort_func( 'priority', $function ); __PACKAGE__->set_rrsort_func( 'default_sort', $function ); 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name URI priority weight target'); =head1 DESCRIPTION Class for DNS Service (URI) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 priority $priority = $rr->priority; $rr->priority( $priority ); The priority of the target URI in this RR. The range of this number is 0-65535. A client MUST attempt to contact the URI with the lowest-numbered priority it can reach; weighted selection being used to distribute load across targets with equal priority. =head2 weight $weight = $rr->weight; $rr->weight( $weight ); A server selection mechanism. The weight field specifies a relative weight for entries with the same priority. Larger weights SHOULD be given a proportionately higher probability of being selected. The range of this number is 0-65535. =head2 target $target = $rr->target; $rr->target( $target ); The URI of the target. Resolution of the URI is according to the definitions for the Scheme of the URI. =head1 COPYRIGHT Copyright (c)2015 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/CDNSKEY.pm0000644000175000017500000000477114756035515016100 0ustar willemwillempackage Net::DNS::RR::CDNSKEY; use strict; use warnings; our $VERSION = (qw$Id: CDNSKEY.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR::DNSKEY); =head1 NAME Net::DNS::RR::CDNSKEY - DNS CDNSKEY resource record =cut use integer; sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return $self->SUPER::_format_rdata() if $self->algorithm; return my @rdata = @{$self}{qw(flags protocol algorithm)}, "AA=="; } sub algorithm { my ( $self, $arg ) = @_; return $self->SUPER::algorithm($arg) if $arg; return $self->SUPER::algorithm() unless defined $arg; @{$self}{qw(flags protocol algorithm keybin)} = ( 0, 3, 0, chr(0) ); return; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name CDNSKEY flags protocol algorithm publickey'); =head1 DESCRIPTION DNS Child DNSKEY resource record This is a clone of the DNSKEY record and inherits all properties of the Net::DNS::RR::DNSKEY class. Please see the L perl documentation for details. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head1 COPYRIGHT Copyright (c)2014,2017 Dick Franks All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/HINFO.pm0000644000175000017500000000607614756035515015643 0ustar willemwillempackage Net::DNS::RR::HINFO; use strict; use warnings; our $VERSION = (qw$Id: HINFO.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::HINFO - DNS HINFO resource record =cut use integer; use Net::DNS::Text; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; ( $self->{cpu}, $offset ) = Net::DNS::Text->decode( $data, $offset ); ( $self->{os}, $offset ) = Net::DNS::Text->decode( $data, $offset ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return join '', $self->{cpu}->encode, $self->{os}->encode; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return join ' ', $self->{cpu}->string, $self->{os}->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->cpu( shift @argument ); $self->os(@argument); return; } sub cpu { my ( $self, @value ) = @_; for (@value) { $self->{cpu} = Net::DNS::Text->new($_) } return $self->{cpu} ? $self->{cpu}->value : undef; } sub os { my ( $self, @value ) = @_; for (@value) { $self->{os} = Net::DNS::Text->new($_) } return $self->{os} ? $self->{os}->value : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name HINFO cpu os'); =head1 DESCRIPTION Class for DNS Hardware Information (HINFO) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 cpu $cpu = $rr->cpu; $rr->cpu( $cpu ); Returns the CPU type for this RR. =head2 os $os = $rr->os; $rr->os( $os ); Returns the operating system type for this RR. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/RESINFO.pm0000644000175000017500000000551014756035515016075 0ustar willemwillempackage Net::DNS::RR::RESINFO; use strict; use warnings; our $VERSION = (qw$Id: RESINFO.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR::TXT); =head1 NAME Net::DNS::RR::RESINFO - DNS RESINFO resource record =cut use integer; 1; __END__ =head1 SYNOPSIS use Net::DNS; my $target = 'resolver.example.net'; my $resolver = Net::DNS::Resolver->new( nameserver => $target, recurse => 0 ); $resolver->send( $target, 'RESINFO' )->print; ;; HEADER SECTION ;; id = 46638 ;; qr = 1 aa = 1 tc = 0 rd = 0 opcode = QUERY ;; ra = 0 z = 0 ad = 0 cd = 0 rcode = NOERROR ;; do = 0 co = 0 ;; qdcount = 1 ancount = 1 ;; nscount = 0 arcount = 0 ;; QUESTION SECTION (1 record) ;; resolver.example.net. IN RESINFO ;; ANSWER SECTION (1 record) resolver.example.net. 7200 IN RESINFO ( qnamemin exterr=15-17 infourl=https://resolver.example.com/guide ) ;; AUTHORITY SECTION (0 records) ;; ADDITIONAL SECTION (0 records) =head1 DESCRIPTION Class for DNS Resolver Information(RESINFO) resource records. RESINFO is a clone of the Net::DNS::RR::TXT class. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 txtdata $string = $rr->txtdata; @list = $rr->txtdata; When invoked in scalar context, $rr->txtdata() returns the resolver properties as a single string, with elements separated by a single space. In a list context, $rr->txtdata() returns a list of the text elements. =head1 COPYRIGHT Copyright (c)2024 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/TKEY.pm0000644000175000017500000001310514756035515015543 0ustar willemwillempackage Net::DNS::RR::TKEY; use strict; use warnings; our $VERSION = (qw$Id: TKEY.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::TKEY - DNS TKEY resource record =cut use integer; use Carp; use Net::DNS::Parameters qw(:class :type); use Net::DNS::DomainName; use constant ANY => classbyname qw(ANY); use constant TKEY => typebyname qw(TKEY); sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $limit = $offset + $self->{rdlength}; ( $self->{algorithm}, $offset ) = Net::DNS::DomainName->decode( $data, $offset ); @{$self}{qw(inception expiration mode error)} = unpack "\@$offset N2n2", $$data; $offset += 12; my $key_size = unpack "\@$offset n", $$data; $self->{key} = substr $$data, $offset + 2, $key_size; $offset += $key_size + 2; my $other_size = unpack "\@$offset n", $$data; $self->{other} = substr $$data, $offset + 2, $other_size; $offset += $other_size + 2; croak('corrupt TKEY data') unless $offset == $limit; # more or less FUBAR return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return '' unless defined $self->{algorithm}; my $rdata = $self->{algorithm}->encode; $rdata .= pack 'N2n2', $self->inception, $self->expiration, $self->mode, $self->error; my $key = $self->key; # RFC2930(2.7) $rdata .= pack 'na*', length $key, $key; my $other = $self->other; # RFC2930(2.8) $rdata .= pack 'na*', length $other, $other; return $rdata; } sub class { ## override RR method return 'ANY'; } sub encode { ## override RR method my $self = shift; my $owner = $self->{owner}->encode(); my $rdata = eval { $self->_encode_rdata() } || ''; return pack 'a* n2 N n a*', $owner, TKEY, ANY, 0, length $rdata, $rdata; } sub algorithm { my ( $self, @value ) = @_; for (@value) { $self->{algorithm} = Net::DNS::DomainName->new($_) } return $self->{algorithm} ? $self->{algorithm}->name : undef; } sub inception { my ( $self, @value ) = @_; for (@value) { $self->{inception} = 0 + $_ } return $self->{inception} || 0; } sub expiration { my ( $self, @value ) = @_; for (@value) { $self->{expiration} = 0 + $_ } return $self->{expiration} || 0; } sub mode { my ( $self, @value ) = @_; for (@value) { $self->{mode} = 0 + $_ } return $self->{mode} || 0; } sub error { my ( $self, @value ) = @_; for (@value) { $self->{error} = 0 + $_ } return $self->{error} || 0; } sub key { my ( $self, @value ) = @_; for (@value) { $self->{key} = $_ } return $self->{key} || ""; } sub other { my ( $self, @value ) = @_; for (@value) { $self->{other} = $_ } return $self->{other} || ""; } sub other_data { return &other; } # uncoverable pod 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = new Net::DNS::RR('example.com IN TKEY ... '); =head1 DESCRIPTION Class for DNS TSIG Key (TKEY) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 algorithm $algorithm = $rr->algorithm; $rr->algorithm( $algorithm ); The algorithm name is in the form of a domain name with the same meaning as in [RFC 2845]. The algorithm determines how the secret keying material agreed to using the TKEY RR is actually used to derive the algorithm specific key. =head2 inception $inception = $rr->inception; $rr->inception( $inception ); Time expressed as the number of non-leap seconds modulo 2**32 since the beginning of January 1970 GMT. =head2 expiration $expiration = $rr->expiration; $rr->expiration( $expiration ); Time expressed as the number of non-leap seconds modulo 2**32 since the beginning of January 1970 GMT. =head2 mode $mode = $rr->mode; $rr->mode( $mode ); The mode field specifies the general scheme for key agreement or the purpose of the TKEY DNS message, as defined in [RFC2930(2.5)]. =head2 error $error = $rr->error; $rr->error( $error ); The error code field is an extended RCODE. =head2 key $key = $rr->key; $rr->key( $key ); Sequence of octets representing the key exchange data. The meaning of this data depends on the mode. =head2 other $other = $rr->other; $rr->other( $other ); Content not defined in the [RFC2930] specification but may be used in future extensions. =head1 COPYRIGHT Copyright (c)2000 Andrew Tridgell. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/SVCB.pm0000644000175000017500000003005114756035515015523 0ustar willemwillempackage Net::DNS::RR::SVCB; use strict; use warnings; our $VERSION = (qw$Id: SVCB.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::SVCB - DNS SVCB resource record =cut use integer; use Net::DNS::DomainName; use Net::DNS::RR::A; use Net::DNS::RR::AAAA; use Net::DNS::Text; use MIME::Base64; my %keybyname = ( mandatory => 'key0', # RFC9460(8) alpn => 'key1', # RFC9460(7.1) 'no-default-alpn' => 'key2', # RFC9460(7.1) port => 'key3', # RFC9460(7.2) ipv4hint => 'key4', # RFC9460(7.3) ech => 'key5', # RFC9460 ipv6hint => 'key6', # RFC9460(7.3) dohpath => 'key7', # RFC9461 ohttp => 'key8', # RFC9540(4) 'tls-supported-groups' => 'key9', ); my %boolean = ( 'no-default-alpn' => 'key2', ohttp => 'key8', ); sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $limit = $self->{rdlength}; my $rdata = $self->{rdata} = substr $$data, $offset, $limit; $self->{SvcPriority} = unpack 'n', $rdata; ( $self->{TargetName}, $offset ) = Net::DNS::DomainName->decode( \$rdata, 2 ); my $params = $self->{SvcParams} = []; while ( ( my $start = $offset + 4 ) <= $limit ) { my ( $key, $size ) = unpack( "\@$offset n2", $rdata ); my $next = $start + $size; last if $next > $limit; push @$params, ( $key, substr $rdata, $start, $size ); $offset = $next; } die $self->type . ': corrupt RDATA' unless $offset == $limit; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return $self->{rdata} if $self->{rdata}; my @packed = pack 'n a*', $self->{SvcPriority}, $self->{TargetName}->encode; my $params = $self->{SvcParams} || []; my @params = @$params; while (@params) { my $key = shift @params; my $val = shift @params; push @packed, pack( 'n2a*', $key, length($val), $val ); } return join '', @packed; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @rdata = unpack 'H4', pack 'n', $self->{SvcPriority}; my $encode = $self->{TargetName}->encode(); my $length = 2 + length $encode; my @target = grep {length} split /(\S{32})/, unpack 'H*', $encode; my $target = substr $self->{TargetName}->string, 0, 40; push @rdata, join '', shift(@target), "\t; $target\n"; push @rdata, @target; my $params = $self->{SvcParams} || []; my @params = @$params; while (@params) { my $key = shift @params; my $val = shift @params; push @rdata, "\n", unpack 'H4H4', pack( 'n2', $key, length $val ); my @hex = grep {length} split /(\S{32})/, unpack 'H*', $val; push @rdata, shift @hex if @hex; push @rdata, "\t; key$key\n" unless $key < 16; push @rdata, @hex; $length += 4 + length $val; } if ( $self->{rdata} ) { if ( my $corrupt = substr $self->{rdata}, $length ) { my ( $hex, @hex ) = grep {length} split /(\S{32})/, unpack 'H*', $corrupt; push @rdata, "\n$hex\t; corrupt RDATA\n", @hex; $length += length $corrupt; } } return ( "\\# $length", @rdata ); } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->svcpriority( shift @argument ); $self->targetname( shift @argument ); local $SIG{__WARN__} = sub { die @_ }; while ( my $svcparam = shift @argument ) { for ($svcparam) { my @value; if (/^key\d+=(.*)$/i) { local $_ = length($1) ? $1 : shift @argument; s/^"([^"]*)"$/$1/; # strip enclosing quotes push @value, $_; } elsif (/^[^=]+=(.*)$/) { local $_ = length($1) ? $1 : shift @argument; die <<"Amen" if /\\092[,\\]/; SVCB: Please use standard RFC1035 escapes RFC9460 double-escape nonsense not implemented Amen s/^"([^"]*)"$/$1/; # strip enclosing quotes s/\\,/\\044/g; # disguise (RFC1035) escaped comma push @value, split /,/; } else { push @value, '' unless $keybyname{$_}; # unregistered boolean key } m/^([^=]+)/; # extract identifier my $key = $1; push @value, 1 if $boolean{$key}; $key =~ s/[-]/_/g; $self->$key(@value); } } return; } sub _post_parse { ## parser post processing my $self = shift; my $paramref = $self->{SvcParams} || []; my %svcparam = scalar(@$paramref) ? @$paramref : return; $self->key0(undef); # ruse to force sorting of SvcParams if ( defined $svcparam{0} ) { my %unique; foreach ( grep { !$unique{$_}++ } unpack 'n*', $svcparam{0} ) { die( $self->type . qq[: unexpected "key0" in mandatory list] ) if $unique{0}; die( $self->type . qq[: duplicate "key$_" in mandatory list] ) if --$unique{$_}; die( $self->type . qq[: mandatory "key$_" not present] ) unless defined $svcparam{$_}; } $self->mandatory( keys %unique ); # restore mandatory key list } die( $self->type . qq[: expected alpn="..." not present] ) if defined( $svcparam{2} ) && !$svcparam{1}; return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->_parse_rdata(qw(0 .)); return; } sub svcpriority { my ( $self, @value ) = @_; # uncoverable pod for (@value) { $self->{SvcPriority} = 0 + $_ } return $self->{SvcPriority} || 0; } sub targetname { my ( $self, @value ) = @_; # uncoverable pod for (@value) { $self->{TargetName} = Net::DNS::DomainName->new($_) } my $target = $self->{TargetName} ? $self->{TargetName}->name : return; return $target unless $self->{SvcPriority}; return ( $target eq '.' ) ? $self->owner : $target; } sub mandatory { ## mandatory=key1,port,... my ( $self, @value ) = @_; my @list = map { $keybyname{lc $_} || $_ } map { split /,/ } @value; my @keys = map { /(\d+)$/ ? $1 : die( $self->type . qq[: unexpected "$_"] ) } @list; return $self->key0( _integer16( sort { $a <=> $b } @keys ) ); } sub alpn { ## alpn=h3,h2,... my ( $self, @value ) = @_; return $self->key1( _string(@value) ); } sub no_default_alpn { ## no-default-alpn (Boolean) my ( $self, @value ) = @_; # uncoverable pod return $self->key2( _boolean(@value) ); } sub port { ## port=1234 my ( $self, @value ) = @_; return $self->key3( map { _integer16($_) } @value ); } sub ipv4hint { ## ipv4hint=192.0.2.1,... my ( $self, @value ) = @_; return $self->key4( _ipv4(@value) ); } sub ech { ## ech=base64 my ( $self, @value ) = @_; return $self->key5( map { _base64($_) } @value ); } sub ipv6hint { ## ipv6hint=2001:DB8::1,... my ( $self, @value ) = @_; return $self->key6( _ipv6(@value) ); } sub dohpath { ## dohpath=/dns-query{?dns} my ( $self, @value ) = @_; # uncoverable pod return $self->key7(@value); } sub ohttp { ## ohttp my ( $self, @value ) = @_; # uncoverable pod return $self->key8( _boolean(@value) ); } sub tls_supported_groups { ## tls_supported_groups=29,23 my ( $self, @value ) = @_; # uncoverable pod return $self->key9( _integer16(@value) ); } ######################################## sub _presentation { ## represent octet string(s) using local charset my @arg = @_; my $raw = scalar(@arg) ? join( '', @arg ) : return (); # concatenate arguments return Net::DNS::Text->decode( \$raw, 0, length($raw) )->string; } sub _boolean { my @arg = @_; return @arg unless scalar @arg; # read key my $arg = shift @arg; return $arg unless defined $arg; # delete key. return ( $arg ? '' : undef, @arg ); # set key } sub _string { my @arg = @_; return _presentation( map { Net::DNS::Text->new($_)->encode() } @arg ); } sub _base64 { my @arg = @_; return _presentation( map { MIME::Base64::decode($_) } @arg ); } sub _integer16 { my @arg = @_; return _presentation( map { pack( 'n', $_ ) } @arg ); } sub _ipv4 { my @arg = @_; return _presentation( map { Net::DNS::RR::A::address( {}, $_ ) } @arg ); } sub _ipv6 { my @arg = @_; return _presentation( map { Net::DNS::RR::AAAA::address( {}, $_ ) } @arg ); } sub AUTOLOAD { ## Dynamic constructor/accessor methods my ( $self, @argument ) = @_; our $AUTOLOAD; my ($method) = reverse split /::/, $AUTOLOAD; my $super = "SUPER::$method"; return $self->$super(@argument) unless $method =~ /^key[0]*(\d+)$/i; my $key = $1; my $paramsref = $self->{SvcParams} || []; my %svcparams = @$paramsref; if ( scalar @argument ) { my $arg = shift @argument; # keyNN($value); delete $svcparams{$key} unless defined $arg; die( $self->type . qq[: duplicate SvcParam "key$key"] ) if defined $svcparams{$key}; die( $self->type . qq[: invalid SvcParam "key$key"] ) if $key > 65534; die( $self->type . qq[: unexpected "key$key" value] ) if scalar @argument; delete $self->{rdata}; $svcparams{$key} = Net::DNS::Text->new("$arg")->raw if defined $arg; $self->{SvcParams} = [map { ( $_, $svcparams{$_} ) } sort { $a <=> $b } keys %svcparams]; } else { die( $self->type . qq[: no value specified for "key$key"] ) unless defined wantarray; } return $svcparams{$key}; } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name SVCB SvcPriority TargetName SvcParams'); =head1 DESCRIPTION DNS Service Binding (SVCB) resource record Service binding and parameter specification via the DNS (SVCB and HTTPS RRs) =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 SvcPriority $svcpriority = $rr->svcpriority; $rr->svcpriority( $svcpriority ); The priority of this record (relative to others, with lower values preferred). A value of 0 indicates AliasMode. =head2 TargetName $rr->targetname( $targetname ); $effecivetarget = $rr->targetname; The domain name of either the alias target (for AliasMode) or the alternative endpoint (for ServiceMode). For AliasMode SVCB RRs, a TargetName of "." indicates that the service is not available or does not exist. For ServiceMode SVCB RRs, a TargetName of "." indicates that the owner name of this record must be used as the effective TargetName. =head2 mandatory, alpn, no-default-alpn, port, ipv4hint, ech, ipv6hint $rr = Net::DNS::RR->new( 'svcb.example. SVCB 1 svcb.example. port=1234' ); $rr->port(1234); $octets = $rr->port(); # 0x04 0xD2 $octets = $rr->key3(); Constructor methods for mnemonic SvcParams prescribed by RFC9460. When invoked without arguments, the methods return the value of the underlying key as an uninterpreted octet string. The behaviour with undefined arguments is not specified. =head2 keyNN $keynn = $rr->keyNN; $rr->keyNN( $keynn ); $rr->keyNN( undef ); Generic constructor and accessor methods for SvcParams. The key index NN is a decimal integer in the range 0 .. 65535. The method argument is a presentation format character string. The returned value is an uninterpreted octet string. The method returns the undefined value if the key is not present. The specified key will be deleted if the argument is undefined. =head1 COPYRIGHT Copyright (c)2020-2024 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/L32.pm0000644000175000017500000000743514756035515015340 0ustar willemwillempackage Net::DNS::RR::L32; use strict; use warnings; our $VERSION = (qw$Id: L32.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::L32 - DNS L32 resource record =cut use integer; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; @{$self}{qw(preference locator32)} = unpack "\@$offset n a4", $$data; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'n a4', $self->{preference}, $self->{locator32}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return join ' ', $self->preference, $self->locator32; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(preference locator32)) { $self->$_( shift @argument ) } return; } sub preference { my ( $self, @value ) = @_; for (@value) { $self->{preference} = 0 + $_ } return $self->{preference} || 0; } sub locator32 { my $self = shift; my $prfx = shift; $self->{locator32} = pack 'C* @4', split /\./, $prfx if defined $prfx; return $self->{locator32} ? join( '.', unpack 'C4', $self->{locator32} ) : undef; } my $function = sub { ## sort RRs in numerically ascending order. return $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; }; __PACKAGE__->set_rrsort_func( 'preference', $function ); __PACKAGE__->set_rrsort_func( 'default_sort', $function ); 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name IN L32 preference locator32'); $rr = Net::DNS::RR->new( name => 'example.com', type => 'L32', preference => 10, locator32 => '10.1.02.0' ); =head1 DESCRIPTION Class for DNS 32-bit Locator (L32) resource records. The L32 resource record is used to hold 32-bit Locator values for ILNPv4-capable nodes. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 preference $preference = $rr->preference; $rr->preference( $preference ); A 16 bit unsigned integer in network byte order that indicates the relative preference for this L32 record among other L32 records associated with this owner name. Lower values are preferred over higher values. =head2 locator32 $locator32 = $rr->locator32; The Locator32 field is an unsigned 32-bit integer in network byte order that has the same syntax and semantics as a 32-bit IPv4 routing prefix. =head1 COPYRIGHT Copyright (c)2012 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/MR.pm0000644000175000017500000000542314756035515015311 0ustar willemwillempackage Net::DNS::RR::MR; use strict; use warnings; our $VERSION = (qw$Id: MR.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::MR - DNS MR resource record =cut use integer; use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, @argument ) = @_; $self->{newname} = Net::DNS::DomainName1035->decode(@argument); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, @argument ) = @_; return $self->{newname}->encode(@argument); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return $self->{newname}->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->newname(@argument); return; } sub newname { my ( $self, @value ) = @_; for (@value) { $self->{newname} = Net::DNS::DomainName1035->new($_) } return $self->{newname} ? $self->{newname}->name : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR('name MR newname'); =head1 DESCRIPTION Class for DNS Mail Rename (MR) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 newname $newname = $rr->newname; $rr->newname( $newname ); A domain name which specifies a mailbox which is the proper rename of the specified mailbox. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/DHCID.pm0000644000175000017500000001001014756035515015572 0ustar willemwillempackage Net::DNS::RR::DHCID; use strict; use warnings; our $VERSION = (qw$Id: DHCID.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::DHCID - DNS DHCID resource record =cut use integer; use MIME::Base64; sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @rdata = split /\s+/, encode_base64( $self->_encode_rdata ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->rdata( MIME::Base64::decode( join "", @argument ) ); return; } # +------------------+------------------------------------------------+ # | Identifier Type | Identifier | # | Code | | # +------------------+------------------------------------------------+ # | 0x0000 | The 1-octet 'htype' followed by 'hlen' octets | # | | of 'chaddr' from a DHCPv4 client's DHCPREQUEST | # | | [7]. | # | 0x0001 | The data octets (i.e., the Type and | # | | Client-Identifier fields) from a DHCPv4 | # | | client's Client Identifier option [10]. | # | 0x0002 | The client's DUID (i.e., the data octets of a | # | | DHCPv6 client's Client Identifier option [11] | # | | or the DUID field from a DHCPv4 client's | # | | Client Identifier option [6]). | # | 0x0003 - 0xfffe | Undefined; available to be assigned by IANA. | # | 0xffff | Undefined; RESERVED. | # +------------------+------------------------------------------------+ sub identifiertype { return unpack 'n', shift->{rdata} || return } sub digesttype { return unpack 'x2C', shift->{rdata} || return } sub digest { return unpack 'x3a*', shift->{rdata} || return } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('client.example.com. DHCID ( AAAB xLmlskllE0MVjd57zHcWmEH3pCQ6VytcKD//7es/deY= )'); $rr = Net::DNS::RR->new( name => 'client.example.com', type => 'DHCID', digest => 'ObfuscatedIdentityData', digesttype => 1, identifiertype => 2, ); =head1 DESCRIPTION DNS RR for Encoding DHCP Information (DHCID) =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 identifiertype $identifiertype = $rr->identifiertype; The 16-bit identifier type describes the form of host identifier used to construct the DHCP identity information. =head2 digesttype $digesttype = $rr->digesttype; The 8-bit digest type number describes the message-digest algorithm used to obfuscate the DHCP identity information. =head2 digest $digest = $rr->digest; Binary representation of the digest of DHCP identity information. =head1 COPYRIGHT Copyright (c)2009 Olaf Kolkman, NLnet Labs. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/A.pm0000644000175000017500000000567514756035515015164 0ustar willemwillempackage Net::DNS::RR::A; use strict; use warnings; our $VERSION = (qw$Id: A.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::A - DNS A resource record =cut use integer; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; $self->{address} = unpack "\@$offset a4", $$data; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'a4', $self->{address}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return $self->address; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->address(@argument); return; } my $pad = pack 'x4'; sub address { my ( $self, $addr ) = @_; return join '.', unpack 'C4', $self->{address} . $pad unless defined $addr; # Note: pack masks overlarge values, mostly without warning my @part = split /\./, $addr; my $last = pop(@part); return $self->{address} = pack 'C4', @part, (0) x ( 3 - @part ), $last; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name IN A address'); $rr = Net::DNS::RR->new( name => 'example.com', type => 'A', address => '192.0.2.1' ); =head1 DESCRIPTION Class for DNS Address (A) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 address $IPv4_address = $rr->address; $rr->address( $IPv4_address ); Version 4 IP address represented using dotted-quad notation. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/CAA.pm0000644000175000017500000001014414756035515015353 0ustar willemwillempackage Net::DNS::RR::CAA; use strict; use warnings; our $VERSION = (qw$Id: CAA.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::CAA - DNS CAA resource record =cut use integer; use Net::DNS::Text; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $limit = $offset + $self->{rdlength}; $self->{flags} = unpack "\@$offset C", $$data; ( $self->{tag}, $offset ) = Net::DNS::Text->decode( $data, $offset + 1 ); $self->{value} = Net::DNS::Text->decode( $data, $offset, $limit - $offset ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'C a* a*', $self->flags, $self->{tag}->encode, $self->{value}->raw; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @rdata = ( $self->flags, $self->{tag}->string, $self->{value}->string ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->flags( shift @argument ); $self->tag( lc shift @argument ); $self->value( shift @argument ); return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->flags(0); return; } sub flags { my ( $self, @value ) = @_; for (@value) { $self->{flags} = 0 + $_ } return $self->{flags} || 0; } sub critical { my ( $self, @value ) = @_; if ( scalar @value ) { for ( $self->{flags} |= 0x80 ) { $_ ^= 0x80 unless shift @value; } } return $self->{flags} & 0x80; } sub tag { my ( $self, @value ) = @_; for (@value) { $self->{tag} = Net::DNS::Text->new($_) } return $self->{tag} ? $self->{tag}->value : undef; } sub value { my ( $self, @value ) = @_; for (@value) { $self->{value} = Net::DNS::Text->new($_) } return $self->{value} ? $self->{value}->value : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name IN CAA flags tag value'); =head1 DESCRIPTION Class for Certification Authority Authorization (CAA) DNS resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 flags $flags = $rr->flags; $rr->flags( $flags ); Unsigned 8-bit number representing Boolean flags. =over 4 =item critical $rr->critical(1); if ( $rr->critical ) { ... } Issuer critical flag. =back =head2 tag $tag = $rr->tag; $rr->tag( $tag ); Property identifier which may contain the characters a-z, A-Z, and 0-9. The tag field must not contain any other characters. Matching of tags is not case sensitive. =head2 value $value = $rr->value; $rr->value( $value ); A sequence of octets representing the property value. Property values are encoded as binary values and may employ sub-formats. =head1 COPYRIGHT Copyright (c)2013,2015 Dick Franks All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/HTTPS.pm0000644000175000017500000000406014756035515015671 0ustar willemwillempackage Net::DNS::RR::HTTPS; use strict; use warnings; our $VERSION = (qw$Id: HTTPS.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR::SVCB); =head1 NAME Net::DNS::RR::HTTPS - DNS HTTPS resource record =cut 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name HTTPS SvcPriority TargetName alpn=h3-29,h3-28,h3-27,h2 ...'); =head1 DESCRIPTION DNS HTTPS resource record The HTTPS class is derived from, and inherits all properties of, the Net::DNS::RR::SVCB class. Please see the L documentation for details. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head1 COPYRIGHT Copyright (c)2020 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/SRV.pm0000644000175000017500000001062514756035515015445 0ustar willemwillempackage Net::DNS::RR::SRV; use strict; use warnings; our $VERSION = (qw$Id: SRV.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::SRV - DNS SRV resource record =cut use integer; use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; @{$self}{qw(priority weight port)} = unpack( "\@$offset n3", $$data ); $self->{target} = Net::DNS::DomainName2535->decode( $data, $offset + 6, @opaque ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, $offset, @opaque ) = @_; my $target = $self->{target}; my @nums = ( $self->priority, $self->weight, $self->port ); return pack 'n3 a*', @nums, $target->encode( $offset + 6, @opaque ); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $target = $self->{target}; my @rdata = ( $self->priority, $self->weight, $self->port, $target->string ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; foreach my $attr (qw(priority weight port target)) { $self->$attr( shift @argument ); } return; } sub priority { my ( $self, @value ) = @_; for (@value) { $self->{priority} = 0 + $_ } return $self->{priority} || 0; } sub weight { my ( $self, @value ) = @_; for (@value) { $self->{weight} = 0 + $_ } return $self->{weight} || 0; } sub port { my ( $self, @value ) = @_; for (@value) { $self->{port} = 0 + $_ } return $self->{port} || 0; } sub target { my ( $self, @value ) = @_; for (@value) { $self->{target} = Net::DNS::DomainName2535->new($_) } return $self->{target} ? $self->{target}->name : undef; } # order RRs by numerically increasing priority, decreasing weight my $function = sub { my ( $a, $b ) = ( $Net::DNS::a, $Net::DNS::b ); return $a->{priority} <=> $b->{priority} || $b->{weight} <=> $a->{weight}; }; __PACKAGE__->set_rrsort_func( 'priority', $function ); __PACKAGE__->set_rrsort_func( 'default_sort', $function ); 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name SRV priority weight port target'); =head1 DESCRIPTION Class for DNS Service (SRV) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 priority $priority = $rr->priority; $rr->priority( $priority ); Returns the priority for this target host. =head2 weight $weight = $rr->weight; $rr->weight( $weight ); Returns the weight for this target host. =head2 port $port = $rr->port; $rr->port( $port ); Returns the port number for the service on this target host. =head2 target $target = $rr->target; $rr->target( $target ); Returns the domain name of the target host. =head1 Sorting of SRV Records By default, rrsort() returns the SRV records sorted from lowest to highest priority and for equal priorities from highest to lowest weight. Note: This is NOT the order in which connections should be attempted. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. Portions Copyright (c)2005 Olaf Kolkman, NLnet Labs. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/SMIMEA.pm0000644000175000017500000001237514756035515015752 0ustar willemwillempackage Net::DNS::RR::SMIMEA; use strict; use warnings; our $VERSION = (qw$Id: SMIMEA.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::SMIMEA - DNS SMIMEA resource record =cut use integer; use Carp; use constant BABBLE => defined eval { require Digest::BubbleBabble }; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $next = $offset + $self->{rdlength}; @{$self}{qw(usage selector matchingtype)} = unpack "\@$offset C3", $$data; $offset += 3; $self->{certbin} = substr $$data, $offset, $next - $offset; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'C3 a*', @{$self}{qw(usage selector matchingtype certbin)}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; $self->_annotation( $self->babble ) if BABBLE; my @cert = split /(\S{64})/, $self->cert; my @rdata = ( $self->usage, $self->selector, $self->matchingtype, @cert ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(usage selector matchingtype)) { $self->$_( shift @argument ) } $self->cert(@argument); return; } sub usage { my ( $self, @value ) = @_; for (@value) { $self->{usage} = 0 + $_ } return $self->{usage} || 0; } sub selector { my ( $self, @value ) = @_; for (@value) { $self->{selector} = 0 + $_ } return $self->{selector} || 0; } sub matchingtype { my ( $self, @value ) = @_; for (@value) { $self->{matchingtype} = 0 + $_ } return $self->{matchingtype} || 0; } sub cert { my ( $self, @value ) = @_; return unpack "H*", $self->certbin() unless scalar @value; my @hex = map { /^"*([\dA-Fa-f]*)"*$/ || croak("corrupt hex"); $1 } @value; return $self->certbin( pack "H*", join "", @hex ); } sub certbin { my ( $self, @value ) = @_; for (@value) { $self->{certbin} = $_ } return $self->{certbin} || ""; } sub certificate { return &cert; } sub babble { return BABBLE ? Digest::BubbleBabble::bubblebabble( Digest => shift->certbin ) : ''; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name SMIMEA usage selector matchingtype certificate'); =head1 DESCRIPTION The SMIMEA DNS resource record (RR) is used to associate an end entity certificate or public key with the associated email address, thus forming a "SMIMEA certificate association". The semantics of how the SMIMEA RR is interpreted are described in RFC6698. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 usage $usage = $rr->usage; $rr->usage( $usage ); 8-bit integer value which specifies the provided association that will be used to match the certificate. =head2 selector $selector = $rr->selector; $rr->selector( $selector ); 8-bit integer value which specifies which part of the certificate presented by the server will be matched against the association data. =head2 matchingtype $matchingtype = $rr->matchingtype; $rr->matchingtype( $matchingtype ); 8-bit integer value which specifies how the certificate association is presented. =head2 certificate =head2 cert $cert = $rr->cert; $rr->cert( $cert ); Hexadecimal representation of the certificate data. =head2 certbin $certbin = $rr->certbin; $rr->certbin( $certbin ); Binary representation of the certificate data. =head2 babble print $rr->babble; The babble() method returns the 'BubbleBabble' representation of the digest if the Digest::BubbleBabble package is available, otherwise an empty string is returned. BubbleBabble represents a message digest as a string of plausible words, to make the digest easier to verify. The "words" are not necessarily real words, but they look more like words than a string of hex characters. The 'BubbleBabble' string is appended as a comment when the string method is called. =head1 COPYRIGHT Copyright (c)2016 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/DS.pm0000644000175000017500000002454514756035515015307 0ustar willemwillempackage Net::DNS::RR::DS; use strict; use warnings; our $VERSION = (qw$Id: DS.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::DS - DNS DS resource record =cut use integer; use Carp; use constant BABBLE => defined eval { require Digest::BubbleBabble }; eval { require Digest::SHA }; ## optional for simple Net::DNS RR my %digest = ( '1' => ['Digest::SHA', 1], '2' => ['Digest::SHA', 256], '4' => ['Digest::SHA', 384], '6' => ['Net::DNS::SEC::Digest::SM3'], ); sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $rdata = substr $$data, $offset, $self->{rdlength}; @{$self}{qw(keytag algorithm digtype digestbin)} = unpack 'n C2 a*', $rdata; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'n C2 a*', @{$self}{qw(keytag algorithm digtype digestbin)}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @rdata = @{$self}{qw(keytag algorithm digtype)}; if ( my $digest = $self->digest ) { $self->_annotation( $self->babble ) if BABBLE; push @rdata, split /(\S{64})/, $digest; } else { push @rdata, '""'; } return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->keytag( shift @argument ); my $algorithm = shift @argument; $self->digtype( shift @argument ); $self->digest(@argument); $self->algorithm($algorithm); return; } sub keytag { my ( $self, @value ) = @_; for (@value) { $self->{keytag} = 0 + $_ } return $self->{keytag} || 0; } sub algorithm { my ( $self, $arg ) = @_; unless ( ref($self) ) { ## class method or simple function my $argn = pop; return $argn =~ /[^0-9]/ ? _algbyname($argn) : _algbyval($argn); } return $self->{algorithm} unless defined $arg; return _algbyval( $self->{algorithm} ) if uc($arg) eq 'MNEMONIC'; return $self->{algorithm} = _algbyname($arg) || die _algbyname('') # disallow algorithm(0) } sub digtype { my ( $self, $arg ) = @_; unless ( ref($self) ) { ## class method or simple function my $argn = pop; return $argn =~ /[^0-9]/ ? _digestbyname($argn) : _digestbyval($argn); } return $self->{digtype} unless defined $arg; return _digestbyval( $self->{digtype} ) if uc($arg) eq 'MNEMONIC'; return $self->{digtype} = _digestbyname($arg) || die _digestbyname('') # disallow digtype(0) } sub digest { my ( $self, @value ) = @_; return unpack "H*", $self->digestbin() unless scalar @value; my @hex = map { /^"*([\dA-Fa-f]*)"*$/ || croak("corrupt hex"); $1 } @value; return $self->digestbin( pack "H*", join "", @hex ); } sub digestbin { my ( $self, @value ) = @_; for (@value) { $self->{digestbin} = $_ } return $self->{digestbin} || ""; } sub babble { return BABBLE ? Digest::BubbleBabble::bubblebabble( Digest => shift->digestbin ) : ''; } sub create { my ( $class, $keyrr, %args ) = @_; my ($type) = reverse split '::', $class; croak "Unable to create $type record for invalid key" unless $keyrr->protocol == 3; croak "Unable to create $type record for revoked key" if $keyrr->revoke; croak "Unable to create $type record for non-zone key" unless $keyrr->zone; my $self = Net::DNS::RR->new( owner => $keyrr->owner, # per definition, same as keyrr type => $type, class => $keyrr->class, ttl => $keyrr->{ttl}, digtype => 1, # SHA1 by default %args, algorithm => $keyrr->algorithm, keytag => $keyrr->keytag ); my $spec = $digest{$self->digtype}; my $hash = eval { my ( $object, @param ) = @$spec; $object->new(@param); }; croak join ' ', 'digtype', $self->digtype('MNEMONIC'), 'not supported' unless $hash; $hash->add( $keyrr->{owner}->canonical ); $hash->add( $keyrr->_encode_rdata ); $self->digestbin( $hash->digest ); return $self; } sub verify { my ( $self, $key ) = @_; my $verify = Net::DNS::RR::DS->create( $key, ( digtype => $self->digtype ) ); return $verify->digestbin eq $self->digestbin; } ######################################## { my @digestbyname = ( 'SHA-1' => 1, # [RFC3658] 'SHA-256' => 2, # [RFC4509] 'GOST-R-34.11-94' => 3, # [RFC5933] 'SHA-384' => 4, # [RFC6605] 'GOST-R-34.11-2012' => 5, # [RFC-makarenko-gost2012-dnssec-05] 'SM3' => 6, # [RFC-cuiling-dnsop-sm2-alg-15] ); my @digestalias = ( 'SHA' => 1 ); my %digestbyval = reverse @digestbyname; foreach (@digestbyname) { s/[\W_]//g; } # strip non-alphanumerics my @digestrehash = map { /^\d/ ? ($_) x 3 : uc($_) } @digestbyname; my %digestbyname = ( @digestalias, @digestrehash ); # work around broken cperl sub _digestbyname { my $arg = shift; my $key = uc $arg; # synthetic key $key =~ s/[\W_]//g; # strip non-alphanumerics my $val = $digestbyname{$key}; return $val if defined $val; return $key =~ /^\d/ ? $arg : croak qq[unknown algorithm $arg]; } sub _digestbyval { my $value = shift; return $digestbyval{$value} || return $value; } } { my @algbyname = ( 'DELETE' => 0, # [RFC4034][RFC4398][RFC8078] 'RSAMD5' => 1, # [RFC3110][RFC4034] 'DH' => 2, # [RFC2539] 'DSA' => 3, # [RFC3755][RFC2536] ## Reserved => 4, # [RFC6725] 'RSASHA1' => 5, # [RFC3110][RFC4034] 'DSA-NSEC3-SHA1' => 6, # [RFC5155] 'RSASHA1-NSEC3-SHA1' => 7, # [RFC5155] 'RSASHA256' => 8, # [RFC5702] ## Reserved => 9, # [RFC6725] 'RSASHA512' => 10, # [RFC5702] ## Reserved => 11, # [RFC6725] 'ECC-GOST' => 12, # [RFC5933] 'ECDSAP256SHA256' => 13, # [RFC6605] 'ECDSAP384SHA384' => 14, # [RFC6605] 'ED25519' => 15, # [RFC8080] 'ED448' => 16, # [RFC8080] 'SM2SM3' => 17, # [RFC-cuiling-dnsop-sm2-alg-15] 'ECC-GOST12' => 23, # [RFC-makarenko-gost2012-dnssec-05] 'INDIRECT' => 252, # [RFC4034] 'PRIVATEDNS' => 253, # [RFC4034] 'PRIVATEOID' => 254, # [RFC4034] ## Reserved => 255, # [RFC4034] ); my %algbyval = reverse @algbyname; foreach (@algbyname) { s/[\W_]//g; } # strip non-alphanumerics my @algrehash = map { /^\d/ ? ($_) x 3 : uc($_) } @algbyname; my %algbyname = @algrehash; # work around broken cperl sub _algbyname { my $arg = shift; my $key = uc $arg; # synthetic key $key =~ s/[\W_]//g; # strip non-alphanumerics my $val = $algbyname{$key}; return $val if defined $val; return $key =~ /^\d/ ? $arg : croak qq[unknown algorithm $arg]; } sub _algbyval { my $value = shift; return $algbyval{$value} || return $value; } } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name DS keytag algorithm digtype digest'); use Net::DNS::SEC; $ds = Net::DNS::RR::DS->create( $dnskeyrr, digtype => 'SHA256', ttl => 3600 ); =head1 DESCRIPTION Class for DNS Delegation Signer (DS) resource record. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 keytag $keytag = $rr->keytag; $rr->keytag( $keytag ); The 16-bit numerical key tag of the key. (RFC2535 4.1.6) =head2 algorithm $algorithm = $rr->algorithm; $rr->algorithm( $algorithm ); Decimal representation of the 8-bit algorithm field. algorithm() may also be invoked as a class method or simple function to perform mnemonic and numeric code translation. =head2 digtype $digtype = $rr->digtype; $rr->digtype( $digtype ); Decimal representation of the 8-bit digest type field. digtype() may also be invoked as a class method or simple function to perform mnemonic and numeric code translation. =head2 digest $digest = $rr->digest; $rr->digest( $digest ); Hexadecimal representation of the digest over the label and key. =head2 digestbin $digestbin = $rr->digestbin; $rr->digestbin( $digestbin ); Binary representation of the digest over the label and key. =head2 babble print $rr->babble; The babble() method returns the 'BubbleBabble' representation of the digest if the Digest::BubbleBabble package is available, otherwise an empty string is returned. BubbleBabble represents a message digest as a string of plausible words, to make the digest easier to verify. The "words" are not necessarily real words, but they look more like words than a string of hex characters. The 'BubbleBabble' string is appended as a comment when the string method is called. =head2 create use Net::DNS::SEC; $dsrr = Net::DNS::RR::DS->create( $keyrr, digtype => 'SHA-256' ); $keyrr->print; $dsrr->print; This constructor takes a DNSKEY argument and will return the corresponding DS RR constructed using the specified algorithm. The digest algorithm defaults to SHA-1. =head2 verify $verify = $dsrr->verify($keyrr); The boolean verify method will return true if the hash over the key RR provided as the argument conforms to the data in the DS itself i.e. the DS points to the DNSKEY from the argument. =head1 COPYRIGHT Copyright (c)2001-2005 RIPE NCC. Author Olaf M. Kolkman Portions Copyright (c)2013,2021 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L =cut Net-DNS-1.50/lib/Net/DNS/RR/TSIG.pm0000644000175000017500000005027514756035515015546 0ustar willemwillempackage Net::DNS::RR::TSIG; use strict; use warnings; our $VERSION = (qw$Id: TSIG.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::TSIG - DNS TSIG resource record =cut use integer; use Carp; use Net::DNS::DomainName; use Net::DNS::Parameters qw(:class :type :rcode); use constant SYMLINK => defined(&CORE::readlink); # Except Win32, VMS, RISC OS use constant ANY => classbyname q(ANY); use constant TSIG => typebyname q(TSIG); eval { require Digest::HMAC }; eval { require Digest::MD5 }; eval { require Digest::SHA }; eval { require MIME::Base64 }; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $limit = $offset + $self->{rdlength}; ( $self->{algorithm}, $offset ) = Net::DNS::DomainName->decode( $data, $offset ); # Design decision: Use 32 bits, which will work until the end of time()! @{$self}{qw(time_signed fudge)} = unpack "\@$offset xxN n", $$data; $offset += 8; my $mac_size = unpack "\@$offset n", $$data; $self->{macbin} = unpack "\@$offset xx a$mac_size", $$data; $offset += $mac_size + 2; @{$self}{qw(original_id error)} = unpack "\@$offset nn", $$data; $offset += 4; my $other_size = unpack "\@$offset n", $$data; $self->{other} = unpack "\@$offset xx a$other_size", $$data; $offset += $other_size + 2; croak('misplaced or corrupt TSIG') unless $limit == length $$data; my $raw = substr $$data, 0, $self->{offset}++; $self->{rawref} = \$raw; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $offset = shift; my $undef = shift; my $message = shift; my $macbin = $self->macbin; unless ($macbin) { my $sigdata = $self->sig_data($message); # form data to be signed $macbin = $self->macbin( $self->_mac_function($sigdata) ); } my $rdata = $self->{algorithm}->canonical; # Design decision: Use 32 bits, which will work until the end of time()! $rdata .= pack 'xxN n', $self->time_signed, $self->fudge; $rdata .= pack 'na*', length($macbin), $macbin; $rdata .= pack 'nn', $self->original_id, $self->{error}; my $other = $self->other; $rdata .= pack 'na*', length($other), $other; return $rdata; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->algorithm(157); $self->class('ANY'); $self->error(0); $self->fudge(300); $self->other(''); return; } sub _size { ## estimate encoded size my $self = shift; my $clone = bless {%$self}, ref($self); # shallow clone return length $clone->encode( 0, undef, Net::DNS::Packet->new() ); } sub encode { ## override RR method my ( $self, @argument ) = @_; my $kname = $self->{owner}->encode(); # uncompressed key name my $rdata = eval { $self->_encode_rdata(@argument) } || ''; return pack 'a* n2 N n a*', $kname, TSIG, ANY, 0, length $rdata, $rdata; } sub string { ## override RR method my $self = shift; my $owner = $self->{owner}->string; my $type = $self->type; my $algorithm = $self->algorithm; my $time_signed = $self->time_signed; my $fudge = $self->fudge; my $signature = $self->mac; my $original_id = $self->original_id; my $error = $self->error; my $other = $self->other; return <<"QQ"; ; $owner $type ; algorithm: $algorithm ; time signed: $time_signed fudge: $fudge ; signature: $signature ; original id: $original_id ; $error $other QQ } sub algorithm { return &_algorithm; } sub key { my ( $self, @argument ) = @_; return MIME::Base64::encode( $self->keybin(), "" ) unless scalar @argument; return $self->keybin( MIME::Base64::decode( join "", @argument ) ); } sub keybin { return &_keybin; } sub time_signed { my ( $self, @value ) = @_; for (@value) { $self->{time_signed} = 0 + $_ } return $self->{time_signed} ? $self->{time_signed} : ( $self->{time_signed} = time() ); } sub fudge { my ( $self, @value ) = @_; for (@value) { $self->{fudge} = 0 + $_ } return $self->{fudge} || 0; } sub mac { my ( $self, @value ) = @_; return MIME::Base64::encode( $self->macbin(), "" ) unless scalar @value; return $self->macbin( MIME::Base64::decode( join "", @value ) ); } sub macbin { my ( $self, @value ) = @_; for (@value) { $self->{macbin} = $_ } return $self->{macbin} || ""; } sub prior_mac { my ( $self, @value ) = @_; return MIME::Base64::encode( $self->prior_macbin(), "" ) unless scalar @value; return $self->prior_macbin( MIME::Base64::decode( join "", @value ) ); } sub prior_macbin { my ( $self, @value ) = @_; for (@value) { $self->{prior_macbin} = $_ } return $self->{prior_macbin} || ""; } sub request_mac { my ( $self, @value ) = @_; return MIME::Base64::encode( $self->request_macbin(), "" ) unless scalar @value; return $self->request_macbin( MIME::Base64::decode( join "", @value ) ); } sub request_macbin { my ( $self, @value ) = @_; for (@value) { $self->{request_macbin} = $_ } return $self->{request_macbin} || ""; } sub original_id { my ( $self, @value ) = @_; for (@value) { $self->{original_id} = 0 + $_ } return $self->{original_id} || 0; } sub error { my ( $self, @value ) = @_; for (@value) { my $error = $self->{error} = rcodebyname($_); $self->other( time() ) if $error == 18; } return rcodebyval( $self->{error} || '' ); } sub other { my ( $self, @value ) = @_; for (@value) { $self->{other} = $_ ? pack( 'xxN', $_ ) : '' } return $self->{other} ? unpack( 'N', $self->{other} ) : ''; } sub other_data { return &other; } # uncoverable pod sub sig_function { my ( $self, @value ) = @_; for (@value) { $self->{sig_function} = $_ } return $self->{sig_function}; } sub sign_func { return &sig_function; } # uncoverable pod sub sig_data { my ( $self, $message ) = @_; if ( ref($message) ) { die 'missing packet reference' unless $message->isa('Net::DNS::Packet'); my @unsigned = grep { ref($_) ne ref($self) } @{$message->{additional}}; local $message->{additional} = \@unsigned; # remake header image my @part = qw(question answer authority additional); my @size = map { scalar @{$message->{$_}} } @part; if ( my $rawref = $self->{rawref} ) { delete $self->{rawref}; my $hbin = pack 'n6', $self->original_id, $message->{status}, @size; $message = join '', $hbin, substr $$rawref, length $hbin; } else { my $data = $message->encode; my $id = $message->header->id; my $hbin = pack 'n6', $id, $message->{status}, @size; $message = join '', $hbin, substr $data, length $hbin; $self->original_id($id); } } # Design decision: Use 32 bits, which will work until the end of time()! my $time = pack 'xxN n', $self->time_signed, $self->fudge; # Insert the prior MAC if present (multi-packet message). $self->prior_macbin( $self->{link}->macbin ) if $self->{link}; my $prior_macbin = $self->prior_macbin; return pack 'na* a* a*', length($prior_macbin), $prior_macbin, $message, $time if $prior_macbin; # Insert the request MAC if present (used to validate responses). my $req_mac = $self->request_macbin; my $sigdata = $req_mac ? pack( 'na*', length($req_mac), $req_mac ) : ''; $sigdata .= $message || ''; my $kname = $self->{owner}->canonical; # canonical key name $sigdata .= pack 'a* n N', $kname, ANY, 0; $sigdata .= $self->{algorithm}->canonical; # canonical algorithm name $sigdata .= $time; $sigdata .= pack 'n', $self->{error}; my $other = $self->other; $sigdata .= pack 'na*', length($other), $other; return $sigdata; } sub create { my ( $class, $karg, @argument ) = @_; croak 'argument undefined' unless defined $karg; if ( ref($karg) ) { if ( $karg->isa('Net::DNS::Packet') ) { my $sigrr = $karg->sigrr; croak 'no TSIG in request packet' unless defined $sigrr; return Net::DNS::RR->new( # ( request, options ) name => $sigrr->name, type => 'TSIG', algorithm => $sigrr->algorithm, request_macbin => $sigrr->macbin, @argument ); } elsif ( ref($karg) eq __PACKAGE__ ) { my $tsig = $karg->_chain; $tsig->{macbin} = undef; return $tsig; } elsif ( ref($karg) eq 'Net::DNS::RR::KEY' ) { return Net::DNS::RR->new( name => $karg->name, type => 'TSIG', algorithm => $karg->algorithm, key => $karg->key, @argument ); } } elsif ( ( scalar(@argument) % 2 ) == 0 ) { require File::Spec; # ( keyfile, options ) require Net::DNS::ZoneFile; my ($keypath) = SYMLINK ? grep( {$_} readlink($karg), $karg ) : $karg; my ( $vol, $dir, $name ) = File::Spec->splitpath($keypath); $name =~ m/^K([^+]+)\+\d+\+(\d+)\./; # BIND dnssec-keygen my ( $keyname, $keytag ) = ( $1, $2 ); my $keyfile = Net::DNS::ZoneFile->new($karg); my ( $algorithm, $secret ); while ( $keyfile->_getline ) { /^key "([^"]+)"/ and $keyname = $1; # BIND tsig key /algorithm ([^;]+);/ and $algorithm = $1; /secret "([^"]+)";/ and $secret = $1; /^Algorithm:/ and ( undef, $algorithm ) = split; # BIND dnssec private key /^Key:/ and ( undef, $secret ) = split; next unless /\bIN\s+KEY\b/; # BIND dnssec public key my $keyrr = Net::DNS::RR->new($_); carp "$karg does not appear to be a BIND dnssec public key" unless $keyrr->keytag == ( $keytag || 0 ); return $class->create( $keyrr, @argument ); } foreach ( $keyname, $algorithm, $secret ) { croak 'key file incompatible with TSIG' unless $_; } return Net::DNS::RR->new( name => $keyname, type => 'TSIG', algorithm => $algorithm, key => $secret, @argument ); } croak "Usage: $class->create( \$keyfile, \@options )"; } sub verify { my ( $self, $data, @link ) = @_; my $fail = undef; if ( scalar @link ) { my $link = shift @link; unless ( ref($link) ) { $self->error('BADSIG'); # (multi-packet) return $fail; } my $signerkey = lc( join '+', $self->name, $self->algorithm ); if ( $link->isa('Net::DNS::Packet') ) { my $request = $link->sigrr; # request TSIG my $rqstkey = lc( join '+', $request->name, $request->algorithm ); $self->error('BADKEY') unless $signerkey eq $rqstkey; $self->request_macbin( $request->macbin ); } elsif ( $link->isa(__PACKAGE__) ) { my $priorkey = lc( join '+', $link->name, $link->algorithm ); $self->error('BADKEY') unless $signerkey eq $priorkey; $self->prior_macbin( $link->macbin ); } else { croak 'Usage: $tsig->verify( $reply, $query )'; } } return $fail if $self->{error}; my $sigdata = $self->sig_data($data); # form data to be verified my $tsigmac = $self->_mac_function($sigdata); my $tsig = $self->_chain; my $macbin = $self->macbin; my $maclen = length $macbin; $self->error('BADSIG') if $macbin ne substr $tsigmac, 0, $maclen; my $minlen = length($tsigmac) >> 1; # per RFC4635, 3.1 $self->error('BADTRUNC') if $maclen < $minlen or $maclen > length $tsigmac; $self->error('BADTRUNC') if $maclen < 10; my $time_signed = $self->time_signed; if ( abs( time() - $time_signed ) > $self->fudge ) { $self->error('BADTIME'); $self->other($time_signed); } return $self->{error} ? $fail : $tsig; } sub vrfyerrstr { return shift->error; } ######################################## { my @algbyname = ( 'HMAC-MD5.SIG-ALG.REG.INT' => 157, # numbers are from ISC BIND keygen 'HMAC-SHA1' => 161, # and not blessed by IANA 'HMAC-SHA224' => 162, 'HMAC-SHA256' => 163, 'HMAC-SHA384' => 164, 'HMAC-SHA512' => 165, ); my @algalias = ( 'HMAC-MD5' => 157, 'HMAC-SHA' => 161, ); my %algbyval = reverse @algbyname; my @algrehash = map { /^\d/ ? ($_) x 3 : uc($_) } @algbyname, @algalias; foreach (@algrehash) { s/[\W_]//g; } # strip non-alphanumerics my %algbyname = @algrehash; # work around broken cperl sub _algbyname { my $key = uc shift; # synthetic key $key =~ s/[\W_]//g; # strip non-alphanumerics return $algbyname{$key}; } sub _algbyval { my $value = shift; return $algbyval{$value}; } } { my %digest = ( '157' => ['Digest::MD5'], '161' => ['Digest::SHA'], '162' => ['Digest::SHA', 224, 64], '163' => ['Digest::SHA', 256, 64], '164' => ['Digest::SHA', 384, 128], '165' => ['Digest::SHA', 512, 128], ); my %keytable; sub _algorithm { ## install sig function in key table my $self = shift; if ( my $algname = shift ) { unless ( my $digtype = _algbyname($algname) ) { $self->{algorithm} = Net::DNS::DomainName->new($algname); } else { $algname = _algbyval($digtype); $self->{algorithm} = Net::DNS::DomainName->new($algname); my ( $hash, @param ) = @{$digest{$digtype}}; my ( undef, @block ) = @param; my $digest = $hash->new(@param); my $function = sub { my $hmac = Digest::HMAC->new( shift, $digest, @block ); $hmac->add(shift); return $hmac->digest; }; $self->sig_function($function); my $keyname = ( $self->{owner} || return )->canonical; $keytable{$keyname}{digest} = $function; } } return defined wantarray ? $self->{algorithm}->name : undef; } sub _keybin { ## install key in key table my ( $self, @argument ) = @_; croak 'access to TSIG key material denied' unless scalar @argument; my $keyref = $keytable{$self->{owner}->canonical} ||= {}; my $private = shift @argument; # closure keeps private key private $keyref->{key} = sub { my $function = $keyref->{digest}; return &$function( $private, @_ ); }; return; } sub _mac_function { ## apply keyed hash function to argument my ( $self, @argument ) = @_; my $owner = $self->{owner}->canonical; $self->algorithm( $self->algorithm ) unless $keytable{$owner}{digest}; my $keyref = $keytable{$owner}; $keyref->{digest} = $self->sig_function unless $keyref->{digest}; my $function = $keyref->{key}; return &$function(@argument); } } # _chain() creates a new TSIG object linked to the original # RR, for the purpose of signing multi-message transfers. sub _chain { my $self = shift; $self->{link} = undef; return bless {%$self, link => $self}, ref($self); } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $tsig = Net::DNS::RR::TSIG->create( $keyfile ); $tsig = Net::DNS::RR::TSIG->create( $keyfile, fudge => 300 ); =head1 DESCRIPTION Class for DNS Transaction Signature (TSIG) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 algorithm $algorithm = $rr->algorithm; $rr->algorithm( $algorithm ); A domain name which specifies the name of the algorithm. =head2 key $rr->key( $key ); Base64 representation of the key material. =head2 keybin $rr->keybin( $keybin ); Binary representation of the key material. =head2 time_signed $time_signed = $rr->time_signed; $rr->time_signed( $time_signed ); Signing time as the number of seconds since 1 Jan 1970 00:00:00 UTC. The default signing time is the current time. =head2 fudge $fudge = $rr->fudge; $rr->fudge( $fudge ); "fudge" represents the permitted error in the signing time. The default fudge is 300 seconds. =head2 mac $rr->mac( $mac ); Message authentication code (MAC). The programmer must call the Net::DNS::Packet data() object method before this will return anything meaningful. =head2 macbin $macbin = $rr->macbin; $rr->macbin( $macbin ); Binary message authentication code (MAC). =head2 prior_mac $prior_mac = $rr->prior_mac; $rr->prior_mac( $prior_mac ); Prior message authentication code (MAC). =head2 prior_macbin $prior_macbin = $rr->prior_macbin; $rr->prior_macbin( $prior_macbin ); Binary prior message authentication code. =head2 request_mac $request_mac = $rr->request_mac; $rr->request_mac( $request_mac ); Request message authentication code (MAC). =head2 request_macbin $request_macbin = $rr->request_macbin; $rr->request_macbin( $request_macbin ); Binary request message authentication code. =head2 original_id $original_id = $rr->original_id; $rr->original_id( $original_id ); The message ID from the header of the original packet. =head2 error =head2 vrfyerrstr $rcode = $tsig->error; Returns the RCODE covering TSIG processing. Common values are NOERROR, BADSIG, BADKEY, and BADTIME. See RFC8945 for details. =head2 other $other = $tsig->other; This field should be empty unless the error is BADTIME, in which case it will contain the server time as the number of seconds since 1 Jan 1970 00:00:00 UTC. =head2 sig_function sub signing_function { my ( $keybin, $data ) = @_; my $hmac = Digest::HMAC->new( $keybin, 'Digest::MD5' ); hmac->add( $data ); return $hmac->digest; } $tsig->sig_function( \&signing_function ); This sets the signing function to be used for this TSIG record. The default signing function is HMAC-MD5. =head2 sig_data $sigdata = $tsig->sig_data($packet); Returns the packet packed according to RFC8945 in a form for signing. This is only needed if you want to supply an external signing function, such as is needed for TSIG-GSS. =head2 create $tsig = Net::DNS::RR::TSIG->create( $keyfile ); $tsig = Net::DNS::RR::TSIG->create( $keyfile, fudge => 300 ); Returns a TSIG RR constructed using the parameters in the specified key file, which is assumed to have been generated by tsig-keygen. =head2 verify $verify = $tsig->verify( $data ); $verify = $tsig->verify( $packet ); $verify = $tsig->verify( $reply, $query ); $verify = $tsig->verify( $packet, $prior ); The boolean verify method will return true if the hash over the packet data conforms to the data in the TSIG itself =head1 TSIG Keys The TSIG authentication mechanism employs a shared secret key to establish a trust relationship between two entities. It should be noted that it is possible for more than one key to be in use simultaneously between any such pair of entities. TSIG keys are generated using the tsig-keygen utility distributed with ISC BIND: tsig-keygen -a HMAC-SHA256 host1-host2.example. Other algorithms may be substituted for HMAC-SHA256 in the above example. These keys must be protected in a manner similar to private keys, lest a third party masquerade as one of the intended parties by forging the message authentication code (MAC). =head1 Configuring BIND Nameserver The generated key must be added to the /etc/named.conf configuration or a separate file introduced by the $INCLUDE directive: key "host1-host2.example. { algorithm hmac-sha256; secret "Secret+known+only+by+participating+entities="; }; =head1 ACKNOWLEDGMENT Most of the code in the Net::DNS::RR::TSIG module was contributed by Chris Turbeville. Support for external signing functions was added by Andrew Tridgell. Support for HMAC-SHA1, HMAC-SHA224, HMAC-SHA256, HMAC-SHA384, HMAC-SHA512 and BIND keyfile handling was added by Dick Franks. =head1 BUGS A 32-bit representation of time is used, contrary to RFC8945 which demands 48 bits. This design decision will need to be reviewed before the code stops working on 7 February 2106. =head1 COPYRIGHT Copyright (c)2000,2001 Michael Fuhr. Portions Copyright (c)2002,2003 Chris Reinhardt. Portions Copyright (c)2013,2020 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L =cut Net-DNS-1.50/Changes0000644000175000017500000023351314756035515013470 0ustar willemwillem$Id: Changes 2015 2025-02-21 08:37:21Z willem $ -*-text-*- **** 1.50 Feb 21, 2025 Minor code improvements in Resolver::Base. Add RESINFO package for resolver information. Documentation revision and reformatting. Fix rt.cpan.org #158714 Fedora41: IPv4 loopback disabled in IPv6-only configuration Fix rt.cpan.org #158706 Use of uninitialized value [in _send_udp] **** 1.49 Dec 27, 2024 Add DSYNC package for Generalized Notification. EDNS: Add support for ZONEVERSION option. Fix rt.cpan.org #157700 "Use of uninitialized value" errors when using TCP connections Fix rt.cpan.org #157669 Net::DNS::Nameserver: SOA not present in NODATA response Fix rt.cpan.org #157195 EDNS option structure does not match JSON from $packet->edns->print Fix rt.cpan.org #157043 User-hostile return value from SVCB key methods **** 1.48 Nov 8, 2024 SVCB: Add tls-suppored-groups parameter. Fix failures in 01-resolver.t dry tests. **** 1.47 Sep 18, 2024 Restore current domain name following $INCLUDE in zone file. Update RFC and other document references. Fix rt.cpan.org #155337 Issue with parallel run of TSIG tests **** 1.46 Aug 19, 2024 Resync with IANA DNS Parameters registry. Revise documentation for Packet.pm and Header.pm. Random ID cache moved from header->id to packet->encode. Restructure resolver method inheritance tree. **** 1.45 May 2, 2024 Resync with IANA DNSSEC Algorithm Numbers registry. Resync with IANA DS Digest Algorithms registry. Add support for EDNS CO flag. Fix rt.cpan.org #152756 Net::DNS::Resolver::UNIX creates $ENV{PATH} key if one doesn't exist **** 1.44 Feb 15, 2024 Simplify testing of resolver error paths. Prevent read beyond end of RDATA in corrupt SVCB RR. **** 1.43 Jan 26, 2024 Update b.root-servers.net addresses in resolver hints. Improve accuracy and completeness of dependency metadata. Nameserver: hangs on persistent TCP connection (Windows). IPSECKEY: leave gateway undefined for gatetype 0. Remove remaining support for GOST. Fix rt.cpan.org #151240 Nameserver.pm: DoS vulnerability in TCP handling Fix rt.cpan.org #151232 Net::DNS::Resolver::new hangs for 150s on Win32 with no active DNS Fix rt.cpan.org #151075 Bug in Net::DNS::Resolver::Recurse::_referral Fix rt.cpan.org #151074 Deep recursion in Net::DNS::Resolver::Recurse **** 1.42 Dec 24, 2023 Fix rt.cpan.org #150695 Hang in Net::DNS::Nameserver on Windows **** 1.41 Nov 28, 2023 Accept inbound Ethernet "Jumbo" UDP packet. Facilitate decoding of mDNS/SD packets with compressed RDATA. Update Parameters.pm to resync with IANA registry. Fix rt.cpan.org #150550 Error trying to use Socket macro SO_REUSEPORT in Windows **** 1.40 Aug 30, 2023 Add support for SVCB dohpath and ohttp parameters. More robust test of bgbusy() SpamAssassin workaround. Fix rt.cpan.org #149456 t/05-SOA.t test fails in 2038 Fix rt.cpan.org #149280 Deep recursion on subroutine "Net::DNS::Resolver::Recurse::_recurse" **** 1.39 Jun 1, 2023 Fix rt.cpan.org #148340 udpsize uninitialized value **** 1.38 May 9, 2023 Mailbox.pm: Improve robustness of address parsing. Deprecate packet->edns->size() method. Deprecate rdatastr() historical RR subtype method. Major overhaul of pre-installation test scripts. Add new t/TestToolkit.pm Refactor socket code and control structure in Nameserver.pm and improve efficiency of zonefile data storage and retrieval. Fix rt.cpan.org #148274 Multicast DNS flag breaks Net::DNS::Parameters::classbyval Fix rt.cpan.org #148273 EDNS extended rcode not handled correctly Fix rt.cpan.org #147507 Nameserver.pm: peerhost undefined after $sock->accept **** 1.37 Mar 13, 2023 Add links to relevant RFCs in package documentation. Fix rt.cpan.org #147038 resolver->axfr( undef ) fails silently Fix rt.cpan.org #145944 Case sensitivity issue with AXFR **** 1.36 Dec 30, 2022 Adopt JSON as presentation notation for EDNS options. Disallow zero packet->id in outbound packet. Remove deprecated 2-argument TSIG->create() method. Revise TSIG test scripts and documentation. **** 1.35 Oct 4, 2022 Improve SVCB error reporting. Fix rt.cpan.org #144328 accept_reply test fails with matched consecutive "random" generated packet->id Fix rt.cpan.org #144299 Spelling errors. **** 1.34 May 30, 2022 Improve robustness of EDNS option compose/decompose functions. Simplify code in Makefile.PL. Fix rt.cpan.org #142426 Avoid "Useless use of a constant in void context" warning. **** 1.33 Dec 16, 2021 Fix rt.cpan.org #137768 Test t/05-SVCB.t on Perl 5.18.0 fails with deep recursion. Fix rt.cpan.org #144136/#132921 $resolver->send wrongly overwrites RD flag in user's packet. **** 1.32 Jul 16, 2021 Text: Offer both Unicode and escaped-ASCII strings. Add LICENSE file to comply with Fedora/RedHat announcement. Fix rt.cpan.org #136666 Net::DNS::RR::ZoneFile parser erroneously strips line terminators in quoted string forming part of multiline RR. **** 1.31 May 2, 2021 Improve implementation of SVCB record. **** 1.30 Mar 30, 2021 Simplify parsing of multi-line RRs in zone file. Improve robustness of "dry" resolver tests. Avoid deep recursion in non-fatal test report. **** 1.29 Nov 18, 2020 Include test number in summary of failed non-fatal tests. Remove Net::DNS::SEC specific tests. Fix faulty test plan in t/08-recurse.t. **** 1.28 Oct 23, 2020 Eliminate indirect object syntax. Eliminate grep/map . **** 1.27 Sep 11, 2020 Fix rt.cpan.org #133203 Net::DNS::RR::LOC erroneously strips non default values from string representation **** 1.26 Aug 6, 2020 Add HTTPS/SVCB packages. Fix rt.cpan.org #132921 EDNS OPT handling **** 1.25 Jun 26, 2020 Parsing of TSIG keyfiles made more robust. **** 1.24 May 27, 2020 Accept TSIG key generated by BIND tsig-keygen. Add Net::DNS::RR::AMTRELAY package. **** 1.23 Mar 18, 2020 Deprecate 2-argument form of TSIG create(). Fix rt.cpan.org #132170 [Documentation] Problems with TSIG on ddns update. Fix rt.cpan.org #131906 Undefined errorstring/warning when axfr fails **** 1.22 Feb 13, 2020 Fix rt.cpan.org #131579 Parse issue in Net::DNS::RR->token Feature Provide rudimentary decode and print for DSO packet. **** 1.21 Aug 30, 2019 Fix error report for non-existent or recursive zone file $INCLUDE. Emit one deprecation warning on invocation of obsolete method. Rework OPT.pm EDNS0 option construction. Remove obsolete Net::DNS::RR::DLV package. Add Net::DNS::RR::ZONEMD package. Fix rt.cpan.org #128901 background TCP query logic expects to read entire response at once **** 1.20 Mar 22, 2019 TSIG MAC representation changed to Base64 (align with BIND). Update Parameters.pm to resync with IANA registry. Refactor resolver test scripts. Revise documentation examples to use AAAA instead of A records. Fix rt.cpan.org #128081 Recurse.pm fails to resolve domain "kickboxingireland.ie" Fix rt.cpan.org #127307 Provide a more informative exception report if application code has no "use Net::DNS::SEC" declaration but nevertheless attempts to invoke the DNSSEC sign or verify features. **** 1.19 Nov 14, 2018 Show structure of EDNS options using Perl-like syntax. Fix rt.cpan.org #127557 Net::DNS::Resolver::Base should use 3 args open Fix rt.cpan.org #127182 Incorrect logic can cause DNS search to emit fruitless queries. **** 1.18 Sep 21, 2018 Documentation revised to remove ambigous use of "answer" which has been used to refer to both the answer section of a packet and the entire reply packet received from a nameserver. Fix rt.cpan.org #127018 Net::DNS::ZoneFile->parse() fails if include directory specified. Fix rt.cpan.org #127012 DNS resolution broken when options ndots used in /etc/resolv.conf **** 1.17 Jul 25, 2018 Fix rt.cpan.org #125890 AXFR: 1 record per packet responses. Fix rt.cpan.org #125889 New NSEC3 for empty non-terminal leaves type bitmap undefined. Fix rt.cpan.org #125882 RDATA name compression pointer calculated incorrectly. **** 1.16 Jul 15, 2018 Feature New NSEC3 encloser(), nextcloser() and wildcard() instance methods return closest encloser, "next closer" and putative wildcard names respectively. Feature Add new NSEC covers() instance method. Feature New NSEC typemap() instance method interrogates type list. IO::Socket::INET6 removed from recommended module metadata. IPv6 requires IO::Socket::IP which is now a core package. No requirement to escape @ in unquoted contiguous string. **** 1.15 Feb 9, 2018 GOST R 34.11-94 hash algorithm: end of life 1st Jan 2018 per sunset clause in successor standard GOST R 34.11-2012. Digest::GOST removed from the recommended module metadata, but will still be used if available. **** 1.14 Dec 15, 2017 Fix rt.cpan.org #123702 'use base' should not be used in packages with several subpackages defined Fix rt.cpan.org #123676 Net::DNS::Nameserver malformed message on big axfr **** 1.13 Oct 18, 2017 Feature IDN query support Queries for domain names containing non-ASCII characters are now possible on Unicode platforms using CPAN Net::LibIDN2 **** 1.12 Aug 18, 2017 Fix rt.cpan.org #122586 Persistent UDP reports false timeouts Fix rt.cpan.org #122352 bgsend(): TCP retry can stall for IO::Socket::IP before 0.38 Feature CDS / CDNSKEY: Implement RFC8078 erratum 5049. **** 1.11 Jun 26, 2017 Fix rt.cpan.org #122138 Send a UDP query with udppacketsize=512 Feature Extract default resolver configuration from OS/390 MVS datasets. Thanks to Sandra Carroll and Yaroslav Kuzmin for their assistance. **** 1.10 May 5, 2017 Fix rt.cpan.org #120748 Net::DNS::Resolver::MSWin32 critical issue Thanks to Dmytro Zagashev for his valuable assistance during the investigation which exposed five distinct issues. Feature rt.cpan.org #18819 Perl 5.22.0 puts EBCDIC character encoding back on the agenda. Thanks to Yaroslav Kuzmin for successful test build on os390. **** 1.09 March 24, 2017 Fix rt.cpan.org #120542 Fails tests when no "." in @INC Fix rt.cpan.org #120470 Fragmented TCP length not correctly reassembled Feature rt.cpan.org #75357 Add mechanism to encode/decode EDNS option octet strings **** 1.08 February 20, 2017 Discontinue support for pre-5.6 perl Remove pre-5.6 workarounds and outdated language features Fix rt.cpan.org #120208 Unable to install 1.07 in local::lib environment Feature rt.cpan.org #119679 Net::DNS::Nameserver: UpdateHandler for responding to UPDATE packets Feature rt.cpan.org #75357 Net::DNS::Nameserver: optionmask (similar to headermask) added to allow user to set EDNS options in reply packet **** 1.07 December 29, 2016 Fix rt.cpan.org #118598/#108908 Serious Makefile.PL issues "make install" now suppressed if pre-1.01 version detected Fix rt.cpan.org #115558 Net::DNS::Nameserver does not allow EDNS replies Fix rt.cpan.org #114917 Net::DNS::ZoneFile fails to parse mixed case mnemonics Fix rt.cpan.org #114876 Use of uninitialized value in lc at MSWin32.pm line 77 Fix rt.cpan.org #114819 Net::DNS fails to compile with taint checks enabled Feature Add support for dynamic RR subtype package creation per draft-levine-dnsextlang **** 1.06 May 27, 2016 Fix rt.cpan.org #114918 Net::DNS::ZoneFile fails when unnamed RR follows $ORIGIN Fix rt.cpan.org #114351 Case sensitive compression breaks resolver->nameservers() Fix rt.cpan.org #113579 Net::DNS::Resolver dies on scoped IPv6 nameserver address Fix rt.cpan.org #113020 Resolve::Recurse Hangs Fix rt.cpan.org #112860 improperly terminated AXFR at t/08-IPv4.t line 446. **** 1.05 March 7, 2016 Fix rt.cpan.org #111559 1.04: TSIG not working anymore (TSIG.pm) Fix rt.cpan.org #108908 Installing recent version gets shadowed by old version. Warnings added to Makefile.PL and t/00-version.t. Fix rt.cpan.org #66900 Net::DNS::Async unable to retry truncated UDP using TCP because of limitations in Net::DNS. **** 1.04 December 8, 2015 Fix rt.cpan.org #109183 Semantics of "retry" and "retrans" options has changed with 1.03 Fix rt.cpan.org #109152 Deprecated method make_query_packet breaks calling code Fix rt.cpan.org #109135 Resolver behaves differently with long and short IPv6 address format Fix rt.cpan.org #108745 Net::DNS::Resolver bgsend **** 1.03 November 6, 2015 Fix rt.cpan.org #107897 t/10-recurse.t freezes, never completes Fix rt.cpan.org #101978 Update Net::DNS to use IO::Socket::IP Fix rt.cpan.org #84375 Timeout doesn't work with bgsend/bgread Fix rt.cpan.org #47050 persistent sockets for Resolver::bg(send|read|isready) Fix rt.cpan.org #15515 bgsend on TCP **** 1.02 September 16, 2015 Fix rt.cpan.org #107052 suppress messages: Can't locate Net/DNS/Resolver/linux.pm Fix rt.cpan.org #106916 Dependency on MIME::Base32 makes Net::DNS not installable on MSWin32 Fix rt.cpan.org #106565 Net::DNS::Resolver::Recurse and IPv6 Reverse DNS Fix rt.cpan.org #105808 Version test for Pod::Test is broken **** 1.01 Jul 6, 2015 Feature The RRs previously only available with Net::DNS::SEC are now integrated with Net::DNS. Net::DNS::SEC needs to be installed to enable the signature generation and verification functions. Fix rt.cpan.org #105491 Can't call method "zclass" on an undefined value at ... Net/DNS/Packet.pm line 474 Fix rt.cpan.org #105421 Dead link in Net::DNS::FAQ Fix rt.cpan.org #104657 Wrong split on Cygwin Fix rt.cpan.org #102810 Dynamic update: rr_add overrides ttl of zero Fix rt.cpan.org #102809 CAA broken **** 0.83 Feb 26, 2015 Fix rt.cpan.org #101798 AUTOLOAD error confusing w/o reference to object class Fix rt.cpan.org #101709 Provide separate control of IPv6 tests Fix rt.cpan.org #101675 MX record with 0 preference fails to parse Fix rt.cpan.org #101405 Install tests fail for v0.81 on Perl 5.21.7 **** 0.82 Jan 20, 2015 Fix rt.cpan.org #100385 Support for IPv6 link-local addresses with scope_id **** 0.81 Oct 29, 2014 Fix rt.cpan.org #99571 AXFR BADSIG failures Fix rt.cpan.org #99531 Resolver doc error - when is a 'bug' a 'bug'? [TSIG verification] Fix rt.cpan.org #99528 TSIG::create fails with some filenames Fix rt.cpan.org #99527 Random errors... [declaration with statement modifier] Fix rt.cpan.org #99429 Infinite recursion in Net::DNS::Resolver::Recurse::send when following certain delegations with empty non-terminals. Fix rt.cpan.org #99320 Net::DNS::ZoneFile bug in "$ORIGIN ." **** 0.80 Sep 22, 2014 Removal of Win32::IPHelper support with cygwin Resolvers on Cygwin can get their DNS configuration from the registry directly via the /proc filesystem. Getting rid of the other method reduces dependencies and makes installations less error prone. Rework rt.cpan.org #96119 "Too late to run INIT block" warning for require Net::DNS **** 0.79 Aug 22, 2014 Feature rt.cpan.org #98149 Add support for Android platform. Fix rt.cpan.org #97736 Net::DNS::Resolver->new mistakenly copies supplied arguments into default configuration on first instantiation. Fix rt.cpan.org #97502 Net::DNS::Resolver->retrans does not accept a value of 1 (uses 2 instead) Fix rt.cpan.org #83642 Configure CD flag in Net::DNS::Resolver->new Fix rt.cpan.org #81760 Reverted workaround for TXT issue preventing propagation of rule updates for SpamAssassin versions earlier than 3.4.0 Fix rt.cpan.org #16630 Net::DNS::Resolver::Recurse issues lots of IMHO unnecessary DNS requests. **** 0.78 Jul 10, 2014 Fix rt.cpan.org #97036 Nameserver identification on Cygwin Fix rt.cpan.org #96814 Trailing comments not stripped in /etc/resolv.conf Fix rt.cpan.org #96812 Net::DNS::Resolver->new() hangs if nameserver :: exists Fix rt.cpan.org #96755 RFC 3597 (hex) parsing mistake Fix rt.cpan.org #96708 String treated as boolean in TXT Fix rt.cpan.org #96608 "Insecure dependency in connect" with Net::DNS::Resolver over TCP Fix rt.cpan.org #96535 Net::DNS::Resolver warns "Use of uninitialized value in length" Fix rt.cpan.org #96531 Calling $resolver->nameservers multiple times returns an increasingly-long list (on some perl installations) Fix rt.cpan.org #96439 Uninitialised decoding object when printing packet **** 0.77 Jun 13, 2014 Fix rt.cpan.org #96151 Unlocalised $_ modified when reading config file Fix rt.cpan.org #96135 Deep recursion problem on Cygwin Fix rt.cpan.org #96119 "Too late to run INIT block" warning for require Net::DNS Fix rt.cpan.org #96035 Insert missing plan 'no-plan' in 10-recurse.t Fix inefficient Net::DNS::SEC compatibility code **** 0.76 May 23, 2014 Fix rt.cpan.org #95738 Test failure with IPv6 address in resolver.conf but without prerequisite IO::Socket::INET6 package installed. Fix rt.cpan.org #95596 Incorrect parsing of nameserver lines in resolv.conf Feature rt.cpan.org #79568 Implement prefer_v6 resolver configuration attribute. Fix rt.cpan.org #67602 Set resolver configuration defaults at first instantiation instead of module load time. **** 0.75 May 8, 2014 Fix rt.cpan.org #94069 Compile-time constant in Domain.pm/Text.pm cannot be used to store pointer to encoding object when using perlcc compiler. Thanks are due to Reini Urban for testing the revised code. Fix rt.cpan.org #93764 Resolver gives unhelpful errorstring when attempting to use IPv6-only nameserver without INET6 and Socket6 installed. Fix rt.cpan.org #92626 Clarify documentation surrounding SRV RR sorting Feature Implement TSIG verified zone transfer. Fix rt.cpan.org #92433 & #91241 TSIG: implement sign/verify for multi-packet message. Fix rt.cpan.org #79569 Iterate nameservers in AXFR **** 0.74 Jan 16, 2014 Fix rt.cpan.org #91306 Nameserver crashes on malformed UDP query. Fix rt.cpan.org #91241 TSIG: Fix incorrectly generated %algbyval table. Feature Add CAA, EUI48 and EUI64 RR implementation. **** 0.73 Nov 29, 2013 Fix rt.cpan.org #88778 $update->unique_push() does not work as advertised. Fix rt.cpan.org #88744 Nameserver crashes on malformed TCP query. Fix rt.cpan.org #84601/#81942 Fix memory leak on packet cleanup. Indirect self-reference via header prevented garbage collector from deallocating packet. Feature rt.cpan.org #84468 TSIG: add support for HMAC-SHA1 .. HMAC-SHA512 Fix rt.cpan.org #84110 Incorrect parsing of PTR records in zonefile. Fix rt.cpan.org #83755 Erroneous attempt to invoke Net::LibIDN package in Domain.pm. Fix rt.cpan.org #83078 Can't locate Net/DNS/Resolver/linux.pm in @INC Conjecture: eval{ ... }; if ($@) { ... }; broken by threads. Fix rt.cpan.org #83075 ZoneFile.pm wrongly rejects $TTL 0 directive. Fix rt.cpan.org #82621 Error string empty after failed TCP query. Fix rt.cpan.org #82296 IPv6 with embedded IPv4 address not mapped to ip6.arpa. Fix rt.cpan.org #82294 Perl taint inadvertently removed in Domain and Text objects. Feature rt.cpan.org #53610 add TSIG validation support **** 0.72 Dec 28, 2012 Fix rt.cpan.org #82148 nxrrset fails to ignore RDATA. Fix rt.cpan.org #82134 TSIG key and algorithm names not downcased in digest. Class not forced to ANY. Fix rt.cpan.org #82063 yxrrset, nxrrset and rr_del functions should force zero TTL. Fix rt.cpan.org #82047 Clarify documentation to indicate that header counts may differ from the number of RRs present if a packet is corrupt. Fix rt.cpan.org #81941 Clarify documentation to make users aware that bgread will not switch to TCP when a truncated packet is received. **** 0.71 Dec 15, 2012 Temporary workaround rt.cpan.org #81760 The rdatastr method for TXT RRs will return unconditionally quoted rdata fields to work around an issue with updating SpamAssassin rules. This workaround will be reverted after release of a version of SpamAssassin which resolves the issue. Fix TSIG initialization Uninitialised algorithm attribute caused signature generation to fail silently when creating a TSIG signed packet. Fix rt.cpan.org #81869 The rr_del auxiliary function broken by a conflicting change in the RR.pm string parser. Note the ambiguous use of ANY, which may stand for CLASS255 or TYPE255 depending upon the argument string presented. Fix rt.cpan.org #81756 Test failures on Perl 5.8.5 .. 5.8.8. lc(), uc() and case insensitive regex matching broken for UTF8. Thanks are due to Paul Howarth for patient work with perl -d. Fix rt.cpan.org #81787 NXDOMAIN no longer reported by $resolver->errorstring. Fix rt.cpan.org #81814 Allow zero in format, tag and algorithm fields of CERT RR. Fix rt.cpan.org #81786 Substitute last owner for leading spaces in multiline zonefile RR. Fix rt.cpan.org #77444 Make use of new extended header modus operandi for OPT records also in the resolver. Preventing a warning. **** 0.70 Dec 6, 2012 Feature Add support for NID L32 L64 LP, RFC6742. **** 0.69 Dec 5, 2012 Feature rt.cpan.org #62030 Parsing of BIND zone files implemented in Net::DNS::ZoneFile. This replaces and is backward compatible with the CPAN module of the same name. Enhancement to simplify RR subtype template and recode packages. Enhancement rt.cpan.org #75185 Packet decoder returns index to end of decoded data. Added packet->reply() method. Fix rt.cpan.org #79569 AXFR not setting packet->answer_from. Enhancement rt.cpan.org #18819 Added support for Unicode and non-ASCII character encoding. Feature integrate OPT as a header extension Treat extended rcodes and the DO flag like they are part of the packet header. Fix rt.cpan.org #77444 Support escaped characters according to RFC1035 in TXT rdata. Fix rt.cpan.org #77304 Fix resolver searchlist from registry setup on Win32. Enhancement rt.cpan.org #67570 Make wire2presentation two till eighteen times faster. A contribution from Matthew Horsfall Fix rt.cpan.org #73366 Remove existing TSIG when resigning with a new TSIG and give warning. Fix rt.cpan.org #75330 Also try nameserver without glue (as a last resort) when recursing. Fix rt.cpan.org #74493 Read correct resolver configuration in OS/2. **** 0.68 Jan 30, 2012 Fix rt.cpan.org #72314 Let a Net::DNS::Nameserver bind on Net::DNS::Nameserver::DEFAULT_ADDR as a last resort. Fix to suppress false warnings about subroutine profiles on ancient versions of perl. Fix to avoid constants with value undef which prevents unwanted code from being optimized away on ancient versions of perl. Fix code error in PTR.pm, canonical RDATA not downcased. Enhancement to clarify the function of parse and data methods, by renaming them to decode and encode respectively. Feature IDN query support. Question.pm modified to use the recently introduced DomainName.pm module to represent DNS names. Queries for domain names containing non-ASCII characters are now possible on Unicode platforms with CPAN Net::LibIDN installed. Introduction of Mailbox.pm module that will be used in the future to represent RDATA components containing DNS coded RFC822 mailbox addresses. Introduction of Text.pm module that will be used in the future to represent RDATA components containing text. **** 0.67 Nov 4, 2011 Enhancement rt.cpan.org #60726 On Cygwin Net::DNS now builds without Win32::IPHelper, unless a previous version is updated that did use it. The choice may also be set by the --iphelper or --noiphelper option to Makefile.PL. Fix to suppress IO::Socket::INET(6)::peerhost usage with TCP. On some systems it doesn't work after receiving data. Enhancement rt.cpan.org #43142 Allow ReplyHandlers to indicate that no answer should be returned by the Net::DNS::Nameserver. Fix rt.cpan.org #71796 Prevent TCP accepts from blocking on unfinished 3-way handshakes. Fix rt.cpan.org #65607 Make 64bits windows work by depending on Win32::IPHelper version 0.07 Thanks to Lian Wan Situ. Fix rt.cpan.org #66470 Named nameserver should be reachable by IPv6 too. Fix to make tests work in jailed environments where a reply might come from a different address than that of the loopback interface. Feature to use a class method ReplyHandler for classes inheriting from Net::DNS::Nameserver. A contribution from Rob Brown. Fix rt.cpan.org #71062 Replace the usage of the obsolete Win32::Registry module by Win32::TieRegistry module. Fix rt.cpan.org #68731 Fix linking of the C compiled parts of the library on Mac OS X New improved version of the check_soa script in the contrib section. A contribution from Dick Franks. Fix rt.cpan.org #70830 Make t/08-online.t handle NXDOMAIN hijacking that return more than one answer. Fix rt.cpan.org #24525 Removed dependency on Net::IP Fix online tests to use the library as documented and not use knowledge of the internal workings of the classes that should be hidden. A contribution from Dick Franks Fix rt.cpan.org #55682 Make online tests non-fatal by default. All interactive prompts are removed from Makefile.PL. Online tests may still be made a requisite by using the --online-tests option. Major rework of Net::DNS::Domain.pm and the addition of Net::DNS::DomainName.pm Which paves the way towards handling of character encodings and IDN. A contribution from Dick Franks. Fix rt.cpan.org #69174 Typo that prevented TCP traffic from being replied from the same socket as it was received on. Fix rt.cpan.org #68338 Suppress warnings of the deprecated use of qw as parentheses in perl 5.14. Enhancement rt.cpan.org #67418 A contribution from Wolfsage to perform presentation to wire format conversion more efficiently. Fix rt.cpan.org #67133 Gracefully handle corrupted incoming packets in Net::DNS::Nameserver. Feature to manage serial numbers in SOA records in a modular and extensible way. Three modules are provided. Strictly sequential, Date Encoded and Time Encoded. A contribution from Dick Franks. Fix rt.cpan.org #53325 Make Net::DNS::Resolver load even if /etc/resolv.conf is unreadable. Fix rt.cpan.org #63486 Make t/08-online.t fail gracefully in stead of crash on failures. Fix rt.cpan.org #55586 Various typo fixes. Fix rt.cpan.org #55682 Really do not use networking functions when online tests are disabled. Fix rt.cpan.org #64562 Replace TSIG key with the signature of the whole packet when signing a packet, even when the TSIG key is not the first in the additional section. Fix rt.cpan.org #56181 and #47265 Assembly of segmented TCP traffic. Feature rt.cpan.org #57289 Provide a configurable IdleTimeout for Net::DNS::Namserver. Fix rt.cpan.org #53595 Fix documentation to reflect code behaviour where on successful packet creation, the error should be ignored. Fix rt.cpan.org #58914 Fix spelling of "algorithm" Fix rt.cpan.org #61725 Include default domain in the search list on Win32. Thanks Mark Rallen. Fix rt.cpan.org #63321 A Net::DNS::Nameserver without a NotifyHandler now responds NOTIMP to NOTIFY requests. Fix rt.cpan.org #53595 Documentation now reflects Net::DNS::Packet construction behaviour. **** 0.66 Dec 30, 2009 Feature Truncation for Nameserver fixes rt.cpan.org #33547 and #42744 TAKE CARE: this feature may cause unexpected behavior for your nameservers and can be turned off by setting Truncate to 0 during the creation of the nameserver. my $ns = Net::DNS::Nameserver->new( Truncate => 0, ); Net::DNS::Packet::truncate is a new method that is called from within Net::DNS::Nameserver that truncates a packet according to the rules of RFC2181 section 9. Acknowledgement Aaron Crane for an elegant test and for inspiration for a direction. Feature: Added Net::DNS::Domain Net::DNS::Domain is an attempt to introduce a consistent model for representation of RFC 1035 s. The class and its test script t/02-domain.t are included to be exposed to various architectures. The class and its methods may be subject to change, both in terms of naming and functionality. A contribution by Dick Franks Fix improved fuzzy matching of CLASS and TYPE in the Question constructor method. A contribution by Dick Franks. Fix rt.cpan.org #43770 Update->rr_del() was reported broken for AAAA after 0.65. The same bug also occurred in HINFO RR. Fix rt.cpan.org #43765 Code inconsistent with documentation for loop_once. Note: Keeping timeout undefined in loop_once will now block until something arrived on the socket. Fix rt.cpan.org #47050 Fixed logic error in bgsend socket acquisition code. Fix rt.cpan.org #47265 (partial) Frequently Net:DNS under Windows XP has a UDP problem which is caused by a buggy implementation of SOCKS under Windows. One liner added to not continue UDP processing when that happens. Feature KX RR Added support for the KX RR, RFC2230 The implementation is trivial since the KX inherits almost all of its functionality by inheritance from the MX RR. Fix NSAP RR string representation RFC1706 specifies the masterfile format to have a leading "0x" and optional dot. This was not how the RR was represented with the rdatastr method (and hence string and print). Fix rt.cpan.org #52307 AAAA v4compat parsing bug Acknowledgement: BLBLACK Fix AAAA dynamic update Dynamic update of AAAA caused FORMERR on the prerequisite caused by AAAA creating rdata even when an address was never specified. This fix may cause difference in behavior for people who expect a NULL address ("::") when creating a AAAA without an address specified. Feature HIP RR Added support for the HIP RR, RFC5205 perldoc Net::DNS::RR::HIP for more information. Feature DHCID RR Added rudimentary support for the DHCID RR. Fix rt.cpan.org #50883 This is basically #11931 but for cygwin. Codepath in Cygwin and Win32 are now the same. This adds a dependency in cygwin. Acknowledgements "mikaraento" Fix rt.cpan.org #45407 and #43190 Fixed escaping of semicolon. Note a change in behavior: For TXT and SPF the rdatastr method (and therefore the print, and string method) returns the escaped format while the chr_str_list method will return unescaped format. Fix rt.cpan.org #43393 Typo in 01-resolver.t Fix rt.cpan.org #43273 Added check for uninitialized opcode in headermask in Nameserver.pm Fix rt.cpan.org #46635 Minor documentation error in OPT.pm Fix rt.cpan.org #51009 Fixed handling of empty string in Net::DNS::stripdot. Elegant one-liner supplied by JMEHNLE. Fix rt.cpan.org #49035 Comment parsing fixed: Semicolon in character string blocks (such as in TXT and NAPTR) were only recognized when escaped. Also fixed the NAPTR regular expression to not interpret "bla' 'foo" as two strings bla and foo, but as one: bla' 'foo Fix cd flag settings Resolver bug and fix reported by Jon Haidu. **** 0.65 January 26, 2009 Fix rt.cpan.org #41076 When the AAAA object was constructed with new_from_hash with an address containing the "::" shorthand notation normalization was not done properly. Fix rt.cpan.org #42375 Typo in Win32.pm Registry root. **** 0.64 December 30, 2008 Feature rt.cpan.org #36656 Added support for the APL record (RFC 3123) The module consists of a list of Address Prefix Item objects as defined in the Net::DNS::RR::APL::ApItem class. NOTE: Class and its interface may be subject to change. Fix rt.cpan.org #11931 Wrong nameserver list handling in Net::DNS::Resolver::Win32 The init method has been rewritten to be based on WIN32::IPhelper for the selection of the domain and the IP addresses. This is believed to be more portable than trying to fetch the data from the registry. We still trying to get the searchlist from the registry. WARNING: If you use Perl under WIN32 (eg ActivePerl or Strawberry Perl) then your module dependency graph has changed drastically Fix IPv6 modules When IO::Socket::INET6 was available but Socket6 was not the code would recurse to infinity. Fix rt.cpan.org #21757 and Feature: Connectivity during test Addition of --no-IPv6-tests and --IPv6-tests option in Makefile.PL. Note: This causes two questions to be asked when building the Makefile instead of one. Besides the test suites are constructed so that all the connectivity testing happen in 001-connectivity.t and nonavailability of connectivity over a certain transport is signaled over files t/online.disabled and t/IPv6.disabled respectively. Both files are removed by t/99-cleanup Fix rt.cpan.org #34511 Priming query logic contained unneeded recursion. Now also falls back to hardcoded hints if there are no nameservers whatsoever. Fix rt.cpan.org #38390 and 37089 Added CD and AD bit control to the resolver. The CD flag defaults to being unset and the AD flags is set by default whenever DNSSEC is available. Both flags default to unset in absence of DNSSEC. Fix rt.cpan.org #37282 Improved error reporting during client disconnect from the nameserver NOTE rt.cpan.org # 40249 Release 0.62 introduced a feature to parse data inside a packet only when needed. This can cause the following to happen: Exception: corrupt or incomplete data at /usr/lib/perl5/Net/DNS/RR.pm line 510. caught at -e line 1 This may happen when you have undefined your packet data before all the sections have been fully parsed. Such as in: $packet = Net::DNS::Packet->new(\$data); undef($data); The workaround is to force parsing by calling the methods that parse the data. e.g. $packet = Net::DNS::Packet->new(\$data); $packet->answer; $packet->additional; $packet->authority; undef ($data) Fix rt.cpan.org # 41076 and # 41071 Net::DNS::RR->new_from_hash function would not normalize the content of the data so that a method getting a string representation would get inconsistent results depending on whether a RR was created from a string of from a hash. Fix rt.cpan.org # 41296 Compression buggy for large packets. Fix by Kim Minh. Fix rt.cpan.org # 35752 Perl 5.10.0 gave a number of issues on several platforms, preferring XSLoader over Dynaloader seemed to fix those. Bug rt.cpan.org #34510 Buggy setting of "Recursion too deep, aborted" corrected. Feature (rt.cpan.org #39284) The ReplyHandler now also receives a variable with an anonymous hash with the connection details. Variables supplied to the Reply handler are: $qname, $qclass, $qtype, $peerhost, $query, $conn The hash referenced by $conn contains the following buckets: sockhost, sockport, peerhost, and peerport. Feature t/08-online.t and t/10-recurse.t In particular environments a query for a.t. will resolve and or middleboxes will replace DNS packet content for queries to the root. A bunch of test is skipped when this (broken) environment is detected. Feature/Bug rt.cpan.org #22019 The initial fix for rt 22019 was to strip a trailing dot from all attributes that were provided as argument for the Net::DNS::RR::new_from_hash function. We have introduced Net::DNS::stripdot, a function that will strip the dots of domain names, taking into account possible escapes (e.g. labels like foo\\\..). As a side effect the new_from_string method will now convert possible spaces that are not trapped by some of the new_from_string functions and convert them to \032 escapes. For information: The internal storage of domain names is using presentation format without trailing dots. Bug @EXPORT and @EXPORT_OK moved to a BEGIN block so that Net::DNS::SEC can make use of exported functions Feature/Bug The Notify handler introduced in 0.63 did not set the OPCODE on the reply appropriately. This has been solved generically by allowing the "Headermask" that is returned as 4th element by the reply or notify handler in the nameserver also allows for the opcode to be set. e.g. as in return ("NXDOMAIN",[],[],[],{ opcode => "NS_NOTIFY_OP" } ); *** 0.63, 8 Feb 2008 This version contains a Security Fix. Feature NotifyHandler in Nameserver The NotifyHandler is a new attribute to the nameserver used in the same way as the ReplyHandler except that it is executed when the opcode is NS_NOTIFY (RFC1996). It takes the same arguments as the reply handler (i.e. $qname, $qclass, $qtype, $peerhost, and $query). Corrections made in the documentation. Fix rt.cpan.org #32937: 5.11 introduces new warning on uc(undef) The patch supplied fixes for methods where undefined arguments were likely. For methods where undefined arguments don't make the warning will be printed. Fix rt.cpan.org #32147: Default LocalAddr broken in Net::DNS::Nameserver 0.62 Listen on the default address if LocalAddr not defined. Fix rt.cpan.org #30316 Security issue with Net::DNS Resolver. Net/DNS/RR/A.pm in Net::DNS 0.60 build 654 allows remote attackers to cause a denial of service (program "croak") via a crafted DNS response (http://nvd.nist.gov/nvd.cfm?cvename=CVE-2007-6341). Packet parsing routines are now enclosed in eval blocks to trap exception and avoid premature termination of user program. Bug: mbox-dname and txt-dname were not allowed to be empty in the RP RR. Fix by Peter Koch *** 0.62, 28 December 2007 Features: Move of some functionality out of the Packet to the Question and RR classes; parsing of elements in the packet is now performed by calling the appropriate subclasses. New methods were introduced: * Net::DNS::Packet->parse() * Net::DNS::RR->parse() * Net::DNS::Question->parse() The Packet class now defers parsing of authority/additional until their content is really needed. This should cause a bit of performance improvement. Dick Franks is acknowledged for this Good Work (TM). Added 20081216 see NOTE above under rt.cpan.org # 40249 Feature: the Net::DNS::Packet's answersize() method will from now on ignore its arguments and just return the size of the packet. Feature: The Net::DNS::RR->new() method used to call Net::DNS::RR->new_from_data() whenever called with the appropriate combination of arguments. That (undocumented) behavior has been deprecated. Use Net::DNS::RR->new_from_data() directly if you depended on that. Feature: Net::DNS::Packets unique_push now ignores the TTL in comparison of uniqueness, this is closer to the intent of RFC2181, but not yet fully compliant. Fix rt.cpan.org #29816 Acquiring the IP address for the Resolver under Cygwin is made more resilient. Fix rt.cpan.org #31425 Empty question section in Base.pm search method detected Fix rt.cpan.org #31042 Makefile corrected to add a library target. Fix rt.cpan.org #29818 10-recurse.t used to fail in very specific environment (where a query for qname="." and qtype="NS" would return with an empty additional section). Fixed by adding the hints explicitly; this also forces the tests to take place under the root served by a-m.root-servers.net Fix rt.cpan.org #29877 Made 00-version.t recognize a "GIT" environment. Fix rt.cpan.org #29878 SPF.pm did not evaluate as true. Thanks Bjorn Hansen. Fix rt.cpan.org #21398 answersize() and answerfrom() set for persistent sockets Fix rt.cpan.org #29883 Fix various tests only available through SVN, so they are more robust (Acknowledgements Bjoern Hansen) Fix rt.cpan.org #24343 Resolver's nameserver() method would do silly things with undefined arguments. Fix rt.cpan.org #29531 Nameserver.pm, Packet.pm and Question.pm modified to avoid erroneous PTR lookup in response to mischievous query packet containing an IP address. Fix rt.cpan.org #27970 better netdns.o Marek Rouchal provided two minor improvements for linking the C code snippets Fix rt.cpan 28345 A fix in Test::Simple revealed an off by 1 error in the testplan for 05-rr-rrsort.t. The fix is to remove a test, creating a dependency on Test::Simple 0.71 seemed overkill. *** 0.61, 1 August 2007 Fix rt.cpan.org #28106, 28198, and 28590 Modification of $_ in various places. Fix t/11-inet6 assumed lowercase domain names. *** 0.60 20 June 2007 Fix spelling mistakes in change log using interactive spell checker (aspell). Fix Two redundant calls of $self->rdatastr() in Net::DNS::RR::string(). Fix rt.cpan.org #27285 bis Unreleased 0.59_1 dn_expand_PP() has security flaw allowing access to arbitrary data using crafted packet with out of range compression pointer. Patch by Dick Franks based on 0.59 code. Fix rt.cpan.org #27391 dn_compress() produces corrupt packet for name containing empty label. Fix rt.cpan.org #26957 dn_compress() croaks for name having label which exceeds 63 characters. Patch by Dick Franks truncates offending label. Feature check_soa test of NCACHE TTL Dick Franks supplied an improved version of check_soa script which performs a direct test of NCACHE TTL by looking up non-existent name and reporting value if it exceeds 86400. Test is skipped unless minimumTTL is above same threshold. Recent BIND implementations impose a ceiling on NCACHE TTLs internally, so a large minimumTTL value is unlikely to have damaging consequences at many sites. Fix rt.cpan.org #27285 Break out of malformed packets with compression loops. Steffen Ullrich is acknowledged for patch and test code. Feature check_zone "alternate domain" and "exception file" flags Paul Archer supplied a patch for check_zone adding two new features. Feature Support for IPSECKEY RR Rudimentary IPSECKEY RR support added. Fix rt.cpan.org #25342 HINFO would only accept its data fields within quotes. That has now been fixed to adhere to by inheriting parsing functions from TXT. Fix rt.cpan.org #24631 / Feature IP address prefix notation Dick Franks supplied a cleaned up version of Question.pm. Revised code deals with incomplete IPv6 address bug and accepts RFC4291 address prefix notation. IPv4/prefix also supported for completeness. This involved a minor change to the API for reverse IP lookup. Changing qtype to PTR is now performed for A and AAAA only. This allows queries for NS and SOA records at interior nodes to be specified using the address prefix. Type ANY queries now also produce the expected result. Cleaned up TYPE/CLASS reversal code, exploiting fact that the intersection of the sets of class and type names contains only one member (ANY). Minor cleanup of remaining code. Fix rt.cpan.org #22019 Expunge trailing dots from RR->new_from_hash() FQDN arguments. Patch by Dick Franks. Fix Recursion and EDNS OPT record The Recursive resolver process would add an OPT-RR with each recursion which causes FORMERRs with a number of authoritative servers. Feature SSHFP warn instead of die We do not die if a not implemented fingerprint type value is read from the wire, instead we 'warn' and return undef. Feature NSEC3PARAM hook A hook to load NSEC3PARAM when available has been added. WARNING: Both NSEC3 and NSEC3PARAM are configured with their experimental type codes. Feature rt r24525 Net::DNS::Resolver depended on Net::IP (2268 Kb) which depends on heavy module Math::BigInt (1780 Kb). Valery Studennikov suggested to ship Net::DNS::Resolver::Base with its own copies of ip_is_ipv[4|6] and supplied a patch with those functions stripped from Net::IP. Note that the package still depends on Net::IP because Net::DNS::Nameserver and a few tests depend on it. Fix rt 22334 Fixed "perl Makefile.PL --xs" behavior, patch by Tamas Palfalvi Fix rt 21752 and 24042 Applied the patch supplied by Alexandr Ciornii to be able to compile on ActiveState perl . Slight modifications based on comments by nimnul Fix rt 23961 Randomized the ID on the queries. Thanks to "hjp" for reporting and suggesting a fix. The randomization of the src port is supposed to be handled by the setting the source port to "0" (default). Overriding the default or using persistent sockets may be problematic. Also see: http://www.potaroo.net/ietf/idref/draft-hubert-dns-anti-spoofing/ Fix Minor compile time warnings for netdns.c on Fedora Core. *** 0.59 September 18, 2006 Fix rt.cpan.org 20836, 20857, 20994, and 21402 These tickets all revolved around proper reverse mapping of IPv6 addresses. Acknowledgments to Dick Franks who has provided elegant solutions and cleaned a bit of code. Note that directly calling Question->new() without arguments will cause the qclass,qtype to be IN, A instead of ANY, ANY. Net::DNS::Resolver's search() method would always gracefully interpret a qname in the form of an IPv4 address. It would go out and do a PTR query in the reverse address tree. This behavior has also been applied to IPv6 addresses in their many shapes and forms. This change did two things, 1) root zone not implicitly added to search list when looking up short name, 2) default domain appended to short name if DEFNAMES and not DNSRCH. Fix rt.cpan.org 18113 Minor error due to unapplied part of patch fixed. Feature: Experimental NSEC3 hooks. Added hook for future support of (experimental) NSEC3 support (NSEC3 having an experimental type code). *** 0.58 July 4, 2006 Feature: hooks for DLV support in Net::DNS::SEC added hooks for DLV support which is/will be available in Net::DNS::SEC as of subversion version 592 (Tests are done against the subversion number, not against the perl release version) Net::DNS::SEC version 0.15 will have DLV support. Partly Fixed rt.cpan.org 18940 djhale noticed a number of error conditions under which the udp_connection in Nameserver dies. We now print a warning instead of dying. Fix rt.cpan.org 18958 Fixed typebyname croak for SIGZERO. Acknowledgments to djhale. Optimize rt.cpan.org 11931 Hanno Stock optimized the method to get the list of available interfaces in Win32. I have only done very rudimentary tests on my Windows XP system. Fix dependency on "CC" rt.cpan.org 19352 The Makefile.PL depended on availability of "cc" and would bail out on systems where gcc is exclusively available. Thanks to Rob Windsor for noticing and patching. Fix compressed dnames in NAPTR/SRV Clayton O'Neill noted that the domain names in the NAPTR and SRV RRs rdata were subject to name compression which does not conform to specs. Also see RFC 2782 and 2915. Fix rt.cpan.org 18897 Zero-length rdata in TXT fixed (Acknowledgments to Roy Arends) Fix rt.cpan.org 18785 SPF would not work unless the TXT RR was already loaded. SPF fully inherits TXT and loading of TXT.pm is therefore a prerequisite. Fix rt.cpan.org 18713 Net::DNS::Resolver now deals gracefully with persistent sockets that got disconnected. It will first try to connect again to the socket and if that fails it will try to connect to the next available nameserver. tcp_timeout() is the parameter that determines how long to wait during a reconnect. Fix rt.cpan.org 18268 Added reference to RFC in croak message for label length > 63 in dn_comp(). Fix rt.cpan.org 18113 The inet6 tests contained another bug when online-tests were disabled. Klaus Heinz discovered and provided a patch. *** 0.57 February 24, 2006 Fix rt.cpan.org 17783 The inet6 tests do not skip enough tests when ipv6 is not available. I did not catch this in my setup since IPv6 is available on all my machines. Since this breaks automatic CPAN installs a new release is reasonable. *** 0.56 February 20, 2006 Fix rt.cpan.org 17694 Net::DNS::typesbyval() now confesses on undefined args. Acknowledgments to Dean Serenevy. Feature Implemented SPF (typecode 99). The class completely inherits from Net::DNS::RR::TXT (the easiest RR to implement ever). Feature added rrsort() function. Feature was requested by Eric Hall in rt.cpan.org 13392 This was a little tricky as I think that the sort functions are in fact RR specific class attributes that should be accessed through class methods. This is difficult to implement. I do think I found a fairly clean manner. It does require a global variable in Net::DNS to store the functions and some trickery when the sorting functions are defined. See Net::DNS and Net::DNS::RR documentation for details. Defaults sorting functions are currently implemented in SRV: default sort: low priority to high priority and for same preference highest weight first. weight: sort all RRs based on weight, highest first priority: see default sort MX: default sort: lowest preference first. preference: see default sort NAPTR: default sort: lowest to highest order, for same order lowest preference first order: see default sort preference: order on preference, lowest first PX: See MX RT: See MX Fix rt.cpan.org 14653 and 14049 TCP fallback after V6 socket failure Reworked Net::DNS::Base::Nameserver::send_tcp() to fallback to IPv4 when possible. (change applied to SVN Revision 538). Feature Cleanup duplicated code axfr_send() and send_tcp() contained some duplicated code. I merged this in one "helper" method _create_tcp_socket() Fix AXFR persistent sockets colliding with query sockets. I think that using the same persistent sockets for AXFR and 'ordinary' queries could lead to race conditions. Better safe than sorry. For axfrs we create a different set of persistent sockets. Note that this prevents performing a SOA query first and then using the same socket for the zone transfer itself(in Net::DNS these are different code paths). This behavior of SOA and transfer on the same socket-- seems to be suggested by 1035 section 4.2.2: "In particular, the server should allow the SOA and AXFR request sequence (which begins a refresh operation) to be made on a single connection." Obviously, on the client side this behavior is not mandatory. Fix rt.cpan.org 17596 The fixes and features above also fixed the timeout problem reported by Paul Hoffman Profiling It turned out that each time we were calling Net::DNS::Resolver::Base::nameserver(); We were creating a resolver object. Now a resolver object is only called when a domain name is given as argument. **** 0.55 December 14, 2005 Fix Inconsistency in test There was an inconsistency in the t/05-rr.t that got triggered by the release of Net::DNS::SEC version 0.13 (when installed). That has been fixed. Feature Net::DNS::Nameserver loop_once() Uncommented the documentation of the loop_once() function and introduced get_open_tcp() that reports if there are any open TCP sockets (useful when using loop_once(). loop_once() itself was introduced in version 0.53_02 Fix rt.cpan.org 16392 TCP Sockets stayed open even if not requested. This may cause the kernel to run out of TCP slots. This bug is the reason for releasing version 0.55 shortly after 0.54. Spotted and patched by Robert Felber. *** 0.54 December 7, 2005 Fix rt.cpan.org 15947 Failure to bind a nameserver when specifying an IPv6 address. Fix rt.cpan.org 11931 Using Net-DNS 0.53 on Win XP, it is unable to retrieve the nameservers when the IP address of the interface is assigned by DHCP. This is due to the DHCP assigned IP address being stored in DhcpIPAddress rather than IPAddress (which is then 0.0.0.0). Adding a check of DhcpIPAddress existence and not being 0.0.0.0 fixes the problem. Applied the patch submitted by "orjan". Fix rt.cpan.org 15119 main_loop() consumed 100% of CPU, because of a bug that caused loop_once() to loop ad infinitum. Fix rt.cpan.org 15299 Defining multiple constants with 'use constant { BLA => 1, FOO =>2 }; is a backwards incompatible feature. Thanks to Ian White for spotting and fixing this. *** 0.53_02 Oct 18, 2005 Fix rt.cpan.org 14046 RRSIGs verify and create failed for a number of RR types. The error message showed something like: Can't call method "dn_comp" on an undefined value This was caused by an omission in the _canonicalRdata() method in Net::DNS::RR that was inherited by all failing RR types. Code was added to t/05-rr.t that will test signature creation if Net::DNS::SEC is available and can be loaded. Feature async nameserver behaviour. In rt.cpan.org 14622 Robert Stone suggested: The fact that it needs to take over the main running thread limits its audience. Since many daemon programs are already driven by a top level select loop, it seems useful to provide an API for the user to integrate Net::DNS::Nameserver processing to their own select loop. He also supplied example code for which he is hereby acknowledged. The patch was not used because simultaneously Robert Martin-Legène supplied a patch to Nameservers.pm that allowed the same async functionality through the use of loop_once method. Robert M-L's code also carefully manages the TCP sockets, so that they can deal with AXFRs. Robert S. has been so kind to review Robert M-L's code and is hereby kindly acknowledged. NB. Since the code may be subject to change the documentation of the loop_once method has been commented out. Fix bgsend srcaddr for IPv6 Achim Adam previously noticed that the source address wildard "::" works provides better portability than "0". We forgot to fix the bgsend() part earlier. Fix rt.cpan.org 14624 Fixed documentation of Nameserver.pm Replyhandler and fixed a bug that prevented the peerhost to be set. Fix rt.cpan.org 14700 mistyped _name2wire helper function name. Noticed and patched by Simon Josefsson. Fix rt.cpan.org 13944 Terminating dot not printed when printing SRV record. The SRV dname should be printed as FQDN, that is, including the dot at the end. Acknowledgments Jakob Schlyter. While adding the "dot" I noticed that in the fileformat parsing code there might be theoretical corner cases where rdata elements are not properly read. The code needs an audit for this. Fix srcport for socket creation in bgsend method Lionel Cons noted and patched a small bug in bgsocket creation code for lib/Net/DNS/Resolver/Base.pm *** 0.53_01 July 31, 2005 Fix rt.cpan.org 13809 "Phar" noted that the peerhost is never passed to the make_reply function in nameserver.pm and provided the trivial patch. Fix rt.cpan.org 13922 Fixed a problem with persistent TCP sockets which was introduced because of using the address family as an index to the array of persistent sockets. Used AF_UNSPEC for the array index for the TCP socket; just to choose a number. The key to the persistent sockets is the remote nameserver:port combination. Acknowledgments to Mike Mitchell for reporting the bug and testing the solution. Feat t/01-resolve will not try to do tests from private IP space; hopefully that cuts down on the number of false positives. *** 0.53 July 22, 2005 Fix rt.cpan.org 13669 Danny Thomas provided a somewhat more elegant line of code for the typesbyval regexp. Fix rt.cpan.org 13534 Net::DNS::Resolver::Recurse would bail out when it happened to run into lame servers. Doc rt.cpan.org 13387 Documented the BUG caught by Robert Martin-Legène Net::DNS::Nameserver running with multiple IP interfaces might violate section 4 of RFC2181. Fix IPv6 on AIX Binding to the local interface did not work when local address was specified as "0" instead of "::". The problem was identified, reported and fixed by Achim Adam. Fix rt.cpan.org 13232 One uncaught AF_INET6. *** 0.52 July 1, 2005 Feature Net::DNS::RR::OPT added the the size(), do(),set_do() and clear_do() methods. *** 0.51_02 June 22, 2005 Fix rt.cpan.org 13297 Persistent_udp option broken starting in version 0.50. This was fixed, based on a patch by Sidney Markowitz. Guido van Rooij independently submitted a similar patch. Fix rt.cpan.org 13289 Was caused by a typo. Fix rt.cpan.org 13243 and 13191 The escaped characters test failed on some system because the the systems dn_expand instead of the supplied dn_expand was used after the makemaker magic linked DNS.xs. This was fixed by renaming the dn_expand that comes with the library to netdns_dn_expand. Fix rt.cpan.org 13239: When queries are refused the resolver would not take the next nameserver on the nameserver list for its next try but skip one. I was also made aware that the "use byte" pragma is incompatible with pre 5.06 perl. BEGIN { eval { require bytes; } } It should be noted that for perl versions < 5.006 I had to disable the escaped character test. Don't expect domain names with labels that contain anything else than host names to work for versions earlier than perl 5.6.0. Thanks to Vladimir Kotal for the assistance in testing the code on his system and the members of the NL-PM list for suggestions and education. *** 0.51_01 June 14, 2005 Fix rt.cpan.org 13232: Replaced IF_INET6 by IF_INET6() so that use strict subs does not complain in the absence of a definition of IF_INET6 in earlier versions perl that did not have IF_INET6 defined in Socket.pm The problem is similar to the problem described in: http://lists.ee.ethz.ch/mrtg-developers/msg00198.html *** 0.51 June 10, 2005 Fix rt.cpan.org 13184: Removed a 'stale' debug line (oops). A "stale" debug line may cause clutter in log files which may cause false positives on log analysis tools. Harmful enough to warrant a quick patch. *** 0.50 June 8, 2005 No changes with respect to 0.49_03. *** 0.49_03 June 1, 2005 (Version 0.50 release candidate 3) Fix: Concatenation of scalars caused modification of data because of Perl's habit to treat scalars as utf characters instead of bytes. Inserted use bytes pragma throughout the code base. DNS is done in octets. Feature: Added "ignqrid" as an attribute to the Resolver. use as: ok (my $res=Net::DNS::Resolver->new(nameservers => ['127.0.0.1'], port => 5354, recurse => 0, igntc => 1, ignqrid => 1, ), When the attribute is set to a non-zero value replies with the qr bit clear and replies with non-matching query ids are happily accepted. This opens the possibility to accept spoofed answers. YOU CAN BURN YOURSELF WITH THIS FEATURE. It is set to 0 per default and remains, except for this changes file an undocumented feature. *** 0.49_02 May 28, 2005 (Version 0.50 release candidate 2) Fix: Smoking Gun tests for non-cygwin Win32. Makefile.PL failed to produce a proper Makefile under win32. (e.g. www,nntp.perl.org/group/perl.cpan.testers/210570) I worked around that by moving the library into the base directory of the distribution as the "subdir" section seemed to be all funny. Fix: rt.cpan.org#11931 (the off-topic part) Sidney Markowitz spotted an awkward condition that rarely happens but is significant enough to be dealt with. In the send_udp method there are two loops: one over the nameservers and one that waits for the sockets to come forward with data. That second loop will sometimes timeout and then be entered with a repeated query to the same nameserver. It occasionally happens that the old packet arrives on the socket. That packet is discarded but the loop does not return to the loop to wait for the remainder of the timeout period for an answer on the second query, that may still arrive. This has now been fixed. Thanks to Sidney for the assessment of the problem and the fix. *** 0.49_01 (Version 0.50 release candidate 1) Fix: Makefile.PL: Minor tweak to recognize Mac OS X 10.4 not so relevant since netdnslib is distributed with the code. Feature: Calling the Net::DNS::Resolver::dnssec method with a non-zero argument will set the udppacketsize to 2048. The method will also carp a warning if you pass a non-zero argument when Net::DNS::SEC is not installed. Feature: IPv6 transport support IPv6 transport has been added to the resolver and to the nameserver code. To use IPv6 please make sure that you have IO::Socket::INET6 version 2.01 or later installed. If IPv6 transport is available Net::DNS::Resolver::Recurse will make use of it (picking randomly between IPv4 and IPv6 transport) use the force_v4() method to only force IPv4. Feature: Binary characters in labels RFC 1035 3.1: Domain names in messages are expressed in terms of a sequence of labels. Each label is represented as a one octet length field followed by that number of octets. Since every domain name ends with the null label of the root, a domain name is terminated by a length byte of zero. The high order two bits of every length octet must be zero, and the remaining six bits of the length field limit the label to 63 octets or less. Unfortunately dname attributes are stored strings throughout Net::DNS. (With hindsight dnames should have had their own class in which one could have preserved the wire format.). To be able to represent all octets that are allowed in domain names I took the approach to use the "presentation format" for the attributes. This presentation format is defined in RFC 1035 5.1. I added code to parse presentation format domain names that has escaped data such as \ddd and \X (where X is not a number) to wireformat and vice verse. In the conversion from wire format to presentation format the characters that have special meaning in a zone file are escaped (so that they can be cut-n-pasted without pain). These are " (0x22), $ (0x24), (0x28), ) (0x29), . (0x2e) , ; (0x3b), @ (ox40) and \ (0x5c). The number between brackets representing the ascii code in hex. Note that wherever a name occurs as a string in Net::DNS it is now in presentation format. For those that dealt with 'hostnames' (subset of all possible domain names) this will be a completely transparent change. Details: I added netdnslib which contains Net::DNS's own dn_expand. Its implemented in C and the source is a hodgepodge of Berkeley based code and snippets from ISC's bind9 distribution. The behavior, in terms of which chars are escaped, is similar to bind9. There are some functions added to DNS.pm that do conversion from presentation and wire format and back. They should only be used internally (although they live in EXPORT_OK.) For esoteric test cases see t/11-escapedchars.t. Fix: rt.cpan.org #11931 Applied the patch suggested by "Sidney". It is a practical workaround that may not be portable to all versions of the OS from Redmond. See the ticket for details. *** 0.49 March 29, 2005 No changes wrt 0.48_03. *** 0.48_03 March 22, 2005 (Version 0.49 release candidate 3) Fix: Only remove leading zeros in the regular expressions for typesbyval and classbyval methods. (patch by Ronald v.d. Pol) Fix: Properly return an empty array in the authority, additional and answer methods (patch by Ronald v.d. Pol) Fix: rt.cpan.org #11930 Incorrect searchlist duplication removal in Net::DNS::Resolver::Win32 Patch courtesy Risto Kankkunen. Problem: rt.cpan.org #11931 Win32.pm used the DNSRegisteredAdapters registry key to determine which local forwarders to send queries to. This is arguably the wrong key as it is used to identify the server which to send dynamic updates to. A real fix for determining the set of nameservers to query has not been implemented. For details see https://rt.cpan.org/Ticket/Display.html?id=11931 *** 0.48_02 March 14, 2005 (Version 0.49 release candidate 2) Fix: Bug report by Bernhard Schmidt (concerning a bug on the IPv6 branch). The bug caused dname compression to fail and to create compression pointers causing loops. *** 0.48_01 March 7, 2005 (Version 0.49 release candidate 1) Fix: rt.cpan.org #8882 No redundant lookups on SERVFAIL response and #6149 Does not search multiple DNS servers Net::DNS::Resolver will now use the other nameservers in the list if the RCODE of the answer is not NOERROR (0) or NXDOMAIN (3). When send() exhausted the last nameserver from the it will return the answer that was received from the last nameserver that responded with an RCODE. The errorstring will be set to "RCODE: " Fix: rt.cpan.org #8803 TXT records don't work with semicolons Since we are expecting "zonefile" presentation at input a comment will need to be escaped ( \; ). It could be argued that this is a to strict interpretation of 1035 section 5.1. While working on this I discovered there are more problems with TXT RRs. Eg; 0100 is a perfectly legal character string that should be represented as "\000" in a zonefile. Net::DNS does pass character strings with "non-ASCII" chars from the wire to the char_str_lst array but the print functions do not properly escape them when printing. Properly dealing with zonefile presentation format and binary data is still to be done. Fix: rt.cpan.org Ticket #8483 eval tests for DNS::RR::SIG fail when using a die handler (Thanks Sebastiaan Hoogeveen) Patch applied. Fix: rt.cpan.org: Ticket #8608 Net::DNS::Packet->data makes incorrect assumptions Implemented the "pop" method for the question. Since having a qcount that is not 1 is somewhat rare (it appears in TCP AXFR streams) the ability to pop the answer from a question has not been documented in the "pod" Also fixed the incorrect assumption. (Thanks Bruce Campbell.) Fix: Ticket #11106 Incorrect instructions in README Corrected in the README and in Makefile.PL Olaf Kolkman took over maintenance responsibility from Chris Reinhardt. This involved importing the code into another subversion repository. I made sure the numbers jumped, but I did not have access to the "original" subversion repository so I lost some of the history. *** 0.48 Aug 12, 2004 Net::DNS is now stored in a subversion repository, replacing cvs. As such the submodule version numbers have taken another big jump. Luckily those numbers don't matter as long as they work. Fixed a bug with Unknown RR types that broke zone signing [Olaf]. Added callback support to Net::DNS::Resolver::Recurse. The demo/trace_dns.pl script demonstrates this. Added a note regarding answers with an empty answer section to the Net::DNS::Resolver::search() and Net::DNS::Resolver::query() documentation. The copyright notice for Net::DNS::RR::SSHFP was incorrect. That file is Copyright (c) 2004 RIPE NCC, Olaf Kolkman. *** 0.47_01 May 6, 2004 ** NOTICE ** RR subclasses no longer pull in parts of Net::DNS; Net::DNS is assumed to be up and running when the subclass is compiled. If you were using a RR subclass directly, this may break your code. It was never documented that you could use them directly however, so hopefully you never did... Fixed bug where SRV records with a priority of 0 did not function correctly. CPAN #6214 Calls to various constants where using the &NAME syntax, which is not inlined. Changed to NAME(). Added SSHFP support. [Olaf] CERT fixes. [Olaf] *** 0.47 April 1, 2004 safe_push() is back in Net::DNS::Packet, due to the excellent debate skills of Luis E Munoz. However, the name safe_push() is deprecated, use the new name unique_push() instead. Fixed a bug in Net::DNS::Nameserver which caused the class to build packets incorrectly in some cases. [Ask Bjorn Hansen] Error message cleanups in Net::DNS::typesbyname() and Net::DNS::typesbyval() [Ask Bjorn Hansen] Net::DNS::RR::new_from_hash() now works with unknown RR types [Olaf]. *** 0.46 February 21, 2004 IPv6 reverse lookups can now be done with Net::DNS::Resolver::search(), as well as with query(). Hostnames can now be used in the 'nameservers' argument to Net::DNS::Resolver->new() *** 0.45_01 February 9, 2004 Net::DNS now uses UDP on windows. Removed Net::DNS::Select from the package. IO::Select appears to work on windows just fine. Fixed a bug that caused MXes with a preference of 0 to function incorrectly, reported by Dick Franks. Net::DNS had a few problems running under taint mode, especially under cygwin. These issues have been fixed. More issues with taint mode may lie undiscovered. Applied Matthew Darwin's patch added support for IPv6 reverse lookups to Net::DNS::Resolver::query. *** 0.45 January 8, 2004 No changes from 0.44_02. ** 0.44_02 January 3, 2004 The XS detection code was broken. We actually use the XS bits now. Major cleanups/optimizations of the various RR subclasses. This release of Net::DNS is over twice as fast at parsing dns packets as 0.44. ** NOTICE ** $rr->rdatastr no longer returns '; no data' if the RR record has no data. This happens in $rr->string now. Net::DNS::Packet::safe_push() no longer exists. The method is now only available from Net::DNS::Update objects. ** 0.44_01 January 3, 2004 Net::DNS::RR objects were not playing nice with Storable, this caused the axfr demo script to fail. Thanks to Joe Dial for the report. ** NOTICE ** This may cause RR objects that are already serialize to not deserialize correctly. Reply handlers in Net::DNS::Nameserver are now passed the query object. Fixed a nasty bug in Nameserver.pm related to the qr bit. As Olaf explained: Replies are sent if the query has its "qr" bit set. The "qr" bit is an indication that the packet is sent as a response to a query. Since there are more implementations that suffer from this bug one can cause all kinds of nasty ping-pong loops by spoofing the initial packet or have an infinite query loop by spoofing a query from the localhost:53 address. Various Win32/Cygwin cleanups from Sidney Markowitz. *** 0.44 December 12, 2003 The Wrath of CPAN Release. CPAN.pm doesn't understand the nature of revision numbers. 1.10 is newer than 1.9; but CPAN.pm treats them as floats. This is bad. All the internal version numbers in Net::DNS have been bumped to 2.100 in order to fix this. No actual code changes in this release. *** 0.43 December 11, 2003 Added warning of deprecation of Net::DNS::Packet::safe_push. This will move into Net::DNS::Update, as Net::DNS::Update is now a proper subclass of Net::DNS::Packet. ** 0.42_02 December 11, 2003 Fixed a long standing bug with zone transfers in the "many-answers" format. CPAN #1903. Added the '--online-tests' flag to Makefile.PL. This activates the online tests without asking the user interactively. "--no-online-tests" turns the tests off. Cleaned up Makefile.PL a little. The "--pm" flag is now deprecated, use "--no-xs" instead. Added support for unknown RR types (rfc3597). Note for developers: the typesbyname, typesbyval, classesbyname and classesbyval hashes should not be used directly, use the same named wrapper functions instead. [Olaf Kolkman] Added two hashes for administrative use; they store which types are qtypes and metatypes (rfc2929). [Olaf Kolkman] ** 0.42_01 November 30, 2003 Major work to get Net::DNS functioning properly on Cygwin by Sidney Markowitz. Fixed a bug in Net::DNS::Nameserver's error handling. CPAN #4195 *** 0.42 October 26, 2003 Fixed compilation problems on panther (Mac OS 10.3). Fixed a bug in Net::DNS::Resolver::Recurse which allowed an endless loop to arise in certain situations. (cpan #3969, patch by Rob Brown) Applied Mike Mitchell's patch implementing a persistent UDP socket. See the Net::DNS::Resolver documentation for details. *** 0.41 October 3, 2003 Added some documentation about modifying the behavior of Net::DNS::Resolver. ** 0.40_01 September 26, 2003 Fixed some uninitialized value warnings when running under windows. Fixed a bug in the test suite that caused 00-version.t to fail with certain versions of ExtUtils::MakeMaker. Thanks to David James, Jos Boumans and others for reporting it. Reply handlers in Net::DNS::Nameserver are now passed the peerhost. (Assen Totin ) Reply handlers in Net::DNS::Nameserver can now tweak the header bits that the nameserver returns. [Olaf] The AD header bit is now documented, and twiddlable. [Olaf] The change log has been trimmed, entries for versions older than 0.21 have been removed. ** NOTICE ** Net::DNS::Resolver::axfr_old() has been removed from the package. An exception will be thrown if you attempt to use this method. Use axfr() or axfr_start() instead. *** 0.40 September 1, 2003 Various POD tweaks. ** 0.39_02 August 28, 2003 Net-DNS-SEC updates, seems that IETF has been busy redefining DNSSEC. [Olaf] Added version to all the modules in the distribution. ** 0.39_01 August 12 2003 Added a META.yaml. The crystal ball says an upgrade to Module::Install may be coming soon. Changed how the versions of the various submodules were set. The CPAN indexer cannot execute "$VERSION = $Net::DNS::VERSION". The single line with the $VERSION assignment is pulled out of the file and eval'ed; at that time, Net::DNS is not loaded. The submodules now pull their version numbers out of CVS. *** 0.39 August 7 2003 Fixed a bug on Win32 where some machines separated lists with commas, not whitespace. Thanks to Jim White for pointing it out. ** 0.38_02 July 29 2003 Reworked the POD for Net::DNS::Resolver. When parsing resolver configuration files, IPv6 addresses are now skipped, as Net::DNS does not yet have IPv6 support. ** 0.38_01 Jun 22 2003 Broke Net::DNS::Resolver into separate classes. UNIX and Win32 classes are currently implemented. Many of the globals in Net::DNS::Resolver no longer exist. They were never documented so you never used them.... right? Options to Net::DNS::Resolver->new() are now supported, including using your own configuration file. See the Net::DNS::Resolver man page for details. Tweaked Net::DNS::RR::TXT to fail more gracefully when the quotes in the data section are not balanced. Add more tests (of course). Moved next_id() from Resolver.pm to Header.pm (which is where it is used). Net::DNS::Select now uses $^O directly, this means that the second argument to Net::DNS::Select::new() (the OS) is now ignored. *** 0.38 Jun 5 2003 Various buglets fixed in the new Makefile.PL. Use Dynaloader instead of XSLoader. Turns out that XSLoader is only in more recent perls. Added deprecation warning to Net::DNS::Resolver::axfr_old(). HP-UX fixes [cpan #2710], I don't have the name of the reporter/patcher. *** 0.37 May 28 2003 Renamed the test C file to compile.c, test.c was confusing the 'make test' target. *** 0.36 May 28 2003 Removed Rob Brown's RPM stuff. Something odd happened in the 0.35 tarball and at the moment I don't have the time to investigate. *** 0.35 May 26 2003 POD fixes, added tests for POD. *** 0.34_03 May 22 2003 Reworked Makefile.PL to try and detect if you have a working C compiler. Added '--pm' and '--xs' command line options to Makefile.PL Fixed linking problem on linux. Tie::DNSHash removed from the package, see Tie::DNS from CPAN for a more complete implementation of a DNS hash. *** 0.34_02 May 21 2003 Net::DNS::Packet::dn_expand is now implemented using the function of the same name from libresolv. This method of decompressing names is around twice as fast as the perl implementation. Applied Jan Dubois's patch to fix nameserver lookup on Windows 2000/95/98/ME. *** 0.34 6 Mar 2003 Applied David Carmean's patch for handling more than one string in a TXT RR's RDATA section. Applied Net::DNS::Resolver::Recurse bug fixes from Rob Brown. Added check of the answer's rcode in Net::DNS::Resolver::axfr_next(). Applied Kenneth Olving Windows changes. Applied patch from Dan Sully (daniel@electricrain.com) allowing multiple questions to be part of a DNS packet. *** 0.33 8 Jan 2003 Fixed 00-load.t to skip the Net::DNS::SEC modules. The test suite should now pass if you have Net::DNS::SEC installed. Fixed the regular expression in RR.pm to comply with the RFCs, turns out we were _too_ paranoid. [Olaf] *** 0.32 5 Jan 2003 Various cleanups for perl 5.004. Thanks to nathan@anderson-net.com ([cpan #1847]) Applied Olaf's SIG patch (thanks as always). Win32 now looks at the environment variables when building the configuration defaults. Thanks to net-dns-bug@oak-wood.co.uk (That's the only name I have... [cpan #1819]) Added Rob Brown's Net::DNS::Resolver::Recurse module. *** 0.31 17 Nov 2002 Applied Olaf's patch for an initialization bug in OPT.pm Applied Rob Brown's patch for udp timeouts. Added stuff from Rob Brown for making RPM creation easier. Fixed a typo in FAQ.pod that was making apropos and whatis grumpy. Thanks to Florian Hinzmann for pointing it out and a patch. *** 0.30 7 Nov 2002 Applied Andrew Tridgell's (tridge@samba.org) patch for TKEY support. Added Net::DNS::Packet->safe_push() to allow for automatically checking for duplicate RRs being pushed into a packet. Inspired by Luis Munoz. Added more tests. *** 0.29 2 Oct 2002 Fixed $_ from creeping out of scope in Resolver.pm. Thanks to Ilya Martynov for finding the problem and the patch to fix it. Fixed divide by zero bug there is no usable network interface(s). Thanks to twilliams@tfcci.com, misiek@pld.ORG.PL (and one other person that I can't seem to find the address of) for reports. *** 0.28 20 Aug 2002 Fixed a bug in the new AUTOLOAD routines that made it impossible to set attributes to '0'. Fixed a bug in the RR patch that broke many updates. *** 0.27 15 Aug 2002 Added (untested) support for perl 5.004. We now allow whitespace at the beginning of a RR. Fixed an issue that gave Net::DNS::SEC problems, %Net::DNS::RR::RR is now in a scope that the Net::DNS::SEC hook can see it from. Fixed SRV records. Fixed debug message in Net::DNS::Resolver::bgread(). *** 0.26 5 Aug 2002 Fixed various bugs in the test suite. Fixed warning in Net::DNS::RR::AUTOLOAD with perl 5.005. --- Olaf Kolkman Chris Reinhardt Michael Fuhr Net-DNS-1.50/demo/0000755000175000017500000000000014756035527013115 5ustar willemwillemNet-DNS-1.50/demo/mresolv0000644000175000017500000000643314756035515014532 0ustar willemwillem#!/usr/bin/perl # $Id: mresolv 1815 2020-10-14 21:55:18Z willem $ =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. =head1 SEE ALSO L, L, L, L, L, L, L =cut use strict; use warnings; use Net::DNS; use IO::Select; use Getopt::Std; use vars qw($opt_d $opt_n $opt_t); local $| = 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 my $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 my $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 my $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-1.50/demo/mx0000644000175000017500000000137014756035515013462 0ustar willemwillem#!/usr/bin/perl # $Id: mx 1815 2020-10-14 21:55:18Z willem $ =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 warnings; 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-1.50/demo/check_soa0000644000175000017500000001020014756035515014745 0ustar willemwillem#!/usr/bin/perl # $Id: check_soa 1815 2020-10-14 21:55:18Z willem $ =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 strict; use warnings; use File::Basename; use Net::DNS; #------------------------------------------------------------------------------ # 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 local $| = 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-1.50/demo/perldig0000644000175000017500000000236714756035515014473 0ustar willemwillem#!/usr/bin/perl # $Id: perldig 1815 2020-10-14 21:55:18Z willem $ =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 warnings; 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-1.50/demo/axfr0000644000175000017500000001065014756035515013777 0ustar willemwillem#!/usr/bin/perl # $Id: axfr 1815 2020-10-14 21:55:18Z willem $ use strict; use warnings; 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 my $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 my $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 my $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-1.50/demo/check_zone0000644000175000017500000000672414756035515015156 0ustar willemwillem#!/usr/bin/perl # $Id: check_zone 1815 2020-10-14 21:55:18Z willem $ =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 warnings; 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 my $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); } } return; } sub check_ptr { my ($domain, $class, @zone) = @_; my $res = Net::DNS::Resolver->new; my $rr; foreach my $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); } return; } sub check_ns { my ($domain, $class, @zone) = @_; my $res = Net::DNS::Resolver->new; my $rr; foreach my $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); } return; } sub check_mx { my ($domain, $class, @zone) = @_; my $res = Net::DNS::Resolver->new; my $rr; foreach my $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); } return; } sub check_cname { my ($domain, $class, @zone) = @_; my $res = Net::DNS::Resolver->new; my $rr; foreach my $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); } return; } Net-DNS-1.50/demo/README0000644000175000017500000000166714756035515014004 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-1.50/META.yml0000664000175000017500000000235614756035527013452 0ustar willemwillem--- abstract: 'Perl Interface to the Domain Name System' author: - 'Dick Franks' - 'Olaf Kolkman' - 'Michael Fuhr' build_requires: ExtUtils::MakeMaker: '0' File::Find: '1.13' File::Spec: '3.29' IO::File: '1.14' Test::Builder: '0.8' Test::More: '0.8' configure_requires: Config: '0' ExtUtils::MakeMaker: '6.48' Getopt::Long: '2.43' IO::File: '1.14' IO::Socket::IP: '0.38' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010' license: mit meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Net-DNS no_index: directory: - t - inc recommends: Digest::BubbleBabble: '0.02' Net::LibIDN2: '1' requires: Carp: '1.1' Digest::HMAC: '1.03' Digest::MD5: '2.37' Digest::SHA: '5.23' Encode: '2.26' Exporter: '5.63' File::Spec: '3.29' IO::File: '1.14' IO::Select: '1.17' IO::Socket: '1.3' IO::Socket::IP: '0.38' MIME::Base64: '3.07' PerlIO: '1.05' Scalar::Util: '1.19' Socket: '1.81' Time::Local: '1.19' base: '2.13' constant: '1.17' integer: '1' overload: '1.06' perl: '5.008009' strict: '1.03' warnings: '1.0501' version: '1.50' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Net-DNS-1.50/MANIFEST0000644000175000017500000000776314756035527013337 0ustar willemwillemChanges contrib/check_soa contrib/check_zone contrib/dnswalk.README contrib/find_zonecut contrib/loc2earth.fcgi contrib/loclist.pl contrib/README demo/axfr demo/check_soa demo/check_zone demo/mresolv demo/mx demo/perldig demo/README 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/Parameters.pm lib/Net/DNS/Question.pm lib/Net/DNS/Resolver.pm lib/Net/DNS/Resolver/android.pm lib/Net/DNS/Resolver/Base.pm lib/Net/DNS/Resolver/cygwin.pm lib/Net/DNS/Resolver/MSWin32.pm lib/Net/DNS/Resolver/os2.pm lib/Net/DNS/Resolver/os390.pm lib/Net/DNS/Resolver/Recurse.pm lib/Net/DNS/Resolver/UNIX.pm lib/Net/DNS/RR.pm lib/Net/DNS/RR/A.pm lib/Net/DNS/RR/AAAA.pm lib/Net/DNS/RR/AFSDB.pm lib/Net/DNS/RR/AMTRELAY.pm lib/Net/DNS/RR/APL.pm lib/Net/DNS/RR/CAA.pm lib/Net/DNS/RR/CDNSKEY.pm lib/Net/DNS/RR/CDS.pm lib/Net/DNS/RR/CERT.pm lib/Net/DNS/RR/CNAME.pm lib/Net/DNS/RR/CSYNC.pm lib/Net/DNS/RR/DELEG.pm lib/Net/DNS/RR/DHCID.pm lib/Net/DNS/RR/DNAME.pm lib/Net/DNS/RR/DNSKEY.pm lib/Net/DNS/RR/DS.pm lib/Net/DNS/RR/DSYNC.pm lib/Net/DNS/RR/EUI48.pm lib/Net/DNS/RR/EUI64.pm lib/Net/DNS/RR/GPOS.pm lib/Net/DNS/RR/HINFO.pm lib/Net/DNS/RR/HIP.pm lib/Net/DNS/RR/HTTPS.pm lib/Net/DNS/RR/IPSECKEY.pm lib/Net/DNS/RR/ISDN.pm lib/Net/DNS/RR/KEY.pm lib/Net/DNS/RR/KX.pm lib/Net/DNS/RR/L32.pm lib/Net/DNS/RR/L64.pm lib/Net/DNS/RR/LOC.pm lib/Net/DNS/RR/LP.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/NID.pm lib/Net/DNS/RR/NS.pm lib/Net/DNS/RR/NSEC.pm lib/Net/DNS/RR/NSEC3.pm lib/Net/DNS/RR/NSEC3PARAM.pm lib/Net/DNS/RR/NULL.pm lib/Net/DNS/RR/OPENPGPKEY.pm lib/Net/DNS/RR/OPT.pm lib/Net/DNS/RR/PTR.pm lib/Net/DNS/RR/PX.pm lib/Net/DNS/RR/RESINFO.pm lib/Net/DNS/RR/RP.pm lib/Net/DNS/RR/RRSIG.pm lib/Net/DNS/RR/RT.pm lib/Net/DNS/RR/SIG.pm lib/Net/DNS/RR/SMIMEA.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/SVCB.pm lib/Net/DNS/RR/TKEY.pm lib/Net/DNS/RR/TLSA.pm lib/Net/DNS/RR/TSIG.pm lib/Net/DNS/RR/TXT.pm lib/Net/DNS/RR/URI.pm lib/Net/DNS/RR/X25.pm lib/Net/DNS/RR/ZONEMD.pm lib/Net/DNS/Text.pm lib/Net/DNS/Update.pm lib/Net/DNS/ZoneFile.pm LICENSE Makefile.PL MANIFEST This list of files README t/00-install.t t/00-load.t t/00-pod.t t/01-resolver-config.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-IDN.t t/02-mailbox.t t/02-text.t t/03-header.t t/03-parameters.t t/03-question.t t/03-rr.t t/04-packet.t t/04-packet-truncate.t t/05-A.t t/05-AAAA.t t/05-AFSDB.t t/05-AMTRELAY.t t/05-APL.t t/05-CAA.t t/05-CDNSKEY.t t/05-CDS.t t/05-CERT.t t/05-CNAME.t t/05-CSYNC.t t/05-DHCID.t t/05-DNAME.t t/05-DNSKEY.t t/05-DS.t t/05-DSYNC.t t/05-EUI48.t t/05-EUI64.t t/05-HINFO.t t/05-HIP.t t/05-HTTPS.t t/05-IPSECKEY.t t/05-ISDN.t t/05-L32.t t/05-L64.t t/05-LP.t t/05-LOC.t t/05-KEY.t t/05-KX.t t/05-MINFO.t t/05-MX.t t/05-NAPTR.t t/05-NID.t t/05-NULL.t t/05-NS.t t/05-NSEC.t t/05-NSEC3.t t/05-NSEC3PARAM.t t/05-OPENPGPKEY.t t/05-OPT.t t/05-PTR.t t/05-PX.t t/05-RP.t t/05-RRSIG.t t/05-RT.t t/05-SIG.t t/05-SMIMEA.t t/05-SOA.t t/05-SPF.t t/05-SRV.t t/05-SSHFP.t t/05-SVCB.t t/05-TKEY.t t/05-TLSA.t t/05-TSIG.t t/05-TXT.t t/05-URI.t t/05-X25.t t/05-ZONEMD.t t/06-update-unique-push.t t/06-update.t t/07-rrsort.t t/07-zonefile.t t/08-IPv4.t t/08-IPv6.t t/08-recurse.t t/21-NSEC-typelist.t t/22-NSEC-match.t t/23-NSEC-covered.t t/24-NSEC-encloser.t t/31-NSEC3-base32.t t/32-NSEC3-typelist.t t/33-NSEC3-hash.t t/34-NSEC3-flags.t t/36-NSEC3-covered.t t/37-NSEC3-encloser.t t/41-DNSKEY-keytag.t t/42-DNSKEY-flags.t t/43-DNSKEY-keylength.t t/51-DS-SHA1.t t/52-DS-SHA256.t t/54-DS-SHA384.t t/71-TSIG-create.t t/72-TSIG-verify.t t/99-cleanup.t t/TestToolkit.pm t/custom.txt META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Net-DNS-1.50/META.json0000664000175000017500000000426414756035527013622 0ustar willemwillem{ "abstract" : "Perl Interface to the Domain Name System", "author" : [ "Dick Franks", "Olaf Kolkman", "Michael Fuhr" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010", "license" : [ "mit" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Net-DNS", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "Config" : "0", "ExtUtils::MakeMaker" : "6.48", "Getopt::Long" : "2.43", "IO::File" : "1.14", "IO::Socket::IP" : "0.38" } }, "runtime" : { "recommends" : { "Digest::BubbleBabble" : "0.02", "Net::LibIDN2" : "1" }, "requires" : { "Carp" : "1.1", "Digest::HMAC" : "1.03", "Digest::MD5" : "2.37", "Digest::SHA" : "5.23", "Encode" : "2.26", "Exporter" : "5.63", "File::Spec" : "3.29", "IO::File" : "1.14", "IO::Select" : "1.17", "IO::Socket" : "1.3", "IO::Socket::IP" : "0.38", "MIME::Base64" : "3.07", "PerlIO" : "1.05", "Scalar::Util" : "1.19", "Socket" : "1.81", "Time::Local" : "1.19", "base" : "2.13", "constant" : "1.17", "integer" : "1", "overload" : "1.06", "perl" : "5.008009", "strict" : "1.03", "warnings" : "1.0501" } }, "test" : { "requires" : { "ExtUtils::MakeMaker" : "0", "File::Find" : "1.13", "File::Spec" : "3.29", "IO::File" : "1.14", "Test::Builder" : "0.8", "Test::More" : "0.8" } } }, "release_status" : "stable", "version" : "1.50", "x_serialization_backend" : "JSON::PP version 4.16" } Net-DNS-1.50/t/0000755000175000017500000000000014756035527012434 5ustar willemwillemNet-DNS-1.50/t/05-ISDN.t0000644000175000017500000000263114756035515013577 0ustar willemwillem#!/usr/bin/perl # $Id: 05-ISDN.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 10; use Net::DNS; my $name = 'ISDN.example'; my $type = 'ISDN'; my $code = 20; my @attr = qw( address sa ); my @data = qw( 150862028003217 004 ); my @also = qw( ISDNaddress ); my $wire = '0f31353038363230323830303332313703303034'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } exit; Net-DNS-1.50/t/05-PTR.t0000644000175000017500000000257414756035515013515 0ustar willemwillem#!/usr/bin/perl # $Id: 05-PTR.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 7; use Net::DNS; my $name = '1.2.0.192.in-addr.arpa'; my $type = 'PTR'; my $code = 12; my @attr = qw( ptrdname ); my @data = qw( example.com ); my @also = qw( ); my $wire = '076578616d706c6503636f6d00'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } exit; Net-DNS-1.50/t/05-NSEC.t0000644000175000017500000000356114756035515013575 0ustar willemwillem#!/usr/bin/perl # $Id: 05-NSEC.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 9; use Net::DNS; my $name = 'alpha.example.com'; my $type = 'NSEC'; my $code = 47; my @attr = qw( nxtdname typelist); my @data = qw( host.example.com A NS NSEC RRSIG SOA ); my @hash = ( qw( host.example.com ), q(A NS NSEC RRSIG SOA) ); my @also = qw( ); my $wire = '04686f7374076578616d706c6503636f6d000006620000000003'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @hash; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { my $a = join ' ', sort split /\s+/, $rr->$_; # typelist order unspecified my $b = join ' ', sort split /\s+/, $hash->{$_}; is( $a, $b, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } for my $rr ( Net::DNS::RR->new("$name $type @data") ) { local $SIG{__WARN__} = sub { }; # suppress deprecation warning eval { $rr->covered('example.') }; # historical eval { $rr->typebm('') }; # historical } Net::DNS::RR->new("$name $type @data")->print; exit; Net-DNS-1.50/t/05-SMIMEA.t0000644000175000017500000000335114756035515014015 0ustar willemwillem#!/usr/bin/perl # $Id: 05-SMIMEA.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 16; use TestToolkit; use Net::DNS; my $name = 'c93f1e400f26708f98cb19d936620da35eec8f72e57f9eec01c1afd6._smimecert.example.com'; my $type = 'SMIMEA'; my $code = 53; my @attr = qw( usage selector matchingtype certificate ); my @data = qw( 1 1 1 d2abde240d7cd3ee6b4b28c54df034b97983a1d16e8a410e4561cb106618e971 ); my @also = qw( certbin babble ); my $wire = qw( 010101d2abde240d7cd3ee6b4b28c54df034b97983a1d16e8a410e4561cb106618e971 ); my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } exception( 'corrupt hexadecimal', sub { $rr->certificate('123456789XBCDEF') } ); } Net::DNS::RR->new("$name $type @data")->print; exit; Net-DNS-1.50/t/05-OPT.t0000644000175000017500000001606614756035515013513 0ustar willemwillem#!/usr/bin/perl # $Id: 05-OPT.t 1996 2024-12-16 13:05:08Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 89; use TestToolkit; use Net::DNS; use Net::DNS::Parameters; use constant UTIL => scalar eval { require Scalar::Util; Scalar::Util->can('isdual') }; ## no critic my $code = 41; my $type = 'OPT'; my @attr = qw( version udpsize rcode flags ); my $wire = '0000290000000000000000'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); for my $edns ( Net::DNS::Packet->new()->edns ) { my $encoded = $edns->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = uc unpack 'H*', $encoded; my $hex2 = uc unpack 'H*', $decoded->encode; is( $hex1, $hex2, 'encode/decode transparent' ); is( $hex1, $wire, 'encoded RDATA matches example' ); like( $edns->string, '/EDNS-VERSION/', '$edns->string works' ); $edns->rdata( pack 'H*', '00040002beef' ); like( $edns->plain, '/TYPE41/', '$edns->generic works' ); # join token(generic) $edns->version(1); like( $edns->string, '/EDNS-VERSION/', '$edns->string (version 1)' ); foreach (@attr) { my $changed = 0xbeef; is( $edns->$_($changed), $changed, "edns->$_(x) returns function argument" ); is( $edns->$_(), $changed, "edns->$_() returns changed value" ); $edns->$_(0); } foreach my $method (qw(class ttl size)) { exception( "deprecated $method method", sub { $edns->$method(512) } ); noexception( "$method warning not repeated", sub { $edns->$method(512) } ); } } for my $edns ( Net::DNS::Packet->new()->edns ) { is( scalar( $edns->options ), 0, 'EDNS option list initially empty' ); my $non_existent = $edns->option(0); is( $non_existent, undef, 'non-existent option(0) returns undef' ); ok( !$edns->_specified, 'state unmodified by existence probe' ); $edns->option( 0 => '' ); is( scalar( $edns->options ), 1, 'insert EDNS option' ); $edns->option( 0 => undef ); is( scalar( $edns->options ), 0, 'delete EDNS option' ); ok( !$edns->_specified, 'state unmodified following delete' ); my @transgression = ( {8 => {"FAMILY" => 99}}, {8 => {"BASE16" => '00990000'}}, {65001 => []} ); foreach (@transgression) { my @test = _presentable($_); my ($option) = keys %$_; exception( "compose(@test)", sub { $edns->option(%$_); my @value = $edns->option($option) } ); } } my $edns = Net::DNS::Packet->new()->edns; foreach my $option ( keys %Net::DNS::Parameters::ednsoptionbyval ) { $edns->option( $option => {'BASE16' => '076578616d706c6500'} ); } my @testcase = ( ["LLQ" => {"BASE16" => "000100000000000000000000000000000000"}], [["NSID" => {"OPTION-DATA" => "rawbytes"}], ["NSID" => {"IDENTIFIER" => "7261776279746573"}]], ["4" => {"OPTION-DATA" => ""}], ["DAU" => ( 8, 10, 13, 14, 15, 16 )], ["DHU" => ( 1, 2, 4 )], ["N3U" => 1], ["CLIENT-SUBNET" => ( "FAMILY" => 1, "ADDRESS" => "192.0.2.1", "SOURCE-PREFIX" => 24 )], ["CLIENT-SUBNET" => {"BASE16" => "0002380020010db8fd1342"}], ["EXPIRE" => 604800], [["COOKIE" => ["7261776279746573", ""]], ["COOKIE" => "7261776279746573"]], ["TCP-KEEPALIVE" => 200], [["PADDING" => {"OPTION-DATA" => ""}], ["PADDING" => 0], ["PADDING" => ""]], ["PADDING" => {"OPTION-DATA" => "rawbytes"}], ["PADDING" => 100], ["CHAIN" => {"BASE16" => "076578616d706c6500"}], ["KEY-TAG" => ( 29281, 30562, 31092, 25971 )], ["EXTENDED-ERROR" => ( "INFO-CODE" => 0, "EXTRA-TEXT" => '{"JSON":"EXAMPLE"}' )], ["EXTENDED-ERROR" => ( "INFO-CODE" => 0, "EXTRA-TEXT" => '{JSON: unparsable}' )], ["EXTENDED-ERROR" => ( "INFO-CODE" => 123 )], ["REPORT-CHANNEL" => ( "AGENT-DOMAIN" => "example." )], [["ZONEVERSION" => ""], ["ZONEVERSION" => {"OPTION-DATA" => ""}], ["ZONEVERSION" => []]], ["ZONEVERSION" => [2, 0, "12345678"]], ); foreach (@testcase) { my ( $canonical, @alternative ) = ref( $$_[0] ) eq 'ARRAY' ? @$_ : $_; my ( $option, @value ) = @$canonical; my @presentable = _presentable(@value); $edns->option( $option => @value ); my $result = $edns->option($option); ok( defined($result), qq[compose( "$option" => @presentable )] ); my $expect = defined($result) ? unpack( 'H*', $result ) : $result; my ($interpretation) = $edns->option($option); # check option interpretation foreach ( [%$interpretation], @alternative ) { my ( $option, @value ) = @$_; my @presentable = _presentable(@value); $edns->option( $option, @value ); my $value = $edns->option($option); my $result = defined($value) ? unpack( 'H*', $value ) : $value; is( $result, $expect, qq[compose( "$option" => @presentable )] ); } } is( Net::DNS::RR::OPT::_JSONify(undef), 'null', '_JSONify undef' ); is( Net::DNS::RR::OPT::_JSONify(1234567), '1234567', '_JSONify integer' ); is( Net::DNS::RR::OPT::_JSONify('12345'), '12345', '_JSONify string integer' ); is( Net::DNS::RR::OPT::_JSONify('1.234'), '1.234', '_JSONify string non-integer' ); is( Net::DNS::RR::OPT::_JSONify('1e+20'), '1e+20', '_JSONify string with exponent' ); is( Net::DNS::RR::OPT::_JSONify('abcde'), '"abcde"', '_JSONify non-numeric string' ); is( Net::DNS::RR::OPT::_JSONify('\\092'), '"\\\\092"', '_JSONify escape character' ); my @json = Net::DNS::RR::OPT::_JSONify( {'BASE16' => '1234'} ); is( "@json", qq[{"BASE16": "1234"}], 'short BASE16 string' ); $edns->print; my $options = $edns->options; my $encoded = $edns->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my @result = $decoded->options; is( scalar(@result), $options, "expected number of options ($options)" ); my $multiple = '. 0 CLASS0 TYPE41 \# 30 00130006010012345678 00130006020012345678 00130006030012345678'; for my $edns ( Net::DNS::RR->new($multiple) ) { my $encoded = $edns->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my @value = $decoded->option('ZONEVERSION'); is( scalar(@value), 3, 'EDNS multi-instance ZONEVERSION option' ); $edns->print; } exit; sub _presentable { my ( $value, @list ) = @_; if ( scalar @list ) { ## unstructured argument list my @token = _presentable( [$value, @list] ); pop @token; shift @token; return @token; } if ( ref($value) eq 'HASH' ) { my @tags = keys %$value; my $tail = pop @tags; my @body = map { my ( $a, @z ) = _presentable( $$value{$_} ); unshift @z, qq("$_" => $a); $z[-1] .= ','; @z; } @tags; my ( $a, @tail ) = _presentable( $$value{$tail} ); unshift @tail, qq("$tail" => $a); return ( '{', @body, @tail, '}' ); } if ( ref($value) eq 'ARRAY' ) { my @array = @$value; return qq([ ]) unless scalar @array; my @tail = _presentable( pop @array ); my @body = map { my @x = _presentable($_); $x[-1] .= ','; @x } @array; return ( '[', @body, @tail, ']' ); } my $string = "$value"; ## stringify, then use isdual() as discriminant return $string if UTIL && Scalar::Util::isdual($value); # native integer for ($string) { unless ( utf8::is_utf8($value) ) { return $_ if /^-?\d{1,10}$/; # integer (string representation) return $_ if /^-?\d+\.\d+$/; # non-integer return $_ if /^-?\d(\.\d*)?e[+-]\d\d?$/; } s/^"(.*)"$/$1/; # strip enclosing quotes s/"/\\"/g; # escape interior quotes } return qq("$string"); } Net-DNS-1.50/t/01-resolver-opt.t0000644000175000017500000000335114756035515015477 0ustar willemwillem#!/usr/bin/perl # $Id: 01-resolver-opt.t 2007 2025-02-08 16:45:23Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 31; use Net::DNS::Resolver; local $ENV{'RES_NAMESERVERS'}; local $ENV{'RES_SEARCHLIST'}; local $ENV{'LOCALDOMAIN'}; local $ENV{'RES_OPTIONS'}; # # Check that we can set things in new() # my %test_config = ( domain => 'net-dns.org', searchlist => ['net-dns.org', 't.net-dns.org'], debug => 1, defnames => 0, dnsrch => 0, recurse => 0, retrans => 6, retry => 5, persistent_tcp => 1, persistent_udp => 1, tcp_timeout => 60, udp_timeout => 60, usevc => 1, port => 54, srcport => 53, adflag => 1, cdflag => 0, dnssec => 0, ); foreach my $key ( sort keys %test_config ) { my $resolver = Net::DNS::Resolver->new( $key => $test_config{$key} ); my @returned = $resolver->$key; my %returned = ( $key => scalar(@returned) > 1 ? [@returned] : shift(@returned) ); is_deeply( $returned{$key}, $test_config{$key}, "$key is correct" ); } # # Check that new() is vetting things properly. # foreach my $test (qw(nameservers searchlist)) { foreach my $input ( {}, \1 ) { my $res = eval { Net::DNS::Resolver->new( $test => $input ); }; ok( $@, 'Invalid input caught' ); ok( !$res, 'No resolver returned' ); } } my @other = ( tsig => bless( {}, 'Net::DNS::RR::TSIG' ), tsig => undef, tsig => 'bogus', replyfrom => 'IP', answerfrom => 'IP', ## historical ); while ( my $key = shift @other ) { my $value = shift(@other); my $res = Net::DNS::Resolver->new(); eval { $res->$key($value) }; my $image = defined($value) ? $value : 'undef'; ok( 1, "resolver->$key($image)" ); } exit; Net-DNS-1.50/t/05-URI.t0000644000175000017500000000272314756035515013503 0ustar willemwillem#!/usr/bin/perl # $Id: 05-URI.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 11; use Net::DNS; my $name = '_ftp._tcp.example.net'; my $type = 'URI'; my $code = 256; my @attr = qw( priority weight target ); my @data = qw( 10 1 ftp://ftp1.example.com/public ); my @also = qw( ); my $wire = '000A00016674703A2F2F667470312E6578616D706C652E636F6D2F7075626C6963'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = uc unpack 'H*', $decoded->encode; my $hex2 = uc unpack 'H*', $encoded; my $hex3 = uc unpack 'H*', $rr->rdata; is( $hex1, $hex2, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } exit; Net-DNS-1.50/t/05-DSYNC.t0000644000175000017500000000275014756035515013724 0ustar willemwillem#!/usr/bin/perl # $Id: 05-DSYNC.t 1996 2024-12-16 13:05:08Z willem $ -*-perl-*- # use strict; use warnings; use Net::DNS; use Test::More tests => 13; my $name = 'DSYNC.example'; my $type = 'DSYNC'; my $code = 66; my @attr = qw( rrtype scheme port target ); my @data = ( 'DS', 1, 911, 'target.example' ); my @also; my $wire = join '', qw( 002B01038F06746172676574076578616D706C6500 ); my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = uc unpack 'H*', $decoded->encode; my $hex2 = uc unpack 'H*', $encoded; my $hex3 = uc unpack 'H*', $rr->rdata; is( $hex1, $hex2, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } Net::DNS::RR->new("$name $type @data")->print; exit; Net-DNS-1.50/t/00-pod.t0000644000175000017500000000103614756035515013615 0ustar willemwillem#!/usr/bin/perl # $Id: 00-pod.t 2007 2025-02-08 16:45:23Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; my %prerequisite = ( 'Test::Pod' => 1.45 ); foreach my $package ( sort keys %prerequisite ) { my @revision = grep {$_} $prerequisite{$package}; next if eval "use $package @revision; 1;"; ## no critic plan skip_all => "$package @revision not installed"; exit; } my @poddirs = qw( . ); my @allpods = grep !m#^[/.]*(blib/|[A-Z]+[-])#i, all_pod_files(@poddirs); all_pod_files_ok( sort @allpods ); exit; __END__ Net-DNS-1.50/t/41-DNSKEY-keytag.t0000644000175000017500000000231114756035515015314 0ustar willemwillem#!/usr/bin/perl # $Id: 41-DNSKEY-keytag.t 1856 2021-12-02 14:36:25Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use Net::DNS; my @prerequisite = qw( MIME::Base64 Net::DNS::RR::DNSKEY; ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 4; my $key = Net::DNS::RR->new( <<'END' ); RSASHA1.example. IN DNSKEY 256 3 5 ( AwEAAZHbngk6sMoFHN8fsYY6bmGR4B9UYJIqDp+mORLEH53Xg0f6RMDtfx+H3/x7bHTUikTr26bV AqsxOs2KxyJ2Xx9RGG0DB9O4gpANljtTq2tLjvaQknhJpSq9vj4CqUtr6Wu152J2aQYITBoQLHDV i8mIIunparIKDmhy8TclVXg9 ) ; Key ID = 1623 END ok( $key, 'set up DNSKEY record' ); my $keytag = $key->keytag; is( $keytag, 1623, 'numerical keytag has expected value' ); my $newkey = <<'END'; AwEAAcNz+cEA/Zkl/8u5/kfJKPNSbmXbdMpk6jM4bMWTEhZlaEOJE+GYsbM+HvjMgEMz00eDpvDR XEMl1o4x60SgW8ap44deky/KAYzDC80rIZrvjDx8DPzF3yIikrGc8P7Eq+0zbWrYyiHRg5DllIT4 5NCz6EMtji1RQloWCaXuAzCN END my $keybin = $key->keybin; $key->key($newkey); isnt( $key->keytag, $keytag, 'keytag recalculated from modified key' ); $key->keybin($keybin); is( $key->keytag, $keytag, 'keytag recalculated from restored key' ); exit; __END__ Net-DNS-1.50/t/23-NSEC-covered.t0000644000175000017500000000474114756035515015223 0ustar willemwillem#!/usr/bin/perl # $Id: 23-NSEC-covered.t 1856 2021-12-02 14:36:25Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use Net::DNS; my @prerequisite = qw( Net::DNS::RR::NSEC ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 28; my @cover = ( # testing owner v argument comparison [qw( . example. zzzzzz.example. )], [qw( example. a.example. zzzzzz.example. )], [qw( a.example. yljkjljk.a.example. zzzzzz.example. )], [qw( yljkjljk.a.example. Z.a.example. zzzzzz.example. )], [qw( Z.a.example. zABC.a.example. zzzzzz.example. )], [qw( zABC.a.EXAMPLE. z.example. zzzzzz.example. )], [qw( z.example. \001.z.example. zzzzzz.example. )], [qw( \001.z.example. *.z.example. zzzzzz.example. )], [qw( *.z.example. \200.z.example. zzzzzz.example. )], # testing nxtdname v argument comparison [qw( example. a.example. yljkjljk.a.example. )], [qw( example. yljkjljk.a.example. Z.a.example. )], [qw( example. Z.a.example. zABC.a.example. )], [qw( example. zABC.a.EXAMPLE. z.example. )], [qw( example. z.example. \001.z.example. )], [qw( example. \001.z.example. *.z.example. )], [qw( example. *.z.example. \200.z.example. )], [qw( example. \200.z.example. zzzzzz.example. )], # testing zone boundary conditions [qw( example. orphan.example. example. )], # empty zone [qw( aft.example. *.aft.example. example. )], [qw( aft.example. after.example. example. )], ); my @nocover = ( [qw( example. example. z.example. )], [qw( example. z.example. z.example. )], [qw( example. zz.example. z.example. )], [qw( example. other.tld. z.example. )], [qw( z.example. other.tld. example. )], [qw( . tld. tld. )], # no labels in owner name [qw( tld. . tld. )], # no labels in argument [qw( tld. tld. . )], # no labels in nxtdname ); foreach my $vector (@cover) { my ( $owner, $argument, $nxtdname ) = @$vector; my $test = join ' ', pad($owner), 'NSEC (', pad($nxtdname), 'A )'; my $nsec = Net::DNS::RR->new($test); ok( $nsec->covers($argument), "$test\t covers('$argument')" ); } foreach my $vector (@nocover) { my ( $owner, $argument, $nxtdname ) = @$vector; my $test = join ' ', pad($owner), 'NSEC (', pad($nxtdname), 'A )'; my $nsec = Net::DNS::RR->new($test); ok( !$nsec->covers($argument), "$test\t!covers('$argument')" ); } sub pad { return sprintf '%20s', shift; } exit; __END__ Net-DNS-1.50/t/05-PX.t0000644000175000017500000000267314756035515013377 0ustar willemwillem#!/usr/bin/perl # $Id: 05-PX.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 11; use Net::DNS; my $name = '*.net2.it'; my $type = 'PX'; my $code = 26; my @attr = qw( preference map822 mapx400 ); my @data = qw( 10 net2.it PRMD-net2.ADMDb.C-it ); my @also = qw( ); my $wire = '000a046e657432026974000950524d442d6e6574320541444d446204432d697400'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } exit; Net-DNS-1.50/t/05-NAPTR.t0000644000175000017500000000303414756035515013724 0ustar willemwillem#!/usr/bin/perl # $Id: 05-NAPTR.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 17; use Net::DNS; my $name = '2.1.2.1.5.5.5.0.7.7.1.e164.arpa.'; my $type = 'NAPTR'; my $code = 35; my @attr = qw( order preference flags service regexp replacement ); my @data = qw( 100 10 u sip+E2U !^.*$!sip:information@foo.se!i . ); my @also = qw( ); my $wire = '0064000a0175077369702b4532551e215e2e2a24217369703a696e666f726d6174696f6e40666f6f2e7365216900'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } exit; Net-DNS-1.50/t/32-NSEC3-typelist.t0000644000175000017500000000266014756035515015532 0ustar willemwillem#!/usr/bin/perl # $Id: 32-NSEC3-typelist.t 1865 2022-05-21 09:57:49Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use Net::DNS; use Net::DNS::Text; use Net::DNS::Parameters qw(:type); my @prerequisite = qw( Net::DNS::RR::NSEC3 ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 77; my $rr = Net::DNS::RR->new( type => 'NSEC3', hnxtname => 'irrelevant', ); foreach my $rrtype ( 0, 256, 512, 768, 1024 ) { my $type = "TYPE$rrtype"; $rr->typelist($type); my $rdata = $rr->rdata; my ( $text, $offset ) = Net::DNS::Text->decode( \$rdata, 4 ); ( $text, $offset ) = Net::DNS::Text->decode( \$rdata, $offset ); my ( $w, $l, $bitmap ) = unpack "\@$offset CCa*", $rdata; is( $w, $rrtype >> 8, "expected window number for $type" ); } foreach my $rrtype ( 0, 7, 8, 15, 16, 23, 24, 31, 32, 39 ) { my $type = typebyval($rrtype); $rr->typelist($type); my $rdata = $rr->rdata; my ( $text, $offset ) = Net::DNS::Text->decode( \$rdata, 4 ); ( $text, $offset ) = Net::DNS::Text->decode( \$rdata, $offset ); my ( $w, $l, $bitmap ) = unpack "\@$offset CCa*", $rdata; is( $l, 1 + ( $rrtype >> 3 ), "expected map length for $type" ); } foreach my $rrtype ( 1 .. 40, 42 .. 53, 55 .. 64 ) { my $type = typebyval($rrtype); $rr->typelist($type); is( $rr->typemap($type), 1, "expected map bit for $type" ); } exit; __END__ Net-DNS-1.50/t/07-rrsort.t0000644000175000017500000000774114756035515014406 0ustar willemwillem#!/usr/bin/perl # $Id: 07-rrsort.t 1815 2020-10-14 21:55:18Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 22; use Net::DNS qw(rrsort); 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 ); is( scalar rrsort("SRV"), 0, "rrsort returns properly with undefined arguments" ); is( scalar rrsort( "SRV", @rrarray ), 8, "rrsort returns properly with undefined attribute (1)" ); is( scalar rrsort( "SRV", undef, @rrarray ), 8, "rrsort returns properly with undefined attribute (2)" ); is( scalar rrsort( "SRV", "", @rrarray ), 8, "rrsort returns properly with undefined attribute (3)" ); my @prioritysorted = rrsort( "SRV", "priority", @rrarray ); my @defaultsorted = rrsort( "SRV", @rrarray ); my @portsorted = rrsort( "SRV", "port", @rrarray ); my @foosorted = rrsort( "SRV", "foo", @rrarray ); is( scalar @foosorted, 8, "rrsort returns properly with undefined attribute (4)" ); is( scalar @prioritysorted, 8, "rrsort correctly maintains RRs test 1" ); is( scalar @portsorted, 8, "rrsort correctly maintains RRs test 2" ); is( scalar rrsort( "A", "priority", @rrarray ), 1, "rrsort correctly maintains RRs test 3" ); is( scalar rrsort( "MX", "priority", @rrarray ), 0, "rrsort correctly maintains RRs test 4" ); ok( eq_array( \@expectedpriority, \@prioritysorted ), "Sorting on SRV priority works" ); ok( eq_array( \@expectedpriority, \@defaultsorted ), "Default SRV sort works" ); # # 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-1.50/t/05-DNSKEY.t0000644000175000017500000000741214756035515014041 0ustar willemwillem#!/usr/bin/perl # $Id: 05-DNSKEY.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use TestToolkit; use Net::DNS; my @prerequisite = qw( MIME::Base64 ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 49; my $name = 'DNSKEY.example'; my $type = 'DNSKEY'; my $code = 48; my @attr = qw( flags protocol algorithm publickey ); my @data = ( 256, 3, 5, join '', qw( AQPSKmynfzW4kyBv015MUG2DeIQ3 Cbl+BBZH4b/0PY1kxkmvHjcZc8no kfzj31GajIQKY+5CptLr3buXA10h WqTkF7H6RfoRqXQeogmMHfpftf6z Mv1LyBUgia7za6ZEzOJBOztyvhjL 742iU/TpPSEDhm2SNKLijfUppn1U aNvv4w== ) ); my @also = qw( keybin keylength keytag privatekeyname zone revoke sep ); my $wire = join '', qw( 010003050103D22A6CA77F35B893206FD35E4C506D8378843709B97E041647E1 BFF43D8D64C649AF1E371973C9E891FCE3DF519A8C840A63EE42A6D2EBDDBB97 035D215AA4E417B1FA45FA11A9741EA2098C1DFA5FB5FEB332FD4BC8152089AE F36BA644CCE2413B3B72BE18CBEF8DA253F4E93D2103866D9234A2E28DF529A6 7D5468DBEFE3 ); my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = uc unpack 'H*', $decoded->encode; my $hex2 = uc unpack 'H*', $encoded; my $hex3 = uc unpack 'H*', $rr->rdata; is( $hex1, $hex2, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); $rr->keybin(''); ok( $rr->rdstring, '$rr->rdstring with empty key field' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach ( @attr, qw(keylength keytag rdstring) ) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } toggle( $rr, 'zone', 1, 0, 1, 0 ); toggle( $rr, 'revoke', 0, 1, 0, 1 ); toggle( $rr, 'sep', 1, 0, 1, 0 ); my $class = ref($rr); is( $class->algorithm('RSASHA256'), 8, 'class method algorithm("RSASHA256")' ); is( $class->algorithm(8), 'RSASHA256', 'class method algorithm(8)' ); is( $class->algorithm(255), 255, 'class method algorithm(255)' ); $rr->algorithm(255); is( $rr->algorithm(), 255, 'algorithm number accepted' ); $rr->algorithm('RSASHA1'); is( $rr->algorithm(), 5, 'algorithm mnemonic accepted' ); is( $rr->algorithm('MNEMONIC'), 'RSASHA1', 'rr->algorithm("MNEMONIC") returns mnemonic' ); is( $rr->algorithm(), 5, 'rr->algorithm("MNEMONIC") preserves value' ); exception( 'unknown algorithm', sub { $rr->algorithm('X') } ); exception( 'disallowed algorithm 0', sub { $rr->algorithm(0) } ); } for my $rr ( Net::DNS::RR->new( type => $type, algorithm => 1, keybin => pack 'H*', '0000000000123456' ) ) { my $expect = unpack 'n', pack 'H*', '1234'; is( $rr->keytag, $expect, 'Historic keytag, per RFC4034 Appendix B.1' ); for my $algorithm ( 3, 8, 13 ) { $rr->algorithm($algorithm); my $mnemonic = $rr->algorithm('mnemonic'); ok( defined( $rr->keylength ), "keylength $mnemonic" ); } } Net::DNS::RR->new("$name $type @data")->print; exit; sub toggle { my ( $object, $attribute, @sequence ) = @_; for my $value (@sequence) { my $change = $object->$attribute($value); my $stored = $object->$attribute(); is( $stored, $change, "expected value after $attribute($value)" ); } return; } Net-DNS-1.50/t/03-header.t0000644000175000017500000001010214756035515014260 0ustar willemwillem#!/usr/bin/perl # $Id: 03-header.t 1980 2024-06-02 10:16:33Z willem $ # use strict; use warnings; use Test::More tests => 78; use TestToolkit; use Net::DNS::Packet; use Net::DNS::Parameters; my $packet = Net::DNS::Packet->new(qw(. NS IN)); my $header = $packet->header; ok( $header->isa('Net::DNS::Header'), 'packet->header object' ); sub toggle { my ( $object, $attribute, @sequence ) = @_; for my $value (@sequence) { my $change = $object->$attribute($value); my $stored = $object->$attribute(); is( $stored, $value, "expected value after header->$attribute($value)" ); } return; } is( $header->id, undef, 'packet header ID initially undefined' ); toggle( $header, 'id', 123, 1234, 12345 ); toggle( $header, 'opcode', qw(QUERY) ); toggle( $header, 'rcode', qw(REFUSED FORMERR NOERROR) ); toggle( $header, 'qr', 1, 0, 1, 0 ); toggle( $header, 'aa', 1, 0, 1, 0 ); toggle( $header, 'tc', 1, 0, 1, 0 ); toggle( $header, 'rd', 0, 1, 0, 1 ); toggle( $header, 'ra', 1, 0, 1, 0 ); toggle( $header, 'ad', 1, 0, 1, 0 ); toggle( $header, 'cd', 1, 0, 1, 0 ); # # Is $header->string remotely sane? # like( $header->string, '/opcode = QUERY/', 'string() has QUERY opcode' ); like( $header->string, '/qdcount = 1/', 'string() has qdcount correct' ); like( $header->string, '/ancount = 0/', 'string() has ancount correct' ); like( $header->string, '/nscount = 0/', 'string() has nscount correct' ); like( $header->string, '/arcount = 0/', 'string() has arcount correct' ); toggle( $header, 'opcode', qw(UPDATE) ); like( $header->string, '/opcode = UPDATE/', 'string() has UPDATE opcode' ); like( $header->string, '/zocount = 1/', 'string() has zocount correct' ); like( $header->string, '/prcount = 0/', 'string() has prcount correct' ); like( $header->string, '/upcount = 0/', 'string() has upcount correct' ); like( $header->string, '/adcount = 0/', 'string() has adcount correct' ); # # Check that the aliases work # my $rr = Net::DNS::RR->new('example.com. 10800 A 192.0.2.1'); my @rr = ( $rr, $rr ); $packet->push( prereq => $rr ); $packet->push( update => $rr, @rr ); $packet->push( additional => @rr, @rr ); is( $header->zocount, $header->qdcount, 'zocount value matches qdcount' ); is( $header->prcount, $header->ancount, 'prcount value matches ancount' ); is( $header->upcount, $header->nscount, 'upcount value matches nscount' ); is( $header->adcount, $header->arcount, 'adcount value matches arcount' ); my $data = $packet->encode; my $packet2 = Net::DNS::Packet->new( \$data ); my $string = $packet->header->string; is( $packet2->header->string, $string, 'encode/decode transparent' ); my $dso = Net::DNS::Packet->new(); toggle( $dso->header, 'opcode', qw(DSO) ); toggle( $header, 'id', 0, 1, 0 ); # ID => DSO direction like( $dso->header->string, '/opcode = DSO/', 'string() has DSO opcode' ); SKIP: { my $size = $header->size; my $edns = $header->edns; ok( $edns->isa('Net::DNS::RR::OPT'), 'header->edns object' ); skip( 'EDNS header extensions not supported', 10 ) unless $edns->isa('Net::DNS::RR::OPT'); toggle( $header, 'do', 0, 1, 0, 1 ); toggle( $header, 'co', 0, 1, 0, 1 ); toggle( $header, 'rcode', qw(BADVERS BADMODE BADNAME FORMERR NOERROR) ); my $packet = Net::DNS::Packet->new(); # empty EDNS size solicitation my $udplim = 1280; $packet->edns->UDPsize($udplim); my $encoded = $packet->encode; my $decoded = Net::DNS::Packet->new( \$encoded ); is( $decoded->edns->UDPsize, $udplim, 'EDNS size request assembled correctly' ); } eval { ## no critic # exercise printing functions require IO::File; my $file = "03-header.tmp"; my $handle = IO::File->new( $file, '>' ) || die "Could not open $file for writing"; select( ( select($handle), $header->print )[0] ); close($handle); unlink($file); }; exception( 'qdcount read-only', sub { $header->qdcount(0) } ); exception( 'ancount read-only', sub { $header->ancount(0) } ); exception( 'nscount read-only', sub { $header->nscount(0) } ); exception( 'adcount read-only', sub { $header->adcount(0) } ); noexception( 'warnings not repeated', sub { $header->qdcount(0) } ); exit; Net-DNS-1.50/t/05-DS.t0000644000175000017500000000660714756035515013357 0ustar willemwillem#!/usr/bin/perl # $Id: 05-DS.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 38; use TestToolkit; use Net::DNS; my $name = 'DS.example'; my $type = 'DS'; my $code = 43; my @attr = qw( keytag algorithm digtype digest ); my @data = ( 60485, 5, 1, '2bb183af5f22588179a53b0a98631fad1a292118' ); my @also = qw( digestbin babble ); my $wire = join '', qw( EC45 05 01 2BB183AF5F22588179A53B0A98631FAD1A292118 ); my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = uc unpack 'H*', $decoded->encode; my $hex2 = uc unpack 'H*', $encoded; my $hex3 = uc unpack 'H*', $rr->rdata; is( $hex1, $hex2, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); $rr->digest(''); ok( $rr->rdstring, '$rr->rdstring with empty digest field' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach ( @attr, 'rdstring' ) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } my $class = ref($rr); is( $class->algorithm('RSASHA256'), 8, 'class method algorithm("RSASHA256")' ); is( $class->algorithm(8), 'RSASHA256', 'class method algorithm(8)' ); is( $class->algorithm(255), 255, 'class method algorithm(255)' ); $rr->algorithm(255); is( $rr->algorithm(), 255, 'algorithm number accepted' ); $rr->algorithm('RSASHA1'); is( $rr->algorithm(), 5, 'algorithm mnemonic accepted' ); is( $rr->algorithm('MNEMONIC'), 'RSASHA1', 'rr->algorithm("MNEMONIC") returns mnemonic' ); is( $rr->algorithm(), 5, 'rr->algorithm("MNEMONIC") preserves value' ); exception( 'unknown algorithm', sub { $rr->algorithm('X') } ); exception( 'disallowed algorithm 0', sub { $rr->algorithm(0) } ); is( $class->digtype('SHA256'), 2, 'class method digtype("SHA256")' ); is( $class->digtype(2), 'SHA-256', 'class method digtype(2)' ); is( $class->digtype(255), 255, 'class method digtype(255)' ); $rr->digtype('SHA256'); is( $rr->digtype(), 2, 'digest type mnemonic accepted' ); is( $rr->digtype('MNEMONIC'), 'SHA-256', 'rr->digtype("MNEMONIC") returns mnemonic' ); is( $rr->digtype(), 2, 'rr->digtype("MNEMONIC") preserves value' ); exception( 'disallowed digtype 0', sub { $rr->digtype(0) } ); exception( 'corrupt hexadecimal', sub { $rr->digest('123456789XBCDEF') } ); my $keyrr = Net::DNS::RR->new( type => 'DNSKEY', keybin => '' ); exception( 'create: wrong digtype', sub { $class->create( $keyrr, ( 'digtype' => 255 ) ) } ); exception( 'create: revoked key', sub { $keyrr->flags(0x80); $class->create($keyrr) } ); exception( 'create: non-zone key', sub { $keyrr->flags(0); $class->create($keyrr) } ); exception( 'create: non-DNSSEC key', sub { $keyrr->protocol(0); $class->create($keyrr) } ); } Net::DNS::RR->new("$name $type @data")->print; exit; Net-DNS-1.50/t/01-resolver-config.t0000644000175000017500000000536214756035515016146 0ustar willemwillem#!/usr/bin/perl # $Id: 01-resolver-config.t 2013 2025-02-11 15:52:59Z willem $ -*-perl-*- # use strict; use warnings; use IO::File; use Test::More tests => 21; use Net::DNS::Resolver; local $ENV{'RES_NAMESERVERS'}; local $ENV{'RES_SEARCHLIST'}; local $ENV{'LOCALDOMAIN'}; local $ENV{'RES_OPTIONS'}; eval { my $fh = IO::File->new( '.resolv.conf', '>' ) || die $!; # owned by effective UID close($fh); }; my $resolver = Net::DNS::Resolver->new(); my $class = ref($resolver); ok( $resolver->isa('Net::DNS::Resolver'), 'new() created object' ); my ($isa) = $resolver->OS_CONF; ok( $class->new( debug => 1 )->_diag(qq(_diag("$isa");)), 'debug message' ); $class->nameservers(qw(127.0.0.1 ::1)); # check class methods ok( scalar( $class->nameservers ), '$class->nameservers' ); $class->searchlist(qw(sub1.example.com sub2.example.com)); ok( scalar( $class->searchlist ), '$class->searchlist' ); $class->domain('example.com'); ok( $class->domain, '$class->domain' ); ok( $class->srcport(1234), '$class->srcport' ); ok( $class->string(), '$class->string' ); ok( $resolver->domain('example.com'), '$resolver->domain' ); # check instance methods ok( $resolver->searchlist('example.com'), '$resolver->searchlist' ); $resolver->nameservers(qw(127.0.0.1 ::1 ::ffff:127.0.0.1 fe80::1234%1)); ok( scalar( $resolver->nameservers() ), '$resolver->nameservers' ); $resolver->nameservers(); is( scalar( $resolver->nameservers() ), 0, 'delete nameservers' ); my ($IPv4) = $resolver->nameserver(qw(127.0.0.1)); is( $IPv4, '127.0.0.1', 'IPv4 nameserver' ); my ($IPv6) = $resolver->nameserver(qw(::1)); SKIP: { skip( 'IPv6 specific test', 6 ) unless $IPv6; is( $IPv6, '::1', 'IPv6 nameserver' ); my ($pref4) = $class->new( prefer_v4 => 1 )->nameserver(qw(::1 127.0.0.1)); is( $pref4, '127.0.0.1', '$resolver->prefer_v4(1)' ); my ($force4) = $class->new( force_v4 => 1 )->nameserver(qw(::1 127.0.0.1)); is( $force4, '127.0.0.1', '$resolver->force_v4(1)' ); my ($pref6) = $class->new( prefer_v6 => 1 )->nameserver(qw(127.0.0.1 ::1)); is( $pref6, '::1', '$resolver->prefer_v6(1)' ); my ($force6) = $class->new( force_v6 => 1 )->nameserver(qw(127.0.0.1 ::1)); is( $force6, '::1', '$resolver->force_v6(1)' ); } foreach my $ip (qw(127.0.0.1 ::1)) { is( $resolver->srcaddr($ip), $ip, "\$resolver->srcaddr($ip)" ); } ok( $resolver->_hints(), 'parse defaults hints RRs' ); # check private methods callable ok( $resolver->_hints(), 'defaults hints accessible' ); eval { ## no critic # exercise printing functions my $object = Net::DNS::Resolver->new(); my $file = "01-resolver.tmp"; my $handle = IO::File->new( $file, '>' ) || die "Could not open $file for writing"; select( ( select($handle), $object->print )[0] ); close($handle); unlink($file); }; exit; Net-DNS-1.50/t/01-resolver.t0000644000175000017500000001251314756035515014677 0ustar willemwillem#!/usr/bin/perl # $Id: 01-resolver.t 1993 2024-11-07 14:06:53Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 38; use TestToolkit; BEGIN { ## off-line dry tests require Net::DNS::Resolver; package Net::DNS::Resolver; sub _create_tcp_socket {return} ## stub sub _create_udp_socket {return} ## stub } BEGIN { ## off-line dry tests require Net::DNS::Resolver::Recurse; package Net::DNS::Resolver::Recurse; sub _create_tcp_socket {return} ## stub sub _create_udp_socket {return} ## stub } my @NOIP = qw(:: 0.0.0.0); my $resolver = Net::DNS::Resolver->new( retrans => 0, retry => 0 ); $resolver->nameservers(@NOIP); foreach (@NOIP) { ## exercise IPv4/IPv6 LocalAddr selection Net::DNS::Resolver::Base::_create_tcp_socket( $resolver, $_ ); Net::DNS::Resolver::Base::_create_udp_socket( $resolver, $_ ); } $resolver->defnames(0); ## exercise query() ok( !$resolver->query(''), '$resolver->query() without defnames' ); $resolver->defnames(1); ok( !$resolver->query(''), '$resolver->query() with defnames' ); $resolver->dnsrch(0); ## exercise search() ok( !$resolver->search('name'), '$resolver->search() without dnsrch' ); $resolver->dnsrch(1); $resolver->ndots(1); $resolver->searchlist(qw(a.example. b.example.)); ok( !$resolver->search('name'), '$resolver->search() simple name' ); ok( !$resolver->search('name.domain'), '$resolver->search() dotted name' ); ok( !$resolver->search('name.domain.'), '$resolver->search() absolute name' ); ok( !$resolver->search(''), '$resolver->search() root label' ); my $query = Net::DNS::Packet->new('.'); ## exercise _accept_reply() $query->encode; my $reply = Net::DNS::Packet->new('.'); $reply->header->qr(1); $reply->encode; ok( !$resolver->_accept_reply(undef), '_accept_reply() no reply' ); ok( !$resolver->_accept_reply($query), '_accept_reply() qr not set' ); ok( !$resolver->_accept_reply( $reply, $query ), '_accept_reply() id mismatch' ); ok( $resolver->_accept_reply( $reply, $reply ), '_accept_reply() id match' ); ok( $resolver->_accept_reply( $reply, undef ), '_accept_reply() query absent/undefined' ); is( scalar( Net::DNS::Resolver::Base::_cname_addr( undef, undef ) ), 0, '_cname_addr() no reply packet' ); $resolver->nameservers(); ## exercise UDP failure path ok( !$resolver->send('.'), 'no UDP nameservers' ); $resolver->nameservers(@NOIP); ok( !$resolver->send('.'), '$resolver->send UDP socket error' ); ok( !$resolver->bgsend('.'), '$resolver->bgsend UDP socket error' ); ok( !$resolver->bgbusy(), '$resolver->bgbusy undefined handle' ); ok( !$resolver->_bgread(), '$resolver->_bgread undefined handle' ); $resolver->usevc(1); ## exercise TCP failure path $resolver->nameservers(); ok( !$resolver->send('.'), 'no TCP nameservers' ); $resolver->nameservers(@NOIP); ok( !$resolver->send('.'), '$resolver->send TCP socket error' ); ok( !$resolver->bgsend('.'), '$resolver->bgsend TCP socket error' ); ok( !$resolver->axfr('.'), '$resolver->axfr TCP socket error' ); is( $resolver->DESTROY, undef, 'DESTROY() exists to placate pre-5.18 AUTOLOAD' ); exception( 'new( config_file => )', sub { Net::DNS::Resolver->new( config_file => 'nonexist.txt' ) } ); exception( 'AUTOLOAD: unrecognised method', sub { $resolver->unknown() } ); exception( 'unresolved nameserver warning', sub { $resolver->nameserver('bogus.example.com.') } ); exception( 'unspecified axfr() zone name', sub { $resolver->axfr(undef) } ); exception( 'deprecated axfr_start() method', sub { $resolver->axfr_start('net-dns.org') } ); exception( 'deprecated axfr_next() method', sub { $resolver->axfr_next() } ); exception( 'deprecated bgisready() method', sub { $resolver->bgisready(undef) } ); my $deprecated = sub { $resolver->make_query_packet('example.com') }; exception( 'deprecated make_query_packet()', $deprecated ); noexception( 'no repeated deprecation warning', $deprecated ); for my $recursive ( Net::DNS::Resolver::Recurse->new( retrans => 0, retry => 0 ) ) { my $domain = 'net-dns.org'; my $packet = Net::DNS::Packet->new( "$domain", 'NS' ); $packet->push( ans => Net::DNS::RR->new("$domain NS nx$$.$domain") ); $packet->push( add => Net::DNS::RR->new("nx$$.$domain AAAA ::") ); $recursive->_referral($packet); my $result = $recursive->_recurse( $packet, $domain ); is( $result, undef, 'non-responding nameserver' ); } for my $recursive ( Net::DNS::Resolver::Recurse->new( retrans => 0, retry => 0 ) ) { my $domain = 'net-dns.org'; my $packet = Net::DNS::Packet->new( "$domain", 'NS' ); $packet->push( ans => Net::DNS::RR->new("$domain NS nx$$.$domain") ); $recursive->_referral($packet); my $result = $recursive->_recurse( $packet, $domain ); is( $result, undef, 'unable to recover missing glue' ); } for my $recursive ( Net::DNS::Resolver::Recurse->new( retrans => 0, retry => 0 ) ) { my $domain = 'net-dns.org'; $recursive->hints(@NOIP); ok( !$recursive->send( "www.$domain", 'A' ), 'fail if no usable hint' ); exception( 'deprecated query_dorecursion()', sub { $recursive->query_dorecursion("www.$domain") } ); exception( 'deprecated recursion_callback()', sub { $recursive->recursion_callback(undef) } ); } SKIP: { skip( 'Unable to emulate SpamAssassin socket usage', 1 ) if $^O eq 'MSWin32'; my $handle = \*DATA; ## exercise SpamAssassin's use of plain sockets ok( !$resolver->bgbusy($handle), 'bgbusy(): SpamAssassin workaround' ); } exit; __DATA__ arbitrary Net-DNS-1.50/t/71-TSIG-create.t0000644000175000017500000000734114756035515015057 0ustar willemwillem#!/usr/bin/perl # $Id: 71-TSIG-create.t 1980 2024-06-02 10:16:33Z willem $ -*-perl-*- # use strict; use warnings; use IO::File; use Test::More; use TestToolkit; use Net::DNS; my @prerequisite = qw( Digest::HMAC Digest::SHA MIME::Base64 ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 18; my $tsig = Net::DNS::RR->new( type => 'TSIG' ); my $class = ref($tsig); my $tsigkey = 'tsigkey.txt'; END { unlink($tsigkey) if defined $tsigkey; } my $fh_tsigkey = IO::File->new( $tsigkey, '>' ) || die "$tsigkey $!"; print $fh_tsigkey <<'END'; Algorithm: name ; BIND dnssec-keygen private key Key: secret ; syntax check only key "host1-host2.example." { ; BIND tsig-keygen key algorithm hmac-sha256; secret "f+JImRXRzLpKseG+bP+W9Vwb2QAgtFuIlRU80OA3NU8="; }; END close($fh_tsigkey); for my $tsig ( $class->create($tsigkey) ) { is( ref($tsig), $class, 'create TSIG from BIND tsig-keygen key' ); ok( $tsig->name, 'TSIG key name' ); ok( $tsig->algorithm, 'TSIG algorithm' ); } for my $packet ( Net::DNS::Packet->new('query.example') ) { $packet->sign_tsig($tsigkey); $packet->encode; my $tsig = $class->create($packet); is( ref($tsig), $class, 'create TSIG from packet->sigrr' ); is( $tsig->name, $packet->sigrr->name, 'TSIG key name' ); is( $tsig->algorithm, $packet->sigrr->algorithm, 'TSIG algorithm' ); } for my $chain ( $class->create($tsig) ) { is( ref($chain), $class, 'create successor to existing TSIG' ); } my $keyrr = Net::DNS::RR->new( <<'END' ); # BIND dnssec-keygen public key host1-host2.example. IN KEY 512 3 163 mvojlAdUskQEtC7J8OTXU5LNvt0= END my $dnsseckey = 'Khmac-sha256.example.+163+52011.key'; END { unlink($dnsseckey) if defined $dnsseckey; } my $fh_dnsseckey = IO::File->new( $dnsseckey, '>' ) || die "$dnsseckey $!"; print $fh_dnsseckey $keyrr->string, "\n"; close($fh_dnsseckey); for my $tsig ( $class->create($dnsseckey) ) { is( ref($tsig), $class, 'create TSIG from BIND dnssec public key' ); ok( $tsig->name, 'TSIG key name' ); ok( $tsig->algorithm, 'TSIG algorithm' ); } exception( 'empty argument list', sub { $class->create() } ); exception( 'argument undefined', sub { $class->create(undef) } ); my $null = Net::DNS::RR->new( type => 'NULL' ); exception( 'unexpected argument', sub { $class->create($null) } ); exception( '2-argument create', sub { $class->create( $keyrr->owner, $keyrr->key ) } ); my $packet = Net::DNS::Packet->new('query.example'); exception( 'no TSIG in packet', sub { $class->create($packet) } ); my $dnskey = 'Kbad.example.+161+39562.key'; END { unlink($dnskey) if defined $dnskey; } my $fh_dnskey = IO::File->new( $dnskey, '>' ) || die "$dnskey $!"; print $fh_dnskey <<'END'; HMAC-SHA1.example. IN DNSKEY 512 3 161 xdX9m8UtQNbJUzUgQ4xDtUNZAmU= END close($fh_dnskey); exception( 'unrecognised key format', sub { $class->create($dnskey) } ); my $renamedBINDkey = 'arbitrary.key'; END { unlink($renamedBINDkey) if defined $renamedBINDkey; } my $fh_renamed = IO::File->new( $renamedBINDkey, '>' ) || die "$renamedBINDkey $!"; print $fh_renamed <<'END'; HMAC-SHA1.example. IN KEY 512 3 161 xdX9m8UtQNbJUzUgQ4xDtUNZAmU= END close($fh_renamed); exception( 'renamed BIND public key', sub { $class->create($renamedBINDkey) } ); my $corruptBINDkey = 'Kcorrupt.example.+161+13198.key'; # unmatched keytag END { unlink($corruptBINDkey) if defined $corruptBINDkey; } my $fh_corrupt = IO::File->new( $corruptBINDkey, '>' ) || die "$corruptBINDkey $!"; print $fh_corrupt <<'END'; print KEY <<'END'; HMAC-SHA1.example. IN KEY 512 3 161 xdX9m8UtQNbJUzUgQ4xDtUNZAmU= END close($fh_corrupt); exception( 'corrupt BIND public key', sub { $class->create($corruptBINDkey) } ); exit; Net-DNS-1.50/t/52-DS-SHA256.t0000644000175000017500000000240314756035515014215 0ustar willemwillem#!/usr/bin/perl # $Id: 52-DS-SHA256.t 1855 2021-11-26 11:33:48Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use Net::DNS; my @prerequisite = qw( Digest::SHA MIME::Base64 Net::DNS::RR::DNSKEY Net::DNS::RR::DS ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 3; # Simple known-answer tests based upon the examples given in RFC4509, section 2.3 my $RFC = 'RFC4509'; my $dnskey = Net::DNS::RR->new( <<'END' ); dskey.example.com. 86400 IN DNSKEY 256 3 5 ( AQOeiiR0GOMYkDshWoSKz9XzfwJr1AYtsmx3TGkJaNXVbfi/2pHm822aJ5iI9BMzNXxeYCmZDRD9 9WYwYqUSdjMmmAphXdvxegXd/M5+X7OrzKBaMbCVdFLUUh6DhweJBjEVv5f2wwjM9XzcnOf+EPbt G9DMBmADjFDc2w/rljwvFw== ) ; Key ID = 60485 END my $ds = Net::DNS::RR->new( <<'END' ); dskey.example.com. 86400 IN DS 60485 5 2 ( D4B7D520E7BB5F0F67674A0CCEB1E3E0614B93C4F9E99B8383F6A1E4469DA50A ) END my $test = Net::DNS::RR::DS->create( $dnskey, digtype => $ds->digtype, ttl => $ds->ttl ); is( $test->string, $ds->string, "created DS matches $RFC example DS" ); ok( $test->verify($dnskey), "created DS verifies $RFC example DNSKEY" ); ok( $ds->verify($dnskey), "$RFC example DS verifies DNSKEY" ); $test->print; __END__ Net-DNS-1.50/t/02-domain.t0000644000175000017500000001266114756035515014312 0ustar willemwillem#!/usr/bin/perl # $Id: 02-domain.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 46; use TestToolkit; use_ok('Net::DNS::Domain'); for my $domain ( Net::DNS::Domain->new('example.com') ) { ok( $domain->isa('Net::DNS::Domain'), 'object returned by new() constructor' ); my $same = Net::DNS::Domain->new( $domain->name ); is( $same, $domain, "same name returns cached object" ); my %cache; my ( $i, $j ); for ( ; ; ) { $j = ( $i++ >> 1 ) + 1; my $fill = "name-$i"; my $test = "name-$j"; $cache{$fill} = Net::DNS::Domain->new($fill); last unless $cache{$test} == Net::DNS::Domain->new($test); } my $size = $i - $j; ok( $size, "name cache at least $size deep" ); } for my $domain ( Net::DNS::Domain->new('name') ) { $domain->name; ## untestable optimisation: avoid returning name in void context is( $domain->name, 'name', '$domain->name() without trailing dot' ); is( $domain->fqdn, 'name.', '$domain->fqdn() with trailing dot' ); is( $domain->string, 'name.', '$domain->string() with trailing dot' ); } for my $root ( Net::DNS::Domain->new('.') ) { is( $root->name, '.', '$root->name() represented by single dot' ); is( $root->fqdn, '.', '$root->fqdn() represented by single dot' ); is( $root->xname, '.', '$root->xname() represented by single dot' ); is( $root->string, '.', '$root->string() represented by single dot' ); } for my $domain ( Net::DNS::Domain->new('example.com') ) { my $labels = @{[$domain->label]}; is( $labels, 2, 'domain labels separated by dots' ); } use constant ESC => '\\'; { my $case = ESC . '.'; my $domain = Net::DNS::Domain->new("example${case}com"); my $labels = @{[$domain->label]}; is( $labels, 1, "$case devoid of special meaning" ); } { my $case = ESC . ESC; my $domain = Net::DNS::Domain->new("example${case}.com"); my $labels = @{[$domain->label]}; is( $labels, 2, "$case devoid of special meaning" ); } { my $case = ESC . ESC . ESC . '.'; my $domain = Net::DNS::Domain->new("example${case}com"); my $labels = @{[$domain->label]}; is( $labels, 1, "$case devoid of special meaning" ); } { my $case = '\092'; my $domain = Net::DNS::Domain->new("example${case}.com"); my $labels = @{[$domain->label]}; is( $labels, 2, "$case devoid of special meaning" ); } { my $name = 'simple-name'; my $simple = Net::DNS::Domain->new($name); is( $simple->name, $name, "$name absolute by default" ); my $create = origin Net::DNS::Domain(undef); my $domain = &$create( sub { Net::DNS::Domain->new($name); } ); is( $domain->name, $name, "$name absolute if origin undefined" ); } { my $name = 'simple-name'; my $create = origin Net::DNS::Domain('.'); my $domain = &$create( sub { Net::DNS::Domain->new($name); } ); is( $domain->name, $name, "$name absolute if origin '.'" ); my @label = $domain->label; is( scalar(@label), 1, "$name has single label" ); } { my $name = 'simple-name'; my $suffix = 'example.com'; my $create = origin Net::DNS::Domain($suffix); my $domain = &$create( sub { Net::DNS::Domain->new($name); } ); my $expect = Net::DNS::Domain->new("$name.$suffix"); is( $domain->name, $expect->name, "origin appended to $name" ); my $root = Net::DNS::Domain->new('@'); is( $root->name, '.', 'bare @ represents root by default' ); my $origin = &$create( sub { Net::DNS::Domain->new('@'); } ); is( $origin->name, $suffix, 'bare @ represents defined origin' ); } { my $ldh = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz-0123456789'; my $domain = Net::DNS::Domain->new($ldh); is( $domain->name, $ldh, '63 octet LDH character label' ); } { my $name = 'example.com'; my $domain = Net::DNS::Domain->new("$name..."); is( $domain->name, $name, 'ignore gratuitous trailing dots' ); } 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 = Net::DNS::Domain->new($case); is( $domain->name, $case, "C0 controls:\t$case" ); } foreach my $case ( '\032!\034#$%&\'\(\)*+,-\./', # 32 .. 47 '0123456789:\;<=>?', # 48 .. '@ABCDEFGHIJKLMNO', # 64 .. 'PQRSTUVWXYZ[\092]^_', # 80 .. '`abcdefghijklmno', # 96 .. 'pqrstuvwxyz{|}~\127' # 112 .. ) { my $domain = Net::DNS::Domain->new($case); is( $domain->name, $case, "G0 graphics:\t$case" ); } 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 = Net::DNS::Domain->new($case); is( $domain->name, $case, "8-bit codes:\t$case" ); } exception( 'empty argument list', sub { Net::DNS::Domain->new() } ); exception( 'argument undefined', sub { Net::DNS::Domain->new(undef) } ); exception( 'empty intial label', sub { Net::DNS::Domain->new('..example.com') } ); exception( 'empty interior label', sub { Net::DNS::Domain->new('..example.com') } ); my $long = '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!'; exception( 'long domain label', sub { Net::DNS::Domain->new($long) } ); exit; Net-DNS-1.50/t/05-L32.t0000644000175000017500000000256014756035515013403 0ustar willemwillem#!/usr/bin/perl # $Id: 05-L32.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 9; use Net::DNS; my $name = 'L32.example'; my $type = 'L32'; my $code = 105; my @attr = qw( preference locator32 ); my @data = qw( 10 10.1.2.0 ); my @also = qw( ); my $wire = '000a0a010200'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } exit; Net-DNS-1.50/t/05-CDS.t0000644000175000017500000000541014756035515013451 0ustar willemwillem#!/usr/bin/perl # $Id: 05-CDS.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 30; use Net::DNS; my $name = 'CDS.example'; my $type = 'CDS'; my $code = 59; my @attr = qw( keytag algorithm digtype digest ); my @data = ( 60485, 5, 1, '2bb183af5f22588179a53b0a98631fad1a292118' ); my @also = qw( digestbin babble ); my $wire = join '', qw( EC45 05 01 2BB183AF5F22588179A53B0A98631FAD1A292118 ); my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = uc unpack 'H*', $decoded->encode; my $hex2 = uc unpack 'H*', $encoded; my $hex3 = uc unpack 'H*', $rr->rdata; is( $hex1, $hex2, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach ( @attr, 'rdstring' ) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } $rr->algorithm(255); is( $rr->algorithm(), 255, 'algorithm number accepted' ); $rr->algorithm('RSASHA1'); is( $rr->algorithm(), 5, 'algorithm mnemonic accepted' ); is( $rr->algorithm('MNEMONIC'), 'RSASHA1', 'rr->algorithm("MNEMONIC") returns mnemonic' ); is( $rr->algorithm(), 5, 'rr->algorithm("MNEMONIC") preserves value' ); $rr->digtype('SHA-256'); is( $rr->digtype(), 2, 'digest type mnemonic accepted' ); is( $rr->digtype('MNEMONIC'), 'SHA-256', 'rr->digtype("MNEMONIC") returns mnemonic' ); is( $rr->digtype(), 2, 'rr->digtype("MNEMONIC") preserves value' ); } for my $rr ( Net::DNS::RR->new("$name. $type 0 0 0 00") ) { # per RFC8078(4), erratum 5049 ok( ref($rr), "DS delete: $name. $type 0 0 0 00" ); is( $rr->keytag(), 0, 'DS delete: keytag 0' ); is( $rr->algorithm(), 0, 'DS delete: algorithm 0' ); is( $rr->digtype(), 0, 'DS delete: digtype 0' ); my $rdata = unpack 'H*', $rr->rdata(); is( $rdata, '0000000000', 'DS delete: rdata wire-format' ); is( $rr->rdstring(), '0 0 0 00', 'DS delete: presentation format' ); } for my $rr ( Net::DNS::RR->new("$name. $type 0 0 0 0") ) { # per RFC8078(4) as published is( $rr->rdstring(), '0 0 0 00', 'DS delete: accept old format' ); } Net::DNS::RR->new("$name $type @data")->print; exit; Net-DNS-1.50/t/05-SIG.t0000644000175000017500000001152414756035515013465 0ustar willemwillem#!/usr/bin/perl # $Id: 05-SIG.t 2005 2025-01-28 13:22:10Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use TestToolkit; use Net::DNS; my @prerequisite = qw( MIME::Base64 Time::Local ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 70; my $name = '.'; my $type = 'SIG'; my $code = 24; my @attr = qw( typecovered algorithm labels orgttl sigexpiration siginception keytag signame signature ); my @data = ( qw( TYPE0 1 0 0 20150814181655 20150814181155 2871 rsamd5.example ), join '', qw( GOjsIo2JXz2ASClRhdbD5W+IYkq+Eo5iF9l3R+LYS/14Q fxqX2M9YHPvuLfz5ORAdnqyuKJTi3/LsrHmF/cUzwY3UM ZJDeGce77WiUJlR93VRKZ4fTs/wPP7JHxgAIhhlYFB4xs vISZr/tgvblxwJSpa4pJIahUuitfaiijFwQw= ) ); my @also = qw( sig sigex sigin vrfyerrstr _size ); my $wire = '000001000000000055CE309755CE2F6B0B37067273616D6435076578616D706C650018E8EC228D895F3D8048295185D6C3E56F88624ABE128E6217D97747E2D84BFD7841FC6A5F633D6073EFB8B7F3E4E440767AB2B8A2538B7FCBB2B1E617F714CF063750C6490DE19C7BBED689426547DDD544A6787D3B3FC0F3FB247C60008861958141E31B2F21266BFED82F6E5C70252A5AE292486A152E8AD7DA8A28C5C10C'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = uc unpack 'H*', $decoded->encode; my $hex2 = uc unpack 'H*', $encoded; my $hex3 = uc unpack 'H*', $rr->rdata; is( $hex1, $hex2, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); my $wireformat = pack 'a* x', $encoded; exception( 'misplaced SIG RR', sub { Net::DNS::RR->decode( \$wireformat ) } ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach ( @attr, 'rdstring' ) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } my $class = ref($rr); $rr->algorithm(255); is( $rr->algorithm(), 255, 'algorithm number accepted' ); $rr->algorithm('RSASHA1'); is( $rr->algorithm(), 5, 'algorithm mnemonic accepted' ); is( $rr->algorithm('MNEMONIC'), 'RSASHA1', 'rr->algorithm("MNEMONIC") returns mnemonic' ); is( $rr->algorithm(), 5, 'rr->algorithm("MNEMONIC") preserves value' ); exception( 'unknown mnemonic', sub { $rr->algorithm('X') } ); is( $class->algorithm('RSASHA256'), 8, 'class method algorithm("RSASHA256")' ); is( $class->algorithm(8), 'RSASHA256', 'class method algorithm(8)' ); is( $class->algorithm(255), 255, 'class method algorithm(255)' ); my $object = Net::DNS::RR->new(". $type"); my $scalar = ''; $object->{algorithm} = 0; ## methods callable with invalid arguments noexception( '_CreateSig callable', sub { $object->_CreateSig( $scalar, $object ) } ); noexception( '_CreateSigData callable', sub { $object->_CreateSigData($object) } ); noexception( '_VerifySig callable', sub { $object->_VerifySig( $object, $object ) } ); exception( 'create callable', sub { $class->create( $scalar, $object ) } ); exception( 'verify callable', sub { $object->verify( $object, $object ) } ); } { my %testcase = ( ## test time conversion edge cases -1 => '21060207062815', 0x00000000 => '19700101000000', 0x7fffffff => '20380119031407', 0x80000000 => '20380119031408', 0xf4d41f7f => '21000228235959', 0xf4d41f80 => '21000301000000', 0xffffffff => '21060207062815', ); foreach my $time ( sort keys %testcase ) { my $string = $testcase{$time}; my $result = Net::DNS::RR::SIG::_time2string($time); is( $result, $string, "_time2string($time)" ); # Test indirectly: $timeval can be 64-bit or negative 32-bit integer my $timeval = Net::DNS::RR::SIG::_string2time($string); my $timestr = Net::DNS::RR::SIG::_time2string($timeval); is( $timestr, $string, "_string2time($string)" ); } my $timenow = time(); my $timeval = Net::DNS::RR::SIG::_string2time($timenow); is( $timeval, $timenow, "_string2time( time() )\t$timeval" ); } sub test_order { my @arg = @_; my ( $a, $b ) = map { defined($_) ? $_ : 'undef' } @arg; ok( Net::DNS::RR::SIG::_ordered(@arg), "_ordered( $a, $b )" ); ok( !Net::DNS::RR::SIG::_ordered( reverse @arg ), "!_ordered( $b, $a )" ); } test_order( 0, 1 ); test_order( 0x7fffffff, 0x80000000 ); test_order( 0xffffffff, 0 ); test_order( -1, 0 ); test_order( -2, -1 ); test_order( undef, 0 ); Net::DNS::RR->new("$name $type @data")->print; exit; Net-DNS-1.50/t/05-TLSA.t0000644000175000017500000000337114756035515013607 0ustar willemwillem#!/usr/bin/perl # $Id: 05-TLSA.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 16; use TestToolkit; use Net::DNS; my $name = '_443._tcp.www.example.com'; my $type = 'TLSA'; my $code = 52; my @attr = qw( usage selector matchingtype certificate ); my @data = qw( 1 1 2 92003ba34942dc74152e2f2c408d29eca5a520e7f2e06bb944f4dca346baf63c1b177615d466f6c4b71c216a50292bd58c9ebdd2f74e38fe51ffd48c43326cbc ); my @also = qw( certbin babble ); my $wire = '01010292003ba34942dc74152e2f2c408d29eca5a520e7f2e06bb944f4dca346baf63c1b177615d466f6c4b71c216a50292bd58c9ebdd2f74e38fe51ffd48c43326cbc'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } { my $rr = Net::DNS::RR->new(". $type"); foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } exception( 'corrupt hexadecimal', sub { $rr->certificate('123456789XBCDEF') } ); } exit; Net-DNS-1.50/t/05-NID.t0000644000175000017500000000260014756035515013450 0ustar willemwillem#!/usr/bin/perl # $Id: 05-NID.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 9; use Net::DNS; my $name = 'NID.example'; my $type = 'NID'; my $code = 104; my @attr = qw( preference nodeid ); my @data = qw( 10 0014:4fff:ff20:ee64 ); my @also = qw( ); my $wire = '000a00144fffff20ee64'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } exit; Net-DNS-1.50/t/24-NSEC-encloser.t0000644000175000017500000000465614756035515015414 0ustar willemwillem#!/usr/bin/perl # $Id: 24-NSEC-encloser.t 1856 2021-12-02 14:36:25Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use Net::DNS; my @prerequisite = qw( Net::DNS::ZoneFile Net::DNS::RR::NSEC ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 9; ## Based on example from RFC7129 3.2 my @nsec = grep { $_->type eq 'NSEC' } Net::DNS::ZoneFile->parse( <<'END' ); $ORIGIN example.org. example.org. SOA ( ns1 dns ) ; DNSKEY ( ... ) ; NS a.example.org. NSEC a.example.org. NS SOA RRSIG NSEC DNSKEY ; RRSIG(NS) ( ... ) ; RRSIG(SOA) ( ... ) ; RRSIG(NSEC) ( ... ) ; RRSIG(DNSKEY) ( ... ) a.example.org. A 192.0.2.1 ; TXT "a record" NSEC d.example.org. A TXT RRSIG NSEC ; RRSIG(A) ( ... ) ; RRSIG(TXT) ( ... ) ; RRSIG(NSEC) ( ... ) d.example.org. A 192.0.2.1 ; TXT "d record" NSEC example.org. A TXT RRSIG NSEC END sub closest_encloser { my $qname = shift; my $encloser; foreach my $nsec (@nsec) { my $ancestor = $nsec->encloser($qname); $encloser = $ancestor if $ancestor; } foreach my $nsec ( reverse @nsec ) { # check order independence my $ancestor = $nsec->encloser($qname); $encloser = $ancestor if $ancestor; } return $encloser; } sub next_closer_name { my $qname = shift; my $nextcloser; foreach my $nsec (@nsec) { next unless $nsec->encloser($qname); $nextcloser = $nsec->nextcloser; } return $nextcloser; } sub closer_wildcard { my $qname = shift; my $wildcard; foreach my $nsec (@nsec) { next unless $nsec->encloser($qname); $wildcard = $nsec->wildcard; } return $wildcard; } is( closest_encloser('example.org.'), undef, 'encloser(example.org)' ); is( closest_encloser('a.example.org.'), 'example.org', 'encloser(a.example.org)' ); is( closest_encloser('d.example.org.'), 'example.org', 'encloser(d.example.org)' ); is( closest_encloser('b.example.org.'), 'example.org', 'encloser(b.example.org)' ); is( next_closer_name('b.example.org.'), 'b.example.org', 'nextcloser(b.example.org)' ); is( closer_wildcard('b.example.org.'), '*.example.org', 'wildcard(b.example.org)' ); is( closest_encloser('a.b.c.example.org.'), 'example.org', 'encloser(a.b.c.example.org)' ); is( next_closer_name('a.b.c.example.org.'), 'c.example.org', 'nextcloser(a.b.c.example.org)' ); is( closer_wildcard('a.b.c.example.org.'), '*.example.org', 'wildcard(a.b.c.example.org)' ); exit; __END__ Net-DNS-1.50/t/34-NSEC3-flags.t0000644000175000017500000000120614756035515014746 0ustar willemwillem#!/usr/bin/perl # $Id: 34-NSEC3-flags.t 2003 2025-01-21 12:06:06Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use Net::DNS; my @prerequisite = qw( Net::DNS::RR::NSEC3 ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 3; my $rr = Net::DNS::RR->new( type => 'NSEC3' ); my $optout = $rr->optout(0); ok( !$optout, 'Boolean optout flag cleared' ); $rr->optout( !$optout ); ok( $rr->optout, 'Boolean optout flag toggled' ); $rr->optout($optout); ok( !$optout, 'Boolean optout flag restored' ); exit; __END__ Net-DNS-1.50/t/05-EUI48.t0000644000175000017500000000235214756035515013640 0ustar willemwillem#!/usr/bin/perl # $Id: 05-EUI48.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 6; use Net::DNS; my $name = 'EUI48.example'; my $type = 'EUI48'; my $code = 108; my @attr = qw( address ); my @data = qw( 5e-ef-10-00-00-2a ); my @also = qw( ); my $wire = '5eef1000002a'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } exit; Net-DNS-1.50/t/02-IDN.t0000644000175000017500000000524714756035515013457 0ustar willemwillem#!/usr/bin/perl # $Id: 02-IDN.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use TestToolkit; ## vvv verbatim from Domain.pm use constant ASCII => ref eval { require Encode; Encode::find_encoding('ascii'); }; use constant UTF8 => scalar eval { ## not UTF-EBCDIC [see UTR#16 3.6] Encode::encode_utf8( chr(182) ) eq pack( 'H*', 'C2B6' ); }; use constant LIBIDN2 => defined eval { require Net::LibIDN2 }; use constant LIBIDN => LIBIDN2 ? undef : defined eval { require Net::LibIDN }; ## ^^^ verbatim from Domain.pm use constant LIBIDNOK => LIBIDN && scalar eval { my $cn = pack( 'U*', 20013, 22269 ); Net::LibIDN::idn_to_ascii( $cn, 'utf-8' ) eq 'xn--fiqs8s'; }; use constant LIBIDN2OK => LIBIDN2 && scalar eval { my $cn = pack( 'U*', 20013, 22269 ); Net::LibIDN2::idn2_to_ascii_8( $cn, 9 ) eq 'xn--fiqs8s'; }; my $codeword = unpack 'H*', '[|'; my %codename = ( '5b7c' => 'ASCII superset', 'ba4f' => 'EBCDIC cp37', 'ad4f' => 'EBCDIC cp1047', 'bb4f' => 'EBCDIC posix-bc' ); my $encoding = $codename{lc $codeword} || "not recognised [$codeword]"; diag "character encoding: $encoding" unless $encoding =~ /ASCII/; plan skip_all => 'Encode package not installed' unless eval { require Encode; }; plan skip_all => 'Encode: ASCII encoding not available' unless ASCII; plan skip_all => 'Encode: UTF-8 encoding not available' unless UTF8; plan skip_all => 'Net::LibIDN2 not installed' unless LIBIDN || LIBIDN2; plan skip_all => 'Net::LibIDN not working' if LIBIDN && !LIBIDNOK; plan skip_all => 'Net::LibIDN2 not working' if LIBIDN2 && !LIBIDN2OK; plan tests => 12; use_ok('Net::DNS::Domain'); my $a_label = 'xn--fiqs8s'; my $u_label = eval { pack( 'U*', 20013, 22269 ); }; is( Net::DNS::Domain->new($a_label)->name, $a_label, 'IDN A-label domain->name' ); is( Net::DNS::Domain->new($a_label)->fqdn, "$a_label.", 'IDN A-label domain->fqdn' ); is( Net::DNS::Domain->new($a_label)->string, "$a_label.", 'IDN A-label domain->string' ); is( Net::DNS::Domain->new($a_label)->xname, $u_label, 'IDN A-label domain->xname' ); is( Net::DNS::Domain->new($u_label)->name, $a_label, 'IDN U-label domain->name' ); is( Net::DNS::Domain->new($u_label)->fqdn, "$a_label.", 'IDN U-label domain->fqdn' ); is( Net::DNS::Domain->new($u_label)->string, "$a_label.", 'IDN U-label domain->string' ); is( Net::DNS::Domain->new($u_label)->xname, $u_label, 'IDN U-label domain->xname' ); is( Net::DNS::Domain->new($u_label)->xname, $u_label, 'IDN cached domain->xname' ); is( Net::DNS::Domain->new('xn--')->xname, 'xn--', 'IDN bogus domain->xname' ); exception( 'new(invalid name)', sub { Net::DNS::Domain->new( pack 'U*', 65533, 92, 48, 65533 ) } ); exit; Net-DNS-1.50/t/00-load.t0000644000175000017500000000361514756035515013757 0ustar willemwillem#!/usr/bin/perl # $Id: 00-load.t 1896 2023-01-30 12:59:25Z willem $ -*-perl-*- # use strict; use warnings; use IO::File; use Test::More; my @module = qw(Net::DNS); my %metadata; my $handle = IO::File->new('MYMETA.json') || IO::File->new('META.json'); if ($handle) { my $json = join '', (<$handle>); for ($json) { s/\s:\s/ => /g; # Perl? en voilà! my $hashref = eval $_; ## no critic %metadata = %$hashref; } close $handle; } my %prerequisite; foreach ( values %{$metadata{prereqs}} ) { # build, runtime, etc. foreach ( values %$_ ) { # requires $prerequisite{$_}++ for keys %$_; } delete @prerequisite{@module}; delete $prerequisite{perl}; } my @diag; foreach my $module ( @module, sort keys %prerequisite ) { eval "require $module"; ## no critic for ( eval { $module->VERSION || () } ) { s/^(\d+\.\d)$/${1}0/; push @diag, sprintf "%-25s %s", $module, $_; } } diag join "\n\t", "\nThese tests were run using:", @diag; plan tests => 20 + scalar(@Net::DNS::EXPORT); use_ok('Net::DNS'); is( Net::DNS->version, $Net::DNS::VERSION, 'Net::DNS->version' ); # # Check on-demand loading using this (incomplete) list of RR packages my @rrs = qw( A AAAA CNAME MX NS NULL PTR SOA TXT ); sub is_rr_loaded { my $rr = shift; return $INC{"Net/DNS/RR/$rr.pm"} ? 1 : 0; } # # 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 { Net::DNS::RR->new( 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 foreach my $sym (@Net::DNS::EXPORT) { ok( defined &{$sym}, "$sym is imported" ); } exit; __END__ Net-DNS-1.50/t/05-AMTRELAY.t0000644000175000017500000000416514756035515014264 0ustar willemwillem#!/usr/bin/perl # $Id: 05-AMTRELAY.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 26; use TestToolkit; use Net::DNS; my $name = '12.100.51.198.in-addr.arpa'; my $type = 'AMTRELAY'; my $code = 260; my @attr = qw( precedence D relaytype relay ); my @data = qw( 10 1 3 amtrelays.example.com ); my @also = qw( ); my $wire = '0a8309616d7472656c617973076578616d706c6503636f6d00'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new("$name $type @data") ) { foreach ( undef, qw(192.0.2.38 2001:db8:0:8002:0:0:2000:1 relay.example.com) ) { my $relay = $_ || '.'; $rr->D( !$rr->D ); # toggle D-bit $rr->relay($relay); is( scalar( $rr->relay ), $_, "rr->relay( '$relay' )" ); my $rr2 = Net::DNS::RR->new( $rr->string ); is( $rr2->rdstring, $rr->rdstring, 'new/string transparent' ); my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); is( $decoded->rdstring, $rr->rdstring, 'encode/decode transparent' ); } } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "$_ attribute of empty RR undefined" ); } exception( 'unrecognised relay ttype', sub { $rr->relay('X') } ); } Net::DNS::RR->new("$name $type @data")->print; exit; Net-DNS-1.50/t/31-NSEC3-base32.t0000644000175000017500000000210514756035515014725 0ustar willemwillem#!/usr/bin/perl # $Id: 31-NSEC3-base32.t 1856 2021-12-02 14:36:25Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use Net::DNS; my @prerequisite = qw( Net::DNS::RR::NSEC3 ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 30; my %testcase = ( chr(85) x 1 => 'ak', chr(85) x 2 => 'alag', chr(85) x 3 => 'alala', chr(85) x 4 => 'alalal8', chr(85) x 5 => 'alalalal', chr(85) x 6 => 'alalalalak', chr(85) x 7 => 'alalalalalag', chr(85) x 8 => 'alalalalalala', chr(85) x 9 => 'alalalalalalal8', chr(85) x 10 => 'alalalalalalalal', ); foreach my $binary ( sort keys %testcase ) { my $base32 = $testcase{$binary}; my $encode = Net::DNS::RR::NSEC3::_encode_base32hex($binary); my $decode = Net::DNS::RR::NSEC3::_decode_base32hex($base32); is( $encode, $base32, 'base32hex encode correct' ); is( length($decode), length($binary), 'decode length correct' ); ok( $decode eq $binary, 'base32hex decode correct' ); } exit; __END__ Net-DNS-1.50/t/05-HIP.t0000644000175000017500000000600114756035515013455 0ustar willemwillem#!/usr/bin/perl # $Id: 05-HIP.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use TestToolkit; use Net::DNS; my @prerequisite = qw( MIME::Base64 ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 19; my $name = 'HIP.example'; my $type = 'HIP'; my $code = 55; my @attr = qw( algorithm hit key servers ); my @data = qw( 2 200100107b1a74df365639cc39f1d578 AwEAAbdxyhNuSutc5EMzxTs9LBPCIkOFH8cIvM4p9+LrV4e19WzK00+CI6zBCQTdtWsuxKbWIy87UOoJTwkUs7lBu+Upr1gsNrut79ryra+bSRGQb1slImA8YVJyuIDsj7kwzG7jnERNqnWxZ48AWkskmdHaVDP4BcelrTI3rMXdXF5D rvs1.example.com rvs2.example.com ); my @also = qw( keybin ); my $wire = join '', qw( 10020084200100107b1a74df365639cc39f1d57803010001b771ca136e4aeb5c e44333c53b3d2c13c22243851fc708bcce29f7e2eb5787b5f56ccad34f8223ac c10904ddb56b2ec4a6d6232f3b50ea094f0914b3b941bbe529af582c36bbadef daf2adaf9b4911906f5b2522603c615272b880ec8fb930cc6ee39c444daa75b1 678f005a4b2499d1da5433f805c7a5ad3237acc5dd5c5e430472767331076578 616d706c6503636f6d000472767332076578616d706c6503636f6d00 ); my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { next if /server/; is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } for (qw(servers)) { my ($rvs) = $rr->$_; # test limitation: single element list is( $rvs, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } } for my $rr ( Net::DNS::RR->new("$name $type @data") ) { my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); my $emptyrr = Net::DNS::RR->new("$name $type")->encode; my $corrupt = pack 'a*X2na*', $emptyrr, $decoded->rdlength - 1, $rr->rdata; exception( 'corrupt wire-format', sub { Net::DNS::RR->decode( \$corrupt ) } ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } exception( 'corrupt hexadecimal', sub { $rr->hit('123456789XBCDEF') } ); noexception( 'deprecate pkalgorithm', sub { $rr->pkalgorithm for ( 1 .. 2 ) } ); noexception( 'deprecate pubkey', sub { $rr->pubkey for ( 1 .. 2 ) } ); noexception( 'deprecate rendezvousservers', sub { $rr->rendezvousservers for ( 1 .. 2 ) } ); } Net::DNS::RR->new("$name $type @data")->print; exit; Net-DNS-1.50/t/05-SRV.t0000644000175000017500000000266014756035515013516 0ustar willemwillem#!/usr/bin/perl # $Id: 05-SRV.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 13; use Net::DNS; my $name = '_foo._tcp.example.com'; my $type = 'SRV'; my $code = 33; my @attr = qw( priority weight port target ); my @data = qw( 1 3 9 fast.example.com ); my @also = qw( ); my $wire = '0001000300090466617374076578616d706c6503636f6d00'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } exit; Net-DNS-1.50/t/37-NSEC3-encloser.t0000644000175000017500000000265414756035515015477 0ustar willemwillem#!/usr/bin/perl # $Id: 37-NSEC3-encloser.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use Net::DNS; use Net::DNS::ZoneFile; my @prerequisite = qw( Digest::SHA Net::DNS::RR::NSEC3 ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 4; ## Based on examples from RFC5155, Appendix B my @nsec3 = Net::DNS::ZoneFile->parse( <<'END' ); 0p9mhaveqvm6t7vbl5lop2u3t2rp3tom.example. IN NSEC3 ( 1 1 12 aabbccdd 2t7b4g4vsa5smi47k61mv5bv1a22bojr NS SOA MX RRSIG DNSKEY NSEC3PARAM ) b4um86eghhds6nea196smvmlo4ors995.example. IN NSEC3 ( 1 1 12 aabbccdd gjeqe526plbf1g8mklp59enfd789njgi MX RRSIG ) 35mthgpgcu1qg68fab165klnsnk3dpvl.example. IN NSEC3 ( 1 1 12 aabbccdd b4um86eghhds6nea196smvmlo4ors995 NS DS RRSIG ) END my $encloser; my $nextcloser; my $wildcard; foreach my $nsec3 (@nsec3) { for ( $nsec3->encloser('a.c.x.w.example') ) { next unless $nsec3->match($_); next if $encloser && length($encloser) > length; $encloser = $_; $nextcloser = $nsec3->nextcloser; $wildcard = $nsec3->wildcard; } } is( $encloser, 'x.w.example', 'closest (provable) encloser' ); is( $nextcloser, 'c.x.w.example', 'next closer name' ); is( $wildcard, '*.x.w.example', 'wildcard at closest encloser' ); is( $nsec3[0]->encloser('a.n.other'), undef, 'reject name out of zone' ); exit; __END__ Net-DNS-1.50/t/00-install.t0000644000175000017500000000240714756035515014504 0ustar willemwillem#!/usr/bin/perl # $Id: 00-install.t 1858 2021-12-08 10:32:12Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use File::Spec; use File::Find; use IO::File; use ExtUtils::MakeMaker; my %manifest; my $handle = IO::File->new( 'MANIFEST', '<' ) or BAIL_OUT("MANIFEST: $!"); while (<$handle>) { my ($filename) = split; $manifest{$filename}++; } close $handle; 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 keys %manifest; my @diag; foreach ( sort keys %manifest ) { # reconcile files with MANIFEST next unless ok( -f $_, "file exists\t$_" ); next unless /\.pm$/; next unless /^lib/; my $module = File::Spec->catfile( 'blib', $_ ); # library component push @diag, "Missing module: $module" unless -f $module; my $version = MM->parse_version($_); # module version push @diag, "\$VERSION = $version\t$_" unless $version =~ /^\d/; } my @files; # flag MANIFEST omissions find( sub { push( @files, $File::Find::name ) if /\.pm$/ }, 'lib' ); foreach ( sort @files ) { next if /Template.pm$/; push @diag, "Filename not in MANIFEST: $_" unless $manifest{$_}; } diag join "\n\t", '', @diag if @diag; exit; __END__ Net-DNS-1.50/t/05-DNAME.t0000644000175000017500000000257314756035515013673 0ustar willemwillem#!/usr/bin/perl # $Id: 05-DNAME.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 8; use Net::DNS; my $name = 'DNAME.example'; my $type = 'DNAME'; my $code = 39; my @attr = qw( target ); my @data = qw( example.com ); my @also = qw( dname ); my $wire = '076578616d706c6503636f6d00'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } exit; Net-DNS-1.50/t/36-NSEC3-covered.t0000644000175000017500000001245714756035515015315 0ustar willemwillem#!/usr/bin/perl # $Id: 36-NSEC3-covered.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use Net::DNS; my @prerequisite = qw( Digest::SHA Net::DNS::RR::NSEC3 ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 16; ## Tests based on example zone from RFC5155, Appendix A my %H = ( 'example' => '0p9mhaveqvm6t7vbl5lop2u3t2rp3tom', 'ns1.example' => '2t7b4g4vsa5smi47k61mv5bv1a22bojr', 'x.y.w.example' => '2vptu5timamqttgl4luu9kg21e0aor3s', 'a.example' => '35mthgpgcu1qg68fab165klnsnk3dpvl', 'x.w.example' => 'b4um86eghhds6nea196smvmlo4ors995', 'ai.example' => 'gjeqe526plbf1g8mklp59enfd789njgi', 'y.w.example' => 'ji6neoaepv8b5o6k4ev33abha8ht9fgc', 'w.example' => 'k8udemvp1j2f7eg6jebps17vp3n8i58h', 'ns2.example' => 'q04jkcevqvmu85r014c7dkba38o0ji5r', '*.w.example' => 'r53bq7cc2uvmubfu5ocmm6pers9tk9en', 'xx.example' => 't644ebqk9bibcna874givr6joj62mlhv', ); my %name = reverse %H; foreach ( sort keys %name ) { print "$_\t$name{$_}\n" } ## Exercise examples from RFC5155, Appendix B my $rr1 = Net::DNS::RR->new( "0p9mhaveqvm6t7vbl5lop2u3t2rp3tom.example. NSEC3 1 1 12 aabbccdd ( 2t7b4g4vsa5smi47k61mv5bv1a22bojr MX DNSKEY NS SOA NSEC3PARAM RRSIG )" ); ok( $rr1->covers('a.c.x.w.example'), 'B.1(1): NSEC3 covers "next closer" name (c.x.w.example.)' ); # Name Error my $rr2 = Net::DNS::RR->new( "b4um86eghhds6nea196smvmlo4ors995.example. NSEC3 1 1 12 aabbccdd ( gjeqe526plbf1g8mklp59enfd789njgi MX RRSIG )" ); ok( !$rr2->covers('a.c.x.w.example'), 'B.1(2): NSEC3 matches closest encloser (x.w.example.)' ); my $rr3 = Net::DNS::RR->new( "35mthgpgcu1qg68fab165klnsnk3dpvl.example. NSEC3 1 1 12 aabbccdd ( b4um86eghhds6nea196smvmlo4ors995 NS DS RRSIG )" ); ok( $rr3->covers('*.x.w.example'), 'B.1(3): NSEC3 covers wildcard at closest encloser (*.x.w.example.)' ); my $rr4 = Net::DNS::RR->new( "2t7b4g4vsa5smi47k61mv5bv1a22bojr.example. NSEC3 1 1 12 aabbccdd ( 2vptu5timamqttgl4luu9kg21e0aor3s A RRSIG )" ); ok( !$rr4->covers('ns1.example'), 'B.2: NSEC3 matches QNAME (ns1.example.) proving MX and CNAME absent' ) ; # No Data Error my $rr5 = Net::DNS::RR->new( "ji6neoaepv8b5o6k4ev33abha8ht9fgc.example. NSEC3 1 1 12 aabbccdd ( k8udemvp1j2f7eg6jebps17vp3n8i58h )" ); ok( !$rr5->covers('y.w.example'), 'B.2.1: NSEC3 matches QNAME (y.w.example.) proving A absent' ) ; # No Data, Empty Non-Terminal my $rr6 = Net::DNS::RR->new( "35mthgpgcu1qg68fab165klnsnk3dpvl.example. NSEC3 1 1 12 aabbccdd ( b4um86eghhds6nea196smvmlo4ors995 NS DS RRSIG )" ); ok( $rr6->covers('mc.c.example'), 'B.3(1): NSEC3 covers "next closer" name (c.example.)' ) ; # Referral to an Opt_Out Unsigned Zone my $rr7 = Net::DNS::RR->new( "0p9mhaveqvm6t7vbl5lop2u3t2rp3tom.example. NSEC3 1 1 12 aabbccdd ( 2t7b4g4vsa5smi47k61mv5bv1a22bojr MX DNSKEY NS SOA NSEC3PARAM RRSIG )" ); ok( !$rr7->covers('mc.c.example'), 'B.3(2): NSEC3 matches closest provable encloser (example.)' ); my $rr8 = Net::DNS::RR->new( "q04jkcevqvmu85r014c7dkba38o0ji5r.example. NSEC3 1 1 12 aabbccdd ( r53bq7cc2uvmubfu5ocmm6pers9tk9en A RRSIG )" ); ok( $rr8->covers('a.z.w.example'), 'B.4: NSEC3 covers "next closer" name (z.w.example.)' ); # Wildcard Expansion my $rr9 = Net::DNS::RR->new( "k8udemvp1j2f7eg6jebps17vp3n8i58h.example. NSEC3 1 1 12 aabbccdd ( kohar7mbb8dc2ce8a9qvl8hon4k53uhi )" ); ok( !$rr9->covers('a.z.w.example'), 'B.5(1): NSEC3 matches closest encloser (w.example.)' ); # Wildcard No Data Error my $rr10 = Net::DNS::RR->new( "q04jkcevqvmu85r014c7dkba38o0ji5r.example. NSEC3 1 1 12 aabbccdd ( r53bq7cc2uvmubfu5ocmm6pers9tk9en A RRSIG )" ); ok( $rr10->covers('a.z.w.example'), 'B.5(2): NSEC3 covers "next closer" name (z.w.example.)' ); my $rr11 = Net::DNS::RR->new( "r53bq7cc2uvmubfu5ocmm6pers9tk9en.example. NSEC3 1 1 12 aabbccdd ( t644ebqk9bibcna874givr6joj62mlhv MX RRSIG )" ); ok( !$rr11->covers('*.w.example'), 'B.5(3): NSEC3 matches wildcard at closest encloser (*.w.example)' ); my $rr12 = Net::DNS::RR->new( "0p9mhaveqvm6t7vbl5lop2u3t2rp3tom.example. NSEC3 1 1 12 aabbccdd ( 2t7b4g4vsa5smi47k61mv5bv1a22bojr MX DNSKEY NS SOA NSEC3PARAM RRSIG )" ); ok( !$rr12->covers('example'), 'B.6: NSEC3 matches QNAME (example.) DS type bit not set' ) ; # DS Child Zone No Data Error ## covers() returns false for hashed name not strictly between ownerhash and nexthash my $rr13 = Net::DNS::RR->new( "0p9mhaveqvm6t7vbl5lop2u3t2rp3tom.example. NSEC3 1 1 12 aabbccdd ( 2t7b4g4vsa5smi47k61mv5bv1a22bojr A RRSIG )" ); ok( !$rr13->covers('.'), 'ancestor name not covered (.)' ); # too few matching labels my $rr14 = Net::DNS::RR->new( "q04jkcevqvmu85r014c7dkba38o0ji5r.example. NSEC3 1 1 12 aabbccdd ( 53bq7cc2uvmubfu5ocmm6pers9tk9en A RRSIG )" ); ok( !$rr14->covers('unrelated.name'), 'name out of zone not covered (unrelated.name.)' ); # non-matching label my $rr15 = Net::DNS::RR->new( "0p9mhaveqvm6t7vbl5lop2u3t2rp3tom.example. NSEC3 1 1 12 aabbccdd ( 2t7b4g4vsa5smi47k61mv5bv1a22bojr )" ); ok( !$rr15->covers('example'), 'owner name not covered (example.)' ); my $rr16 = Net::DNS::RR->new( "0p9mhaveqvm6t7vbl5lop2u3t2rp3tom.example. NSEC3 1 1 12 aabbccdd ( 2t7b4g4vsa5smi47k61mv5bv1a22bojr )" ); ok( !$rr16->covers('ns1.example'), 'next hashed name not covered (ns1.example.)' ); exit; __END__ Net-DNS-1.50/t/05-HTTPS.t0000644000175000017500000000325214756035515013744 0ustar willemwillem#!/usr/bin/perl # $Id: 05-HTTPS.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 9; use Net::DNS; my $name = 'alias.example'; my $type = 'HTTPS'; my $code = 65; my @attr = qw( svcpriority targetname ); my @data = qw( 0 pool.svc.example ); my @also = qw( ); my $wire = '000004706f6f6c03737663076578616d706c6500'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } Net::DNS::RR->new( <<'END' )->print; blog.cloudflare.com. 300 IN HTTPS ( 1 . key1=\005h3-29\005h3-28\005h3-27\002h2 key4=h\018\026.h\018\027. key6=&\006G\000\000\000\000\000\000\000\000\000h\018\026.&\006G\000\000\000\000\000\000\000\000\000h\018\027. key65280 ) END exit; Net-DNS-1.50/t/05-KEY.t0000644000175000017500000000375314756035515013500 0ustar willemwillem#!/usr/bin/perl # $Id: 05-KEY.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use Net::DNS; my @prerequisite = qw( MIME::Base64 ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 16; my $name = 'KEY.example'; my $type = 'KEY'; my $code = 25; my @attr = qw( flags protocol algorithm publickey ); my @data = ( 256, 3, 5, join '', qw( AQPSKmynfzW4kyBv015MUG2DeIQ3 Cbl+BBZH4b/0PY1kxkmvHjcZc8no kfzj31GajIQKY+5CptLr3buXA10h WqTkF7H6RfoRqXQeogmMHfpftf6z Mv1LyBUgia7za6ZEzOJBOztyvhjL 742iU/TpPSEDhm2SNKLijfUppn1U aNvv4w== ) ); my @also = qw( keybin keylength keytag privatekeyname zone revoke sep ); my $wire = join '', qw( 010003050103D22A6CA77F35B893206FD35E4C506D8378843709B97E041647E1 BFF43D8D64C649AF1E371973C9E891FCE3DF519A8C840A63EE42A6D2EBDDBB97 035D215AA4E417B1FA45FA11A9741EA2098C1DFA5FB5FEB332FD4BC8152089AE F36BA644CCE2413B3B72BE18CBEF8DA253F4E93D2103866D9234A2E28DF529A6 7D5468DBEFE3 ); my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = uc unpack 'H*', $decoded->encode; my $hex2 = uc unpack 'H*', $encoded; my $hex3 = uc unpack 'H*', $rr->rdata; is( $hex1, $hex2, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } exit; Net-DNS-1.50/t/05-IPSECKEY.t0000644000175000017500000000505114756035515014255 0ustar willemwillem#!/usr/bin/perl # $Id: 05-IPSECKEY.t 1911 2023-04-17 12:30:59Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use TestToolkit; use Net::DNS; my @prerequisite = qw( MIME::Base64 ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 31; my $name = '38.2.0.192.in-addr.arpa'; my $type = 'IPSECKEY'; my $code = 45; my @attr = qw( precedence gatetype algorithm gateway key ); my @data = qw( 10 3 2 gateway.example.com AQNRU3mG7TVTO2BkR47usntb102uFJtugbo6BSGvgqt4AQ== ); my @also = qw( pubkey keybin ); my $wire = '0a03020767617465776179076578616d706c6503636f6d00010351537986ed35533b6064478eeeb27b5bd74dae149b6e81ba3a0521af82ab7801'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new("$name $type @data") ) { foreach ( undef, qw(192.0.2.38 2001:db8:0:8002:0:0:2000:1 gateway.example.com) ) { my $gateway = $_ || '.'; $rr->gateway($gateway); is( scalar( $rr->gateway ), $_, "rr->gateway( '$gateway' )" ); my $rr2 = Net::DNS::RR->new( $rr->string ); is( $rr2->rdstring, $rr->rdstring, 'new/string transparent' ); my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); is( $decoded->rdstring, $rr->rdstring, 'encode/decode transparent' ); } } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "$_ attribute of empty RR undefined" ); } } exception( 'exception raised in decode', sub { Net::DNS::RR->new(". $type \\# 3 01ff05") } ); exception( 'exception raised in gateway', sub { Net::DNS::RR->new( type => $type )->gateway('X') } ); Net::DNS::RR->new("$name $type @data")->print; exit; Net-DNS-1.50/t/05-HINFO.t0000644000175000017500000000257414756035515013713 0ustar willemwillem#!/usr/bin/perl # $Id: 05-HINFO.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 9; use Net::DNS; my $name = 'HINFO.example'; my $type = 'HINFO'; my $code = 13; my @attr = qw( cpu os ); my @data = qw( VAX-11/750 VMS ); my @also = qw( ); my $wire = '0a5641582d31312f37353003564d53'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } exit; Net-DNS-1.50/t/01-resolver-flags.t0000644000175000017500000000211014756035515015761 0ustar willemwillem#!/usr/bin/perl # $Id: 01-resolver-flags.t 1815 2020-10-14 21:55:18Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 23; use Net::DNS::Resolver; local $ENV{'RES_NAMESERVERS'}; local $ENV{'RES_SEARCHLIST'}; local $ENV{'LOCALDOMAIN'}; local $ENV{'RES_OPTIONS'}; my $res = Net::DNS::Resolver->new(); ok( $res->isa('Net::DNS::Resolver'), 'new() created object' ); ok( !$res->dnssec(), "default dnssec flag off" ); my $udpsize = $res->udppacketsize(); $res->dnssec(1); ok( $res->dnssec(), "dnssec flag toggles on" ); my $size = $res->udppacketsize(); isnt( $size, $udpsize, "dnssec(1) sets udppacketsize ($size)" ); $res->dnssec(0); ok( !$res->dnssec(), "dnssec flag toggles off" ); my @flag = qw(adflag cdflag force_v4 force_v6 prefer_v4 prefer_v6); foreach my $flag (@flag) { my $default = $res->$flag(); my $changed = $default ? 0 : 1; ok( defined $default, "default $flag $default" ); $res->$flag($changed); is( $res->$flag(), $changed, "toggle $flag $changed" ); $res->$flag($default); is( $res->$flag(), $default, "toggle $flag $default" ); } exit; Net-DNS-1.50/t/01-resolver-env.t0000644000175000017500000000201614756035515015462 0ustar willemwillem#!/usr/bin/perl # $Id: 01-resolver-env.t 1815 2020-10-14 21:55:18Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 10; use Net::DNS::Resolver; local $ENV{'RES_NAMESERVERS'} = '10.0.3.128 10.0.4.128'; local $ENV{'RES_SEARCHLIST'} = 'net-dns.org lib.net-dns.org'; local $ENV{'LOCALDOMAIN'} = 'net-dns.org'; local $ENV{'RES_OPTIONS'} = 'retrans:3 retry:2 debug bogus'; my $res = Net::DNS::Resolver->new; ok( $res->isa('Net::DNS::Resolver'), 'new() created object' ); is( $res->domain, 'net-dns.org', 'domain works' ); my @search = $res->searchlist; is( $search[0], 'net-dns.org', 'searchlist correct' ); is( $search[1], 'lib.net-dns.org', 'searchlist correct' ); my @servers = $res->nameservers; ok( scalar(@servers), "nameservers() works" ); is( $servers[0], '10.0.3.128', 'nameservers list correct' ); is( $servers[1], '10.0.4.128', 'nameservers list correct' ); is( $res->retrans, 3, 'retrans works' ); is( $res->retry, 2, 'retry works' ); is( $res->debug, 1, 'debug() works' ); exit; Net-DNS-1.50/t/05-RP.t0000644000175000017500000000265614756035515013372 0ustar willemwillem#!/usr/bin/perl # $Id: 05-RP.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 9; use Net::DNS; my $name = 'RP.example'; my $type = 'RP'; my $code = 17; my @attr = qw( mbox txtdname ); my @data = qw( rp@example.com txt.example.net ); my @also = qw( ); my $wire = '027270076578616d706c6503636f6d0003747874076578616d706c65036e657400'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } exit; Net-DNS-1.50/t/05-LOC.t0000644000175000017500000000272014756035515013456 0ustar willemwillem#!/usr/bin/perl # $Id: 05-LOC.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 21; use Net::DNS; my $name = 'LOC.example'; my $type = 'LOC'; my $code = 29; my @attr = qw( latitude longitude altitude size hp vp ); my @data = qw( 42.35799 -71.014338 -44 2000 10 10 ); my @also = qw( version latlon horiz_pre vert_pre ); my $wire = '002513138916cb3c70c310df00988550'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } exit; Net-DNS-1.50/t/05-DHCID.t0000644000175000017500000000277514756035515013666 0ustar willemwillem#!/usr/bin/perl # $Id: 05-DHCID.t 2003 2025-01-21 12:06:06Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use Net::DNS; my @prerequisite = qw( MIME::Base64 ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 11; my $name = 'DHCID.example'; my $type = 'DHCID'; my $code = 49; my @attr = qw( identifiertype digesttype digest ); my @data = qw(); my @also = qw(); my $data = 'AAIBT2JmdXNjYXRlZElkZW50aXR5RGF0YQ=='; my $wire = '0002014f6266757363617465644964656e7469747944617461'; for my $rr ( Net::DNS::RR->new( type => $type ) ) { my $typecode = unpack 'xn', $rr->encode; is( $typecode, $code, "$type RR type code = $code" ); like( $rr->string, '/no data/i', "empty $type record" ); foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } for my $rr ( Net::DNS::RR->new("$name $type $data") ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); foreach (@attr) { is( defined( $rr->$_ ), 1, "'$_' attribute defined" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } Net::DNS::RR->new("$name $type $data")->print; exit; Net-DNS-1.50/t/03-rr.t0000644000175000017500000002073114756035515013464 0ustar willemwillem#!/usr/bin/perl # $Id: 03-rr.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 106; use TestToolkit; use_ok('Net::DNS::RR'); foreach my $testcase ( ## check plausible ways to create empty record 'example.com A', 'example.com IN', 'example.com IN A', 'example.com IN 123 A', 'example.com 123 A', 'example.com 123 IN A', 'example.com 123 In Aaaa', 'example.com A \\# 0', ) { my $rr = Net::DNS::RR->new("$testcase"); is( length( $rr->rdata ), 0, "Net::DNS::RR->new( $testcase )" ); } my ( $name, $class, $ttl, $type, $rdata ) = qw(example.com IN 123 A 192.0.2.1); for my $rr ( Net::DNS::RR->new("$name $ttl $class $type $rdata") ) { my $rdlen = length $rr->rdata; ## check basic functions is( $rr->name, $name, 'expected value returned by $rr->name' ); is( $rr->owner, $name, 'expected value returned by $rr->owner' ); is( $rr->type, $type, 'expected value returned by $rr->type' ); is( $rr->class, $class, 'expected value returned by $rr->class' ); is( $rr->TTL, $ttl, 'expected value returned by $rr->TTL' ); is( $rr->rdstring, $rdata, 'expected value returned by $rr->rdstring' ); is( $rr->rdlength, $rdlen, 'expected value returned by $rr->rdlength' ); } for my $example ( Net::DNS::RR->new('example.com. 0 IN A 192.0.2.1') ) { my $expect = $example->string; ## check basic parsing of all acceptable forms of A record foreach my $testcase ( join( "\t", qw( example.com 0 IN A ), q(\# 4 c0 00 02 01) ), join( "\t", qw( example.com 0 IN A ), q(\# 4 c0000201 ) ), 'example.com 0 IN A 192.0.2.1', 'example.com 0 IN TYPE1 192.0.2.1', 'example.com 0 CLASS1 A 192.0.2.1', 'example.com 0 CLASS1 TYPE1 192.0.2.1', 'example.com 0 A 192.0.2.1', 'example.com 0 TYPE1 192.0.2.1', 'example.com IN A 192.0.2.1', 'example.com IN TYPE1 192.0.2.1', 'example.com CLASS1 A 192.0.2.1', 'example.com CLASS1 TYPE1 192.0.2.1', 'example.com A 192.0.2.1', 'example.com TYPE1 192.0.2.1', 'example.com IN 0 A 192.0.2.1', 'example.com IN 0 TYPE1 192.0.2.1', 'example.com CLASS1 0 A 192.0.2.1', 'example.com CLASS1 0 TYPE1 192.0.2.1', ) { my $rr = Net::DNS::RR->new("$testcase"); $rr->ttl( $example->ttl ); # TTL only shown if defined is( $rr->string, $expect, "Net::DNS::RR->new( $testcase )" ); } } for my $example ( Net::DNS::RR->new('example.com. 0 IN TXT "txt-data"') ) { my $expect = $example->string; ## check parsing of comments, quotes and brackets foreach my $testcase ( q(example.com 0 IN TXT txt-data ; space delimited), q(example.com 0 TXT txt-data), q(example.com IN TXT txt-data), q(example.com TXT txt-data), q(example.com IN 0 TXT txt-data), q(example.com 0 IN TXT txt-data ; tab delimited), q(example.com 0 TXT txt-data), q(example.com IN TXT txt-data), q(example.com TXT txt-data), q(example.com IN 0 TXT txt-data), q(example.com 0 IN TXT "txt-data" ; "quoted"), q(example.com 0 TXT "txt-data"), q(example.com IN TXT "txt-data"), q(example.com TXT "txt-data"), q(example.com IN 0 TXT "txt-data"), 'example.com ( 0 IN TXT txt-data ) ; bracketed', ) { my $rr = Net::DNS::RR->new("$testcase"); $rr->ttl( $example->ttl ); # TTL only shown if defined is( $rr->string, $expect, "Net::DNS::RR->new( $testcase )" ); } } foreach my $testcase ( ## check object construction from attribute list [type => 'A', address => '192.0.2.1'], [type => 'A', address => ['192.0.2.1']], ) { my $rdata = Net::DNS::RR->new(@$testcase)->rdata; my @array = map { ref($_) ? "[@$_]" : $_ } @$testcase; is( length($rdata), 4, "Net::DNS::RR->new(@array)" ); } foreach my $testcase ( [type => 'A', rdata => ''], [name => 'example.com', type => 'MX'], [type => 'MX', class => 'IN', ttl => 123], ) { my $rr = Net::DNS::RR->new(@$testcase); is( length( $rr->rdstring ), 0, "Net::DNS::RR->new( @$testcase )" ); } foreach my $testcase ( ## check encode/decode functions 'example.com A', 'example.com IN', 'example.com IN A', 'example.com IN 123 A', 'example.com 123 A', 'example.com 123 IN A', 'example.com A 192.0.2.1', '1.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.8.B.D.0.1.0.0.2.ip6.arpa PTR example.com.' ) { my $rr = Net::DNS::RR->new("$testcase"); my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); $rr->ttl( $decoded->ttl ) unless $rr->ttl; is( $decoded->string, $rr->string, "encode/decode $testcase" ); } for my $rr ( Net::DNS::RR->new( type => 'OPT' ) ) { my $encoded = $rr->encode; ## check OPT decode special case my ( $decoded, $offset ) = Net::DNS::RR->decode( \$encoded ); is( $offset, length($encoded), 'decode OPT RR' ); } foreach my $testcase ( ## check canonical encode function 'example.com 0 IN A', 'EXAMPLE.com 123 A 192.0.2.1', ) { my $rr = Net::DNS::RR->new("$testcase"); my $expected = unpack 'H*', $rr->encode(0); my $canonical = unpack 'H*', $rr->canonical; is( $canonical, $expected, "canonical encode $testcase" ); } foreach my $testcase ( ## check plain and generic formats [owner => 'example.com.', type => 'A'], [owner => 'example.com.', type => 'A', rdata => ''], ['example.com. IN NS a.iana-servers.net.'], [ 'example.com. IN SOA ( sns.dns.icann.org. noc.dns.icann.org. 2015082417 ;serial 7200 ;refresh 3600 ;retry 1209600 ;expire 3600 ;minimum )' ], [owner => 'example.com.', type => 'ATMA'], ## unimplemented [owner => 'example.com.', type => 'ATMA', rdata => ''], [owner => 'example.com.', type => 'ATMA', rdata => 'octets'], ) { my $rr = Net::DNS::RR->new(@$testcase); my $type = $rr->type; my $plain = Net::DNS::RR->new( $rr->plain ); is( $plain->string, $rr->string, "parse rr->plain format $type" ); my $rfc3597 = Net::DNS::RR->new( $rr->generic ); is( $rfc3597->string, $rr->string, "parse rr->generic format $type" ); } foreach my $attr ( [], ['preference'], ['X'] ) { ## check RR sorting functions my $func = Net::DNS::RR::MX->get_rrsort_func(@$attr); is( ref($func), 'CODE', "MX->get_rrsort_func(@$attr)" ); } eval { ## no critic # exercise printing functions require Data::Dumper; require IO::File; local $Data::Dumper::Maxdepth; local $Data::Dumper::Sortkeys; local $Data::Dumper::Useqq; my $object = Net::DNS::RR->new('example.com A 192.0.2.1'); my $file = "03-rr.tmp"; my $handle = IO::File->new( $file, '>' ) || die "Could not open $file for writing"; select( ( select($handle), $object->print )[0] ); select( ( select($handle), $object->dump )[0] ); $Data::Dumper::Maxdepth = 6; $Data::Dumper::Sortkeys = 1; $Data::Dumper::Useqq = 1; select( ( select($handle), $object->dump )[0] ); close($handle); unlink($file); Net::DNS::RR::_wrap( 'exercise', '', "\n", "\n", "line\n", 'wrapping' ); }; is( Net::DNS::RR->new( type => 'A' )->DESTROY, undef, 'DESTROY() exists to placate pre-5.18 AUTOLOAD' ); exception( 'unrecognised class method', sub { Net::DNS::RR->unknown() } ); noexception( 'RR->unknown() returns undef', sub { die if defined Net::DNS::RR->unknown() } ); exception( "unparsable RR->new(undef)", sub { Net::DNS::RR->new(undef) } ); exception( "unparsable RR->new( [] )", sub { Net::DNS::RR->new( [] ) } ); exception( "unparsable RR->new( {} )", sub { Net::DNS::RR->new( {} ) } ); exception( "unparsable RR->new('()')", sub { Net::DNS::RR->new('()') } ); exception( "unparsable RR->new('. NULL x')", sub { Net::DNS::RR->new('. NULL x') } ); exception( "unparsable RR->new('. ATMA x')", sub { Net::DNS::RR->new('. ATMA x') } ); exception( "unparsable RR->new('. BOGUS x')", sub { Net::DNS::RR->new('. BOGUS x') } ); foreach ( '# 0 c0000201', '# 3 c0000201', '# 5 c0000201' ) { exception( "mismatched length $_", sub { Net::DNS::RR->new(". A $_") } ); } exception( 'RR type is immutable', sub { Net::DNS::RR->new( type => 'AAAA' )->type('BOGUS') } ); exception( 'unrecognised time unit', sub { Net::DNS::RR->new( type => 'AAAA' )->ttl('1y') } ); exception( 'unrecognised method', sub { Net::DNS::RR->new( type => 'AAAA', bogus => 0 ) } ); exception( 'unimplemented RRtype', sub { Net::DNS::RR->new( type => 'ATMA', bogus => 0 ) } ); exception( 'RR->string warning', sub { Net::DNS::RR->new( type => 'MINFO', emailbx => '.' )->string } ); exception( 'RR->rdstring warning', sub { Net::DNS::RR->new( type => 'MINFO', emailbx => '.' )->rdstring } ); foreach ( '', '0841424344454647480001', '0000010001000000010004', ) { exception( 'decode(corrupt data)', sub { Net::DNS::RR->decode( \pack 'H*', $_ ) } ); } exception( 'rdatastr deprecation warning', sub { Net::DNS::RR->new( type => 'AAAA' )->rdatastr for ( 1 .. 2 ) } ); exit; Net-DNS-1.50/t/72-TSIG-verify.t0000644000175000017500000001114214756035515015113 0ustar willemwillem#!/usr/bin/perl # $Id: 72-TSIG-verify.t 1990 2024-09-18 13:16:07Z willem $ -*-perl-*- # use strict; use warnings; use IO::File; use Test::More; use TestToolkit; use Net::DNS; my @prerequisite = qw( Digest::HMAC Digest::MD5 Digest::SHA MIME::Base64 ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 26; my $tsig = Net::DNS::RR->new( type => 'TSIG' ); my $class = ref($tsig); my $tsigkey = 'tsigkey72.txt'; END { unlink($tsigkey) if defined $tsigkey; } my $fh_tsigkey = IO::File->new( $tsigkey, '>' ) || die "$tsigkey $!"; print $fh_tsigkey <<'END'; key "host1-host2.example." { algorithm hmac-sha256; secret "f+JImRXRzLpKseG+bP+W9Vwb2QAgtFuIlRU80OA3NU8="; }; END close($fh_tsigkey); for my $packet ( Net::DNS::Packet->new('query.example') ) { $packet->sign_tsig($tsigkey); $packet->encode; my $verified = $packet->verify(); my $verifyerr = $packet->verifyerr(); ok( $verified, "verify signed packet $verifyerr" ); is( ref($verified), $class, 'packet->verify returns TSIG' ); } for my $packet ( Net::DNS::Packet->new('query.example') ) { $packet->sign_tsig($tsigkey); $packet->encode; $packet->push( update => rr_add( type => 'NULL' ) ); my $verified = $packet->verify(); my $verifyerr = $packet->verifyerr(); ok( !$verified, "verify corrupt packet $verifyerr" ); is( $verified, undef, 'packet->verify returns undef' ); } for my $query ( Net::DNS::Packet->new('query.example') ) { $query->sign_tsig($tsigkey); $query->encode; my $reply = $query->reply; $reply->sign_tsig($query); $reply->encode; my $verified = $reply->verify($query); my $verifyerr = $reply->verifyerr(); ok( $verified, "verify reply packet $verifyerr" ); } { my @packet = map { Net::DNS::Packet->new($_) } ( 0 .. 3 ); my $signed = $tsigkey; foreach my $packet (@packet) { $signed = $packet->sign_tsig($signed); $packet->encode; is( ref($signed), $class, 'sign multi-packet' ); } my @verified; foreach my $packet (@packet) { @verified = $packet->verify(@verified); my ($verified) = @verified; my $verifyerr = $packet->verifyerr(); ok( $verified, "verify multi-packet $verifyerr" ); } my @unverifiable; $packet[2]->sigrr->fudge(0); foreach my $packet (@packet) { @unverifiable = $packet->verify(@unverifiable); my $verifyerr = $packet->verifyerr(); ok( 1, "verify corrupt multi-packet $verifyerr" ); } my ($verified) = @unverifiable; is( $verified, undef, 'final packet->verify returns undef' ); } for my $packet ( Net::DNS::Packet->new('query.example') ) { $packet->sign_tsig( $tsigkey, fudge => 0 ); my $encoded = $packet->encode; sleep 2; # guarantee one complete second delay my $query = Net::DNS::Packet->new( \$encoded ); $query->verify(); is( $query->verifyerr, 'BADTIME', 'unverifiable query packet: BADTIME' ); } for my $packet ( Net::DNS::Packet->new() ) { $packet->sign_tsig($tsigkey); $packet->sigrr->error('BADTIME'); my $encoded = $packet->encode; my $decoded = Net::DNS::Packet->new( \$encoded ); ok( $decoded->sigrr->other, 'time appended to BADTIME response' ); } for my $query ( Net::DNS::Packet->new('query.example') ) { $query->sign_tsig($tsigkey); $query->encode; my $reply = $query->reply; $reply->sign_tsig($query); $reply->encode; $reply->sigrr->algorithm('hmac-sha1'); my $verified = $reply->verify($query); my $verifyerr = $reply->verifyerr(); ok( !$verified, "mismatched verify keys $verifyerr" ); } for my $packet ( Net::DNS::Packet->new('query.example') ) { $packet->sign_tsig($tsigkey); $packet->encode; my $tsig = $packet->reply->sign_tsig($tsigkey); $tsig->algorithm('hmac-sha1'); my $verified = $packet->verify($tsig); my $verifyerr = $packet->verifyerr(); ok( !$verified, "mismatched verify keys $verifyerr" ); } for my $packet ( Net::DNS::Packet->new() ) { $packet->sign_tsig($tsigkey); $packet->encode; $packet->sigrr->macbin( substr $packet->sigrr->macbin, 0, 9 ); $packet->verify(); is( $packet->verifyerr, 'BADTRUNC', 'signature too short: BADTRUNC' ); } for my $packet ( Net::DNS::Packet->new() ) { $packet->sign_tsig($tsigkey); $packet->encode; my $macbin = $packet->sigrr->macbin; $packet->sigrr->macbin( join '', $packet->sigrr->macbin, 'x' ); $packet->verify(); is( $packet->verifyerr, 'BADTRUNC', 'signature too long: BADTRUNC' ); } for my $packet ( Net::DNS::Packet->new() ) { $packet->sign_tsig($tsigkey); my $null = Net::DNS::RR->new( type => 'NULL' ); exception( 'unexpected argument', sub { $packet->sigrr->verify($null) } ); exception( 'unexpected argument', sub { $packet->sigrr->verify( $packet, $null ) } ); } exit; Net-DNS-1.50/t/05-RRSIG.t0000644000175000017500000001133714756035515013733 0ustar willemwillem#!/usr/bin/perl # $Id: 05-RRSIG.t 2005 2025-01-28 13:22:10Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use TestToolkit; use Net::DNS; my @prerequisite = qw( MIME::Base64 Time::Local ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 67; my $name = 'net-dns.org'; my $type = 'RRSIG'; my $code = 46; my @attr = qw( typecovered algorithm labels orgttl sigexpiration siginception keytag signame signature ); my @data = ( qw( NS 7 2 3600 20130914141655 20130815141655 60909 net-dns.org ), join '', qw( IRlCjYNZCkddjoFw6UGxAga/EvxgENl+IESuyRH9vlrys yqne0gPpclC++raP3+yRA+gDIHrMkIwsLudqod4iuoA73 Mw1NxETS6lm2eQTDNzLSY6dnJxZBqXypC3Of7bF3UmR/G NhcFIThuV/qFq+Gs+g0TJ6eyMF6ydYhjS31k= ) ); my @also = qw( sig sigin sigex vrfyerrstr ); my $wire = '0002070200000E1052346FD7520CE2D7EDED076E65742D646E73036F7267002119428D83590A475D8E8170E941B10206BF12FC6010D97E2044AEC911FDBE5AF2B32AA77B480FA5C942FBEADA3F7FB2440FA00C81EB324230B0BB9DAA87788AEA00EF7330D4DC444D2EA59B67904C33732D263A767271641A97CA90B739FEDB17752647F18D85C1484E1B95FEA16AF86B3E8344C9E9EC8C17AC9D6218D2DF59'; my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = uc unpack 'H*', $decoded->encode; my $hex2 = uc unpack 'H*', $encoded; my $hex3 = uc unpack 'H*', $rr->rdata; is( $hex1, $hex2, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach ( @attr, 'rdstring' ) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } for my $rr ( Net::DNS::RR->new(". $type @data") ) { my $class = ref($rr); $rr->algorithm(255); is( $rr->algorithm(), 255, 'algorithm number accepted' ); $rr->algorithm('RSASHA1'); is( $rr->algorithm(), 5, 'algorithm mnemonic accepted' ); is( $rr->algorithm('MNEMONIC'), 'RSASHA1', 'rr->algorithm("MNEMONIC") returns mnemonic' ); is( $rr->algorithm(), 5, 'rr->algorithm("MNEMONIC") preserves value' ); eval { $rr->algorithm('X'); }; my ($exception) = split /\n/, "$@\n"; ok( $exception, "unknown mnemonic\t[$exception]" ); is( $class->algorithm('RSASHA256'), 8, 'class method algorithm("RSASHA256")' ); is( $class->algorithm(8), 'RSASHA256', 'class method algorithm(8)' ); is( $class->algorithm(255), 255, 'class method algorithm(255)' ); my $object = Net::DNS::RR->new(". $type"); my $scalar = ''; $object->{algorithm} = 0; ## methods callable with invalid arguments noexception( '_CreateSig callable', sub { $object->_CreateSig( $scalar, $object ) } ); noexception( '_CreateSigData callable', sub { $object->_CreateSigData($object) } ); noexception( '_VerifySig callable', sub { $object->_VerifySig( $object, $object ) } ); exception( 'create callable', sub { $class->create( $scalar, $object ) } ); exception( 'verify callable', sub { $object->verify( $object, $object ) } ); } { my %testcase = ( ## test time conversion edge cases -1 => '21060207062815', 0x00000000 => '19700101000000', 0x7fffffff => '20380119031407', 0x80000000 => '20380119031408', 0xf4d41f7f => '21000228235959', 0xf4d41f80 => '21000301000000', 0xffffffff => '21060207062815', ); foreach my $time ( sort keys %testcase ) { my $string = $testcase{$time}; my $result = Net::DNS::RR::RRSIG::_time2string($time); is( $result, $string, "_time2string($time)" ); # Test indirectly: $timeval can be 64-bit or negative 32-bit integer my $timeval = Net::DNS::RR::RRSIG::_string2time($string); my $timestr = Net::DNS::RR::RRSIG::_time2string($timeval); is( $timestr, $string, "_string2time($string)" ); } my $timenow = time(); my $timeval = Net::DNS::RR::RRSIG::_string2time($timenow); is( $timeval, $timenow, "_string2time( time() )\t$timeval" ); } sub test_order { my @arg = @_; my ( $a, $b ) = map { defined($_) ? $_ : 'undef' } @arg; ok( Net::DNS::RR::RRSIG::_ordered(@arg), "_ordered( $a, $b )" ); ok( !Net::DNS::RR::RRSIG::_ordered( reverse @arg ), "!_ordered( $b, $a )" ); } test_order( 0, 1 ); test_order( 0x7fffffff, 0x80000000 ); test_order( 0xffffffff, 0 ); test_order( -1, 0 ); test_order( -2, -1 ); test_order( undef, 0 ); Net::DNS::RR->new("$name $type @data")->print; exit; Net-DNS-1.50/t/99-cleanup.t0000644000175000017500000000046414756035515014510 0ustar willemwillem#!/usr/bin/perl # $Id: 99-cleanup.t 1880 2022-10-04 13:42:34Z willem $ -*-perl-*- # use strict; use warnings; 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" ); exit; Net-DNS-1.50/t/05-NULL.t0000644000175000017500000000212414756035515013611 0ustar willemwillem#!/usr/bin/perl # $Id: 05-NULL.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 6; use Net::DNS; my $name = 'NULL.example'; my $type = 'NULL'; my $code = 10; my @attr = qw( ); my @data = ('\# 4 61626364'); my @also = qw( rdlength rdata ); my $wire = '61626364'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } $rr->ttl(1234); my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); is( $decoded->string, $rr->string, 'encode/decode transparent' ); } exit; Net-DNS-1.50/t/05-AAAA.t0000644000175000017500000001105414756035515013524 0ustar willemwillem#!/usr/bin/perl # $Id: 05-AAAA.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 133; use Net::DNS; my $name = 'AAAA.example'; my $type = 'AAAA'; my $code = 28; my @attr = qw( address ); my @data = qw( 1:203:405:607:809:a0b:c0d:e0f ); my @also = qw( ); my $wire = '000102030405060708090a0b0c0d0e0f'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } my %IPv6compression = ( '0:0:0:0:0:0:0:0' => '::', '0:0:0:0:0:0:0:8' => '::8', '0:0:0:0:0:0:7:0' => '::7:0', '0:0:0:0:0:6:0:0' => '::6:0:0', '0:0:0:0:0:6:0:8' => '::6:0:8', '0:0:0:0:5:0:0:0' => '::5:0:0:0', '0:0:0:0:5:0:0:8' => '::5:0:0:8', '0:0:0:0:5:0:7:0' => '::5:0:7:0', '0:0:0:4:0:0:0:0' => '0:0:0:4::', '0:0:0:4:0:0:0:8' => '::4:0:0:0:8', '0:0:0:4:0:0:7:0' => '::4:0:0:7:0', '0:0:0:4:0:6:0:0' => '::4:0:6:0:0', '0:0:0:4:0:6:0:8' => '::4:0:6:0:8', '0:0:3:0:0:0:0:0' => '0:0:3::', '0:0:3:0:0:0:0:8' => '0:0:3::8', '0:0:3:0:0:0:7:0' => '0:0:3::7:0', '0:0:3:0:0:6:0:0' => '::3:0:0:6:0:0', '0:0:3:0:0:6:0:8' => '::3:0:0:6:0:8', '0:0:3:0:5:0:0:0' => '0:0:3:0:5::', '0:0:3:0:5:0:0:8' => '::3:0:5:0:0:8', '0:0:3:0:5:0:7:0' => '::3:0:5:0:7:0', '0:2:0:0:0:0:0:0' => '0:2::', '0:2:0:0:0:0:0:8' => '0:2::8', '0:2:0:0:0:0:7:0' => '0:2::7:0', '0:2:0:0:0:6:0:0' => '0:2::6:0:0', '0:2:0:0:0:6:0:8' => '0:2::6:0:8', '0:2:0:0:5:0:0:0' => '0:2:0:0:5::', '0:2:0:0:5:0:0:8' => '0:2::5:0:0:8', '0:2:0:0:5:0:7:0' => '0:2::5:0:7:0', '0:2:0:4:0:0:0:0' => '0:2:0:4::', '0:2:0:4:0:0:0:8' => '0:2:0:4::8', '0:2:0:4:0:0:7:0' => '0:2:0:4::7:0', '0:2:0:4:0:6:0:0' => '0:2:0:4:0:6::', '0:2:0:4:0:6:0:8' => '0:2:0:4:0:6:0:8', '1:0:0:0:0:0:0:0' => '1::', '1:0:0:0:0:0:0:8' => '1::8', '1:0:0:0:0:0:7:0' => '1::7:0', '1:0:0:0:0:6:0:0' => '1::6:0:0', '1:0:0:0:0:6:0:8' => '1::6:0:8', '1:0:0:0:5:0:0:0' => '1::5:0:0:0', '1:0:0:0:5:0:0:8' => '1::5:0:0:8', '1:0:0:0:5:0:7:0' => '1::5:0:7:0', '1:0:0:4:0:0:0:0' => '1:0:0:4::', '1:0:0:4:0:0:0:8' => '1:0:0:4::8', '1:0:0:4:0:0:7:0' => '1::4:0:0:7:0', '1:0:0:4:0:6:0:0' => '1::4:0:6:0:0', '1:0:0:4:0:6:0:8' => '1::4:0:6:0:8', '1:0:3:0:0:0:0:0' => '1:0:3::', '1:0:3:0:0:0:0:8' => '1:0:3::8', '1:0:3:0:0:0:7:0' => '1:0:3::7:0', '1:0:3:0:0:6:0:0' => '1:0:3::6:0:0', '1:0:3:0:0:6:0:8' => '1:0:3::6:0:8', '1:0:3:0:5:0:0:0' => '1:0:3:0:5::', '1:0:3:0:5:0:0:8' => '1:0:3:0:5::8', '1:0:3:0:5:0:7:0' => '1:0:3:0:5:0:7:0', ); foreach my $address ( sort keys %IPv6compression ) { my $compact = $IPv6compression{$address}; my $rr1 = Net::DNS::RR->new( name => $name, type => $type, address => $address ); is( $rr1->address_short, $compact, "address compression:\t$address" ); my $rr2 = Net::DNS::RR->new( name => $name, type => $type, address => $compact ); is( $rr2->address_long, $address, "address expansion:\t$compact" ); } my %IPv6completion = ( '1' => '1:0:0:0:0:0:0:0', '1:' => '1:0:0:0:0:0:0:0', '1:2' => '1:2:0:0:0:0:0:0', '1:2:' => '1:2:0:0:0:0:0:0', '1:2:3' => '1:2:3:0:0:0:0:0', '1:2:3:' => '1:2:3:0:0:0:0:0', '1:2:3:4' => '1:2:3:4:0:0:0:0', '1:2:3:4:' => '1:2:3:4:0:0:0:0', '1:2:3:4:5' => '1:2:3:4:5:0:0:0', '1:2:3:4:5:' => '1:2:3:4:5:0:0:0', '1:2:3:4:5:6' => '1:2:3:4:5:6:0:0', '1:2:3:4:5:6:' => '1:2:3:4:5:6:0:0', '1:2:3:4:5:6:7' => '1:2:3:4:5:6:7:0', '1:2:3:4:5:6:7:' => '1:2:3:4:5:6:7:0', '::ffff:1.2.3.4' => '0:0:0:0:0:ffff:102:304', '::ffff:1.2.4' => '0:0:0:0:0:ffff:102:4', '::ffff:1.4' => '0:0:0:0:0:ffff:100:4', ); foreach my $address ( sort keys %IPv6completion ) { my $expect = Net::DNS::RR->new( name => $name, type => $type, address => $IPv6completion{$address} ); my $rr = Net::DNS::RR->new( name => $name, type => $type, address => $address ); is( $rr->address, $expect->address, "address completion:\t$address" ); } exit; Net-DNS-1.50/t/05-TKEY.t0000644000175000017500000000343114756035515013615 0ustar willemwillem#!/usr/bin/perl # $Id: 05-TKEY.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 21; use TestToolkit; use Net::DNS; my $name = 'TKEY.example'; my $type = 'TKEY'; my $code = 249; my @attr = qw( algorithm inception expiration mode error key other ); my $fake = pack 'H*', '64756d6d79'; my @data = ( qw( alg.example 1434806118 1434806118 1 17 ), $fake, $fake ); my @also = qw( other_data ); my $wire = '03616c67076578616d706c6500558567665585676600010011000564756d6d79000564756d6d79'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); my $emptyrr = Net::DNS::RR->new("$name $type")->encode; my $corrupt = pack 'a*X2na*', $emptyrr, $decoded->rdlength - 1, $rr->rdata; exception( 'corrupt wire-format', sub { Net::DNS::RR->decode( \$corrupt ) } ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } exit; Net-DNS-1.50/t/05-AFSDB.t0000644000175000017500000000263014756035515013660 0ustar willemwillem#!/usr/bin/perl # $Id: 05-AFSDB.t 1911 2023-04-17 12:30:59Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 9; use Net::DNS; my $name = 'AFSDB.example'; my $type = 'AFSDB'; my $code = 18; my @attr = qw( subtype hostname ); my @data = qw( 12345 host.example.com ); my @also = qw( ); my $wire = '303904686f7374076578616d706c6503636f6d00'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } exit; Net-DNS-1.50/t/42-DNSKEY-flags.t0000644000175000017500000000232514756035515015132 0ustar willemwillem#!/usr/bin/perl # $Id: 42-DNSKEY-flags.t 1856 2021-12-02 14:36:25Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use Net::DNS; my @prerequisite = qw( MIME::Base64 Net::DNS::RR::DNSKEY; ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 16; my $dnskey = Net::DNS::RR->new( <<'END' ); RSASHA1.example. IN DNSKEY 256 3 5 ( AwEAAZHbngk6sMoFHN8fsYY6bmGR4B9UYJIqDp+mORLEH53Xg0f6RMDtfx+H3/x7bHTUikTr26bV AqsxOs2KxyJ2Xx9RGG0DB9O4gpANljtTq2tLjvaQknhJpSq9vj4CqUtr6Wu152J2aQYITBoQLHDV i8mIIunparIKDmhy8TclVXg9 ) ; Key ID = 1623 END ok( $dnskey, 'set up DNSKEY record' ); $dnskey->flags(0); foreach my $flag (qw(sep zone revoke)) { my $boolean = $dnskey->$flag(0); ok( !$boolean, "Boolean $flag flag has expected value" ); my $keytag = $dnskey->keytag; $dnskey->$flag( !$boolean ); ok( $dnskey->$flag, "Boolean $flag flag toggled" ); isnt( $dnskey->keytag, $keytag, "keytag recalculated using modified $flag flag" ); $dnskey->$flag($boolean); ok( !$dnskey->$flag, "Boolean $flag flag restored" ); is( $dnskey->keytag, $keytag, "keytag recalculated using restored $flag flag" ); } exit; __END__ Net-DNS-1.50/t/TestToolkit.pm0000644000175000017500000000502014756035515015251 0ustar willemwillem# $Id: TestToolkit.pm 1908 2023-03-15 07:28:50Z willem $ -*-perl-*- package TestToolkit; =head1 NAME TestToolkit - Convenient tools to simplify test script construction. =cut use strict; use warnings; use Carp; use Test::Builder; use Test::More; use base qw(Exporter); our @EXPORT = qw(exception noexception NonFatalBegin NonFatalEnd); =head1 exception noexception [no]exception( 'test description', sub { code fragment } ); Executes the supplied code fragment and reports a raised exception or warning using the Test::More ok() mechanism. =cut sub exception { my ( $name, $code ) = @_; my $exception = _execute($code); my $boolean = $exception ? 1 : 0; my $tb = Test::Builder->new; return $tb->ok( $boolean, "$name\t[$exception]" ); } sub noexception { my ( $name, $code ) = @_; my $exception = _execute($code); my $boolean = $exception ? 0 : 1; my $tb = Test::Builder->new; return $tb->ok( $boolean, $exception ? "$name\t[$exception]" : $name ); } sub _execute { my $code = shift; my @warning; local $SIG{__WARN__} = sub { push @warning, "@_" }; local ( $@, $!, $SIG{__DIE__} ); ## isolate eval eval { &$code; croak shift(@warning) if @warning; }; my ($exception) = split /[\r\n]+/, "$@\n"; return $exception; } ######################################## # # Test::More test functions all eventually call Test::Builder::ok # (on the (singular) builder instance) to report the status. # The NonFatal package defines a subclass derived from Test::Builder, # with a redefined ok method that overrides the completion status # seen by the test harness. # # Note: Modified behaviour is enabled by the 't/online.nonfatal' file. # =head1 NonFatalBegin NonFatalEnd Tests that are between these functions will always appear to succeed. The failure report itself is not suppressed. =cut sub NonFatalBegin { return bless Test::Builder->new, qw(NonFatal) } sub NonFatalEnd { return bless Test::Builder->new, qw(Test::Builder) } package NonFatal; use base qw(Test::Builder); my $enabled = eval { -e 't/online.nonfatal' }; my @failed; sub ok { my ( $self, $test, @name ) = @_; return $self->SUPER::ok( $test, @name ) if $test; if ($enabled) { my $number = $self->current_test + 1; push @failed, join( "\t", $number, @name ); @name = "NOT OK (tolerating failure) @name"; } return $self->SUPER::ok( $enabled, @name ); } END { my $n = scalar(@failed) || return; my $s = ( $n == 1 ) ? '' : 's'; my $tb = __PACKAGE__->SUPER::new(); $tb->diag( join "\n", "\nDisregarding $n failed sub-test$s", @failed ); } 1; __END__ Net-DNS-1.50/t/08-IPv4.t0000644000175000017500000003111414756035515013625 0ustar willemwillem#!/usr/bin/perl # $Id: 08-IPv4.t 2007 2025-02-08 16:45:23Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use TestToolkit; use Net::DNS; use IO::Select; my $debug = 0; my @hints = Net::DNS::Resolver->new()->_hints; my $NOIP = qw(0.0.0.0); my @nsdname = qw( ns.net-dns.org ns.nlnetlabs.nl ); exit( plan skip_all => 'Online tests disabled.' ) if -e 't/online.disabled'; exit( plan skip_all => 'Online tests disabled.' ) unless -e 't/online.enabled'; eval { my $resolver = Net::DNS::Resolver->new( igntc => 1 ); exit plan skip_all => 'No nameservers' unless $resolver->nameservers; my $reply = $resolver->send(qw(. NS IN)) || die $resolver->errorstring; my @ns = grep { $_->type eq 'NS' } $reply->answer, $reply->authority; exit plan skip_all => 'Local nameserver broken' unless scalar @ns; 1; } || exit( plan skip_all => "Non-responding local nameserver: $@" ); eval { my $resolver = Net::DNS::Resolver->new( nameservers => [@hints] ); $resolver->force_v4(1); exit plan skip_all => 'No IPv4 transport' unless $resolver->nameservers; my $reply = $resolver->send(qw(. NS IN)) || die $resolver->errorstring; my $from = $reply->from(); my @ns = grep { $_->type eq 'NS' } $reply->answer, $reply->authority; exit plan skip_all => "Unexpected response from $from" unless scalar @ns; exit plan skip_all => "Non-authoritative response from $from" unless $reply->header->aa; 1; } || exit( plan skip_all => "Cannot reach global root: $@" ); my $IP = eval { my $resolver = Net::DNS::Resolver->new(); $resolver->nameservers(@nsdname); $resolver->force_v4(1); [$resolver->nameservers()]; } || []; exit( plan skip_all => 'Unable to resolve nameserver name' ) unless scalar @$IP; diag join( "\n\t", 'will use nameservers', @$IP ) if $debug; Net::DNS::Resolver->debug($debug); plan tests => 62; NonFatalBegin(); { my $resolver = Net::DNS::Resolver->new( nameservers => $IP, dnsrch => 1 ); ok( $resolver->search('ns.net-dns.org.'), '$resolver->search(ns.net-dns.org.)' ); ok( !$resolver->search('nx.net-dns.org.'), '$resolver->search(nx.net-dns.org.)' ); my $packet = Net::DNS::Packet->new(qw(net-dns.org SOA IN)); ok( $resolver->send($packet), '$resolver->send(...) UDP' ); $packet->edns->option( PADDING => ( 'OPTION-LENGTH' => 500 ) ); # force TCP delete $packet->{id}; ok( $resolver->send($packet), '$resolver->send(...) TCP' ); } { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); $resolver->dnssec(1); $resolver->udppacketsize(513); $resolver->igntc(1); my $udp = $resolver->send(qw(net-dns.org DNSKEY IN)); ok( $udp && $udp->header->tc, '$resolver->send(...) truncated UDP reply' ); $resolver->igntc(0); my $retry = $resolver->send(qw(net-dns.org DNSKEY IN)); ok( $retry && !$retry->header->tc, '$resolver->send(...) automatic TCP retry' ); } { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); $resolver->igntc(0); my $packet = Net::DNS::Packet->new(qw(net-dns.org SOA IN)); my $udp = $resolver->bgsend($packet); ok( $udp, '$resolver->bgsend(...) UDP' ); while ( $resolver->bgbusy($udp) ) { sleep 1; } ok( $resolver->bgread($udp), '$resolver->bgread($udp)' ); $packet->edns->option( PADDING => ( 'OPTION-LENGTH' => 500 ) ); # force TCP delete $packet->{id}; my $tcp = $resolver->bgsend($packet); ok( $tcp, '$resolver->bgsend(...) TCP' ); while ( $resolver->bgbusy($tcp) ) { sleep 1; } ok( $resolver->bgread($tcp), '$resolver->bgread($tcp)' ); } { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); $resolver->dnssec(1); $resolver->udppacketsize(513); $resolver->igntc(1); my $handle = $resolver->bgsend(qw(net-dns.org DNSKEY IN)); ok( $handle, '$resolver->bgsend(...) truncated UDP' ); my $packet = $resolver->bgread($handle); ok( $packet && $packet->header->tc, '$resolver->bgread($udp) ignore UDP truncation' ); } { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); $resolver->dnssec(1); $resolver->udppacketsize(513); $resolver->igntc(0); my $handle = $resolver->bgsend(qw(net-dns.org DNSKEY IN)); ok( $handle, '$resolver->bgsend(...) truncated UDP' ); my $udp = $handle; my $packet = $resolver->bgread($handle); isnt( $handle, $udp, '$resolver->bgbusy($udp) handle changed to TCP' ); ok( $packet && !$packet->header->tc, '$resolver->bgread($udp) background TCP retry' ); } { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); $resolver->dnssec(1); $resolver->udppacketsize(513); $resolver->igntc(0); my $handle = $resolver->bgsend(qw(net-dns.org DNSKEY IN)); $resolver->nameserver(); # no nameservers my $packet = $resolver->bgread($handle); ok( $packet && $packet->header->tc, '$resolver->bgread($udp) background TCP fail' ); } { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); $resolver->persistent_udp(1); my $handle = $resolver->bgsend(qw(net-dns.org SOA IN)); ok( $handle, '$resolver->bgsend(...) persistent UDP' ); my $bgread = $resolver->bgread($handle); ok( $bgread, '$resolver->bgread($udp)' ); my $test = $resolver->bgsend(qw(net-dns.org SOA IN)); ok( $test, '$resolver->bgsend(...) persistent UDP' ); is( $test, $handle, 'same UDP socket object used' ); } { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); $resolver->persistent_tcp(1); $resolver->usevc(1); my $handle = $resolver->bgsend(qw(net-dns.org SOA IN)); ok( $handle, '$resolver->bgsend(...) persistent TCP' ); my $bgread = $resolver->bgread($handle); ok( $bgread, '$resolver->bgread($tcp)' ); my $test = $resolver->bgsend(qw(net-dns.org SOA IN)); ok( $test, '$resolver->bgsend(...) persistent TCP' ); is( $test, $handle, 'same TCP socket object used' ); eval { close($handle) }; my $recover = $resolver->bgsend(qw(net-dns.org SOA IN)); ok( $recover, 'connection recovered after close' ); } my $tsig_key = eval { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); $resolver->domain('net-dns.org'); my @answer = $resolver->query(qw(tsig-md5 KEY))->answer; shift @answer; }; my $bad_key = Net::DNS::RR->new('MD5.example KEY 512 3 157 MD5keyMD5keyMD5keyMD5keyMD5='); SKIP: { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); eval { $resolver->tsig($tsig_key) }; skip( 'automatic TSIG tests', 3 ) if $@; $resolver->igntc(1); my $udp = $resolver->send(qw(net-dns.org SOA IN)); ok( $udp, '$resolver->send(...) UDP + automatic TSIG' ); $resolver->usevc(1); my $tcp = $resolver->send(qw(net-dns.org SOA IN)); ok( $tcp, '$resolver->send(...) TCP + automatic TSIG' ); my $bgread; foreach my $ip (@$IP) { $resolver->nameserver($ip); my $handle = $resolver->bgsend(qw(net-dns.org SOA IN)); last if $bgread = $resolver->bgread($handle); } ok( $bgread, '$resolver->bgsend/read TCP + automatic TSIG' ); } SKIP: { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); $resolver->igntc(1); eval { $resolver->tsig($bad_key) }; skip( 'failed TSIG tests', 3 ) if $@; my $udp = $resolver->send(qw(net-dns.org SOA IN)); ok( !$udp, '$resolver->send(...) UDP + failed TSIG' ); $resolver->usevc(1); my $tcp = $resolver->send(qw(net-dns.org SOA IN)); ok( !$tcp, '$resolver->send(...) TCP + failed TSIG' ); my $handle = $resolver->bgsend(qw(net-dns.org SOA IN)); my $bgread = $resolver->bgread($handle); ok( !$bgread, '$resolver->bgsend/read TCP + failed TSIG' ); } { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); my $udp = $resolver->query(qw(bogus.net-dns.org A IN)); ok( !$udp, '$resolver->query() nonexistent name UDP' ); $resolver->usevc(1); my $tcp = $resolver->query(qw(bogus.net-dns.org A IN)); ok( !$tcp, '$resolver->query() nonexistent name TCP' ); } { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); my $update = Net::DNS::Update->new(qw(example.com)); ok( $resolver->send($update), '$resolver->send($update) UDP' ); $resolver->usevc(1); delete $update->{id}; ok( $resolver->send($update), '$resolver->send($update) TCP' ); } { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); my $mx = 'mx2.t.net-dns.org'; my @rr = rr( $resolver, $mx, 'MX' ); is( scalar(@rr), 2, 'Net::DNS::rr() works with specified resolver' ); is( scalar rr( $resolver, $mx, 'MX' ), 2, 'Net::DNS::rr() works in scalar context' ); is( scalar rr( $mx, 'MX' ), 2, 'Net::DNS::rr() works with default resolver' ); } { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); my $mx = 'mx2.t.net-dns.org'; my @mx = mx( $resolver, $mx ); is( scalar(@mx), 2, 'Net::DNS::mx() works with specified resolver' ); # some people seem to use mx() in scalar context is( scalar mx( $resolver, $mx ), 2, 'Net::DNS::mx() works in scalar context' ); is( scalar mx($mx), 2, 'Net::DNS::mx() works with default resolver' ); is( scalar mx('bogus.t.net-dns.org'), 0, "Net::DNS::mx() works for bogus name" ); } SKIP: { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); $resolver->tcp_timeout(10); my @zone = $resolver->axfr('net-dns.org'); ok( scalar(@zone), '$resolver->axfr() returns entire zone in list context' ); my @notauth = $resolver->axfr('bogus.net-dns.org'); my $notauth = $resolver->errorstring; ok( !scalar(@notauth), "mismatched zone\t[$notauth]" ); my $iterator = $resolver->axfr('net-dns.org'); ok( ref($iterator), '$resolver->axfr() returns iterator in scalar context' ); skip( 'AXFR iterator tests', 4 ) unless $iterator; my $soa = $iterator->(); is( ref($soa), 'Net::DNS::RR::SOA', '$iterator->() returns initial SOA RR' ); my $iterations; $soa->serial(undef) if $soa; # force SOA mismatch exception( 'mismatched SOA serial', sub { $iterations++ while $iterator->() } ); ok( $iterations, '$iterator->() iterates through remaining RRs' ); is( $iterator->(), undef, '$iterator->() returns undef after last RR' ); } SKIP: { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); $resolver->domain('net-dns.org'); eval { $resolver->tsig($tsig_key) }; skip( 'TSIG AXFR tests', 4 ) if $@; $resolver->tcp_timeout(10); my @zone = $resolver->axfr(); ok( scalar(@zone), '$resolver->axfr() with TSIG verify' ); my @notauth = $resolver->axfr('bogus.net-dns.org'); my $notauth = $resolver->errorstring; ok( !scalar(@notauth), "mismatched zone\t[$notauth]" ); eval { $resolver->tsig($bad_key) }; skip( 'AXFR failure reporting', 2 ) if $@; my @unverifiable = $resolver->axfr(); my $errorstring = $resolver->errorstring; ok( !scalar(@unverifiable), "mismatched key\t[$errorstring]" ); } SKIP: { my $resolver = Net::DNS::Resolver->new( nameservers => $NOIP ); eval { $resolver->tsig($tsig_key) }; skip( 'TSIG bgsend tests', 2 ) if $@; my $query = Net::DNS::Packet->new(qw(. SOA IN)); ok( $resolver->bgsend($query), '$resolver->bgsend() + automatic TSIG' ); delete $query->{id}; ok( $resolver->bgsend($query), '$resolver->bgsend() + existing TSIG' ); } { my $resolver = Net::DNS::Resolver->new(); $resolver->nameserver('cname.t.net-dns.org'); ok( scalar( $resolver->nameservers ), 'resolve nameserver cname' ); } { ## exercise error paths in _axfr_next() my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); $resolver->tcp_timeout(10); exception( 'TCP time out', sub { $resolver->_axfr_next( IO::Select->new ) } ); my $packet = Net::DNS::Packet->new(qw(net-dns.org SOA)); my $socket = $resolver->_bgsend_tcp( $packet, $packet->encode ); my $select = IO::Select->new($socket); while ( $resolver->bgbusy($socket) ) { sleep 1 } my $discarded = ''; ## [size][id][status] [qdcount]... $socket->recv( $discarded, 6 ) if $socket; exception( 'corrupt data', sub { $resolver->_axfr_next($select) } ); } SKIP: { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); $resolver->domain('net-dns.org'); eval { $resolver->tsig($tsig_key) }; $resolver->tcp_timeout(10); my $packet = $resolver->_make_query_packet(qw(net-dns.org SOA)); my $socket = $resolver->_bgsend_tcp( $packet, $packet->encode ); my $tsigrr = $packet->sigrr; skip( 'verify fail', 1 ) unless $tsigrr; my $select = IO::Select->new($socket); exception( 'verify fail', sub { $resolver->_axfr_next( $select, $tsigrr ) } ); } { ## exercise error paths in _send_udp et al my $resolver = Net::DNS::Resolver->new( nameservers => $IP, retry => 1 ); my $original = Net::DNS::Packet->new(qw(net-dns.org SOA)); my $mismatch = Net::DNS::Packet->new(qw(net-dns.org SOA)); $original->encode; ok( !$resolver->_send_tcp( $original, $mismatch->encode ), '_send_tcp() id mismatch' ); ok( !$resolver->_send_udp( $original, $mismatch->encode ), '_send_udp() id mismatch' ); my $handle = $resolver->_bgsend_udp( $original, $mismatch->encode ); $resolver->udp_timeout(1); ok( !$resolver->bgread($handle), 'bgread() id mismatch' ); ok( !$resolver->bgread( ref($handle)->new ), 'bgread() timeout' ); } NonFatalEnd(); exit; __END__ Net-DNS-1.50/t/05-RT.t0000644000175000017500000000262114756035515013366 0ustar willemwillem#!/usr/bin/perl # $Id: 05-RT.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 9; use Net::DNS; my $name = '*.prime.com'; my $type = 'RT'; my $code = 21; my @attr = qw( preference intermediate ); my @data = qw( 90 relay.prime.com ); my @also = qw( ); my $wire = '005a0572656c6179057072696d6503636f6d00'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } exit; Net-DNS-1.50/t/21-NSEC-typelist.t0000644000175000017500000000274114756035515015445 0ustar willemwillem#!/usr/bin/perl # $Id: 21-NSEC-typelist.t 1865 2022-05-21 09:57:49Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use Net::DNS; use Net::DNS::DomainName; use Net::DNS::Parameters qw(:type); my @prerequisite = qw( Net::DNS::RR::NSEC ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 79; my $rr = Net::DNS::RR->new( type => 'NSEC', nxtdname => 'irrelevant', ); is( $rr->typemap(0), undef, 'typemap($type) undefined for empty map' ); $rr->typelist(1); is( $rr->typemap(256), undef, 'typemap($type) undefined for empty map block' ); foreach my $rrtype ( 0, 256, 512, 768, 1024 ) { my $type = "TYPE$rrtype"; $rr->typelist($type); my $rdata = $rr->rdata; my ( $name, $offset ) = Net::DNS::DomainName->decode( \$rdata ); my ( $w, $l, $bitmap ) = unpack "\@$offset CCa*", $rdata; is( $w, $rrtype >> 8, "expected window number for $type" ); } foreach my $rrtype ( 0, 7, 8, 15, 16, 23, 24, 31, 32, 39 ) { my $type = typebyval($rrtype); $rr->typelist($type); my $rdata = $rr->rdata; my ( $name, $offset ) = Net::DNS::DomainName->decode( \$rdata ); my ( $w, $l, $bitmap ) = unpack "\@$offset CCa*", $rdata; is( $l, 1 + ( $rrtype >> 3 ), "expected map length for $type" ); } foreach my $rrtype ( 1 .. 40, 42 .. 53, 55 .. 64 ) { my $type = typebyval($rrtype); $rr->typelist($type); is( $rr->typemap($type), 1, "expected map bit for $type" ); } exit; __END__ Net-DNS-1.50/t/02-text.t0000644000175000017500000001260414756035515014024 0ustar willemwillem#!/usr/bin/perl # $Id: 02-text.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 40; use TestToolkit; use_ok('Net::DNS::Text'); for my $object ( Net::DNS::Text->new( my $string = 'example' ) ) { ok( $object->isa('Net::DNS::Text'), 'object returned by new() constructor' ); $object->value; ## untestable optimisation: avoid returning value in void context is( $object->value, $string, 'expected object->value' ); is( $object->string, $string, 'expected object->string' ); is( $object->unicode, $string, 'expected object->unicode' ); } for my $object ( Net::DNS::Text->new( my $sample = '' ) ) { my $expect = '""'; is( $object->string, $expect, 'quoted empty object->string' ); is( $object->unicode, $expect, 'quoted empty object->unicode' ); } for my $object ( Net::DNS::Text->new( my $sample = '\e\x\a\m\p\l\e' ) ) { my $expect = 'example'; is( $object->string, $expect, 'character escape' ); } for my $object ( Net::DNS::Text->new( my $sample = '\065' ) ) { my $expect = 'A'; is( $object->string, $expect, 'numeric escape' ); } for my $object ( Net::DNS::Text->new( my $string = 'a' x 256 ) ) { is( scalar(@$object), 2, 'new() splits long argument' ); is( length( $object->value ), length($string), 'object->value reassembles string' ); is( length( $object->string ), length($string), 'object->string reassembles string' ); } for my $object ( Net::DNS::Text->new( join '', ( my $filler = 'a' x 254 ), '\192\160' ) ) { is( scalar(@$object), 2, 'new() splits long UTF8 sequence' ); is( length( $object->[0] ), length($filler), 'new() does not break UTF8 sequence' ); } for my $object ( Net::DNS::Text->new( my $sample = 'x\000x\031x\127x\128x\159\160\255x' ) ) { my $expect = '7800781f787f7880789fa0ff78'; my $length = sprintf '%02x', length pack( 'H*', $expect ); my $buffer = $object->encode; is( unpack( 'H*', $buffer ), $length . $expect, 'encode() returns expected data' ); is( unpack( 'H*', $object->raw ), $expect, 'raw() returns expected data' ); } for my $object ( Net::DNS::Text->new( my $sample = 'example' ) ) { my $buffer = $object->encode; my $decode = Net::DNS::Text->decode( \$buffer ); ok( $decode->isa('Net::DNS::Text'), 'decode() constructor' ); is( $decode->string, $sample, 'decode matches original data' ); my ( $x, $next ) = Net::DNS::Text->decode( \$buffer ); is( $next, length $buffer, 'expected offset returned by decode()' ); } for my $object ( Net::DNS::Text->new( my $sample = 'example' ) ) { my $buffer = $object->encode; my ( $decode, $next ) = Net::DNS::Text->decode( \$buffer, 1, length($buffer) - 1 ); is( $decode->string, $sample, 'decode() extracts arbitrary substring' ); is( $next, length $buffer, 'expected offset returned by decode()' ); } my %C0controls = ( '000102030405060708090a0b0c0d0e0f' => '\000\001\002\003\004\005\006\007\008\009\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 %C0controls ) { my $string = $C0controls{$hexcode}; my $content = pack 'H*', $hexcode; my $buffer = pack 'C a*', length $content, $content; my $decoded = Net::DNS::Text->decode( \$buffer ); my $compare = $decoded->string; is( $compare, qq($string), "C0 controls:\t$string" ); } my %ASCIIprintable = ( '202122232425262728292a2b2c2d2e2f' => q|" !\034#$%&'()*+,-./"|, '303132333435363738393a3b3c3d3e3f' => q|"0123456789:;<=>?"|, '404142434445464748494a4b4c4d4e4f' => '@ABCDEFGHIJKLMNO', '505152535455565758595a5b5c5d5e5f' => 'PQRSTUVWXYZ[\092]^_', '606162636465666768696a6b6c6d6e6f' => '`abcdefghijklmno', '707172737475767778797a7b7c7d7e7f' => 'pqrstuvwxyz{|}~\127' ); foreach my $hexcode ( sort keys %ASCIIprintable ) { my $string = $ASCIIprintable{$hexcode}; my $content = pack 'H*', $hexcode; my $buffer = pack 'C a*', length $content, $content; my $decoded = Net::DNS::Text->decode( \$buffer ); my $compare = $decoded->string; is( $compare, qq($string), "G0 graphics:\t$string" ); } my %unprintable = ( '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 %unprintable ) { my $string = $unprintable{$hexcode}; my $encoded = Net::DNS::Text->new($string)->encode; is( unpack( 'xH*', $encoded ), $hexcode, qq(8-bit codes:\t$string) ); } exception( 'empty argument list', sub { Net::DNS::Text->new() } ); exception( 'argument undefined', sub { Net::DNS::Text->new(undef) } ); my $truncated = substr Net::DNS::Text->new('example')->encode, 0, 2; exception( 'corrupt wire-format', sub { Net::DNS::Text->decode( \$truncated ) } ); exit; Net-DNS-1.50/t/01-resolver-file.t0000644000175000017500000000332414756035515015614 0ustar willemwillem#!/usr/bin/perl # $Id: 01-resolver-file.t 1910 2023-03-30 19:16:30Z willem $ # use strict; use warnings; use File::Spec; use Test::More tests => 16; use TestToolkit; use Net::DNS::Resolver; local $ENV{'RES_NAMESERVERS'}; local $ENV{'RES_SEARCHLIST'}; local $ENV{'LOCALDOMAIN'}; local $ENV{'RES_OPTIONS'}; my $class = 'Net::DNS::Resolver'; my $config = File::Spec->catfile(qw(t custom.txt)); # .txt to run on Windows for my $resolver ( $class->new( config_file => $config ) ) { ok( $resolver->isa($class), "new( config_file => '$config' )" ); my @servers = $resolver->nameservers; ok( scalar(@servers), 'nameservers list populated' ); is( $servers[0], '10.0.1.128', 'nameservers list correct' ); is( $servers[1], '10.0.2.128', 'nameservers list correct' ); my @search = $resolver->searchlist; ok( scalar(@search), 'searchlist populated' ); is( $search[0], 'alt.net-dns.org', 'searchlist correct' ); is( $search[1], 'ext.net-dns.org', 'searchlist correct' ); is( $resolver->domain, $search[0], 'domain correct' ); is( $class->domain, $resolver->domain, 'initial config sets defaults' ); } $class->domain('domain.default'); for my $resolver ( $class->new( config_file => $config ) ) { ok( $resolver->isa($class), "new( config_file => $config )" ); my @servers = $resolver->nameservers; ok( scalar(@servers), 'nameservers list populated' ); my @search = $resolver->searchlist; ok( scalar(@search), 'searchlist populated' ); is( $search[0], 'alt.net-dns.org', 'searchlist correct' ); is( $resolver->domain, $search[0], 'domain correct' ); isnt( $class->domain, $resolver->domain, 'default config unchanged' ); } exception( 'new( config_file => ?', sub { $class->new( config_file => 'nonexist.txt' ) } ); exit; Net-DNS-1.50/t/05-LP.t0000644000175000017500000000265714756035515013365 0ustar willemwillem#!/usr/bin/perl # $Id: 05-LP.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 11; use Net::DNS; my $name = 'LP.example'; my $type = 'LP'; my $code = 107; my @attr = qw( preference target ); my @data = qw( 10 locator.example.com ); my @also = qw( FQDN fqdn ); my $wire = join '', qw( 000a076c6f6361746f72076578616d706c6503636f6d00 ); my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } exit; Net-DNS-1.50/t/05-KX.t0000644000175000017500000000261114756035515013362 0ustar willemwillem#!/usr/bin/perl # $Id: 05-KX.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 9; use Net::DNS; my $name = 'KX.example'; my $type = 'KX'; my $code = 36; my @attr = qw( preference exchange ); my @data = qw( 10 kx.example.com ); my @also = qw( ); my $wire = '000a026b78076578616d706c6503636f6d00'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } exit; Net-DNS-1.50/t/02-mailbox.t0000644000175000017500000001032114756035515014465 0ustar willemwillem#!/usr/bin/perl # $Id: 02-mailbox.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 40; use TestToolkit; use_ok('Net::DNS::Mailbox'); for my $mailbox ( Net::DNS::Mailbox->new('mbox@example.com') ) { ok( $mailbox->isa('Net::DNS::Mailbox'), 'object returned by new() constructor' ); $mailbox->address; ## untestable optimisation: avoid returning address in void context ok( $mailbox->address, 'mailbox->address' ); } 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', 'empty <>' => '<>', 'fore aft' => 'a.b@c.d', 'nested <>' => 'mailbox', 'obscure <<<>>>' => 'right', 'obsolete <@source;@route:mailbox>' => 'mailbox', 'quoted <"stuff@local"@domain>' => '"stuff@local"@domain', ); foreach my $test ( sort keys %testcase ) { my $expect = $testcase{$test}; my $mailbox = Net::DNS::Mailbox->new($test); my $data = $mailbox->encode; my $decoded = Net::DNS::Mailbox->decode( \$data ); is( $decoded->address, $expect, "encode/decode mailbox $test" ); } for my $mailbox ( Net::DNS::Mailbox->new( uc 'MBOX.EXAMPLE.COM' ) ) { my $hash = {}; my $data = $mailbox->encode( 1, $hash ); my $compress = $mailbox->encode( length $data, $hash ); my $canonical = $mailbox->encode( length $data ); my $decoded = Net::DNS::Mailbox->decode( \$data ); my $downcased = Net::DNS::Mailbox->new( lc $mailbox->name )->encode( 0, {} ); ok( $mailbox->isa('Net::DNS::Mailbox'), 'object returned by Net::DNS::Mailbox->new()' ); ok( $decoded->isa('Net::DNS::Mailbox'), 'object returned by Net::DNS::Mailbox->decode()' ); 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' ); } for my $mailbox ( Net::DNS::Mailbox1035->new( uc 'MBOX.EXAMPLE.COM' ) ) { my $hash = {}; my $data = $mailbox->encode( 1, $hash ); my $compress = $mailbox->encode( length $data, $hash ); my $canonical = $mailbox->encode( length $data ); my $decoded = Net::DNS::Mailbox1035->decode( \$data ); my $downcased = Net::DNS::Mailbox1035->new( lc $mailbox->name )->encode( 0, {} ); ok( $mailbox->isa('Net::DNS::Mailbox1035'), 'object returned by Net::DNS::Mailbox1035->new()' ); ok( $decoded->isa('Net::DNS::Mailbox1035'), 'object returned by Net::DNS::Mailbox1035->decode()' ); 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' ); } for my $mailbox ( Net::DNS::Mailbox2535->new( uc 'MBOX.EXAMPLE.COM' ) ) { my $hash = {}; my $data = $mailbox->encode( 1, $hash ); my $compress = $mailbox->encode( length $data, $hash ); my $canonical = $mailbox->encode( length $data ); my $decoded = Net::DNS::Mailbox2535->decode( \$data ); my $downcased = Net::DNS::Mailbox2535->new( lc $mailbox->name )->encode( 0, {} ); ok( $mailbox->isa('Net::DNS::Mailbox2535'), 'object returned by Net::DNS::Mailbox2535->new()' ); ok( $decoded->isa('Net::DNS::Mailbox2535'), 'object returned by Net::DNS::Mailbox2535->decode()' ); 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' ); } exception( 'empty argument list', sub { Net::DNS::Mailbox->new() } ); exception( 'argument undefined', sub { Net::DNS::Mailbox->new(undef) } ); exit; Net-DNS-1.50/t/04-packet.t0000644000175000017500000002126714756035515014316 0ustar willemwillem#!/usr/bin/perl # $Id: 04-packet.t 1980 2024-06-02 10:16:33Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 104; use TestToolkit; use_ok('Net::DNS::Packet'); # new() class constructor method must return object of appropriate class my $object = Net::DNS::Packet->new(); ok( $object->isa('Net::DNS::Packet'), 'new() object' ); ok( $object->header, 'header() method works' ); ok( $object->header->isa('Net::DNS::Header'), 'header() returns header object' ); ok( $object->edns, 'edns() method works' ); ok( $object->edns->isa('Net::DNS::RR::OPT'), 'edns() returns OPT RR object' ); like( $object->string, '/HEADER/', 'string() returns representation of packet' ); $object->header->do(1); $object->encode(); like( $object->string, '/EDNS/', 'string() contains representation of EDNS' ); $object->header->opcode('UPDATE'); like( $object->string, '/UPDATE/', 'string() returns representation of update' ); # 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), qw(zone pre prerequisite update) ) { my @result = $empty->$method; ok( @result == 0, "$method() returns empty list" ); } # 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' ); 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' ); # encode() method returns non-empty scalar my $packet_data = $packet->encode; ok( $packet_data, 'packet->encode() method works' ); ok( $packet->data, 'packet->data() alias works' ); # new(\$data) class constructor method returns object of appropriate class my $packet2 = Net::DNS::Packet->new( \$packet_data ); ok( $packet2->isa('Net::DNS::Packet'), 'new(\$data) object' ); is( $packet2->string, $packet->string, 'decoded packet matches original' ); is( unpack( 'H*', $packet2->encode ), unpack( 'H*', $packet_data ), 'retransmitted packet matches original' ); my $empty_packet = Net::DNS::Packet->new()->encode; ok( Net::DNS::Packet->decode( \$empty_packet )->string, 'decoded empty packet' ); my $dso = Net::DNS::Packet->new(); $dso->header->opcode('DSO'); my $dso_packet = $dso->encode . pack( 'n2H*', 1, 2, 'beef' ); ok( Net::DNS::Packet->decode( \$dso_packet )->string, 'decoded DSO packet' ); # 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->encode; my $decoded = eval { Net::DNS::Packet->decode( \$buffer ) }; ok( $decoded, 'decode() from data buffer works' ); is( $decoded->size, length($buffer), '$decoded->size() works' ); $decoded->from('local'); ok( $decoded->from(), '$decoded->from() works' ); ok( $decoded->string(), '$decoded->string() works' ); foreach my $count (qw(qdcount ancount nscount arcount)) { is( $decoded->header->$count, $update->header->$count, "check header->$count correct" ); } ok( $decoded->answersize, 'answersize() alias works' ); ok( $decoded->answerfrom, 'answerfrom() alias works' ); foreach my $section (qw(question)) { my @original = map { $_->string } $update->$section; my @content = map { $_->string } $decoded->$section; is_deeply( \@content, \@original, "check content of $section section" ); } foreach my $section (qw(answer authority additional)) { my @original = map { $_->ttl(0); $_->string } $update->$section; # almost! need TTL defined my @content = map { $_->string } $decoded->$section; is_deeply( \@content, \@original, "check content of $section section" ); } # check that pop() removes RR from section Memo to self: no RR in question section! foreach my $section (qw(answer authority additional)) { my $c1 = $update->push( $section, Net::DNS::RR->new('X TXT ""') ); my $rr = $update->pop($section); my $c2 = $update->push($section); is( $c2, $c1 - 1, "pop() RR from $section section" ); } for my $packet ( Net::DNS::Packet->new('example.com') ) { my $case1 = $packet->pop(''); ## check tolerance of invalid pop my $case2 = $packet->pop('bogus'); } # 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->decode( \$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' ); for my $packet ( Net::DNS::Packet->new('example.com') ) { my $reply = $packet->reply(); ## check $packet->reply() ok( $reply->isa('Net::DNS::Packet'), '$packet->reply() returns packet' ); like( $reply->string, '/HEADER/', 'reply->string() represents packet' ); my $udpmax = 2048; $packet->edns->udpsize($udpmax); $packet->encode; is( $packet->reply($udpmax)->edns->udpsize(), $udpmax, 'packet->reply() supports EDNS' ); } for my $packet ( Net::DNS::Packet->new() ) { ## check $packet->sigrr my $sigrr = Net::DNS::RR->new( type => 'TSIG' ); my $other = Net::DNS::RR->new( type => 'AAAA' ); $packet->unique_push( 'additional' => $other ); is( $packet->sigrr(), undef, 'sigrr() undef for unsigned packet' ); is( $packet->verify(), undef, 'verify() fails for unsigned packet' ); ok( $packet->verifyerr(), 'verifyerr() returned for unsigned packet' ); is( ref( $packet->sign_tsig($sigrr) ), ref($sigrr), 'sign_tsig() returns TSIG record' ); is( $packet->verifyerr(), '', 'verifyerr() returns empty string' ); $packet->push( 'additional' => $sigrr ); is( ref( $packet->sigrr() ), ref($sigrr), 'sigrr() returns TSIG record' ); } eval { ## no critic # exercise dump and debug diagnostics require IO::File; require Data::Dumper; local $Data::Dumper::Maxdepth; local $Data::Dumper::Sortkeys; local $Data::Dumper::Useqq; my $packet = Net::DNS::Packet->new(); my $buffer = $packet->encode; my $corrupt = substr $buffer, 0, 10; my $file = '04-packet.txt'; my $handle = IO::File->new( $file, '>' ) || die "Could not open $file for writing"; select( ( select($handle), $packet->dump )[0] ); $Data::Dumper::Maxdepth = 6; $Data::Dumper::Sortkeys = 1; $Data::Dumper::Useqq = 1; select( ( select($handle), $packet->dump )[0] ); select( ( select($handle), Net::DNS::Packet->decode( \$buffer, 1 )->dump )[0] ); select( ( select($handle), Net::DNS::Packet->decode( \$corrupt, 1 ) )[0] ); close($handle); unlink($file); }; for my $packet ( Net::DNS::Packet->new(qw(example.com. A IN)) ) { my $wire = $packet->encode; while ( length($wire) ) { chop($wire); my $n = length($wire); ## Note: need to re-raise exception trapped by constructor exception( "decode truncated ($n octets)", sub { Net::DNS::Packet->decode( \$wire ); die } ); } my $sig = Net::DNS::RR->new( type => 'SIG' ); exception( 'reply->reply()', sub { $packet->reply->reply } ); exception( 'sign_tsig(...)', sub { $packet->sign_tsig($packet) } ); exception( 'sign_sig0(...)', sub { $packet->sign_sig0($packet) } ); exception( 'sig0 verify()', sub { $packet->sign_sig0($sig); $packet->verify } ); } exit; Net-DNS-1.50/t/05-CNAME.t0000644000175000017500000000256314756035515013671 0ustar willemwillem#!/usr/bin/perl # $Id: 05-CNAME.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 7; use Net::DNS; my $name = 'CNAME.example'; my $type = 'CNAME'; my $code = 5; my @attr = qw( cname ); my @data = qw( example.com ); my @also = qw( ); my $wire = '076578616d706c6503636f6d00'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } exit; Net-DNS-1.50/t/05-CDNSKEY.t0000644000175000017500000000631014756035515014140 0ustar willemwillem#!/usr/bin/perl # $Id: 05-CDNSKEY.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use Net::DNS; my @prerequisite = qw( MIME::Base64 ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 34; my $name = 'CDNSKEY.example'; my $type = 'CDNSKEY'; my $code = 60; my @attr = qw( flags protocol algorithm publickey ); my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my @data = ( 256, 3, 5, join '', qw( AQPSKmynfzW4kyBv015MUG2DeIQ3 Cbl+BBZH4b/0PY1kxkmvHjcZc8no kfzj31GajIQKY+5CptLr3buXA10h WqTkF7H6RfoRqXQeogmMHfpftf6z Mv1LyBUgia7za6ZEzOJBOztyvhjL 742iU/TpPSEDhm2SNKLijfUppn1U aNvv4w== ) ); my @also = qw( keybin keylength keytag privatekeyname zone revoke sep ); my $wire = join '', qw( 010003050103D22A6CA77F35B893206FD35E4C506D8378843709B97E041647E1 BFF43D8D64C649AF1E371973C9E891FCE3DF519A8C840A63EE42A6D2EBDDBB97 035D215AA4E417B1FA45FA11A9741EA2098C1DFA5FB5FEB332FD4BC8152089AE F36BA644CCE2413B3B72BE18CBEF8DA253F4E93D2103866D9234A2E28DF529A6 7D5468DBEFE3 ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = uc unpack 'H*', $decoded->encode; my $hex2 = uc unpack 'H*', $encoded; my $hex3 = uc unpack 'H*', $rr->rdata; is( $hex1, $hex2, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach ( @attr, qw(keylength keytag rdstring) ) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } $rr->algorithm(255); is( $rr->algorithm(), 255, 'algorithm number accepted' ); $rr->algorithm('RSASHA1'); is( $rr->algorithm(), 5, 'algorithm mnemonic accepted' ); is( $rr->algorithm('MNEMONIC'), 'RSASHA1', 'rr->algorithm("MNEMONIC") returns mnemonic' ); is( $rr->algorithm(), 5, 'rr->algorithm("MNEMONIC") preserves value' ); } for my $rr ( Net::DNS::RR->new("$name. $type 0 3 0 AA==") ) { # per RFC8078(4), erratum 5049 ok( ref($rr), "DNSKEY delete: $name. $type 0 3 0 AA==" ); is( $rr->flags(), 0, 'DNSKEY delete: flags 0' ); is( $rr->protocol(), 3, 'DNSKEY delete: protocol 3' ); is( $rr->algorithm(), 0, 'DNSKEY delete: algorithm 0' ); my $rdata = unpack 'H*', $rr->rdata(); is( $rdata, '0000030000', 'DNSKEY delete: rdata wire-format' ); is( $rr->rdstring(), '0 3 0 AA==', 'DNSKEY delete: presentation format' ); } for my $rr ( Net::DNS::RR->new("$name. $type 0 3 0 0") ) { # per RFC8078(4) as published is( $rr->rdstring(), '0 3 0 AA==', 'DNSKEY delete: accept old format' ); } Net::DNS::RR->new("$name $type @data")->print; exit; Net-DNS-1.50/t/05-APL.t0000644000175000017500000000353014756035515013455 0ustar willemwillem#!/usr/bin/perl # $Id: 05-APL.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 28; use TestToolkit; use Net::DNS; my $name = 'APL.example'; my $type = 'APL'; my $code = 42; my @attr = qw( aplist ); my @data = qw( 1:224.0.0.0/4 2:FF00::0/16 !1:192.168.38.0/28 1:224.0.0.0/0 2:FF00::0/0 ); my @also = qw( string negate family address ); # apitem attributes my $wire = '00010401e000021001ff00011c83c0a8260001000000020000'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } } for my $rr ( Net::DNS::RR->new("$name $type @data") ) { foreach my $item ( $rr->aplist ) { foreach (@also) { ok( defined( $item->$_ ), "aplist item->$_() attribute" ); } } } for my $rr ( Net::DNS::RR->new("$name $type @data") ) { my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); my $emptyrr = Net::DNS::RR->new("$name $type")->encode; my $corrupt = pack 'a*X2na*', $emptyrr, $decoded->rdlength - 1, $rr->rdata; exception( 'corrupt wire-format', sub { Net::DNS::RR->decode( \$corrupt ) } ); } exception( 'unknown address family', sub { Net::DNS::RR->new("$name $type 0:0::0/0") } ); exit; Net-DNS-1.50/t/05-SPF.t0000644000175000017500000000261114756035515013470 0ustar willemwillem#!/usr/bin/perl # $Id: 05-SPF.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 7; use Net::DNS; my $name = 'SPF.example'; my $type = 'SPF'; my $code = 99; my @attr = qw( spfdata ); my @data = ('v=spf1 +mx a:colo.example.com/28 -all'); my @also = qw( txtdata ); my $wire = '25763d73706631202b6d7820613a636f6c6f2e6578616d706c652e636f6d2f3238202d616c6c'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { my $r1 = join '', $rr->$_; is( $r1, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { my $r1 = join '', $rr->$_; my $r2 = join '', $rr2->$_; is( $r2, $r1, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } exit; Net-DNS-1.50/t/22-NSEC-match.t0000644000175000017500000000165414756035515014667 0ustar willemwillem#!/usr/bin/perl # $Id: 22-NSEC-match.t 1856 2021-12-02 14:36:25Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use Net::DNS; my @prerequisite = qw( Net::DNS::RR::NSEC ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 8; my $owner = 'match.example.com'; my $nxtdname = 'irrelevant'; my @typelist = qw(TYPE1 TYPE2 TYPE3); my @args = ( $nxtdname, @typelist ); my $nsec = Net::DNS::RR->new("$owner NSEC @args"); my @match = qw( match.example.com. match.EXAMPLE.com MATCH.example.com match.example.com ); my @nomatch = qw( example.com *.example.com mis.match.example.com mis-match.example.com ); foreach my $name (@match) { ok( $nsec->match($name), " nsec->match($name)" ); } foreach my $name (@nomatch) { ok( !$nsec->match($name), "!nsec->match($name)" ); } exit; __END__ Net-DNS-1.50/t/08-recurse.t0000644000175000017500000000667514756035515014531 0ustar willemwillem#!/usr/bin/perl # $Id: 08-recurse.t 2007 2025-02-08 16:45:23Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use TestToolkit; use Net::DNS; use Net::DNS::Resolver::Recurse; my @hints = Net::DNS::Resolver->new()->_hints; exit( plan skip_all => 'Online tests disabled.' ) if -e 't/online.disabled'; exit( plan skip_all => 'Online tests disabled.' ) unless -e 't/online.enabled'; eval { my $resolver = Net::DNS::Resolver->new(); exit plan skip_all => 'No nameservers' unless $resolver->nameservers; my $reply = $resolver->send(qw(. NS IN)) || die $resolver->errorstring; my @ns = grep { $_->type eq 'NS' } $reply->answer, $reply->authority; exit plan skip_all => 'Local nameserver broken' unless scalar @ns; 1; } || exit( plan skip_all => "Non-responding local nameserver: $@" ); eval { my $resolver = Net::DNS::Resolver->new( nameservers => [@hints] ); exit plan skip_all => 'No nameservers' unless $resolver->nameservers; my $reply = $resolver->send(qw(. NS IN)) || die $resolver->errorstring; my $from = $reply->from(); my @ns = grep { $_->type eq 'NS' } $reply->answer; exit plan skip_all => "No NS RRs in response from $from" unless scalar @ns; exit plan skip_all => "Non-authoritative response from $from" unless $reply->header->aa; 1; } || exit( plan skip_all => "Cannot reach global root: $@" ); plan tests => 12; NonFatalBegin(); SKIP: { my $res = Net::DNS::Resolver::Recurse->new(); ok( $res->isa('Net::DNS::Resolver::Recurse'), 'new() created object' ); my $reply = $res->send( '.', 'NS' ); is( ref($reply), 'Net::DNS::Packet', 'response received for priming query' ); skip( 'no response to priming query', 3 ) unless $reply; my $from = $reply->from(); ok( $reply->header->aa, "authoritative response from $from" ); my @ns = grep { $_->type eq 'NS' } $reply->answer; my $ns = scalar(@ns); ok( scalar(@ns), "$ns NS RRs in response from $from" ); my @ar = grep { $_->can('address') } $reply->additional; my $ar = scalar(@ar); ok( scalar(@ar), "$ar address RRs in response from $from" ); } for my $res ( Net::DNS::Resolver::Recurse->new( debug => 0 ) ) { my $reply = $res->send( 'www.net-dns.org', 'A' ); is( ref($reply), 'Net::DNS::Packet', 'query returned a packet' ); } for my $res ( Net::DNS::Resolver::Recurse->new( debug => 0 ) ) { # test the callback my $count = 0; $res->callback( sub { $count++ } ); $res->send( 'a.t.net-dns.org', 'A' ); ok( $count >= 3, "Lookup took $count queries" ); } for my $res ( Net::DNS::Resolver::Recurse->new( debug => 0 ) ) { my $count = 0; $res->callback( sub { $count++ } ); $res->send( '2a04:b900:0:0:8:0:0:60', 'PTR' ); ok( $count >= 3, "Reverse lookup took $count queries" ); } for my $res ( Net::DNS::Resolver::Recurse->new() ) { is( scalar( $res->hints() ), 0, 'hints() initially empty' ); $res->hints(@hints); is( scalar( $res->hints ), scalar(@hints), 'hints() set' ); } for my $res ( Net::DNS::Resolver::Recurse->new( debug => 0 ) ) { $res->callback( sub { my $reply = shift; my ($q) = $reply->question; my ($a) = ( $reply->authority, $reply->answer ); $a->{owner} = Net::DNS::DomainName->new('bogus.example') if lc( $a->owner ) eq lc( $q->qname ); } ); my $reply = $res->send( 'net-dns.org', 'NS' ); is( $reply, undef, 'reject bogus referral' ); } for my $res ( Net::DNS::Resolver::Recurse->new() ) { local $res->{recurse_depth} = 200; exception( 'deep recursion', sub { $res->send('www.net-dns.org') } ); } NonFatalEnd(); exit; Net-DNS-1.50/t/05-SVCB.t0000644000175000017500000001716214756035515013604 0ustar willemwillem#!/usr/bin/perl # $Id: 05-SVCB.t 1996 2024-12-16 13:05:08Z willem $ -*-perl-*- # use strict; use warnings; use Net::DNS; use Net::DNS::ZoneFile; use Test::More; use TestToolkit; exit( plan skip_all => 'unresolved AUTOLOAD regression [perl #120694]' ) unless ( $] > 5.018001 ) or ( $] < 5.018 ); plan tests => 48; my $name = 'SVCB.example'; my $type = 'SVCB'; my $code = 64; my @attr = qw( svcpriority targetname port ); my @data = qw( 1 pool.svc.example 1234 ); my @also = qw(mandatory alpn no-default-alpn port ipv4hint ech ipv6hint dohpath ohttp); my $wire = '000104706f6f6c03737663076578616d706c65000003000204d2'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (qw(svcpriority targetname)) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach ( qw(TargetName), @also ) { is( $rr->$_(), undef, "empty RR has undefined $_" ); } $rr->svcpriority(1); $rr->targetname('.'); my $l0 = length $rr->encode; $rr->no_default_alpn(0); $rr->no_default_alpn(1); isnt( length( $rr->encode ), $l0, 'insert SvcParams key' ); $rr->no_default_alpn(undef); is( length( $rr->encode ), $l0, 'delete SvcParams key' ); } for my $corruption ( pack 'H*', '00004000010000000000070001000bad0001' ) { local $SIG{__WARN__} = sub { }; my $rr = Net::DNS::RR->decode( \$corruption ); like( $rr->string, '/corrupt/i', 'string() includes corrupt RDATA' ); } Net::DNS::RR->new( <<'END' )->print; example.com. SVCB 16 foo.example.org. ( mandatory=alpn alpn=h2,h3-19 no-default-alpn port=1234 ipv4hint=192.0.2.1 ech=AEP+DQA/BAAgACCW2/dfOBZAtQU55/py/BlhdRdaauPAkrERAUwppoeSEgAEAAEAAQAQY2QxLnRlc3QuZGVmby5pZQAA ipv6hint=2001:db8::1 dohpath=/dns-query{?dns} ohttp tls-supported-groups=29,23 ) END #### Test Vectors my $zonefile = Net::DNS::ZoneFile->new( \*DATA ); sub testcase { my $ident = shift; my $vector = $zonefile->read; my $expect = $zonefile->read; is( $vector->string, $expect->string, $ident ); return; } sub failure { my $ident = shift; exception( "$ident", sub { $zonefile->read } ); return; } testcase('SVCB Alias Form'); testcase('SVCB Service Form'); testcase('SVCB defines a port'); testcase('unregistered key, unquoted value'); testcase('unregistered key, quoted with decimal escape'); testcase('two IPv6 hints in quoted presentation format'); testcase('single IPv6 hint in IPv4 mapped IPv6 format'); testcase('unsorted SvcParams and mandatory key list'); failure('alpn with escaped escape and escaped comma'); # Appendix A not implemented $zonefile->read(); failure('alpn with numeric escape and escaped comma'); $zonefile->read(); failure('key already defined'); foreach my $key (qw(mandatory alpn port ipv4hint ech ipv6hint)) { failure("no argument ($key)"); } failure('no-default-alpn + value'); failure('port + multiple values'); failure('ech + multiple values'); failure('mandatory lists key0'); failure('duplicate mandatory key'); failure('undefined mandatory key'); failure('alpn not specified'); failure('unrecognised key name'); failure('invalid SvcParam key'); failure('non-numeric port value'); failure('corrupt wire format'); exit; __DATA__ ;; D.1. Alias Form example.com. SVCB 0 foo.example.com. example.com SVCB \# 19 ( 00 00 ; priority 03 66 6f 6f 07 65 78 61 6d 70 6c 65 03 63 6f 6d 00 ; target ) ;; D.2. Service Form example.com. SVCB 1 . example.com SVCB \# 3 ( 00 01 ; priority 00 ; target (root label) ) example.com. SVCB 16 foo.example.com. port=53 example.com SVCB \# 25 ( 00 10 ; priority 03 66 6f 6f 07 65 78 61 6d 70 6c 65 03 63 6f 6d 00 ; target 00 03 ; key 3 00 02 ; length 2 00 35 ; value ) example.com. SVCB 1 foo.example.com. key667=hello example.com SVCB \# 28 ( 00 01 ; priority 03 66 6f 6f 07 65 78 61 6d 70 6c 65 03 63 6f 6d 00 ; target 02 9b ; key 667 00 05 ; length 5 68 65 6c 6c 6f ; value ) example.com. SVCB 1 foo.example.com. key667="hello\210qoo" example.com SVCB \# 32 ( 00 01 ; priority 03 66 6f 6f 07 65 78 61 6d 70 6c 65 03 63 6f 6d 00 ; target 02 9b ; key 667 00 09 ; length 9 68 65 6c 6c 6f d2 71 6f 6f ; value ) example.com. SVCB 1 foo.example.com. ipv6hint="2001:db8::1,2001:db8::53:1" example.com SVCB \# 55 ( 00 01 ; priority 03 66 6f 6f 07 65 78 61 6d 70 6c 65 03 63 6f 6d 00 ; target 00 06 ; key 6 00 20 ; length 32 20 01 0d b8 00 00 00 00 00 00 00 00 00 00 00 01 ; first address 20 01 0d b8 00 00 00 00 00 00 00 00 00 53 00 01 ; second address ) example.com. SVCB 1 example.com. ipv6hint="::ffff:198.51.100.100" example.com SVCB \# 35 ( 00 01 ; priority 07 65 78 61 6d 70 6c 65 03 63 6f 6d 00 ; target 00 06 ; key 6 00 10 ; length 16 00 00 00 00 00 00 00 00 00 00 ff ff c6 33 64 64 ; address ) example.com. SVCB 1 foo.example.org. ( ; unsorted SvcParam keys key23609 key23600 mandatory=key23609,key23600 ) example.com SVCB \# 35 ( 00 01 ; priority 03 66 6f 6f 07 65 78 61 6d 70 6c 65 03 6f 72 67 00 ; target 00 00 ; key 0 00 04 ; param length 4 5c 30 ; value: key 23600 5c 39 ; value: key 23609 5c 30 ; key 23600 00 00 ; param length 0 5c 39 ; key 23609 00 00 ; param length 0 ) foo.example.com SVCB 16 foo.example.org. alpn="f\\\\oo\\,bar,h2" foo.example.com SVCB \# 35 ( 00 10 ; priority 03 66 6f 6f 07 65 78 61 6d 70 6c 65 03 6f 72 67 00 ; target 00 01 ; key 1 00 0c ; param length 12 08 ; alpn length 8 66 5c 6f 6f 2c 62 61 72 ; alpn value 02 ; alpn length 2 68 32 ; alpn value ) foo.example.com SVCB 16 foo.example.org. alpn=f\\\092oo\092,bar,h2 foo.example.com SVCB \# 35 ( 00 10 ; priority 03 66 6f 6f 07 65 78 61 6d 70 6c 65 03 6f 72 67 00 ; target 00 01 ; key 1 00 0c ; param length 12 08 ; alpn length 8 66 5c 6f 6f 2c 62 61 72 ; alpn value 02 ; alpn length 2 68 32 ; alpn value ) ;; D.3. Failure Cases example.com. SVCB 1 foo.example.com. ( key123=abc key123=def ) example.com. SVCB 1 foo.example.com. mandatory example.com. SVCB 1 foo.example.com. alpn example.com. SVCB 1 foo.example.com. port example.com. SVCB 1 foo.example.com. ipv4hint example.com. SVCB 1 foo.example.com. ech example.com. SVCB 1 foo.example.com. ipv6hint example.com. SVCB 1 foo.example.com. no-default-alpn=abc example.com. SVCB 1 foo.example.com. port=1234,5678 example.com. SVCB 1 foo.example.com. ech=b25l,Li4u example.com. SVCB 1 foo.example.com. mandatory=mandatory example.com. SVCB 1 foo.example.com. ( mandatory=key123,key123 key123=abc ) example.com. SVCB 1 foo.example.com. mandatory=key123 example.com. SVCB 1 foo.example.com. ( no-default-alpn ; without expected alpn ) example.com. SVCB 1 foo.example.com. mandatory=bogus example.com. SVCB 1 foo.example.com. key65535=invalid example.com. SVCB 1 foo.example.com. port=1234X5 example.com. SVCB ( \# 25 0001 ; 1 03666f6f076578616d706c6503636f6d 00 ; foo.example.com. 0003 0003 0035 ) ; corrupt wire format Net-DNS-1.50/t/03-question.t0000644000175000017500000001456614756035515014721 0ustar willemwillem#!/usr/bin/perl # $Id: 03-question.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 105; use TestToolkit; use Net::DNS::Question; use Net::DNS::Parameters; for my $question ( Net::DNS::Question->new( my $name = 'example.com', 'A', 'IN' ) ) { ok( $question->isa('Net::DNS::Question'), 'object returned by new() constructor' ); is( $question->qname, $name, '$question->qname returns expected value' ); is( $question->qtype, 'A', '$question->qtype returns expected value' ); is( $question->qclass, 'IN', '$question->qclass returns expected value' ); is( $question->name, $name, '$question->name returns expected value' ); is( $question->type, $question->qtype, '$question->type returns expected value' ); is( $question->zname, $name, '$question->zname returns expected value' ); is( $question->ztype, $question->qtype, '$question->ztype returns expected value' ); is( $question->zclass, $question->class, '$question->zclass returns expected value' ); my $string = $question->string; my $expected = "$name.\tIN\tA"; is( $string, $expected, '$question->string returns text representation of object' ); my $test = 'new() argument undefined or absent'; is( Net::DNS::Question->new( $name, 'A', undef )->string, $expected, "$test\t( $name,\tA,\tundef\t)" ); is( Net::DNS::Question->new( $name, 'A', () )->string, $expected, "$test\t( $name,\tA,\t\t)" ); is( Net::DNS::Question->new( $name, undef, 'IN' )->string, $expected, "$test\t( $name,\tundef,\tIN\t)" ); is( Net::DNS::Question->new( $name, (), 'IN' )->string, $expected, "$test\t( $name,\t\tIN\t)" ); is( Net::DNS::Question->new( $name, undef, undef )->string, $expected, "$test\t( $name,\tundef,\tundef\t)" ); is( Net::DNS::Question->new( $name, (), () )->string, $expected, "$test\t( $name \t\t\t)" ); } foreach my $class (qw(IN CLASS1 ANY)) { my $test = 'new() arguments in zone file order'; my $fqdn = 'example.com.'; foreach my $type (qw(A TYPE1 ANY)) { my $testcase = Net::DNS::Question->new( $fqdn, $class, $type )->string; my $expected = Net::DNS::Question->new( $fqdn, $type, $class )->string; is( $testcase, $expected, "$test\t( $fqdn,\t$class,\t$type\t)" ); } } foreach my $class (qw(IN HS ANY)) { my $test = 'decoded object matches encoded data'; foreach my $type (qw(A AAAA MX NS SOA ANY)) { my $question = Net::DNS::Question->new( 'example.com', $type, $class ); my $encoded = $question->encode; my $expected = $question->string; my $decoded = Net::DNS::Question->decode( \$encoded ); is( $decoded->string, $expected, "$test\t$expected" ); } } for my $question ( Net::DNS::Question->new('example.com') ) { my $encoded = $question->encode; my ( $decoded, $offset ) = Net::DNS::Question->decode( \$encoded ); is( $offset, length($encoded), 'returned offset has expected value' ); } my @IPv4part = ( 1 .. 4 ); while (@IPv4part) { my $test = 'interpret IPv4 prefix as PTR query'; my $prefix = join '.', @IPv4part; my $domain = Net::DNS::Question->new($prefix); my $actual = $domain->qname; my $invert = join '.', reverse 'in-addr.arpa', @IPv4part; my $inaddr = Net::DNS::Question->new($invert); my $expect = $inaddr->qname; is( $actual, $expect, "$test\t$prefix" ); pop @IPv4part; } foreach my $type (qw(NS SOA ANY)) { my $test = "query $type in in-addr.arpa namespace"; my $question = Net::DNS::Question->new( '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 = Net::DNS::Question->new("$ip4/$n"); my $expect = Net::DNS::Question->new("$ip4/$m"); my $string = $expect->qname; is( $actual->qname, $expect->qname, "$test\t$string" ); } is( Net::DNS::Question->new('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( Net::DNS::Question->new('::ffff:192.0.2.1')->string, "1.2.0.192.in-addr.arpa.\tIN\tPTR", 'interpret IPv6 form of IPv4 address as query in in-addr.arpa' ); is( Net::DNS::Question->new('1:2:3:4:5:6:192.0.2.1')->string, "1.0.2.0.0.0.0.c.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 + embedded IPv4 address as query in ip6.arpa' ); is( Net::DNS::Question->new(':x:')->string, ":x:.\tIN\tA", 'non-address character precludes interpretation as PTR query' ); is( Net::DNS::Question->new(':.:')->string, ":.:.\tIN\tA", 'non-numeric character precludes interpretation as PTR query' ); my @IPv6part = ( 1 .. 8 ); while (@IPv6part) { my $n = 16 * scalar(@IPv6part); my $test = 'interpret IPv6 prefix as PTR query'; my $prefix = join ':', @IPv6part; my $actual = Net::DNS::Question->new($prefix)->qname; my $expect = Net::DNS::Question->new("$prefix/$n")->qname; is( $actual, $expect, "$test\t$prefix" ) if $prefix =~ /:/; pop @IPv6part; } 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 = Net::DNS::Question->new("$ip6/$n"); my $expect = Net::DNS::Question->new("$ip6/$m"); my $string = $expect->qname; is( $actual->qname, $expect->qname, "$test\t$string" ); } foreach my $i ( reverse 0 .. 6 ) { my $expected = length Net::DNS::Question->new('1:2:3:4:5:6:7:8')->qname; foreach my $j ( $i + 3 .. 9 ) { my $ip6 = join( ':', 1 .. $i ) . '::' . join( ':', $j .. 8 ); my $name = Net::DNS::Question->new("$ip6")->qname; is( length $name, $expected, "check length of expanded IPv6 address\t$ip6" ); } } eval { ## no critic # exercise but do not test print require IO::File; my $object = Net::DNS::Question->new('example.com'); my $file = '03-question.txt'; my $handle = IO::File->new( $file, '>' ) || die "Could not open $file for writing"; select( ( select($handle), $object->print )[0] ); close($handle); unlink($file); }; exception( 'argument undefined', sub { Net::DNS::Question->new(undef) } ); exception( 'corrupt wire-format', sub { my $wire = pack 'H*', '000001'; Net::DNS::Question->decode( \$wire ) } ); foreach my $method (qw(qname qtype qclass name)) { exception( "$method is read-only", sub { Net::DNS::Question->new('.')->$method('any') } ); } exit; Net-DNS-1.50/t/43-DNSKEY-keylength.t0000644000175000017500000000373114756035515016033 0ustar willemwillem#!/usr/bin/perl # $Id: 43-DNSKEY-keylength.t 1957 2024-01-10 14:54:10Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use Net::DNS; my @prerequisite = qw( MIME::Base64 Net::DNS::RR::DNSKEY; ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 7; my $rsa = Net::DNS::RR->new( <<'END' ); RSASHA1.example. IN DNSKEY 256 3 5 ( AwEAAZHbngk6sMoFHN8fsYY6bmGR4B9UYJIqDp+mORLEH53Xg0f6RMDtfx+H3/x7bHTUikTr26bV AqsxOs2KxyJ2Xx9RGG0DB9O4gpANljtTq2tLjvaQknhJpSq9vj4CqUtr6Wu152J2aQYITBoQLHDV i8mIIunparIKDmhy8TclVXg9 ) ; Key ID = 1623 END ok( $rsa, 'set up RSA public key' ); is( $rsa->keylength, 1024, 'RSA keylength has expected value' ); my $longformat = pack 'xn a*', unpack 'C a*', $rsa->keybin; $rsa->keybin($longformat); is( $rsa->keylength, 1024, 'keylength for long format RSA key' ); my $dsa = Net::DNS::RR->new( <<'END' ); DSA.example. IN DNSKEY 256 3 3 ( CMKzsCaT2Jy1w/sPdpigEE+nbeJ/x5C6cruWvStVum6/YulcR7MHeujx9c2iBDbo3kW4X8/l+qgk 7ZEZ+yV5lphWtJMmMtOHIU+YdAhgLpt84NKhcupWL8wfuBW/97cqIv5Z+51fwn0YEAcZsoCrE0nL 5+31VfkK9LTNuVo38hsbWa3eWZFalID5NesF6sJRgXZoAyeAH46EQVCq1UBnnaHslvSDkdb+Z1kT bMQ64ZVI/sBRXRbqIcDlXVZurCTDV7JL9KZwwfeyrQcnVyYh5mdHPsXbpX5NQJvoqPgvRZWBpP4h pjkAm9UrUbow9maPCQ1JQ3JuiU5buh9cjAI+QIyGMujKLT2OsogSZD2IFUciaZBL/rSe0gmAUv0q XrczmIYFUCoRGZ6+lKVqQQ6f2U7Gsr6zRbeJN+JCVD6BJ52zjLUaWUPHbakhZb/wMO7roX/tnA/w zoDYBIIF7yuRYWblgPXBJTK2Bp07xre8lKCRbzY4J/VXZFziZgHgcn9tkHnrfov04UG9zlWEdT6X E/60HjrP ) ; Key ID = 53244 END ok( $dsa, 'set up DSA public key' ); is( $dsa->keylength, 1024, 'DSA keylength has expected value' ); my $ecdsa = Net::DNS::RR->new( <<'END' ); ECDSAP256SHA256.example. IN DNSKEY 256 3 13 ( 7Y4BZY1g9uzBwt3OZexWk7iWfkiOt0PZ5o7EMip0KBNxlBD+Z58uWutYZIMolsW8v/3rfgac45lO IikBZK4KZg== ) ; Key ID = 44222 END ok( $ecdsa, 'set up ECDSA public key' ); is( $ecdsa->keylength, 256, 'ECDSA keylength has expected value' ); exit; __END__ Net-DNS-1.50/t/05-MINFO.t0000644000175000017500000000266614756035515013722 0ustar willemwillem#!/usr/bin/perl # $Id: 05-MINFO.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 9; use Net::DNS; my $name = 'MINFO.example'; my $type = 'MINFO'; my $code = 14; my @attr = qw( rmailbx emailbx ); my @data = qw( rp@example.com rp@example.net ); my @also = qw( ); my $wire = '027270076578616d706c6503636f6d00027270076578616d706c65036e657400'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } exit; Net-DNS-1.50/t/05-ZONEMD.t0000644000175000017500000000360714756035515014042 0ustar willemwillem#!/usr/bin/perl # $Id: 05-ZONEMD.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 20; use TestToolkit; use Net::DNS; my $name = 'ZONEMD.example'; my $type = 'ZONEMD'; my $code = 63; my @attr = qw( serial scheme algorithm digest); my @data = ( 12345, 1, 1, '2bb183af5f22588179a53b0a98631fad1a292118' ); my @also = qw( digestbin ); my $wire = join '', qw( 00003039 01 01 2BB183AF5F22588179A53B0A98631FAD1A292118 ); my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = uc unpack 'H*', $decoded->encode; my $hex2 = uc unpack 'H*', $encoded; my $hex3 = uc unpack 'H*', $rr->rdata; is( $hex1, $hex2, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach ( @attr, @also, 'rdstring' ) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } exception( 'corrupt hexadecimal', sub { $rr->digest('123456789XBCDEF') } ); } for my $rr ( Net::DNS::RR->new( type => $type, scheme => 1 ) ) { ok( $rr->string, 'string method with default values' ); is( $rr->string, Net::DNS::RR->new( $rr->string )->string, 'parse $rr->string' ); $rr->digestbin(''); ok( $rr->string, 'string method with null digest' ); } exit; Net-DNS-1.50/t/02-domainname.t0000644000175000017500000001260214756035515015146 0ustar willemwillem#!/usr/bin/perl # $Id: 02-domainname.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 35; use TestToolkit; use_ok('Net::DNS::DomainName'); for my $domain ( Net::DNS::DomainName->new('') ) { is( $domain->name, '.', 'DNS root represented as single dot' ); my @label = $domain->_wire; is( scalar(@label), 0, "DNS root name has zero labels" ); my $binary = unpack 'H*', $domain->encode; my $expect = '00'; is( $binary, $expect, 'DNS root wire-format representation' ); } my $ldh = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz-0123456789'; for my $domain ( Net::DNS::DomainName->new($ldh) ) { is( $domain->name, $ldh, '63 octet LDH character label' ); my @label = $domain->_wire; is( scalar(@label), 1, "name has single 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 ) = Net::DNS::DomainName->decode( \$buffer ); is( $decoded->name, $domain->name, 'simple wire-format decoding' ); my $subdomain = Net::DNS::DomainName->new("sub.$ldh"); is( Net::DNS::DomainName->decode( \$subdomain->encode )->name, $subdomain->name, 'simple wire-format decoding' ); my $data = '03737562c000c000c000'; $buffer .= pack( 'H*', $data ); my $cache = {}; ( $decoded, $offset ) = Net::DNS::DomainName->decode( \$buffer, $offset, $cache ); is( $decoded->name, $subdomain->name, 'compressed wire-format decoding' ); my @labels = $decoded->_wire; is( scalar(@labels), 2, "decoded name has two labels" ); $decoded = Net::DNS::DomainName->decode( \$buffer, $offset, $cache ); is( $decoded->name, $domain->name, 'compressed wire-format decoding' ); } for my $domain ( Net::DNS::DomainName->new( 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 = Net::DNS::DomainName->decode( \$data ); my $downcased = Net::DNS::DomainName->new( lc $domain->name )->encode( 0, {} ); ok( $domain->isa('Net::DNS::DomainName'), 'object returned by new() constructor' ); ok( $decoded->isa('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' ); } for my $domain ( Net::DNS::DomainName1035->new( 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 = Net::DNS::DomainName1035->decode( \$data ); my $downcased = Net::DNS::DomainName1035->new( lc $domain->name )->encode( 0x4000, {} ); ok( $domain->isa('Net::DNS::DomainName1035'), 'object returned by new() constructor' ); ok( $decoded->isa('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' ); } for my $domain ( Net::DNS::DomainName2535->new( 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 = Net::DNS::DomainName2535->decode( \$data ); my $downcased = Net::DNS::DomainName2535->new( lc $domain->name )->encode( 0, {} ); ok( $domain->isa('Net::DNS::DomainName2535'), 'object returned by new() constructor' ); ok( $decoded->isa('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' ); } my $truncated = pack 'H*', '0200'; exception( 'truncated wire-format', sub { Net::DNS::DomainName->decode( \$truncated ) } ); my $type1label = pack 'H*', join '', '40', '4142434445464748494a4b4c4d4e4f50' x 4, '00'; exception( 'unsupported wire-format', sub { Net::DNS::DomainName->decode( \$type1label ) } ); my $type2label = pack 'H*', join '', '80', '4142434445464748494a4b4c4d4e4f50' x 8, '00'; exception( 'unsupported wire-format', sub { Net::DNS::DomainName->decode( \$type2label ) } ); my $overreach = pack 'H*', 'c002'; exception( 'bad compression pointer', sub { Net::DNS::DomainName->decode( \$overreach ) } ); my $loop = pack 'H*', '0344454603414243c000'; exception( 'compression loop', sub { Net::DNS::DomainName->decode( \$loop, 4 ) } ); exit; Net-DNS-1.50/t/06-update.t0000644000175000017500000002002114756035515014316 0ustar willemwillem#!/usr/bin/perl # $Id: 06-update.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 84; use Net::DNS; 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 $default = Net::DNS::Resolver->domain('example.org'); # resolver default domain #------------------------------------------------------------------------------ # Packet creation. #------------------------------------------------------------------------------ for my $packet ( Net::DNS::Update->new( $zone, $class ) ) { # specified domain ok( $packet, 'new() returned packet' ); is( $packet->header->opcode, 'UPDATE', 'header opcode correct' ); my ($z) = $packet->zone; is( $z->zname, $zone, 'zname from explicit argument' ); is( $z->zclass, $class,'zclass correct' ); is( $z->ztype, 'SOA', 'ztype correct' ); } for my $packet ( Net::DNS::Update->new() ) { my ($z) = $packet->zone; is( $z->zname, $default, 'zname from resolver defaults' ); } #------------------------------------------------------------------------------ # RRset exists (value-independent). #------------------------------------------------------------------------------ for my $rr ( yxrrset( my $arg = "$name $ttl $class $type" ) ) { ok( $rr, "yxrrset($arg)" ); is( $rr->name, $name, 'yxrrset - right name' ); is( $rr->ttl, 0, 'yxrrset - ttl 0' ); is( $rr->class, 'ANY', 'yxrrset - class ANY' ); is( $rr->type, $type, "yxrrset - type $type" ); ok( is_empty( $rr->rdstring ), 'yxrrset - data empty' ); } #------------------------------------------------------------------------------ # RRset exists (value-dependent). #------------------------------------------------------------------------------ for my $rr ( yxrrset( my $arg = "$name $ttl $class $type $rdata" ) ) { ok( $rr, "yxrrset($arg)" ); is( $rr->name, $name, 'yxrrset - right name' ); is( $rr->ttl, 0, 'yxrrset - ttl 0' ); is( $rr->class, $class, "yxrrset - class $class" ); is( $rr->type, $type, "yxrrset - type $type" ); is( $rr->rdstring, $rdata, 'yxrrset - right data' ); } #------------------------------------------------------------------------------ # RRset does not exist. #------------------------------------------------------------------------------ for my $rr ( nxrrset( my $arg = "$name $ttl $class $type $rdata" ) ) { ok( $rr, "nxrrset($arg)" ); is( $rr->name, $name, 'nxrrset - right name' ); is( $rr->ttl, 0, 'nxrrset - ttl 0' ); is( $rr->class, 'NONE', 'nxrrset - class NONE' ); is( $rr->type, $type, "nxrrset - type $type" ); ok( is_empty( $rr->rdstring ), 'nxrrset - data empty' ); } #------------------------------------------------------------------------------ # Name is in use. #------------------------------------------------------------------------------ for my $rr ( yxdomain( my $arg = "$name" ) ) { ok( $rr, "yxdomain($arg)" ); is( $rr->name, $name, 'yxdomain - right name' ); is( $rr->ttl, 0, 'yxdomain - ttl 0' ); is( $rr->class, 'ANY', 'yxdomain - class ANY' ); is( $rr->type, 'ANY', 'yxdomain - type ANY' ); ok( is_empty( $rr->rdstring ), 'yxdomain - data empty' ); } for my $rr ( yxdomain( my @arg = ( name => $name ) ) ) { ok( $rr, "yxdomain(@arg)" ); is( $rr->name, $name, 'yxdomain - right name' ); is( $rr->ttl, 0, 'yxdomain - ttl 0' ); is( $rr->class, 'ANY', 'yxdomain - class ANY' ); is( $rr->type, 'ANY', 'yxdomain - type ANY' ); ok( is_empty( $rr->rdstring ), 'yxdomain - data empty' ); } #------------------------------------------------------------------------------ # Name is not in use. #------------------------------------------------------------------------------ for my $rr ( nxdomain( my $arg = "$name" ) ) { ok( $rr, "nxdomain($arg)" ); is( $rr->name, $name, 'nxdomain - right name' ); is( $rr->ttl, 0, 'nxdomain - ttl 0' ); is( $rr->class, 'NONE', 'nxdomain - class NONE' ); is( $rr->type, 'ANY', 'nxdomain - type ANY' ); ok( is_empty( $rr->rdstring ), 'nxdomain - data empty' ); } for my $rr ( nxdomain( my @arg = ( name => $name ) ) ) { ok( $rr, "nxdomain(@arg)" ); is( $rr->name, $name, 'nxdomain - right name' ); is( $rr->ttl, 0, 'nxdomain - ttl 0' ); is( $rr->class, 'NONE', 'nxdomain - class NONE' ); is( $rr->type, 'ANY', 'nxdomain - type ANY' ); ok( is_empty( $rr->rdstring ), 'nxdomain - data empty' ); } #------------------------------------------------------------------------------ # Add to an RRset. #------------------------------------------------------------------------------ for my $rr ( rr_add( my $arg = "$name $ttl $class $type $rdata" ) ) { ok( $rr, "rr_add($arg)" ); is( $rr->name, $name, 'rr_add - right name' ); is( $rr->ttl, $ttl, "rr_add - ttl $ttl" ); is( $rr->class, $class, "rr_add - class $class" ); is( $rr->type, $type, "rr_add - type $type" ); is( $rr->rdstring, $rdata, 'rr_add - right data' ); } for my $rr ( rr_add( my $arg = "$name $class $type $rdata" ) ) { my $rr = rr_add($arg); ok( $rr, "rr_add($arg)" ); is( $rr->name, $name, 'rr_add - right name' ); is( $rr->ttl, 86400, "rr_add - ttl 86400" ); is( $rr->class, $class, "rr_add - class $class" ); is( $rr->type, $type, "rr_add - type $type" ); is( $rr->rdstring, $rdata, 'rr_add - right data' ); } #------------------------------------------------------------------------------ # Delete an RRset. #------------------------------------------------------------------------------ for my $rr ( rr_del( my $arg = "$name $class $type" ) ) { ok( $rr, "rr_del($arg)" ); is( $rr->name, $name, 'rr_del - right name' ); is( $rr->ttl, 0, 'rr_del - ttl 0' ); is( $rr->class, 'ANY', 'rr_del - class ANY' ); is( $rr->type, $type, "rr_del - type $type" ); ok( is_empty( $rr->rdstring ), 'rr_del - data empty' ); } #------------------------------------------------------------------------------ # Delete All RRsets From A Name. #------------------------------------------------------------------------------ for my $rr ( rr_del( my $arg = "$name" ) ) { ok( $rr, "rr_del($arg)" ); is( $rr->name, $name, 'rr_del - right name' ); is( $rr->ttl, 0, 'rr_del - ttl 0' ); is( $rr->class, 'ANY', 'rr_del - class ANY' ); is( $rr->type, 'ANY', 'rr_del - type ANY' ); ok( is_empty( $rr->rdstring ), 'rr_del - data empty' ); } #------------------------------------------------------------------------------ # Delete An RR From An RRset. #------------------------------------------------------------------------------ for my $rr ( rr_del( my $arg = "$name $class $type $rdata" ) ) { ok( $rr, "rr_del($arg)" ); is( $rr->name, $name, 'rr_del - right name' ); is( $rr->ttl, 0, 'rr_del - ttl 0' ); is( $rr->class, 'NONE', 'rr_del - class NONE' ); is( $rr->type, $type, "rr_del - type $type" ); is( $rr->rdstring, $rdata, 'rr_del - right data' ); } #------------------------------------------------------------------------------ # Make sure RRs in an update packet have the same class as the zone, unless # the class is NONE or ANY. #------------------------------------------------------------------------------ for my $packet ( Net::DNS::Update->new( $zone, $class ) ) { ok( $packet, 'packet created' ); $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, '"pre" length correct' ); is( $pre[0]->class, $class, 'first class right' ); is( $pre[1]->class, $class, 'second class right' ); is( $pre[2]->class, 'ANY', 'third class right' ); is( $pre[3]->class, 'NONE', 'fourth class right' ); } Net-DNS-1.50/t/03-parameters.t0000644000175000017500000000560314756035515015205 0ustar willemwillem#!/usr/bin/perl # $Id: 03-parameters.t 1921 2023-05-08 18:39:59Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use TestToolkit; use Net::DNS::Parameters qw(:class :type :opcode :rcode :ednsoption :dsotype); plan tests => ( 5 + scalar keys %Net::DNS::Parameters::classbyval ) + ( 4 + scalar keys %Net::DNS::Parameters::typebyval ) + ( 5 + scalar keys %Net::DNS::Parameters::opcodebyval ) + ( 3 + scalar keys %Net::DNS::Parameters::rcodebyval ) + ( 2 + scalar keys %Net::DNS::Parameters::ednsoptionbyval ) + ( 2 + scalar keys %Net::DNS::Parameters::dsotypebyval ); foreach ( sort { $a <=> $b } 32767, keys %Net::DNS::Parameters::classbyval ) { my $name = classbyval($_); ## check class conversion functions my $code = eval { classbyname($name) }; is( $code, $_, "classbyname($name)" ); } foreach ( sort { $a <=> $b } 65535, keys %Net::DNS::Parameters::typebyval ) { my $name = typebyval($_); ## check type conversion functions my $code = eval { typebyname($name) }; is( $code, $_, "typebyname($name)" ); } is( typebyname('*'), typebyname('ANY'), "typebyname(*)" ); foreach ( sort { $a <=> $b } 255, keys %Net::DNS::Parameters::opcodebyval ) { my $name = opcodebyval($_); ## check OPCODE type conversion functions my $code = eval { opcodebyname($name) }; is( $code, $_, "opcodebyname($name)" ); } is( opcodebyname('NS_NOTIFY_OP'), opcodebyname('NOTIFY'), "opcodebyname(NS_NOTIFY_OP)" ); foreach ( sort { $a <=> $b } 4095, keys %Net::DNS::Parameters::rcodebyval ) { my $name = rcodebyval($_); ## check RCODE conversion functions my $code = eval { rcodebyname($name) }; is( $code, $_, "rcodebyname($name)" ); } is( rcodebyname('BADVERS'), rcodebyname('BADSIG'), "rcodebyname(BADVERS)" ); foreach ( sort { $a <=> $b } 65535, keys %Net::DNS::Parameters::ednsoptionbyval ) { my $name = ednsoptionbyval($_); ## check EDNS option conversion functions my $code = eval { ednsoptionbyname($name) }; is( $code, $_, "ednsoptionbyname($name)" ); } foreach ( sort { $a <=> $b } 65535, keys %Net::DNS::Parameters::dsotypebyval ) { my $name = dsotypebyval($_); ## check DSO type conversion functions my $code = eval { dsotypebyname($name) }; is( $code, $_, "dsotypebyname($name)" ); } exception( 'classbyval', sub { classbyval(65536) } ); exception( 'classbyname', sub { classbyname(65536) } ); exception( 'classbyname', sub { classbyname('CLASS65536') } ); exception( 'classbyname', sub { classbyname('BOGUS') } ); exception( 'typebyval', sub { typebyval(65536) } ); exception( 'typebyname', sub { typebyname(65536) } ); exception( 'typebyname', sub { typebyname('CLASS65536') } ); exception( 'typebyname', sub { typebyname('BOGUS') } ); exception( 'opcodebyname', sub { opcodebyname('BOGUS') } ); exception( 'rcodebyname', sub { rcodebyname('BOGUS') } ); exception( 'ednsoptionbyname', sub { ednsoptionbyname('BOGUS') } ); exception( 'dsotypebyname', sub { dsotypebyname('BOGUS') } ); exit; Net-DNS-1.50/t/custom.txt0000644000175000017500000000026314756035515014505 0ustar willemwillem# $Id: custom.txt 1573 2017-06-12 11:03:59Z willem $ domain alt.net-dns.org search alt.net-dns.org ext.net-dns.org nameserver 10.0.1.128 10.0.2.128 options attempts:2 inet6 bogus Net-DNS-1.50/t/05-NSEC3PARAM.t0000644000175000017500000000340514756035515014436 0ustar willemwillem#!/usr/bin/perl # $Id: 05-NSEC3PARAM.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 17; use TestToolkit; use Net::DNS; my $name = 'example'; my $type = 'NSEC3PARAM'; my $code = 51; my @attr = qw( algorithm flags iterations salt ); my @data = qw( 1 1 12 aabbccdd ); my @also = qw( hashalgo ); my $wire = '0101000c04aabbccdd'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } for my $rr ( Net::DNS::RR->new(<<'END') ) { ## RR with null salt (RT#95034) nosalt.example. IN NSEC3PARAM 2 0 12 - END ok( $rr->string, 'NSEC3PARAM created' ); is( unpack( 'H*', $rr->saltbin ), '', 'NSEC3PARAM null salt value' ); } exception( 'NSEC3PARAM with corrupt salt', sub { Net::DNS::RR->new('corrupt NSEC3PARAM 2 0 12 aabbccfs') } ); exit; Net-DNS-1.50/t/05-NSEC3.t0000644000175000017500000000516414756035515013661 0ustar willemwillem#!/usr/bin/perl # $Id: 05-NSEC3.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 23; use TestToolkit; use Net::DNS; my $name = '0p9mhaveqvm6t7vbl5lop2u3t2rp3tom.example'; my $type = 'NSEC3'; my $code = 50; my @attr = qw( algorithm flags iterations salt hnxtname typelist ); my @data = qw( 1 1 12 aabbccdd 2t7b4g4vsa5smi47k61mv5bv1a22bojr NS SOA MX RRSIG DNSKEY NSEC3PARAM ); my @hash = ( qw( 1 1 12 aabbccdd 2t7b4g4vsa5smi47k61mv5bv1a22bojr ), q(NS SOA MX RRSIG DNSKEY NSEC3PARAM) ); my @also = qw( hashalgo optout ); my $wire = '0101000c04aabbccdd14174eb2409fe28bcb4887a1836f957f0a8425e27b000722010000000290'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @hash; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { my $a = join ' ', sort split /\s+/, $rr->$_; # typelist order unspecified my $b = join ' ', sort split /\s+/, $hash->{$_}; is( $a, $b, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type 1 1 12 - 2t7b4g4vsa5smi47k61mv5bv1a22bojr A") ) { is( $rr->salt, '', 'parse RR with salt field placeholder' ); like( $rr->rdstring, '/^1 1 12 - /', 'placeholder denotes empty salt field' ); exception( 'corrupt hexadecimal', sub { $rr->salt('123456789XBCDEF') } ); } for my $rr ( Net::DNS::RR->new(". $type @data") ) { my $class = ref($rr); $rr->algorithm('SHA-1'); is( $rr->algorithm(), 1, 'algorithm mnemonic accepted' ); is( $rr->algorithm('MNEMONIC'), 'SHA-1', "rr->algorithm('MNEMONIC')" ); is( $class->algorithm('SHA-1'), 1, "class method algorithm('SHA-1')" ); is( $class->algorithm(1), 'SHA-1', "class method algorithm(1)" ); is( $class->algorithm(255), 255, "class method algorithm(255)" ); exception( 'unknown mnemonic', sub { $rr->algorithm('X') } ); exception( 'invalid algorithm', sub { Net::DNS::RR::NSEC3::name2hash( 0, 1, '' ) } ); } Net::DNS::RR->new("$name $type @data")->print; exit; Net-DNS-1.50/t/05-L64.t0000644000175000017500000000260214756035515013405 0ustar willemwillem#!/usr/bin/perl # $Id: 05-L64.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 9; use Net::DNS; my $name = 'L64.example'; my $type = 'L64'; my $code = 106; my @attr = qw( preference locator64 ); my @data = qw( 10 2001:db8:1140:1000 ); my @also = qw( ); my $wire = '000a20010db811401000'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } exit; Net-DNS-1.50/t/05-A.t0000644000175000017500000000305314756035515013221 0ustar willemwillem#!/usr/bin/perl # $Id: 05-A.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 9; use Net::DNS; my $name = 'A.example'; my $type = 'A'; my $code = 1; my @attr = qw( address ); my @data = qw( 192.0.2.1 ); my @also = qw( ); my $wire = 'c0000201'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } my %IPv4completion = ( '1.2.3.4' => '1.2.3.4', '1.2.4' => '1.2.0.4', '1.4' => '1.0.0.4', ); foreach my $address ( sort keys %IPv4completion ) { my $expect = $IPv4completion{$address}; my $rr = Net::DNS::RR->new( name => $name, type => $type, address => $address ); is( $rr->address, $expect, "address completion:\t$address" ); } exit; Net-DNS-1.50/t/05-X25.t0000644000175000017500000000260114756035515013415 0ustar willemwillem#!/usr/bin/perl # $Id: 05-X25.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 8; use Net::DNS; my $name = 'relay.prime.com'; my $type = 'X25'; my $code = 19; my @attr = qw( address ); my @data = qw( 311061700956 ); my @also = qw( PSDNaddress ); my $wire = '0c333131303631373030393536'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } exit; Net-DNS-1.50/t/33-NSEC3-hash.t0000644000175000017500000000321714756035515014600 0ustar willemwillem#!/usr/bin/perl # $Id: 33-NSEC3-hash.t 1856 2021-12-02 14:36:25Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use Net::DNS; my @prerequisite = qw( Digest::SHA Net::DNS::RR::NSEC3 Net::DNS::RR::NSEC3PARAM ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 12; my $nsec3param = Net::DNS::RR->new('example NSEC3PARAM 1 0 12 aabbccdd'); my $algorithm = $nsec3param->algorithm; my $iteration = $nsec3param->iterations; my $salt = $nsec3param->salt; ok( Net::DNS::RR::NSEC3::name2hash( 1, 'example' ), "defaulted arguments" ); ok( Net::DNS::RR::NSEC3::name2hash( 1, 'example', $iteration, $salt ), "explicit arguments" ); my %testcase = ( ## test vectors from RFC5155 'example' => '0p9mhaveqvm6t7vbl5lop2u3t2rp3tom', 'a.example' => '35mthgpgcu1qg68fab165klnsnk3dpvl', 'ai.example' => 'gjeqe526plbf1g8mklp59enfd789njgi', 'ns1.example' => '2t7b4g4vsa5smi47k61mv5bv1a22bojr', 'ns2.example' => 'q04jkcevqvmu85r014c7dkba38o0ji5r', 'w.example' => 'k8udemvp1j2f7eg6jebps17vp3n8i58h', '*.w.example' => 'r53bq7cc2uvmubfu5ocmm6pers9tk9en', 'x.w.example' => 'b4um86eghhds6nea196smvmlo4ors995', 'y.w.example' => 'ji6neoaepv8b5o6k4ev33abha8ht9fgc', 'x.y.w.example' => '2vptu5timamqttgl4luu9kg21e0aor3s', ); my @name = qw(example a.example ai.example ns1.example ns2.example w.example *.w.example x.w.example y.w.example x.y.w.example); foreach my $name (@name) { my $hash = $testcase{$name}; my @args = ( $algorithm, $name, $iteration, $salt ); is( Net::DNS::RR::NSEC3::name2hash(@args), $hash, "H($name)" ); } exit; __END__ Net-DNS-1.50/t/05-OPENPGPKEY.t0000644000175000017500000000417014756035515014523 0ustar willemwillem#!/usr/bin/perl # $Id: 05-OPENPGPKEY.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use Net::DNS; my @prerequisite = qw( MIME::Base64 ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 8; my $name = '8d5730bd8d76d417bf974c03f59eedb7af98cb5c3dc73ea8ebbd54b7._openpgpkey.example.com'; my $type = 'OPENPGPKEY'; my $code = 61; my @attr = qw( key ); my @data = join '', qw( AQPSKmynfzW4kyBv015MUG2DeIQ3Cbl+BBZH4b/0PY1kxkmvHjcZc8nokfzj31GajIQKY+5CptLr 3buXA10hWqTkF7H6RfoRqXQeogmMHfpftf6zMv1LyBUgia7za6ZEzOJBOztyvhjL742iU/TpPSED hm2SNKLijfUppn1UaNvv4w== ); my @also = qw( keybin ); my $wire = join '', qw( 0103D22A6CA77F35B893206FD35E4C506D8378843709B97E041647E1 BFF43D8D64C649AF1E371973C9E891FCE3DF519A8C840A63EE42A6D2EBDDBB97 035D215AA4E417B1FA45FA11A9741EA2098C1DFA5FB5FEB332FD4BC8152089AE F36BA644CCE2413B3B72BE18CBEF8DA253F4E93D2103866D9234A2E28DF529A6 7D5468DBEFE3 ); my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = uc unpack 'H*', $decoded->encode; my $hex2 = uc unpack 'H*', $encoded; my $hex3 = uc unpack 'H*', $rr->rdata; is( $hex1, $hex2, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } Net::DNS::RR->new("$name $type @data")->print; exit; Net-DNS-1.50/t/05-CERT.t0000644000175000017500000000460114756035515013576 0ustar willemwillem#!/usr/bin/perl # $Id: 05-CERT.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use TestToolkit; use Net::DNS; my @prerequisite = qw( MIME::Base64 ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 21; my $name = 'CERT.example'; my $type = 'CERT'; my $code = 37; my @attr = qw( certtype keytag algorithm cert ); my @data = qw( 1 2 3 MTIzNDU2Nzg5YWJjZGVmZ2hpamtsbW5vcHFyc3R1dnd4eXo= ); my @also = qw( certificate format tag ); my $wire = '00010002033132333435363738396162636465666768696a6b6c6d6e6f707172737475767778797a'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { next if /certificate/; is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new('foo IN CERT 1 2 3 foo=') ) { is( $rr->algorithm('MNEMONIC'), 'DSA', 'algorithm mnemonic' ); $rr->algorithm(255); is( $rr->algorithm('MNEMONIC'), 255, 'algorithm with no mnemonic' ); exception( 'unknown algorithm mnemonic', sub { $rr->algorithm('X') } ); noexception( 'valid certtype mnemonic', sub { $rr->certtype('PKIX') } ); exception( 'unknown certtype mnemonic', sub { $rr->certtype('X') } ); } is( Net::DNS::RR->new('foo IN CERT 0 2 3 foo=')->certtype, 0, 'certtype may be zero' ); is( Net::DNS::RR->new('foo IN CERT 1 0 3 foo=')->keytag, 0, 'keytag may be zero' ); is( Net::DNS::RR->new('foo IN CERT 1 2 0 foo=')->algorithm, 0, 'algorithm may be zero' ); is( Net::DNS::RR->new('foo IN CERT 1 2 3 "" ')->cert, "", 'cert may be empty' ); exit; Net-DNS-1.50/t/05-TSIG.t0000644000175000017500000004433014756035515013612 0ustar willemwillem#!/usr/bin/perl # $Id: 05-TSIG.t 1980 2024-06-02 10:16:33Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use TestToolkit; use Net::DNS; my @prerequisite = qw( Digest::HMAC Digest::MD5 Digest::SHA MIME::Base64 ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 63; sub mysign { my ( $key, $data ) = @_; my $hmac = Digest::HMAC->new( $key, 'Digest::MD5' ); $hmac->add($data); return $hmac->digest; } my $name = '123456789-test'; my $type = 'TSIG'; my $code = 250; my @attr = qw( algorithm time_signed fudge sig_function ); my @data = ( qw( fake.alg 100001 600 ), \&mysign ); my @also = qw( mac prior_mac request_mac error sign_func other_data _size ); my $wire = '0466616b6503616c67000000000186a102580010a5d31d3ce3b7122b4a598c225d9c3f2a04d200000000'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {keybin => pack( 'H*', '66616b65206b6579' )}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; like( $rr->string, "/$$hash{algorithm}/", 'got expected rr->string' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { ok( defined $rr->$_, "additional attribute rr->$_()" ); } my $packet = Net::DNS::Packet->new( $name, 'TKEY', 'IN' ); $packet->header->id(1234); # fix packet id $packet->header->rd(1); my $buffer; my $encoded = $buffer = $rr->encode( 0, {}, $packet ); my $decoded = Net::DNS::RR->decode( \$buffer ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); my $wireformat = pack 'a* x', $encoded; exception( "misplaced $type RR", sub { Net::DNS::RR->decode( \$wireformat ) } ); } for my $rr ( Net::DNS::RR->new( type => 'TSIG', key => '' ) ) { ok( !$rr->verify(), 'verify() fails on empty TSIG' ); ok( $rr->vrfyerrstr(), 'vrfyerrstr() reports failure' ); ok( !$rr->other(), 'other() undefined' ); ok( $rr->time_signed(), 'time_signed() defined' ); exception( "TSIG key write-only", sub { $rr->key() } ); } foreach my $method (qw(mac request_mac prior_mac)) { my $mac = 'kpRyejY4uxwT9I74FYv8nQ=='; my $rr = Net::DNS::RR->new( type => 'TSIG', $method => $mac ); is( $rr->$method(), $mac, "correct $method" ); } for my $tsig ( Net::DNS::RR->new( type => 'TSIG', fudge => 300 ) ) { my $function = $tsig->sig_function; # default signing function my $algorithm = $tsig->algorithm; # default algorithm my $expected = 'HMAC-MD5.SIG-ALG.REG.INT'; is( $algorithm, $expected, 'Check algorithm correctly identified' ); # Check default signing function using test cases from RFC2202, section 2. { my $data = pack 'H*', '4869205468657265'; my $key = "\x0b" x 16; my $result = lc unpack( 'H*', &$function( $key, $data ) ); my $expect = '9294727a3638bb1c13f48ef8158bfc9d'; is( $result, $expect, "Check signing function for $algorithm" ); } { my $data = pack 'H*', '7768617420646f2079612077616e7420666f72206e6f7468696e673f'; my $key = pack 'H*', '4a656665'; my $result = lc unpack( 'H*', &$function( $key, $data ) ); my $expect = '750c783e6ab0b503eaa86e310a5db738'; is( $result, $expect, "Check $algorithm with key shorter than hash size" ); } { my $data = "\xdd" x 50; my $key = "\xaa" x 16; my $result = lc unpack( 'H*', &$function( $key, $data ) ); my $expect = '56be34521d144c88dbb8c733f0e8b3f6'; is( $result, $expect, "Check $algorithm with data longer than hash size" ); } { my $data = "\xcd" x 50; my $key = pack 'H*', '0102030405060708090a0b0c0d0e0f10111213141516171819'; my $result = lc unpack( 'H*', &$function( $key, $data ) ); my $expect = '697eaf0aca3a3aea3a75164746ffaa79'; is( $result, $expect, "Check $algorithm with key and data longer than hash" ); } { my $data = pack 'H*', join '', qw( 54657374205573696e67204c61726765 72205468616e20426c6f636b2d53697a 65204b6579202d2048617368204b6579 204669727374 ); my $key = "\xaa" x 80; my $result = lc unpack( 'H*', &$function( $key, $data ) ); my $expect = '6b1ab7fe4bd7bf8f0b62e6ce61b9d0cd'; is( $result, $expect, "Check $algorithm with key longer than block size" ); } { my $data = pack 'H*', join '', qw( 54657374205573696e67204c61726765 72205468616e20426c6f636b2d53697a 65204b657920616e64204c6172676572 205468616e204f6e6520426c6f636b2d 53697a652044617461 ); my $key = "\xaa" x 80; my $result = lc unpack( 'H*', &$function( $key, $data ) ); my $expect = '6f630fad67cda0ee1fb1f562db3aa53e'; is( $result, $expect, "Check $algorithm with both long key and long data" ); } } for my $tsig ( Net::DNS::RR->new( type => 'TSIG', algorithm => 'HMAC-SHA' ) ) { # alias HMAC-SHA1 my $algorithm = $tsig->algorithm; my $function = $tsig->sig_function; is( $algorithm, 'HMAC-SHA1', 'Check algorithm correctly identified' ); # Check HMAC-SHA1 signing function using test cases from RFC2202, section 3. { my $data = pack 'H*', '4869205468657265'; my $key = "\x0b" x 20; my $result = lc unpack( 'H*', &$function( $key, $data ) ); my $expect = 'b617318655057264e28bc0b6fb378c8ef146be00'; is( $result, $expect, "Check signing function for $algorithm" ); } { my $data = pack 'H*', '7768617420646f2079612077616e7420666f72206e6f7468696e673f'; my $key = pack 'H*', '4a656665'; my $result = lc unpack( 'H*', &$function( $key, $data ) ); my $expect = 'effcdf6ae5eb2fa2d27416d5f184df9c259a7c79'; is( $result, $expect, "Check $algorithm with key shorter than hash size" ); } { my $data = "\xdd" x 50; my $key = "\xaa" x 20; my $result = lc unpack( 'H*', &$function( $key, $data ) ); my $expect = '125d7342b9ac11cd91a39af48aa17b4f63f175d3'; is( $result, $expect, "Check $algorithm with data longer than hash size" ); } { my $data = "\xcd" x 50; my $key = pack 'H*', '0102030405060708090a0b0c0d0e0f10111213141516171819'; my $result = lc unpack( 'H*', &$function( $key, $data ) ); my $expect = '4c9007f4026250c6bc8414f9bf50c86c2d7235da'; is( $result, $expect, "Check $algorithm with key and data longer than hash" ); } { my $data = pack 'H*', join '', qw( 54657374205573696e67204c61726765 72205468616e20426c6f636b2d53697a 65204b6579202d2048617368204b6579 204669727374 ); my $key = "\xaa" x 80; my $result = lc unpack( 'H*', &$function( $key, $data ) ); my $expect = 'aa4ae5e15272d00e95705637ce8a3b55ed402112'; is( $result, $expect, "Check $algorithm with key longer than block size" ); } { my $data = pack 'H*', join '', qw( 54657374205573696e67204c61726765 72205468616e20426c6f636b2d53697a 65204b657920616e64204c6172676572 205468616e204f6e6520426c6f636b2d 53697a652044617461 ); my $key = "\xaa" x 80; my $result = lc unpack( 'H*', &$function( $key, $data ) ); my $expect = 'e8e99d0f45237d786d6bbaa7965c7808bbff1a91'; is( $result, $expect, "Check $algorithm with both long key and long data" ); } } for my $tsig ( Net::DNS::RR->new( type => 'TSIG', algorithm => 162 ) ) { # alias HMAC-SHA224 my $algorithm = $tsig->algorithm; my $function = $tsig->sig_function; is( $algorithm, 'HMAC-SHA224', 'Check algorithm correctly identified' ); # Check HMAC-SHA224 signing function using test cases from RFC4634, section 8.4. { my $data = pack 'H*', '4869205468657265'; my $key = "\x0b" x 20; my $result = uc unpack( 'H*', &$function( $key, $data ) ); my $expect = '896FB1128ABBDF196832107CD49DF33F47B4B1169912BA4F53684B22'; is( $result, $expect, "Check signing function for $algorithm" ); } { my $data = pack 'H*', '7768617420646f2079612077616e7420666f72206e6f7468696e673f'; my $key = pack 'H*', '4a656665'; my $result = uc unpack( 'H*', &$function( $key, $data ) ); my $expect = 'A30E01098BC6DBBF45690F3A7E9E6D0F8BBEA2A39E6148008FD05E44'; is( $result, $expect, "Check $algorithm with key shorter than hash size" ); } { my $data = "\xdd" x 50; my $key = "\xaa" x 20; my $result = uc unpack( 'H*', &$function( $key, $data ) ); my $expect = '7FB3CB3588C6C1F6FFA9694D7D6AD2649365B0C1F65D69D1EC8333EA'; is( $result, $expect, "Check $algorithm with data longer than hash size" ); } { my $data = "\xcd" x 50; my $key = pack 'H*', '0102030405060708090a0b0c0d0e0f10111213141516171819'; my $result = uc unpack( 'H*', &$function( $key, $data ) ); my $expect = '6C11506874013CAC6A2ABC1BB382627CEC6A90D86EFC012DE7AFEC5A'; is( $result, $expect, "Check $algorithm with key and data longer than hash" ); } { my $data = pack 'H*', join '', qw( 54657374205573696e67204c61726765 72205468616e20426c6f636b2d53697a 65204b6579202d2048617368204b6579 204669727374 ); my $key = "\xaa" x 131; my $result = uc unpack( 'H*', &$function( $key, $data ) ); my $expect = '95E9A0DB962095ADAEBE9B2D6F0DBCE2D499F112F2D2B7273FA6870E'; is( $result, $expect, "Check $algorithm with key longer than block size" ); } { my $data = pack 'H*', join '', qw( 54686973206973206120746573742075 73696e672061206c6172676572207468 616e20626c6f636b2d73697a65206b65 7920616e642061206c61726765722074 68616e20626c6f636b2d73697a652064 6174612e20546865206b6579206e6565 647320746f2062652068617368656420 6265666f7265206265696e6720757365 642062792074686520484d414320616c 676f726974686d2e ); my $key = "\xaa" x 131; my $result = uc unpack( 'H*', &$function( $key, $data ) ); my $expect = '3A854166AC5D9F023F54D517D0B39DBD946770DB9C2B95C9F6F565D1'; is( $result, $expect, "Check $algorithm with both long key and long data" ); } } for my $tsig ( Net::DNS::RR->new( type => 'TSIG', algorithm => 'HMAC-SHA256' ) ) { my $algorithm = $tsig->algorithm; my $function = $tsig->sig_function; # Check HMAC-SHA256 signing function using test cases from RFC4634, section 8.4. { my $data = pack 'H*', '4869205468657265'; my $key = "\x0b" x 20; my $result = uc unpack( 'H*', &$function( $key, $data ) ); my $expect = 'B0344C61D8DB38535CA8AFCEAF0BF12B881DC200C9833DA726E9376C2E32CFF7'; is( $result, $expect, "Check signing function for $algorithm" ); } { my $data = pack 'H*', '7768617420646f2079612077616e7420666f72206e6f7468696e673f'; my $key = pack 'H*', '4a656665'; my $result = uc unpack( 'H*', &$function( $key, $data ) ); my $expect = '5BDCC146BF60754E6A042426089575C75A003F089D2739839DEC58B964EC3843'; is( $result, $expect, "Check $algorithm with key shorter than hash size" ); } { my $data = "\xdd" x 50; my $key = "\xaa" x 20; my $result = uc unpack( 'H*', &$function( $key, $data ) ); my $expect = '773EA91E36800E46854DB8EBD09181A72959098B3EF8C122D9635514CED565FE'; is( $result, $expect, "Check $algorithm with data longer than hash size" ); } { my $data = "\xcd" x 50; my $key = pack 'H*', '0102030405060708090a0b0c0d0e0f10111213141516171819'; my $result = uc unpack( 'H*', &$function( $key, $data ) ); my $expect = '82558A389A443C0EA4CC819899F2083A85F0FAA3E578F8077A2E3FF46729665B'; is( $result, $expect, "Check $algorithm with key and data longer than hash" ); } { my $data = pack 'H*', join '', qw( 54657374205573696e67204c61726765 72205468616e20426c6f636b2d53697a 65204b6579202d2048617368204b6579 204669727374 ); my $key = "\xaa" x 131; my $result = uc unpack( 'H*', &$function( $key, $data ) ); my $expect = '60E431591EE0B67F0D8A26AACBF5B77F8E0BC6213728C5140546040F0EE37F54'; is( $result, $expect, "Check $algorithm with key longer than block size" ); } { my $data = pack 'H*', join '', qw( 54686973206973206120746573742075 73696e672061206c6172676572207468 616e20626c6f636b2d73697a65206b65 7920616e642061206c61726765722074 68616e20626c6f636b2d73697a652064 6174612e20546865206b6579206e6565 647320746f2062652068617368656420 6265666f7265206265696e6720757365 642062792074686520484d414320616c 676f726974686d2e ); my $key = "\xaa" x 131; my $result = uc unpack( 'H*', &$function( $key, $data ) ); my $expect = '9B09FFA71B942FCB27635FBCD5B0E944BFDC63644F0713938A7F51535C3A35E2'; is( $result, $expect, "Check $algorithm with both long key and long data" ); } } for my $tsig ( Net::DNS::RR->new( type => 'TSIG', algorithm => 'HMAC-SHA384' ) ) { my $algorithm = $tsig->algorithm; my $function = $tsig->sig_function; # Check HMAC-SHA384 signing function using test cases from RFC4634, section 8.4. { my $data = pack 'H*', '4869205468657265'; my $key = "\x0b" x 20; my $result = uc unpack( 'H*', &$function( $key, $data ) ); my $expect = join '', qw( AFD03944D84895626B0825F4AB46907F 15F9DADBE4101EC682AA034C7CEBC59C FAEA9EA9076EDE7F4AF152E8B2FA9CB6 ); is( $result, $expect, "Check signing function for $algorithm" ); } { my $data = pack 'H*', '7768617420646f2079612077616e7420666f72206e6f7468696e673f'; my $key = pack 'H*', '4a656665'; my $result = uc unpack( 'H*', &$function( $key, $data ) ); my $expect = join '', qw( AF45D2E376484031617F78D2B58A6B1B 9C7EF464F5A01B47E42EC3736322445E 8E2240CA5E69E2C78B3239ECFAB21649 ); is( $result, $expect, "Check $algorithm with key shorter than hash size" ); } { my $data = "\xdd" x 50; my $key = "\xaa" x 20; my $result = uc unpack( 'H*', &$function( $key, $data ) ); my $expect = join '', qw( 88062608D3E6AD8A0AA2ACE014C8A86F 0AA635D947AC9FEBE83EF4E55966144B 2A5AB39DC13814B94E3AB6E101A34F27 ); is( $result, $expect, "Check $algorithm with data longer than hash size" ); } { my $data = "\xcd" x 50; my $key = pack 'H*', '0102030405060708090a0b0c0d0e0f10111213141516171819'; my $result = uc unpack( 'H*', &$function( $key, $data ) ); my $expect = join '', qw( 3E8A69B7783C25851933AB6290AF6CA7 7A9981480850009CC5577C6E1F573B4E 6801DD23C4A7D679CCF8A386C674CFFB ); is( $result, $expect, "Check $algorithm with key and data longer than hash" ); } { my $data = pack 'H*', join '', qw( 54657374205573696e67204c61726765 72205468616e20426c6f636b2d53697a 65204b6579202d2048617368204b6579 204669727374 ); my $key = "\xaa" x 131; my $result = uc unpack( 'H*', &$function( $key, $data ) ); my $expect = join '', qw( 4ECE084485813E9088D2C63A041BC5B4 4F9EF1012A2B588F3CD11F05033AC4C6 0C2EF6AB4030FE8296248DF163F44952 ); is( $result, $expect, "Check $algorithm with key longer than block size" ); } { my $data = pack 'H*', join '', qw( 54686973206973206120746573742075 73696e672061206c6172676572207468 616e20626c6f636b2d73697a65206b65 7920616e642061206c61726765722074 68616e20626c6f636b2d73697a652064 6174612e20546865206b6579206e6565 647320746f2062652068617368656420 6265666f7265206265696e6720757365 642062792074686520484d414320616c 676f726974686d2e ); my $key = "\xaa" x 131; my $result = uc unpack( 'H*', &$function( $key, $data ) ); my $expect = join '', qw( 6617178E941F020D351E2F254E8FD32C 602420FEB0B8FB9ADCCEBB82461E99C5 A678CC31E799176D3860E6110C46523E ); is( $result, $expect, "Check $algorithm with both long key and long data" ); } } for my $tsig ( Net::DNS::RR->new( type => 'TSIG', algorithm => 'HMAC-SHA512' ) ) { my $algorithm = $tsig->algorithm; my $function = $tsig->sig_function; # Check HMAC-SHA512 signing function using test cases from RFC4634, section 8.4. { my $data = pack 'H*', '4869205468657265'; my $key = "\x0b" x 20; my $result = uc unpack( 'H*', &$function( $key, $data ) ); my $expect = join '', qw( 87AA7CDEA5EF619D4FF0B4241A1D6CB0 2379F4E2CE4EC2787AD0B30545E17CDE DAA833B7D6B8A702038B274EAEA3F4E4 BE9D914EEB61F1702E696C203A126854 ); is( $result, $expect, "Check signing function for $algorithm" ); } { my $data = pack 'H*', '7768617420646f2079612077616e7420666f72206e6f7468696e673f'; my $key = pack 'H*', '4a656665'; my $result = uc unpack( 'H*', &$function( $key, $data ) ); my $expect = join '', qw( 164B7A7BFCF819E2E395FBE73B56E0A3 87BD64222E831FD610270CD7EA250554 9758BF75C05A994A6D034F65F8F0E6FD CAEAB1A34D4A6B4B636E070A38BCE737 ); is( $result, $expect, "Check $algorithm with key shorter than hash size" ); } { my $data = "\xdd" x 50; my $key = "\xaa" x 20; my $result = uc unpack( 'H*', &$function( $key, $data ) ); my $expect = join '', qw( FA73B0089D56A284EFB0F0756C890BE9 B1B5DBDD8EE81A3655F83E33B2279D39 BF3E848279A722C806B485A47E67C807 B946A337BEE8942674278859E13292FB ); is( $result, $expect, "Check $algorithm with data longer than hash size" ); } { my $data = "\xcd" x 50; my $key = pack 'H*', '0102030405060708090a0b0c0d0e0f10111213141516171819'; my $result = uc unpack( 'H*', &$function( $key, $data ) ); my $expect = join '', qw( B0BA465637458C6990E5A8C5F61D4AF7 E576D97FF94B872DE76F8050361EE3DB A91CA5C11AA25EB4D679275CC5788063 A5F19741120C4F2DE2ADEBEB10A298DD ); is( $result, $expect, "Check $algorithm with key and data longer than hash" ); } { my $data = pack 'H*', join '', qw( 54657374205573696e67204c61726765 72205468616e20426c6f636b2d53697a 65204b6579202d2048617368204b6579 204669727374 ); my $key = "\xaa" x 131; my $result = uc unpack( 'H*', &$function( $key, $data ) ); my $expect = join '', qw( 80B24263C7C1A3EBB71493C1DD7BE8B4 9B46D1F41B4AEEC1121B013783F8F352 6B56D037E05F2598BD0FD2215D6A1E52 95E64F73F63F0AEC8B915A985D786598 ); is( $result, $expect, "Check $algorithm with key longer than block size" ); } { my $data = pack 'H*', join '', qw( 54686973206973206120746573742075 73696e672061206c6172676572207468 616e20626c6f636b2d73697a65206b65 7920616e642061206c61726765722074 68616e20626c6f636b2d73697a652064 6174612e20546865206b6579206e6565 647320746f2062652068617368656420 6265666f7265206265696e6720757365 642062792074686520484d414320616c 676f726974686d2e ); my $key = "\xaa" x 131; my $result = uc unpack( 'H*', &$function( $key, $data ) ); my $expect = join '', qw( E37B6A775DC87DBAA4DFA9F96E5E3FFD DEBD71F8867289865DF5A32D20CDC944 B6022CAC3C4982B10D5EEB55C3E4DE15 134676FB6DE0446065C97440FA8C6A58 ); is( $result, $expect, "Check $algorithm with both long key and long data" ); } } exit; Net-DNS-1.50/t/07-zonefile.t0000644000175000017500000003015414756035515014660 0ustar willemwillem#!/usr/bin/perl # $Id: 07-zonefile.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use IO::File; use Test::More tests => 88; use TestToolkit; ## vvv verbatim from Domain.pm use constant ASCII => ref eval { require Encode; Encode::find_encoding('ascii'); }; use constant UTF8 => scalar eval { ## not UTF-EBCDIC [see UTR#16 3.6] Encode::encode_utf8( chr(182) ) eq pack( 'H*', 'C2B6' ); }; use constant LIBIDN2 => defined eval { require Net::LibIDN2 }; use constant IDN2FLAG => LIBIDN2 ? &Net::LibIDN2::IDN2_NFC_INPUT + &Net::LibIDN2::IDN2_NONTRANSITIONAL : 0; use constant LIBIDN => LIBIDN2 ? undef : defined eval { require Net::LibIDN }; ## ^^^ verbatim from Domain.pm use constant LIBIDNOK => LIBIDN && scalar eval { my $cn = pack( 'U*', 20013, 22269 ); Net::LibIDN::idn_to_ascii( $cn, 'utf-8' ) eq 'xn--fiqs8s'; }; use constant LIBIDN2OK => LIBIDN2 && scalar eval { my $cn = pack( 'U*', 20013, 22269 ); Net::LibIDN2::idn2_to_ascii_8( $cn, 9 ) eq 'xn--fiqs8s'; }; my $class = 'Net::DNS::ZoneFile'; use_ok($class); my @file; my $seq; END { unlink $_ foreach @file; } sub source { ## zone file builder my ( $text, @args ) = @_; my $tag = ++$seq; my $file = "zone$tag.txt"; my $handle = IO::File->new( $file, '>' ); # create test file die "Failed to create $file" unless $handle; eval { binmode($handle) }; # suppress encoding layer push @file, $file; print $handle $text; close $handle; return $class->new( $file, @args ); } my $misdirect = join ' ', '$INCLUDE zone0.txt ; presumed not to exist'; my $recursive = join ' ', '$INCLUDE', source('$INCLUDE zone1.txt')->name; exception( 'new(): invalid argument', sub { $class->new(undef) } ); exception( 'new(): not a file handle', sub { $class->new( [] ) } ); exception( 'new(): non-existent file', sub { $class->new('zone0.txt') } ); for my $zonefile ( source('') ) { ## public methods ok( $zonefile->isa('Net::DNS::ZoneFile'), 'new ZoneFile object' ); ok( defined $zonefile->name, 'zonefile->name always defined' ); ok( defined $zonefile->line, 'zonefile->line always defined' ); ok( defined $zonefile->origin, 'zonefile->origin always defined' ); ok( !defined $zonefile->ttl, 'zonefile->ttl initially undefined' ); my @rr = $zonefile->read; is( scalar(@rr), 0, 'zonefile->read to end of file' ); is( $zonefile->line, 0, 'zonefile->line zero if file empty' ); is( $zonefile->origin, '.', 'zonefile->origin defaults to DNS root' ); } for my $origin ('example') { ## initial origin my $absolute = source( '', "$origin." ); is( $absolute->origin, "$origin.", 'new ZoneFile with absolute origin' ); my $relative = source( '', "$origin" ); is( $relative->origin, "$origin.", 'new ZoneFile->origin always absolute' ); } for my $zonefile ( source( "\n" x 10 ) ) { ## line numbering is( $zonefile->line, 0, 'zonefile->line zero before calling read()' ); my @rr = $zonefile->read; is( $zonefile->line, 10, 'zonefile->line number incremented by read()' ); } exception( 'incomplete $TTL directive', sub { source('$TTL')->read } ); exception( 'incomplete $INCLUDE directive', sub { source('$INCLUDE')->read } ); exception( 'incomplete $ORIGIN directive', sub { source('$ORIGIN')->read } ); exception( 'incomplete $GENERATE directive', sub { source('$GENERATE')->read } ); exception( 'unrecognised $BOGUS directive', sub { source('$BOGUS')->read } ); exception( 'non-existent include file', sub { source("$misdirect")->read } ); exception( 'recursive include directive', sub { my @zone = source("$recursive")->read } ); for my $zonefile ( source <<'EOF' ) { ## $TTL directive at start of zone file $TTL 54321 rr0 SOA mname rname 99 6h 1h 1w 12345 EOF is( $zonefile->read->ttl, 54321, 'SOA TTL set from $TTL directive' ); } for my $zonefile ( source <<'EOF' ) { ## $TTL directive following implicit default rr0 SOA mname rname 99 6h 1h 1w 12345 rr1 NULL $TTL 54321 rr2 NULL rr3 3h NULL EOF is( $zonefile->read->ttl, 12345, 'SOA TTL set from SOA minimum field' ); is( $zonefile->read->ttl, 12345, 'implicit default from SOA record' ); is( $zonefile->read->ttl, 54321, 'explicit default from $TTL directive' ); is( $zonefile->read->ttl, 10800, 'explicit TTL value overrides default' ); is( $zonefile->ttl, 54321, '$zonefile->ttl set from $TTL directive' ); } for my $include ( source <<'EOF' ) { ## $INCLUDE directive rr2 NULL EOF my $directive = join ' ', '$INCLUDE', $include->name, '.'; my $zonefile = source <<"EOF"; rr1 NULL $directive rr3 NULL EOF my $fn1 = $zonefile->name; my $rr1 = $zonefile->read; is( $rr1->name, 'rr1', 'zonefile->read expected record' ); is( $zonefile->name, $fn1, 'zonefile->name identifies file' ); is( $zonefile->line, 1, 'zonefile->line identifies record' ); my $fn2 = $include->name; my $rr2 = $zonefile->read; my $sfx = $zonefile->origin; is( $rr2->name, 'rr2', 'zonefile->read expected record' ); is( $zonefile->name, $fn2, 'zonefile->name identifies file' ); is( $zonefile->line, 1, 'zonefile->line identifies record' ); my $rr3 = $zonefile->read; is( $rr3->name, 'rr3', 'zonefile->read expected record' ); is( $zonefile->name, $fn1, 'zonefile->name identifies file' ); is( $zonefile->line, 3, 'zonefile->line identifies record' ); } for my $nested ( source <<'EOF' ) { ## $ORIGIN directive nested NULL EOF my $origin = 'example.com'; my $ORIGIN = '$ORIGIN'; my $inner = join ' ', '$INCLUDE', $nested->name; my $include = source <<"EOF"; $ORIGIN $origin @ NS host $inner @ NULL $ORIGIN relative @ NULL EOF my $outer = join ' ', '$INCLUDE', $include->name; my $zonefile = source <<"EOF"; $outer outer NULL $ORIGIN $origin NULL EOF my $ns = $zonefile->read; is( $ns->name, $origin, '@ NS has expected name' ); is( $ns->nsdname, "host.$origin", '@ NS has expected rdata' ); my $rr = $zonefile->read; my $expect = join '.', 'nested', $origin; is( $rr->name, $expect, 'scope of $ORIGIN encompasses nested $INCLUDE' ); is( $zonefile->read->name, $origin, 'scope of $ORIGIN continues after $INCLUDE' ); is( $zonefile->read->name, "relative.$origin", '$ORIGIN can be relative to current $ORIGIN' ); is( $zonefile->read->name, 'outer', 'scope of $ORIGIN curtailed by end of file' ); is( $zonefile->read->name, $origin, 'implicit owner following $ORIGIN directive' ); } for my $zonefile ( source <<'EOF' ) { ## $GENERATE directive $GENERATE 10-30/10 "@ TXT $" ; BIND expects template to be quoted $GENERATE 30-10/10 @ TXT $ $GENERATE 123-123 @ TXT ${,,} $GENERATE 123-123 @ TXT ${0,0,d} $GENERATE 123-123 @ TXT ${0,0,o} $GENERATE 123-123 @ TXT ${0,0,x} $GENERATE 123-123 @ TXT ${0,0,X} $GENERATE 123-123 @ TXT ${0,4,X} $GENERATE 123-123 @ TXT ${4096,4,X} $GENERATE 11259375 @ TXT ${0,6,n} $GENERATE 11259375 @ TXT ${0,16,N} $GENERATE 0-0 @ TXT ${0,0,Z} EOF is( $zonefile->read->rdstring, '10', 'generate TXT $ with step 10' ); is( $zonefile->read->rdstring, '20', 'generate TXT $ with step 10' ); is( $zonefile->read->rdstring, '30', 'generate TXT $ with step 10' ); is( $zonefile->read->rdstring, '30', 'generate TXT $ with step -10' ); is( $zonefile->read->rdstring, '20', 'generate TXT $ with step -10' ); is( $zonefile->read->rdstring, '10', 'generate TXT $ with step -10' ); is( $zonefile->read->rdstring, '123', 'generate TXT ${,,}' ); is( $zonefile->read->rdstring, '123', 'generate TXT ${0,0,d}' ); is( $zonefile->read->rdstring, '173', 'generate TXT ${0,0,o}' ); is( $zonefile->read->rdstring, '7b', 'generate TXT ${0,0,x}' ); is( $zonefile->read->rdstring, '7B', 'generate TXT ${0,0,X}' ); is( $zonefile->read->rdstring, '007B', 'generate TXT ${0,4,X}' ); is( $zonefile->read->rdstring, '107B', 'generate TXT ${4096,4,X}' ); is( $zonefile->read->rdstring, 'f.e.d.', 'generate TXT ${0,6,n}' ); is( $zonefile->read->rdstring, 'F.E.D.C.B.A.0.0.', 'generate TXT ${0,16,N}' ); exception( 'unknown generator format', sub { $zonefile->read } ); } for my $zonefile ( source <<'EOF' ) { ## multi-line parsing $TTL 1234 $ORIGIN example. hosta A 192.0.2.1 ; whole line comment ; indented comment ; vvv empty line ; ^^^ empty line ; vvv line with white space ; ^^^ line with white space MX 10 hosta ; end of line comment TXT (string) ; redundant brackets TXT \(string\) TXT no\;comment TXT quoted\"quote TXT ( multiline ; interspersed ( mischievously ) resource ; with ( possibly confusing ) record ) ; comments TXT ( contiguous string ) ; excludes line terminator TXT ( multiline "quoted string" ) ; includes line terminator TXT ( "multiline quoted string" ) ; includes line terminator EOF is( $zonefile->read->name, 'hosta.example', 'name of simple RR as expected' ); is( $zonefile->read->name, 'hosta.example', 'name propagated from previous RR' ); is( $zonefile->read->rdstring, 'string', 'redundant brackets ignored' ); is( $zonefile->read->rdstring, '"(string)"', 'quoted brackets protected' ); is( $zonefile->read->rdstring, '"no;comment"', 'quoted semicolon protected' ); is( $zonefile->read->rdstring, 'quoted\034quote', 'quoted quote protected' ); is( $zonefile->read->rdstring, 'multiline resource record', 'multiline RR parsed correctly' ); is( $zonefile->read->rdstring, 'contiguousstring', 'contiguous string reassembled' ); like( $zonefile->read->rdstring, '/quoted.*string$/', 'multiline string reassembled' ); like( $zonefile->read->rdstring, '/quoted.*string$/', 'quoted string reassembled' ); } for my $zonefile ( source <<'EOF' ) { ## CLASS coersion rr0 CH NULL rr1 CLASS1 NULL rr2 CLASS2 NULL rr3 CLASS3 NULL EOF my $rr = $zonefile->read; foreach ( $zonefile->read ) { is( $_->class, $rr->class, 'rr->class matches initial record' ); } } for my $zonefile ( source <<'EOF' ) { ## compatibility with defunct Net::DNS::ZoneFile 1.04 distro $ORIGIN example.com @ SOA mname rname 99 6h 1h 1w 12345 NS ns ns AAAA 2001:DB8::add EOF my $filename = $zonefile->name; my @array = $class->read($filename); ok( scalar(@array), 'class->read( filename )' ); my $listref = $class->read( $filename, '.' ); ok( scalar(@$listref), 'class->read( filename, path )' ); exception( 'class->read( /nxfile, dir )', sub { $class->read( '/zone0.txt', '.' ) } ); exception( 'class->read( nxfile, dir )', sub { $class->read( 'zone0.txt', 't' ) } ); ok( scalar( Net::DNS::ZoneFile::read($filename) ), 'class::read( filename ) subroutine call (not object-oriented)' ); } for my $string ( <<'EOF' ) { a1.example A 192.0.2.1 a2.example A 192.0.2.2 EOF my @list = $class->parse($string); # this also tests readfh() is( scalar(@list), 2, 'class->parse( $string )' ); my $listref = $class->parse( \$string ); is( scalar(@$listref), 2, 'class->parse( \$string )' ); exception( 'class->parse( erroneous )', sub { scalar( $class->parse('$BOGUS') ) } ); exception( '@list = class->parse( ) )', sub { my @x = $class->parse('$BOGUS') } ); ok( scalar( Net::DNS::ZoneFile::parse($string) ), 'class::parse( string ) subroutine call (not object-oriented)' ); } SKIP: { ## Non-ASCII zone content skip( 'Unicode/UTF-8 not supported', 4 ) unless UTF8; my $greek = pack 'C*', 103, 114, 9, 84, 88, 84, 9, 229, 224, 241, 231, 234, 225, 10; my $file1 = source($greek); my $fh1 = IO::File->new( $file1->name, '<:encoding(ISO8859-7)' ); # Greek my $zone1 = $class->new($fh1); my $txtgr = $zone1->read; my $text = pack 'U*', 949, 944, 961, 951, 954, 945; is( $txtgr->txtdata, $text, 'ISO8859-7 TXT rdata' ); eval { binmode(DATA) }; # suppress encoding layer my $jptxt = join "\n", ; my $file2 = source($jptxt); my $fh2 = IO::File->new( $file2->name, '<:utf8' ); # UTF-8 character encoding my $zone2 = $class->new($fh2); my $txtrr = $zone2->read; # TXT RR with kanji RDATA my @rdata = $txtrr->txtdata; my $rdata = $txtrr->txtdata; is( length($rdata), 12, 'Unicode/UTF-8 TXT rdata' ); is( scalar(@rdata), 1, 'Unicode/UTF-8 TXT contiguous' ); skip( 'Non-ASCII domain - IDNA not supported', 1 ) unless LIBIDNOK || LIBIDN2OK; my $jpnull = $zone2->read; # NULL RR with kanji owner name is( $jpnull->name, 'xn--wgv71a', 'Unicode/UTF-8 domain name' ); } exit; __END__ jp TXT 古池や　蛙飛込む　水の音 ; Unicode text string 日本 NULL ; Unicode domain name Net-DNS-1.50/t/05-CSYNC.t0000644000175000017500000000346214756035515013724 0ustar willemwillem#!/usr/bin/perl # $Id: 05-CSYNC.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 17; use Net::DNS; my $name = 'alpha.example.com'; my $type = 'CSYNC'; my $code = 62; my @attr = qw( SOAserial flags typelist); my @data = qw( 66 3 A NS AAAA); my @hash = ( 66, 3, q(A NS AAAA) ); my @also = qw( immediate soaminimum ); my $wire = '000000420003000460000008'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @hash; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { my $a = join ' ', sort split /\s+/, $rr->$_; # typelist order unspecified my $b = join ' ', sort split /\s+/, $hash->{$_}; is( $a, $b, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } ok( $rr->immediate(1), 'set $rr->immediate' ); ok( !$rr->immediate(0), 'clear $rr->immediate' ); ok( $rr->soaminimum(1), 'set $rr->soaminimum' ); ok( !$rr->soaminimum(0), 'clear $rr->soaminimum' ); } Net::DNS::RR->new("$name $type @data")->print; exit; Net-DNS-1.50/t/05-NS.t0000644000175000017500000000256514756035515013370 0ustar willemwillem#!/usr/bin/perl # $Id: 05-NS.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 7; use Net::DNS; my $name = 'NS.example'; my $type = 'NS'; my $code = 2; my @attr = qw( nsdname ); my @data = qw( ns.example.com ); my @also = qw( ); my $wire = '026e73076578616d706c6503636f6d00'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } exit; Net-DNS-1.50/t/06-update-unique-push.t0000644000175000017500000000565614756035515016620 0ustar willemwillem#!/usr/bin/perl # $Id: 06-update-unique-push.t 1895 2023-01-16 13:38:08Z willem $ # use strict; use warnings; use Test::More tests => 45; use_ok('Net::DNS'); # Matching of RR name is not case sensitive my $domain = 'example.com'; my $method = 'unique_push'; my $packet = Net::DNS::Update->new($domain); my $rr_1 = Net::DNS::RR->new('bla.foo 100 IN TXT "text" ;lower case'); my $rr_2 = Net::DNS::RR->new('bla.Foo 100 IN Txt "text" ;mixed 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->$method( "answer", $rr_1 ); $packet->$method( "answer", $rr_2 ); is( $packet->header->ancount, 1, "$method case sensitivity test 1" ); $packet->$method( "answer", $rr_3 ); $packet->$method( "answer", $rr_4 ); is( $packet->header->ancount, 3, "$method case sensitivity test 2" ); my %sections = ( answer => 'ancount', authority => 'nscount', additional => 'arcount', ); my @tests = ( [ 1, Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.1'), Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.1'), ], [ 2, Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.1'), Net::DNS::RR->new('bar.example.com 60 IN A 192.0.2.1'), ], [ 1, Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.1'), Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.1'), Net::DNS::RR->new('foo.example.com 90 IN A 192.0.2.1'), ], [ 3, Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.1'), Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.2'), Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.3'), ], [ 3, Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.1'), Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.2'), Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.3'), Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.1'), ], [ 3, Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.1'), Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.2'), Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.1'), Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.4'), Net::DNS::RR->new('foo.example.com 60 HS A 192.0.2.4'), ], [ 3, # without RDATA Net::DNS::RR->new('foo.example.com IN A'), Net::DNS::RR->new('foo.example.com ANY A'), Net::DNS::RR->new('foo.example.com NONE A'), ], ); foreach my $test (@tests) { my ( $expect, @rrs ) = @$test; while ( my ( $section, $count_meth ) = each %sections ) { my $packet = Net::DNS::Update->new($domain); $packet->$method( $section => @rrs ); my $count = $packet->header->$count_meth(); is( $count, $expect, "$method $section => RR, RR, ..." ); } # # Now do it again, pushing each RR individually. # while ( my ( $section, $count_meth ) = each %sections ) { my $packet = Net::DNS::Update->new($domain); foreach my $rr (@rrs) { $packet->$method( $section => $rr ); } my $count = $packet->header->$count_meth(); is( $count, $expect, "$method $section => RR" ); } } Net-DNS-1.50/t/04-packet-truncate.t0000644000175000017500000001155114756035515016134 0ustar willemwillem#!/usr/bin/perl # $Id: 04-packet-truncate.t 1980 2024-06-02 10:16:33Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 33; use Net::DNS; use Net::DNS::ZoneFile; my $source = Net::DNS::ZoneFile->new( \*DATA ); my @rr = $source->read; for my $packet ( Net::DNS::Packet->new('query.example.') ) { $packet->push( answer => @rr ); $packet->push( authority => @rr ); $packet->push( additional => @rr ); my $unlimited = length $packet->encode; my %before = map { ( $_, scalar $packet->$_ ) } qw(answer authority additional); my $truncated = length $packet->truncate($unlimited); ok( $truncated == $unlimited, "unconstrained packet length $unlimited" ); foreach my $section (qw(answer authority additional)) { my $before = $before{$section}; my $after = scalar( $packet->$section ); is( $after, $before, "$section section unchanged, $before RRs" ); } ok( !$packet->header->tc, 'header->tc flag not set' ); } for my $packet ( Net::DNS::Packet->new('query.example.') ) { $packet->push( answer => @rr ); $packet->push( authority => @rr ); $packet->push( additional => @rr ); my $unlimited = length $packet->encode; my %before = map { ( $_, scalar $packet->$_ ) } qw(answer authority additional); my $truncated = length $packet->truncate; # exercise default size ok( $truncated < $unlimited, "long packet was $unlimited, now $truncated" ); foreach my $section (qw(answer authority additional)) { my $before = $before{$section}; my $after = scalar( $packet->$section ); ok( $after < $before, "$section section was $before RRs, now $after" ); } ok( $packet->header->tc, 'header->tc flag set' ); } for my $packet ( Net::DNS::Packet->new('query.example.') ) { $packet->push( answer => @rr ); $packet->push( authority => @rr ); $packet->push( additional => @rr ); my $keyrr = Net::DNS::RR->new('tsig.example KEY 512 3 157 ARDJZgtuTDzAWeSGYPAu9uJUkX0='); my $tsig = eval { $packet->sign_tsig($keyrr) }; my $unlimited = length $packet->encode; my %before = map { ( $_, scalar $packet->$_ ) } qw(answer authority additional); my $truncated = length $packet->encode(512); # explicit minimum size ok( $truncated < $unlimited, "signed packet was $unlimited, now $truncated" ); foreach my $section (qw(answer authority additional)) { my $before = $before{$section}; my $after = scalar( $packet->$section ); ok( $after < $before, "$section section was $before RRs, now $after" ); } my $sigrr = $packet->sigrr; is( $sigrr, $tsig, 'TSIG still in additional section' ); ok( $packet->header->tc, 'header->tc flag set' ); } for my $packet ( Net::DNS::Packet->new('query.example.') ) { my @auth = map { Net::DNS::RR->new( type => 'NS', nsdname => $_->name ) } @rr; $packet->unique_push( authority => @auth ); $packet->push( additional => @rr ); $packet->edns->UDPsize(2048); # + all bells and whistles my $unlimited = length $packet->encode; my %before = map { ( $_, scalar $packet->$_ ) } qw(answer authority additional); my $truncated = length $packet->truncate; ok( $truncated < $unlimited, "referral packet was $unlimited, now $truncated" ); foreach my $section (qw(answer authority)) { my $before = $before{$section}; my $after = scalar( $packet->$section ); is( $after, $before, "$section section unchanged, $before RRs" ); } foreach my $section (qw(additional)) { my $before = $before{$section}; my $after = scalar( $packet->$section ); ok( $after <= $before, "$section section was $before RRs, now $after" ); } ok( !$packet->header->tc, 'header->tc flag not set' ); } for my $packet ( Net::DNS::Packet->new('query.example.') ) { $packet->push( additional => @rr, @rr ); # two of everything my $unlimited = length $packet->encode; my $truncated = length $packet->truncate( $unlimited >> 1 ); ok( $truncated, "check RRsets in truncated additional section" ); my %rrset; foreach my $rr ( grep { $_->type eq 'A' } $packet->additional ) { my $name = $rr->name; $rrset{"$name. A"}++; } foreach my $rr ( grep { $_->type eq 'AAAA' } $packet->additional ) { my $name = $rr->name; $rrset{"$name. AAAA"}++; } my $expect = 2; foreach my $key ( sort keys %rrset ) { is( $rrset{$key}, $expect, "$key ; $expect RRs" ); } } exit; __DATA__ a.example. A 198.41.0.4 a.example. AAAA 2001:503:ba3e::2:30 b.example. A 192.228.79.201 b.example. AAAA 2001:500:84::b c.example. A 192.33.4.12 c.example. AAAA 2001:500:2::c d.example. A 199.7.91.13 d.example. AAAA 2001:500:2d::d e.example. A 192.203.230.10 f.example. A 192.5.5.241 f.example. AAAA 2001:500:2f::f g.example. A 192.112.36.4 h.example. A 128.63.2.53 h.example. AAAA 2001:500:1::803f:235 i.example. A 192.36.148.17 i.example. AAAA 2001:7fe::53 j.example. A 192.58.128.30 j.example. AAAA 2001:503:c27::2:30 k.example. A 193.0.14.129 k.example. AAAA 2001:7fd::1 l.example. A 199.7.83.42 l.example. AAAA 2001:500:3::42 m.example. A 202.12.27.33 m.example. AAAA 2001:dc3::35 Net-DNS-1.50/t/54-DS-SHA384.t0000644000175000017500000000234514756035515014226 0ustar willemwillem#!/usr/bin/perl # $Id: 54-DS-SHA384.t 1855 2021-11-26 11:33:48Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use Net::DNS; my @prerequisite = qw( Digest::SHA MIME::Base64 Net::DNS::RR::DNSKEY Net::DNS::RR::DS ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 3; # Simple known-answer tests based upon the examples given in RFC6605, section 6.2 my $RFC = 'RFC6605'; my $dnskey = Net::DNS::RR->new( <<'END' ); example.net. 3600 IN DNSKEY 257 3 14 ( xKYaNhWdGOfJ+nPrL8/arkwf2EY3MDJ+SErKivBVSum1w/egsXvSADtNJhyem5RCOpgQ6K8X1DRS EkrbYQ+OB+v8/uX45NBwY8rp65F6Glur8I/mlVNgF6W/qTI37m40 ) ; Key ID = 10771 END my $ds = Net::DNS::RR->new( <<'END' ); example.net. 3600 IN DS 10771 14 4 ( 72D7B62976CE06438E9C0BF319013CF801F09ECC84B8D7E9495F27E305C6A9B0 563A9B5F4D288405C3008A946DF983D6 ) END my $test = Net::DNS::RR::DS->create( $dnskey, digtype => $ds->digtype, ttl => $ds->ttl ); is( $test->string, $ds->string, "created DS matches $RFC example DS" ); ok( $test->verify($dnskey), "created DS verifies $RFC example DNSKEY" ); ok( $ds->verify($dnskey), "$RFC example DS verifies DNSKEY" ); $ds->print; __END__ Net-DNS-1.50/t/05-MX.t0000644000175000017500000000337514756035515013374 0ustar willemwillem#!/usr/bin/perl # $Id: 05-MX.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 12; use Net::DNS; my $name = 'MX.example'; my $type = 'MX'; my $code = 15; my @attr = qw( preference exchange ); my @data = qw( 10 mx.example.com ); my @also = qw( ); my $wire = '000a026d78076578616d706c6503636f6d00'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $empty ( Net::DNS::RR->new( type => $type ) ) { is( $empty->preference, 0, 'unspecified integer returns 0 (not default value)' ); is( $empty->exchange, undef, 'unspecified domain name returns undefined' ); } for my $rr ( Net::DNS::RR->new( type => $type, exchange => 'mx.example' ) ) { is( $rr->preference, 10, 'unspecified integer returns default value' ); ok( $rr->exchange, 'domain name defined as expected' ); is( $rr->preference(0), 0, 'zero integer replaces default value' ); } exit; Net-DNS-1.50/t/05-EUI64.t0000644000175000017500000000236414756035515013641 0ustar willemwillem#!/usr/bin/perl # $Id: 05-EUI64.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 6; use Net::DNS; my $name = 'EUI64.example'; my $type = 'EUI64'; my $code = 109; my @attr = qw( address ); my @data = qw( 00-00-5e-ef-10-00-00-2a ); my @also = qw( ); my $wire = '00005eef1000002a'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } exit; Net-DNS-1.50/t/05-SSHFP.t0000644000175000017500000000313114756035515013721 0ustar willemwillem#!/usr/bin/perl # $Id: 05-SSHFP.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 15; use TestToolkit; use Net::DNS; my $name = 'host.example'; my $type = 'SSHFP'; my $code = 44; my @attr = qw( algorithm fptype fp ); my @data = qw( 2 1 123456789abcdef67890123456789abcdef67890 ); my @also = qw( fingerprint fpbin babble ); my $wire = '0201123456789abcdef67890123456789abcdef67890'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } exception( 'corrupt hexadecimal', sub { $rr->fp('123456789XBCDEF') } ); } Net::DNS::RR->new("$name $type @data")->print; exit; Net-DNS-1.50/t/08-IPv6.t0000644000175000017500000003133514756035515013634 0ustar willemwillem#!/usr/bin/perl # $Id: 08-IPv6.t 2007 2025-02-08 16:45:23Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use TestToolkit; use Net::DNS; use IO::Select; my $debug = 0; my @hints = Net::DNS::Resolver->new()->_hints; my $NOIP = qw(::); my @nsdname = qw( ns.net-dns.org ns.nlnetlabs.nl ); exit( plan skip_all => 'Online tests disabled.' ) if -e 't/online.disabled'; exit( plan skip_all => 'Online tests disabled.' ) unless -e 't/online.enabled'; exit( plan skip_all => 'IPv6 tests disabled.' ) if -e 't/IPv6.disabled'; exit( plan skip_all => 'IPv6 tests disabled.' ) unless -e 't/IPv6.enabled'; eval { my $resolver = Net::DNS::Resolver->new( igntc => 1 ); exit plan skip_all => 'No nameservers' unless $resolver->nameservers; my $reply = $resolver->send(qw(. NS IN)) || die $resolver->errorstring; my @ns = grep { $_->type eq 'NS' } $reply->answer, $reply->authority; exit plan skip_all => 'Local nameserver broken' unless scalar @ns; 1; } || exit( plan skip_all => "Non-responding local nameserver: $@" ); eval { my $resolver = Net::DNS::Resolver->new( nameservers => [@hints] ); $resolver->force_v6(1); exit plan skip_all => 'No IPv6 transport' unless $resolver->nameservers; my $reply = $resolver->send(qw(. NS IN)) || die $resolver->errorstring; my $from = $reply->from(); my @ns = grep { $_->type eq 'NS' } $reply->answer, $reply->authority; exit plan skip_all => "Unexpected response from $from" unless scalar @ns; exit plan skip_all => "Non-authoritative response from $from" unless $reply->header->aa; 1; } || exit( plan skip_all => "Cannot reach global root: $@" ); my $IP = eval { my $resolver = Net::DNS::Resolver->new(); $resolver->nameservers(@nsdname); $resolver->force_v6(1); [$resolver->nameservers()]; } || []; exit( plan skip_all => 'Unable to resolve nameserver name' ) unless scalar @$IP; diag join( "\n\t", 'will use nameservers', @$IP ) if $debug; Net::DNS::Resolver->debug($debug); plan tests => 62; NonFatalBegin(); { my $resolver = Net::DNS::Resolver->new( nameservers => $IP, dnsrch => 1 ); ok( $resolver->search('ns.net-dns.org.'), '$resolver->search(ns.net-dns.org.)' ); ok( !$resolver->search('nx.net-dns.org.'), '$resolver->search(nx.net-dns.org.)' ); my $packet = Net::DNS::Packet->new(qw(net-dns.org SOA IN)); ok( $resolver->send($packet), '$resolver->send(...) UDP' ); $packet->edns->option( PADDING => ( 'OPTION-LENGTH' => 500 ) ); # force TCP delete $packet->{id}; ok( $resolver->send($packet), '$resolver->send(...) TCP' ); } { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); $resolver->dnssec(1); $resolver->udppacketsize(513); $resolver->igntc(1); my $udp = $resolver->send(qw(net-dns.org DNSKEY IN)); ok( $udp && $udp->header->tc, '$resolver->send(...) truncated UDP reply' ); $resolver->igntc(0); my $retry = $resolver->send(qw(net-dns.org DNSKEY IN)); ok( $retry && !$retry->header->tc, '$resolver->send(...) automatic TCP retry' ); } { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); $resolver->igntc(0); my $packet = Net::DNS::Packet->new(qw(net-dns.org SOA IN)); my $udp = $resolver->bgsend($packet); ok( $udp, '$resolver->bgsend(...) UDP' ); while ( $resolver->bgbusy($udp) ) { sleep 1; } ok( $resolver->bgread($udp), '$resolver->bgread($udp)' ); $packet->edns->option( PADDING => ( 'OPTION-LENGTH' => 500 ) ); # force TCP delete $packet->{id}; my $tcp = $resolver->bgsend($packet); ok( $tcp, '$resolver->bgsend(...) TCP' ); while ( $resolver->bgbusy($tcp) ) { sleep 1; } ok( $resolver->bgread($tcp), '$resolver->bgread($tcp)' ); } { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); $resolver->dnssec(1); $resolver->udppacketsize(513); $resolver->igntc(1); my $handle = $resolver->bgsend(qw(net-dns.org DNSKEY IN)); ok( $handle, '$resolver->bgsend(...) truncated UDP' ); my $packet = $resolver->bgread($handle); ok( $packet && $packet->header->tc, '$resolver->bgread($udp) ignore UDP truncation' ); } { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); $resolver->dnssec(1); $resolver->udppacketsize(513); $resolver->igntc(0); my $handle = $resolver->bgsend(qw(net-dns.org DNSKEY IN)); ok( $handle, '$resolver->bgsend(...) truncated UDP' ); my $udp = $handle; my $packet = $resolver->bgread($handle); isnt( $handle, $udp, '$resolver->bgbusy($udp) handle changed to TCP' ); ok( $packet && !$packet->header->tc, '$resolver->bgread($udp) background TCP retry' ); } { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); $resolver->dnssec(1); $resolver->udppacketsize(513); $resolver->igntc(0); my $handle = $resolver->bgsend(qw(net-dns.org DNSKEY IN)); $resolver->nameserver(); # no nameservers my $packet = $resolver->bgread($handle); ok( $packet && $packet->header->tc, '$resolver->bgread($udp) background TCP fail' ); } { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); $resolver->persistent_udp(1); my $handle = $resolver->bgsend(qw(net-dns.org SOA IN)); ok( $handle, '$resolver->bgsend(...) persistent UDP' ); my $bgread = $resolver->bgread($handle); ok( $bgread, '$resolver->bgread($udp)' ); my $test = $resolver->bgsend(qw(net-dns.org SOA IN)); ok( $test, '$resolver->bgsend(...) persistent UDP' ); is( $test, $handle, 'same UDP socket object used' ); } { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); $resolver->persistent_tcp(1); $resolver->usevc(1); my $handle = $resolver->bgsend(qw(net-dns.org SOA IN)); ok( $handle, '$resolver->bgsend(...) persistent TCP' ); my $bgread = $resolver->bgread($handle); ok( $bgread, '$resolver->bgread($tcp)' ); my $test = $resolver->bgsend(qw(net-dns.org SOA IN)); ok( $test, '$resolver->bgsend(...) persistent TCP' ); is( $test, $handle, 'same TCP socket object used' ); eval { close($handle) }; my $recover = $resolver->bgsend(qw(net-dns.org SOA IN)); ok( $recover, 'connection recovered after close' ); } my $tsig_key = eval { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); $resolver->domain('net-dns.org'); my @answer = $resolver->query(qw(tsig-md5 KEY))->answer; shift @answer; }; my $bad_key = Net::DNS::RR->new('MD5.example KEY 512 3 157 MD5keyMD5keyMD5keyMD5keyMD5='); SKIP: { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); eval { $resolver->tsig($tsig_key) }; skip( 'automatic TSIG tests', 3 ) if $@; $resolver->igntc(1); my $udp = $resolver->send(qw(net-dns.org SOA IN)); ok( $udp, '$resolver->send(...) UDP + automatic TSIG' ); $resolver->usevc(1); my $tcp = $resolver->send(qw(net-dns.org SOA IN)); ok( $tcp, '$resolver->send(...) TCP + automatic TSIG' ); my $bgread; foreach my $ip (@$IP) { $resolver->nameserver($ip); my $handle = $resolver->bgsend(qw(net-dns.org SOA IN)); last if $bgread = $resolver->bgread($handle); } ok( $bgread, '$resolver->bgsend/read TCP + automatic TSIG' ); } SKIP: { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); $resolver->igntc(1); eval { $resolver->tsig($bad_key) }; skip( 'failed TSIG tests', 3 ) if $@; my $udp = $resolver->send(qw(net-dns.org SOA IN)); ok( !$udp, '$resolver->send(...) UDP + failed TSIG' ); $resolver->usevc(1); my $tcp = $resolver->send(qw(net-dns.org SOA IN)); ok( !$tcp, '$resolver->send(...) TCP + failed TSIG' ); my $handle = $resolver->bgsend(qw(net-dns.org SOA IN)); my $bgread = $resolver->bgread($handle); ok( !$bgread, '$resolver->bgsend/read TCP + failed TSIG' ); } { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); my $udp = $resolver->query(qw(bogus.net-dns.org A IN)); ok( !$udp, '$resolver->query() nonexistent name UDP' ); $resolver->usevc(1); my $tcp = $resolver->query(qw(bogus.net-dns.org A IN)); ok( !$tcp, '$resolver->query() nonexistent name TCP' ); } { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); my $update = Net::DNS::Update->new(qw(example.com)); ok( $resolver->send($update), '$resolver->send($update) UDP' ); $resolver->usevc(1); delete $update->{id}; ok( $resolver->send($update), '$resolver->send($update) TCP' ); } { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); my $mx = 'mx2.t.net-dns.org'; my @rr = rr( $resolver, $mx, 'MX' ); is( scalar(@rr), 2, 'Net::DNS::rr() works with specified resolver' ); is( scalar rr( $resolver, $mx, 'MX' ), 2, 'Net::DNS::rr() works in scalar context' ); is( scalar rr( $mx, 'MX' ), 2, 'Net::DNS::rr() works with default resolver' ); } { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); my $mx = 'mx2.t.net-dns.org'; my @mx = mx( $resolver, $mx ); is( scalar(@mx), 2, 'Net::DNS::mx() works with specified resolver' ); # some people seem to use mx() in scalar context is( scalar mx( $resolver, $mx ), 2, 'Net::DNS::mx() works in scalar context' ); is( scalar mx($mx), 2, 'Net::DNS::mx() works with default resolver' ); is( scalar mx('bogus.t.net-dns.org'), 0, "Net::DNS::mx() works for bogus name" ); } SKIP: { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); $resolver->tcp_timeout(10); my @zone = $resolver->axfr('net-dns.org'); ok( scalar(@zone), '$resolver->axfr() returns entire zone in list context' ); my @notauth = $resolver->axfr('bogus.net-dns.org'); my $notauth = $resolver->errorstring; ok( !scalar(@notauth), "mismatched zone\t[$notauth]" ); my $iterator = $resolver->axfr('net-dns.org'); ok( ref($iterator), '$resolver->axfr() returns iterator in scalar context' ); skip( 'AXFR iterator tests', 4 ) unless $iterator; my $soa = $iterator->(); is( ref($soa), 'Net::DNS::RR::SOA', '$iterator->() returns initial SOA RR' ); my $iterations; $soa->serial(undef) if $soa; # force SOA mismatch exception( 'mismatched SOA serial', sub { $iterations++ while $iterator->() } ); ok( $iterations, '$iterator->() iterates through remaining RRs' ); is( $iterator->(), undef, '$iterator->() returns undef after last RR' ); } SKIP: { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); $resolver->domain('net-dns.org'); eval { $resolver->tsig($tsig_key) }; skip( 'TSIG AXFR tests', 4 ) if $@; $resolver->tcp_timeout(10); my @zone = $resolver->axfr(); ok( scalar(@zone), '$resolver->axfr() with TSIG verify' ); my @notauth = $resolver->axfr('bogus.net-dns.org'); my $notauth = $resolver->errorstring; ok( !scalar(@notauth), "mismatched zone\t[$notauth]" ); eval { $resolver->tsig($bad_key) }; skip( 'AXFR failure reporting', 2 ) if $@; my @unverifiable = $resolver->axfr(); my $errorstring = $resolver->errorstring; ok( !scalar(@unverifiable), "mismatched key\t[$errorstring]" ); } SKIP: { my $resolver = Net::DNS::Resolver->new( nameservers => $NOIP ); eval { $resolver->tsig($tsig_key) }; skip( 'TSIG bgsend tests', 2 ) if $@; my $query = Net::DNS::Packet->new(qw(. SOA IN)); ok( $resolver->bgsend($query), '$resolver->bgsend() + automatic TSIG' ); delete $query->{id}; ok( $resolver->bgsend($query), '$resolver->bgsend() + existing TSIG' ); } { my $resolver = Net::DNS::Resolver->new(); $resolver->nameserver('cname.t.net-dns.org'); ok( scalar( $resolver->nameservers ), 'resolve nameserver cname' ); } { ## exercise error paths in _axfr_next() my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); $resolver->tcp_timeout(10); exception( 'TCP time out', sub { $resolver->_axfr_next( IO::Select->new ) } ); my $packet = Net::DNS::Packet->new(qw(net-dns.org SOA)); my $socket = $resolver->_bgsend_tcp( $packet, $packet->encode ); my $select = IO::Select->new($socket); while ( $resolver->bgbusy($socket) ) { sleep 1 } my $discarded = ''; ## [size][id][status] [qdcount]... $socket->recv( $discarded, 6 ) if $socket; exception( 'corrupt data', sub { $resolver->_axfr_next($select) } ); } SKIP: { my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); $resolver->domain('net-dns.org'); eval { $resolver->tsig($tsig_key) }; $resolver->tcp_timeout(10); my $packet = $resolver->_make_query_packet(qw(net-dns.org SOA)); my $socket = $resolver->_bgsend_tcp( $packet, $packet->encode ); my $tsigrr = $packet->sigrr; skip( 'verify fail', 1 ) unless $tsigrr; my $select = IO::Select->new($socket); exception( 'verify fail', sub { $resolver->_axfr_next( $select, $tsigrr ) } ); } { ## exercise error paths in _send_udp et al my $resolver = Net::DNS::Resolver->new( nameservers => $IP, retry => 1 ); my $original = Net::DNS::Packet->new(qw(net-dns.org SOA)); my $mismatch = Net::DNS::Packet->new(qw(net-dns.org SOA)); $original->encode; ok( !$resolver->_send_tcp( $original, $mismatch->encode ), '_send_tcp() id mismatch' ); ok( !$resolver->_send_udp( $original, $mismatch->encode ), '_send_udp() id mismatch' ); my $handle = $resolver->_bgsend_udp( $original, $mismatch->encode ); $resolver->udp_timeout(1); ok( !$resolver->bgread($handle), 'bgread() id mismatch' ); ok( !$resolver->bgread( ref($handle)->new ), 'bgread() timeout' ); } NonFatalEnd(); exit; __END__ Net-DNS-1.50/t/05-SOA.t0000644000175000017500000000744214756035515013471 0ustar willemwillem#!/usr/bin/perl # $Id: 05-SOA.t 1934 2023-08-25 12:14:08Z willem $ -*-perl-*- # use strict; use warnings; use integer; use Test::More tests => 43; use Net::DNS; my $name = 'SOA.example'; my $type = 'SOA'; my $code = 6; my @attr = qw( mname rname serial refresh retry expire minimum ); my @data = qw( ns.example.net rp@example.com 0 14400 1800 604800 7200 ); my @also = qw( ); my $wire = '026e73076578616d706c65036e657400027270076578616d706c6503636f6d0000000000000038400000070800093a8000001c20'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } for my $rr ( Net::DNS::RR->new("name SOA mname rname 0") ) { use integer; ## exercise 32-bit compatibility code on 64-bit hardware ok( $rr->serial(-1), 'ordering function 32-bit compatibility' ); my $initial = 0; ## test serial number partial ordering function foreach my $serial ( 2E9, 3E9, 4E9, 1E9, 2E9, 4E9, 1E9, 3E9 ) { $rr->serial($initial); is( sprintf( '%u', $rr->serial($serial) ), sprintf( '%u', $serial ), "rr->serial($serial) steps from $initial to $serial" ); is( sprintf( '%u', $rr->serial($serial) ), sprintf( '%u', $serial + 1 ), "rr->serial($serial) increments existing serial number" ); $initial = $serial; } } for my $rr ( Net::DNS::RR->new('name SOA mname rname 1') ) { my $initial = $rr->serial; is( $rr->serial(SEQUENTIAL), ++$initial, 'rr->serial(SEQUENTIAL) increments existing serial number' ); my $pre31wrap = 0x7FFFFFFF; my $post31wrap = 0x80000000; $rr->serial($pre31wrap); is( sprintf( '%x', $rr->serial(SEQUENTIAL) ), sprintf( '%x', $post31wrap ), "rr->serial(SEQUENTIAL) wraps from $pre31wrap to $post31wrap" ); my $pre32wrap = 0xFFFFFFFF; my $post32wrap = 0x00000000; $rr->serial($pre32wrap); is( sprintf( '%x', $rr->serial(SEQUENTIAL) ), sprintf( '%x', $post32wrap ), "rr->serial(SEQUENTIAL) wraps from $pre32wrap to $post32wrap" ); } for my $rr ( Net::DNS::RR->new('name SOA mname rname 2000000000') ) { my $predate = $rr->serial; my $postdate = YYYYMMDDxx; my $postincr = $postdate + 1; is( $rr->serial($postdate), $postdate, "rr->serial(YYYYMMDDxx) steps from $predate to $postdate" ); is( $rr->serial($postdate), $postincr, "rr->serial(YYYYMMDDxx) increments $postdate to $postincr" ); } for my $rr ( Net::DNS::RR->new('name SOA mname rname') ) { my $posttime = UNIXTIME; my $pretime = $posttime - 10; $rr->serial($pretime); is( sprintf( '%u', $rr->serial($posttime) ), sprintf( '%u', $posttime ), "rr->serial(UNIXTIME) steps from $pretime to $posttime" ); } for my $rr ( Net::DNS::RR->new('name SOA mname rname') ) { my $jan2038 = 0x80007B40; is( sprintf( '%x', $rr->serial($jan2038) ), sprintf( '%x', $jan2038 ), "rr->serial(UNIXTIME) will still work after 19 Jan 2038" ); } for my $rr ( Net::DNS::RR->new("$name $type @data") ) { $rr->serial(YYYYMMDDxx); $rr->print; } exit; Net-DNS-1.50/t/05-CAA.t0000644000175000017500000000316014756035515013424 0ustar willemwillem#!/usr/bin/perl # $Id: 05-CAA.t 2003 2025-01-21 12:06:06Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 15; use Net::DNS; my $name = 'nocerts.example,com'; my $type = 'CAA'; my $code = 257; my @attr = qw( flags tag value ); my @data = ( 0, 'issue', ";" ); my @also = qw( critical ); my $wire = '000569737375653b'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { next if /certificate/; is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } ok( $rr->critical(1), 'set $rr->critical' ); ok( $rr->flags, '$rr->flags changed' ); ok( !$rr->critical(0), 'clear $rr->critical' ); } Net::DNS::RR->new( name => $name, type => $type, %$hash )->print; exit; Net-DNS-1.50/t/05-TXT.t0000644000175000017500000000457314756035515013530 0ustar willemwillem#!/usr/bin/perl # $Id: 05-TXT.t 1910 2023-03-30 19:16:30Z willem $ -*-perl-*- # use strict; use warnings; use Test::More tests => 50; use TestToolkit; use Net::DNS; my $name = 'TXT.example'; my $type = 'TXT'; my $code = 16; my @attr = qw( txtdata ); my @data = qw( arbitrary_text ); my @also = qw( char_str_list ); my $wire = '0e6172626974726172795f74657874'; my $typecode = unpack 'xn', Net::DNS::RR->new( type => $type )->encode; is( $typecode, $code, "$type RR type code = $code" ); my $hash = {}; @{$hash}{@attr} = @data; for my $rr ( Net::DNS::RR->new( name => $name, type => $type, %$hash ) ) { my $string = $rr->string; my $rr2 = Net::DNS::RR->new($string); is( $rr2->string, $string, 'new/string transparent' ); is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); foreach (@attr) { is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); } foreach (@also) { ok( $rr->$_, "additional attribute rr->$_()" ); } my $encoded = $rr->encode; my $decoded = Net::DNS::RR->decode( \$encoded ); my $hex1 = unpack 'H*', $encoded; my $hex2 = unpack 'H*', $decoded->encode; my $hex3 = unpack 'H*', $rr->rdata; is( $hex2, $hex1, 'encode/decode transparent' ); is( $hex3, $wire, 'encoded RDATA matches example' ); my $emptyrr = Net::DNS::RR->new("$name $type")->encode; my $corrupt = pack 'a*X2na*', $emptyrr, $decoded->rdlength - 1, $rr->rdata; exception( 'corrupt wire-format', sub { Net::DNS::RR->decode( \$corrupt ) } ); } for my $rr ( Net::DNS::RR->new(". $type") ) { foreach (@attr) { ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); } } { foreach my $testcase ( q|contiguous|, q|three unquoted strings|, q|"in quotes"|, q|"two separate" "quoted strings"|, q|"" empty|, q|" " space|, q|!|, q|\"|, q|#|, q|$|, q|%|, q|&|, q|'|, q|\(|, q|\)|, q|*|, q|+|, q|,|, q|-|, q|.|, q|/|, q|:|, q|\;|, q|<|, q|=|, q|>|, q|?|, q|@|, q|[|, q|\\\\|, q|]|, q|^|, q|_|, q|`|, q|{|, q(|), q|}|, q|~|, q|0|, q|1|, join( q|\227\128\128|, q|\229\143\164\230\177\160\227\130\132|, q|\232\155\153\233\163\155\232\190\188\227\130\128|, q|\230\176\180\227\129\174\233\159\179| ) ) { my $string = "$name. TXT $testcase"; my $expect = Net::DNS::RR->new($string)->string; # test for consistent parsing my $result = Net::DNS::RR->new($expect)->string; is( $result, $expect, $string ); } } exit; __END__ Net-DNS-1.50/t/51-DS-SHA1.t0000644000175000017500000000245614756035515014050 0ustar willemwillem#!/usr/bin/perl # $Id: 51-DS-SHA1.t 1855 2021-11-26 11:33:48Z willem $ -*-perl-*- # use strict; use warnings; use Test::More; use Net::DNS; my @prerequisite = qw( Digest::SHA MIME::Base64 Net::DNS::RR::DNSKEY Net::DNS::RR::DS ); foreach my $package (@prerequisite) { next if eval "require $package"; ## no critic plan skip_all => "$package not installed"; exit; } plan tests => 3; # Simple known-answer tests based upon the examples given in RFC4034, section 5.4 my $RFC = 'RFC4034'; my $dnskey = Net::DNS::RR->new( <<'END' ); dskey.example.com. 86400 IN DNSKEY 256 3 5 ( AQOeiiR0GOMYkDshWoSKz9XzfwJr1AYtsmx3TGkJaNXVbfi/2pHm822aJ5iI9BMzNXxeYCmZDRD9 9WYwYqUSdjMmmAphXdvxegXd/M5+X7OrzKBaMbCVdFLUUh6DhweJBjEVv5f2wwjM9XzcnOf+EPbt G9DMBmADjFDc2w/rljwvFw== ) ; Key ID = 60485 END my $ds = Net::DNS::RR->new( <<'END' ); dskey.example.com. 86400 IN DS 60485 5 1 ( 2BB183AF5F22588179A53B0A98631FAD1A292118 ) ; xepor-cybyp-zulyd-dekom-civip-hovob-pikek-fylop-tekyd-namac-moxex END my $test = Net::DNS::RR::DS->create( $dnskey, digtype => $ds->digtype, ttl => $ds->ttl ); is( $test->string, $ds->string, "created DS matches $RFC example DS" ); ok( $test->verify($dnskey), "created DS verifies $RFC example DNSKEY" ); ok( $ds->verify($dnskey), "$RFC example DS verifies DNSKEY" ); $test->print; __END__ Net-DNS-1.50/contrib/0000755000175000017500000000000014756035527013631 5ustar willemwillemNet-DNS-1.50/contrib/loclist.pl0000644000175000017500000000620014756035515015632 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 strict; use warnings; use Net::DNS '0.08'; use Getopt::Std; getopts('vnrd'); $res = Net::DNS::Resolver->new(); line: while (<>) { 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 my $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 my $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 my $ans ($query->answer) { if ($ans->type eq "A") { push(@addrs,$ans->address); } } } if (@addrs) { checkaddrs: foreach my $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 my $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 my $ans ($query->answer) { if ($ans->type eq "A") { $mask = unpack("L",pack("CCCC", split(/\./,$ans->address,4))); } } } } } if (@netnames) { foreach my $network (@netnames) { $query = $res->query($network,"LOC"); if (defined ($query)) { foreach my $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-1.50/contrib/check_soa0000644000175000017500000004112414756035515015472 0ustar willemwillem#!/usr/bin/perl use strict; use warnings; my $VERSION = (qw$LastChangedRevision: 1982 $)[1]; =head1 NAME check_soa - Check nameservers for a domain =head1 SYNOPSIS check_soa [-d] [-n] [-s] [-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<-s> Request DNSSEC resource records. =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,2014 Dick Franks Erwfranks[...]acm.orgE All rights reserved. FOR DEMONSTRATION PURPOSES ONLY, NO WARRANTY, NO SUPPORT =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 my $self = $0; # script my $options = 'dnstv'; # 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 @flag = map { "[-$_]" } split( //, $options ); # documentation die eval { system("perldoc -F $self"); "" }, < ( $option{d} || 0 ), # -d enable diagnostics igntc => ( $option{t} || 0 ), # -t ignore truncation udppacketsize => 1232 ); my $negtest = $option{n}; # -n report NCACHE TTL my $dnssec = $option{s}; # -s request DNSSEC RRs 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.100; # minimum polling interval my $zone = find_zonecut($domain); # (also inverts IP address/prefix) local $SIG{__WARN__} = sub { }; # suppress all warnings my $resolver = Net::DNS::Resolver->new(@conf); # create resolver object $resolver->nameservers(@nameserver) or die $resolver->string; my @ns = NS($zone); # find NS serving zone die "\ninvalid: $domain\n\n", $resolver->string unless @ns; # game over my @nsname = grep { $_ ne $zone } map { $_->nsdname } @ns; # extract server names from NS records my @server = @nameserver ? (@nameserver) : ( sort @nsname ); $resolver->dnssec(1) if $dnssec; my @soa = grep { $_->type eq '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 CNAME )) { my $probe = $resolver->send( $mname, $rrtype ) || next; last if ( $resolved = scalar $probe->answer ); } for ($mname) { last unless $_ eq $owner; # RFC6303 local zone displayRR( $zone, 'NS' ) unless @nameserver; # ensure NS always 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('zone data expires with no 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("zone data expires 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 = $negtest ? NCACHE($zone) : (); # report observed NCACHE TTL displayRR( $zone, 'NS' ) if @nameserver; # show NS if testing specific nameserver @server = ( shift @server ) if $zone eq '.'; # minimal test for root zone $resolver->usevc(1); # no longer ok to query ANY over UDP $resolver->nameservers(@server); displayRR( $domain, 'ANY' ); print "----\n"; my ( $bad, $seq, $iphash ) = checkNS( $zone, @server ); # report status $iphash->{$seq} ||= ''; 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('SOAs do not identify unique primary server'); # RFC1034, 4.3.5 foreach my $mname ( sort keys %mname ) { foreach ( $mname, $resolver->nameservers($mname) ) { delete $iphash->{$_} } } my %serial = map { ( $iphash->{$_} => $_ ) } sort { $a <=> $b } keys %$iphash; foreach ( sort keys %mname ) { report( sprintf '%10s %s', $serial{$_}, $_ ) } } exit; sub checkNS0 { ## initial status vector for checkNS my $serial = undef; my $hash = {}; my $res = Net::DNS::Resolver->new(@conf); foreach my $soa ( grep { $_->type eq 'SOA' } @ncache, @soa ) { my $mname = lc $soa->mname; # populate hash with name/IP of primary next if $mname eq lc $soa->name; # RFC6303 local zone foreach ( $mname, $res->nameservers($mname) ) { $hash->{$_} = $mname } my $s = $soa->serial; $hash->{$s} = $mname; $serial = $s if ordered( $serial, $s ); } return ( 0, $serial, $hash ); } sub checkNS { ## query nameservers (concurrently) and report status my $zone = shift; my $index = scalar @_; # index last element my $element = pop(@_) || return checkNS0; # pop element, terminate if undef my ( $ns, $if ) = split / /, lc $element; # name + optional interface IP my $res = Net::DNS::Resolver->new(@conf); # use clean resolver for each test my @xip = $res->nameservers( $if || $ns ); # point at nameserver 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 ); ( $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 ? ( $ip => 1 ) : (); # 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 scalar(@_), "$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 = $hash->{$mname} ? () : $res->nameservers($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' } $ip ? displayRR($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; # RFC6303 local zone report($rcode); # abject failure return @fail; } my @result = @fail; # analyse response my @auth = @soa ? () : $packet->authority; 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( 'negative cache', 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('NOERROR (no data)'); # 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 $response = $res->send( $zone, 'SOA' ); # repeat test before pointing finger my ($retest) = grep { $_->type eq 'SOA' } $response ? $response->answer : (); $serial = $retest->serial if ordered( $serial, $retest->serial ); } print "\t\t\tzone serial\t", $serial, "\n"; $hash->{$serial} = $hash->{$ip} if $primary; if ( ordered( $serial, $latest ) ) { report('serial number not current'); return @fail unless $primary; report('discredited as unique primary nameserver'); 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 ) }; ## no critic return; } 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 $qname = $question->qname; my $name = $qname =~ /^xn--/ ? eval { $question->name } : ''; my @annotation = $name ? ("; $name\n") : (); my @answer = $packet->answer; my @authority = $packet->authority; my @ncache = grep { $_->type eq 'SOA' } @authority; # per RFC2308 my @workaround = $qtype eq 'SOA' ? @ncache : (); # SOA misplaced/withheld? my @remark = @workaround ? qw(unexpected) : (); foreach my $rr ( @answer, @workaround ) { # print RRs unless shown elsewhere next if $qtype eq 'ANY' && $rr->type =~ /^(SOA|NS|RRSIG)$/; print @annotation if $rr->name eq $qname; # annotate IDN for ( $rr->string ) { my $l = $verbose ? length($_) : 108; # abbreviate long RR substr( $_, $l ) = ' ...' if length($_) > $l && $rr->type ne 'SOA'; print "$_\n"; } } report( @remark, "$rcode:", $question->string, @annotation ) 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) { my $serial = $_->serial; my ($seen) = ( @soa, @ncache ); my @source = $serial > $seen->serial ? ("\t(SOA: $serial)") : (); report( 'negative cache data', ttl( $_->ttl ), @source ); } return @ncache; } sub NS { ## find NS records for domain my $name = shift; my $packet = $resolver->send( $name, 'NS' ) or die $resolver->string; # Bear in mind the possibility of malformed zones! return ( grep { $_->type eq 'NS' } $packet->answer, $packet->authority ); } sub find_zonecut { my $name = shift; require Net::DNS::Resolver::Recurse; my $resolver = Net::DNS::Resolver::Recurse->new(); my $response = $resolver->send( $name, 'NULL' ) || die $resolver->errorstring; my ($cut) = map { $_->name } $response->authority; return $cut || die "failed to find zone cut for $name"; } sub ordered { ## irreflexive 32-bit partial ordering my ( $n1, $n2 ) = @_; return 0 unless defined $n2; # ( any, undef ) return 1 unless defined $n1; # ( undef, any ) # unwise to assume 64-bit arithmetic, or that 32-bit integer overflow goes unpunished use integer; # fold, leaving $n2 non-negative $n1 = ( $n1 & 0xFFFFFFFF ) ^ ( $n2 & 0x80000000 ); # -2**31 <= $n1 < 2**32 $n2 = ( $n2 & 0x7FFFFFFF ); # 0 <= $n2 < 2**31 return $n1 < $n2 ? ( $n1 > ( $n2 - 0x80000000 ) ) : ( $n2 < ( $n1 - 0x80000000 ) ); } sub report { ## concatenate strings into fault report return 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-1.50/contrib/dnswalk.README0000644000175000017500000000024314756035515016147 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-1.50/contrib/loc2earth.fcgi0000644000175000017500000001351514756035515016350 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 1811 2020-10-05 08:24:23Z willem $ use strict; use warnings; # 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 = Net::DNS::Resolver->new(); @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 ( CGI::Fast->new ) { # 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 my $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 my $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 my $ans ($query->answer) { if ($ans->type eq "A") { push(@addrs,$ans->address); } } } if (@addrs) { checkaddrs: foreach my $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 my $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 my $ans ($query->answer) { if ($ans->type eq "A") { $mask = unpack("L",pack("CCCC", split(/\./,$ans->address,4))); } } } } } if (@netnames) { foreach my $network (@netnames) { $query = $res->query($network,"LOC"); if (defined ($query)) { foreach my $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:"), "
    \n
  • ",join("\n
  • ",@samplehosts),"
"; 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 my $alt (49, 204, 958, 35875) { print ('', $alt,'km '); } return print " above this point

"; } Net-DNS-1.50/contrib/README0000644000175000017500000000110114756035515014477 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 find_zonecut Dick Franks loc2earth.fcgi Christopher Davis loclist.pl Christopher Davis --- $Id: README 1251 2014-08-18 10:18:23Z willem $ Net-DNS-1.50/contrib/check_zone0000644000175000017500000004565414756035515015677 0ustar willemwillem#!/usr/local/bin/perl -w # $Id: check_zone 1842 2021-07-08 14:25:00Z willem $ =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 =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. =back =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 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 warnings; use Carp; 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; local $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 assert { croak 'violated assertion' unless shift; return } sub parse_exceptions_file { my %exceptions; my $file = $opt_e || ""; return %exceptions unless ( -r $file); open( my $fh, '<', $file ); die "Couldn't read $file: $!" unless $fh; while (<$fh>) { chomp; #print " raw line: $_\n"; next if /^$/; next if /^\s*#/; s/#.*$//; s/^\s*//; s/\s*$//; s/'//g; my ($left, $right) = (split /[\s:]+/, $_)[0, -1]; push @{$exceptions{$left}}, $right; #print "processed line: $line\n"; } close($fh); 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 = Net::DNS::Resolver->new(); $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 my $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 my $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); } } return; } sub check_soa { my( $domain, $class, $nsl ) = @_; my( $soa_sn, $soa_diff ) = ( 0, 0 ); my( $ns, $soa_rr ); my $rr_count = 0; my $res = Net::DNS::Resolver->new(); $res->defnames( 0 ); $res->retry( 2 ); $res->recurse( 0 ); # Contact each name server and get the # SOA for the somain. # foreach my $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 my $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"; return; } sub check_ptr { my( $domain, $class, $nsl, $zone ) = @_; my $res = Net::DNS::Resolver->new(); my $ptr_rr; my $rr_count = 0; $res->defnames( 0 ); $res->retry( 2 ); $res->nameservers( @$nsl ); foreach my $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"; return; } sub check_ns { my( $domain, $class, $nsl, $zone ) = @_; my $res = Net::DNS::Resolver->new(); 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 my $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"; return; } sub check_a { my( $domain, $class, $nsl, $zone ) = @_; my $res = Net::DNS::Resolver->new(); 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 my $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"; return; } sub check_mx { my( $domain, $class, $nsl, $zone ) = @_; my $res = Net::DNS::Resolver->new(); 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 my $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"; return; } sub check_cname { my( $domain, $class, $nsl, $zone ) = @_; my $res = Net::DNS::Resolver->new(); 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 my $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"; return; } 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 = Net::DNS::Resolver->new(); $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 my $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" ); } return; } sub xcheck_ptr2a { my( $ptr_rr, $domain, $class, $nsl ) = @_; my $res = Net::DNS::Resolver->new(); $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 my $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" ); } return; } sub xcheck_name { my( $name, $domain, $class, $nsl ) = @_; my $res = Net::DNS::Resolver->new(); $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 my $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" ); } return; } sub types4name { my( $name, $domain, $class, $nsl ) = @_; my $res = Net::DNS::Resolver->new(); 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 my $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 ); return; } Net-DNS-1.50/contrib/find_zonecut0000644000175000017500000000160314756035515016240 0ustar willemwillem#!/usr/bin/perl use strict; use warnings; my $VERSION = (qw$LastChangedRevision: 1944 $)[1]; =head1 NAME find_zonecut - Find zonecut for a domain name =head1 SYNOPSIS find_zonecut name =head1 DESCRIPTION B returns the name of the closest delegation point to the specified domain name. =cut use Net::DNS; print find_zonecut(shift), "\n"; sub find_zonecut { my $name = shift; require Net::DNS::Resolver::Recurse; my $resolver = Net::DNS::Resolver::Recurse->new(); my $response = $resolver->send( $name, 'NULL' ) || die $resolver->errorstring; my ($cut) = map { $_->name } $response->authority; return $cut || die "failed to find zone cut for $name"; } __END__ =head1 COPYRIGHT (c)2014 Dick Franks Erwfranks[...]acm.orgE All rights reserved. FOR DEMONSTRATION PURPOSES ONLY, NO WARRANTY, NO SUPPORT =head1 SEE ALSO L, L =cut Net-DNS-1.50/Makefile.PL0000644000175000017500000001640114756035515014142 0ustar willemwillem# # $Id: Makefile.PL 2007 2025-02-08 16:45:23Z willem $ -*-perl-*- # use 5.008009; use strict; use warnings; use ExtUtils::MakeMaker; my $distro = 'Net::DNS'; my $module = join '/', 'lib', split /::/, "$distro.pm"; my $author = ['Dick Franks', 'Olaf Kolkman', 'Michael Fuhr']; $author = join ', ', @$author if $ExtUtils::MakeMaker::VERSION < 6.58; # See perldoc ExtUtils::MakeMaker for details of how to influence # the contents of the Makefile that is written. my %metadata = ( NAME => $distro, VERSION_FROM => $module, ABSTRACT_FROM => $module, AUTHOR => $author, LICENSE => 'mit', MIN_PERL_VERSION => 5.008009, CONFIGURE_REQUIRES => { 'Config' => 0, 'ExtUtils::MakeMaker' => 6.48, 'Getopt::Long' => 2.43, 'IO::File' => 1.14, 'IO::Socket::IP' => 0.38, }, TEST_REQUIRES => { 'ExtUtils::MakeMaker' => 0, 'File::Find' => 1.13, 'File::Spec' => 3.29, 'IO::File' => 1.14, 'Test::Builder' => 0.80, 'Test::More' => 0.80, } ); my %platform = ( ## platform-specific dependencies MSWin32 => { 'Win32::IPHelper' => 0.07, 'Win32::API' => 0.55, 'Win32::TieRegistry' => 0.24, } ); my $platform = $platform{$^O} || {}; my %prerequisite = ( 'Carp' => 1.10, 'Digest::HMAC' => 1.03, 'Digest::MD5' => 2.37, 'Digest::SHA' => 5.23, 'Encode' => 2.26, 'Exporter' => 5.63, 'File::Spec' => 3.29, 'IO::File' => 1.14, 'IO::Select' => 1.17, 'IO::Socket' => 1.30, 'IO::Socket::IP' => 0.38, 'MIME::Base64' => 3.07, 'PerlIO' => 1.05, 'Scalar::Util' => 1.19, 'Socket' => 1.81, 'Time::Local' => 1.19, 'base' => 2.13, 'constant' => 1.17, 'integer' => 1.00, 'overload' => 1.06, 'strict' => 1.03, 'warnings' => 1.0501, %$platform ); my %optional = ( 'Digest::BubbleBabble' => 0.02, 'Net::LibIDN2' => 1.00, ); ## IMPORTANT: THE USE AND/OR HANDLING OF STRONG ENCRYPTION TECHNOLOGIES IS ## PROHIBITED OR SEVERELY RESTRICTED IN MANY TERRITORIES. delete $prerequisite{'Net::DNS::SEC'}; ## MUST NOT list Net::DNS::SEC dependency in metadata. delete $optional{'Net::DNS::SEC'}; ## Require explicit user action to install Net::DNS::SEC. my @debris = qw(.resolv.conf *.lock); # # Get the command line args # use constant USE_GETOPT => defined eval { require Getopt::Long }; my $help = 0; my $IPv6_tests = 1; my $online_tests = 2; ## 2 = non-fatal, 1 = on, 0 = off ## my @options = ( 'online-tests!' => \$online_tests, 'non-fatal-online-tests' => sub { $online_tests = 2; }, 'IPv6-tests!' => \$IPv6_tests, 'help!' => \$help ); if ( USE_GETOPT && !Getopt::Long::GetOptions(@options) ) { print "Error: Unrecognized option.\n"; print "Try perl Makefile.PL --help for more information\n"; exit 1; } if ($help) { print <<'EOT'; Usage: perl Makefile.PL [OPTION...] Prepare Makefile for building and installing Net::DNS --online-tests Perform tests by communicating with the outside world. Beware that their success is also dependent on outside influences. --noonline-tests Skip online tests completely. --IPv6-tests Perform IPv6 specific online tests. Default is the same as regular online tests. --noIPv6-tests Skip IPv6 specific online test --non-fatal-online-tests Perform online test, but do not let failures negatively affect the outcome of running make test. This is the default. EOT exit 0; } # # Enable tests if we have internet connection (code lifted from LWP) # use constant USE_SOCKET_IP => defined eval 'use IO::Socket::IP 0.38; 1;'; ## no critic require IO::Socket::INET unless USE_SOCKET_IP; if ($online_tests) { my $class = USE_SOCKET_IP ? 'IO::Socket::IP' : 'IO::Socket::INET'; my $socket = $class->new( PeerAddr => 'dns.google.', PeerPort => 53, ## check 53/TCP not blocked ## Timeout => 10 ); unless ($socket) { $online_tests = 0; print <<"EOT"; Unable to establish TCP/IP connection to the global Internet. $@ Disabling online tests altogether... EOT } } # set up online testing configuration files. my $enable = 't/online.enabled'; my $IPv6 = 't/IPv6.enabled'; my $nonfatal = 't/online.nonfatal'; push @debris, $enable, $IPv6, $nonfatal; if ($online_tests) { require IO::File; my $fh1 = IO::File->new( $enable, '>' ) or die "Can't touch $enable $!"; close($fh1); if ( $online_tests == 2 ) { print "\nActivating Non Fatal Online Tests...\n"; my $fh2 = IO::File->new( $nonfatal, '>' ) or die "Can't touch $nonfatal $!"; close($fh2); } else { print "\nActivating Online Tests...\n"; } if ( USE_SOCKET_IP && $IPv6_tests ) { print "\nActivating IPv6 Tests...\n"; my $fh3 = IO::File->new( $IPv6, '>' ) or die "Can't touch $IPv6 $!"; close($fh3); } print <<'EOT'; Warning! ======== Online tests depend on conditions beyond the control of Net::DNS. The tests check for the expected results when both Net::DNS and the outside world are functioning properly. In case of failure it is often undecidable if the error lies within Net::DNS or elsewhere. EOT } WriteMakefile( ## Makefile & distribution metadata %metadata, PREREQ_PM => {%prerequisite}, META_MERGE => {recommends => {%optional}}, clean => {FILES => "@debris"}, ); exit; package MY; ## customise generated Makefile sub constants { return join "\n", shift->SUPER::constants(), <<'END' if $^O =~ /MSWin/i; # include test directory TEST_DIR = t FULLPERLRUN = $(FULLPERL) "-I$(TEST_DIR)" END return join "\n", shift->SUPER::constants(), <<'END'; # suppress parallel test execution include test directory TEST_DIR = t FULLPERLRUN = HARNESS_OPTIONS=j1:c $(FULLPERL) "-I$(TEST_DIR)" END } sub dist { return join "\n", shift->SUPER::dist(), <<'END'; # $(PERM_RWX) raises security issues downstream PREOP = $(CHMOD) $(PERM_RW) $(DISTVNAME)$(DFSEP)contrib$(DFSEP)* $(DISTVNAME)$(DFSEP)demo$(DFSEP)* END } sub install { my $self = shift; my %install_type = qw(perl INSTALLPRIVLIB site INSTALLSITELIB vendor INSTALLVENDORLIB); my $install_site = join '', '$(DESTDIR)$(', $install_type{$self->{INSTALLDIRS}}, ')'; for ($install_site) { s/\$\(([A-Z_]+)\)/$self->{$1}/eg while /\$\(/; # expand Makefile macros s|([/])[/]+|$1|g; # remove gratuitous //s } eval "require $distro"; ## no critic my @version = ( 'version', eval { $distro->VERSION } ); my $nameregex = join '\W+', '', split /::/, "$distro.pm\$"; my @installed = grep { $_ && m/$nameregex/io } values %INC; my %occluded; foreach (@installed) { my $path = m/^(.+)$nameregex/io ? $1 : ''; my %seen; foreach (@INC) { $seen{$_}++; # find $path in @INC last if $_ eq $path; } foreach ( grep { !$seen{$_} } @INC ) { $occluded{$_}++; # suppress install } } return $self->SUPER::install(@_) unless $occluded{$install_site}; my $message; warn $message = <<"AMEN"; ## ## The install location for this version of $distro differs ## from the existing @version in your perl library at ## @installed ## ## The installation would be rendered ineffective because the ## existing @version occurs in the library search path before ## $install_site ## ## The generated Makefile supports build and test only. ## AMEN my $echo = ' $(NOECHO) $(ECHO) "##"'; $message =~ s/##/$echo/eg; return join '', <<"END"; install : $message \$(NOECHO) \$(FALSE) END } sub postamble { return <<'END'; test_cover : cover -delete cover -test END } __END__ Net-DNS-1.50/LICENSE0000644000175000017500000000173714756035515013203 0ustar willemwillem LICENSE ======= Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ---- $Id: LICENSE 1843 2021-07-09 09:10:08Z willem $ Net-DNS-1.50/README0000644000175000017500000002526014756035515013053 0ustar willemwillem Net::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. License 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 is planned for future versions, see the CPAN RT ticket list. The author invites feedback on Net::DNS. If there is something you would 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 announcements 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: https://metacpan.org/release/Net-DNS or through http://www.net-dns.org/ 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: Digest::HMAC Digest::MD5 Digest::SHA File::Spec IO::Socket IO::Socket::IP MIME::Base64 Time::Local Test::More The availability of these optional packages is tested at runtime: Digest::BubbleBabble Net::DNS::SEC Net::LibIDN2 You can obtain the latest version of Perl from: http://www.cpan.org 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. 4. INSTALLATION ------------ Please install any modules mentioned in the PREREQUISITES section above. If you do not, some features of Net::DNS will not work. When you run "perl Makefile.PL", Perl should complain if any of the required modules is missing. To build this module, run the following commands: tar xvzf Net-DNS-?.??.tar.gz cd Net-DNS-?.?? perl Makefile.PL make make test make install If you do not wish to 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 adversely affect the outcome of test suite. Also, if you do not wish to 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. Here is 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 ------------------------ Net::DNS supports the TSIG resource record to perform signed queries and updates (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 enable the DNSSEC signature generation and verification functions are distributed separately as Net::DNS::SEC. The package is available from CPAN. 10. BUGS ---- Net::DNS, although begun in 1997, is still under development and may still contain a few bugs. Please see CPAN RT and Changes file for more information. We 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 authors accept no blame if you corrupt your zone. That warning in place, We are aware of one large company that has used Net::DNS to make thousands of dynamic updates per day for at least 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 any bugs, please report each in a separate "rt.cpan.org" report along with the following information: * subject field containing a concise descriptive summary * 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 are making, if the fault can be demonstrated using Internet nameservers If we do not have access to a system similar to yours, you may be asked to insert some debugging lines and report back on the results. The more focussed the help and information you provide, the better. Net::DNS is currently maintained at NLnet Labs (www.nlnetlabs.nl) by: Willem Toorop. Between 2005 and 2012 Net::DNS was maintained by: Olaf Kolkman and his team. Between 2002 and 2004 Net::DNS was maintained by Chris Reinhardt. Net::DNS was created in 1997 by Michael Fuhr. 11. COPYRIGHT --------- Authorship of individual components and significant contributions is shown in the copyright notice attached to the relevant documentation. Copyright in all components is retained by their respective authors. 12. LICENSE ------- Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both 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 prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 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 maintaining Net::DNS for a couple of years. Thanks to Olaf for maintaining Net::DNS for over eight 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 file; 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 is 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 have always developed Net::DNS using open-source systems and I am proud to make Net::DNS freely available to the world. ---- $Id: README 1856 2021-12-02 14:36:25Z willem $