PK!}7EhhDNS/Nameserver.pmnu[package Net::DNS::Nameserver; use strict; use warnings; our $VERSION = (qw$Id: Nameserver.pm 1860 2021-12-11 09:19:50Z 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'], ZoneFile => "filename" ); my $nameserver = Net::DNS::Nameserver->new( LocalAddr => '10.1.2.3', LocalPort => 5353, ReplyHandler => \&reply_handler ); =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 for an example. =cut 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 integer; use Carp; use Net::DNS; use Net::DNS::ZoneFile; use IO::Socket; use IO::Select; use constant FORCE_IPv4 => 0; use constant DEFAULT_ADDR => qw(::1 127.0.0.1); use constant DEFAULT_PORT => 5353; use constant STATE_ACCEPTED => 1; use constant STATE_GOT_LENGTH => 2; use constant STATE_SENDING => 3; use constant PACKETSZ => 512; #------------------------------------------------------------------------------ # Constructor. #------------------------------------------------------------------------------ sub new { my ( $class, %self ) = @_; my $self = bless \%self, $class; if ( !exists $self{ReplyHandler} ) { if ( my $handler = UNIVERSAL::can( $class, "ReplyHandler" ) ) { $self{ReplyHandler} = sub { $handler->( $self, @_ ); }; } } croak 'No reply handler!' unless ref( $self{ReplyHandler} ) eq "CODE"; $self->ReadZoneFile( $self{ZoneFile} ) if exists $self{ZoneFile}; # local server addresses must also be accepted by a resolver my $LocalAddr = $self{LocalAddr} || [DEFAULT_ADDR]; my $resolver = Net::DNS::Resolver->new( nameservers => $LocalAddr ); $resolver->force_v4(1) unless USE_SOCKET_IP; $resolver->force_v4(1) if FORCE_IPv4; my @localaddresses = $resolver->nameservers; my $port = $self{LocalPort} || DEFAULT_PORT; $self{Truncate} = 1 unless defined( $self{Truncate} ); $self{IdleTimeout} = 120 unless defined( $self{IdleTimeout} ); my @sock_tcp; # All the TCP sockets we will listen to. my @sock_udp; # All the UDP sockets we will listen to. # while we are here, print incomplete lines as they come along. local $| = 1 if $self{Verbose}; foreach my $addr (@localaddresses) { #-------------------------------------------------------------------------- # Create the TCP socket. #-------------------------------------------------------------------------- print "\nCreating TCP socket $addr#$port - " if $self{Verbose}; my $sock_tcp = inet_new( LocalAddr => $addr, LocalPort => $port, Listen => 64, Proto => "tcp", Reuse => 1, Blocking => 0, ); if ($sock_tcp) { push @sock_tcp, $sock_tcp; print "done.\n" if $self{Verbose}; } else { carp "Couldn't create TCP socket: $!"; } #-------------------------------------------------------------------------- # Create the UDP Socket. #-------------------------------------------------------------------------- print "Creating UDP socket $addr#$port - " if $self{Verbose}; my $sock_udp = inet_new( LocalAddr => $addr, LocalPort => $port, Proto => "udp", ); if ($sock_udp) { push @sock_udp, $sock_udp; print "done.\n" if $self{Verbose}; } else { carp "Couldn't create UDP socket: $!"; } } #-------------------------------------------------------------------------- # Create the Select object. #-------------------------------------------------------------------------- my $select = $self{select} = IO::Select->new; $select->add(@sock_tcp); $select->add(@sock_udp); return unless $select->count; #-------------------------------------------------------------------------- # Return the object. #-------------------------------------------------------------------------- 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->{RRhash} = {}; my $RRlist = []; while ( my $rr = $zonefile->read ) { my ($leaf) = $rr->{owner}->label; push @{$RRhash->{lc $leaf}}, $rr; # Warning: Nasty trick abusing SOA to reference zone RR list if ( $rr->type eq 'SOA' ) { $RRlist = $rr->{RRlist} = [] } else { push @$RRlist, $rr } } return; } #------------------------------------------------------------------------------ # ReplyHandler - Default reply handler serving RRs from zone file #------------------------------------------------------------------------------ sub ReplyHandler { my ( $self, $qname, $qclass, $qtype, $peerhost, $query, $conn ) = @_; my $opcode = $query->header->opcode; my $rcode = 'NOERROR'; my @ans; my $lcase = lc $qname; # assume $qclass always 'IN' my ( $leaf, @tail ) = split /\./, $lcase; my $RRhash = $self->{RRhash}; my $RRlist = $RRhash->{$leaf} || []; # hash, then linear search my @match = grep { lc( $_->owner ) eq $lcase } @$RRlist; if ( $qtype eq 'AXFR' ) { my ($soa) = grep { $_->type eq 'SOA' } @match; if ($soa) { push @ans, $soa, @{$soa->{RRlist}}, $soa } else { $rcode = 'NOTAUTH' } } else { unless ( scalar(@match) ) { my $wildcard = join '.', '*', @tail; my $wildlist = $RRhash->{'*'} || []; foreach ( grep { lc( $_->owner ) eq $wildcard } @$wildlist ) { my $clone = bless {%$_}, ref($_); $clone->owner($qname); push @match, $clone; } $rcode = 'NXDOMAIN' unless @match; } @ans = grep { $_->type eq $qtype } @match; } return ( $rcode, \@ans, [], [], {aa => 1}, {} ); } #------------------------------------------------------------------------------ # inet_new - Calls the constructor in the correct module for making sockets. #------------------------------------------------------------------------------ sub inet_new { return USE_SOCKET_IP ? IO::Socket::IP->new(@_) : IO::Socket::INET->new(@_); } #------------------------------------------------------------------------------ # make_reply - Make a reply packet. #------------------------------------------------------------------------------ sub make_reply { my ( $self, $query, $sock ) = @_; unless ($query) { print "ERROR: invalid packet\n" if $self->{Verbose}; 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 $self->{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 ) { print "ERROR: qdcount $qdcount unsupported\n" if $self->{Verbose}; $header->rcode("FORMERR"); } else { my ($qr) = $query->question; my $qname = $qr->qname; my $qtype = $qr->qtype; my $qclass = $qr->qclass; my $id = $query->header->id; print "query $id : $qname $qclass $qtype\n" if $self->{Verbose}; my $peer = $sock->peerhost; my $conn = { peerhost => $peer, 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 $self->{Verbose}; $rcode = "FORMERR"; } if ( !defined($rcode) ) { print "remaining silent\n" if $self->{Verbose}; return; } $header->rcode($rcode); $reply->{answer} = [@$ans] if $ans; $reply->{authority} = [@$auth] if $auth; $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 $self->{Verbose} && ( $headermask || $optionmask ); return $reply; } #------------------------------------------------------------------------------ # readfromtcp - read from a TCP client #------------------------------------------------------------------------------ sub readfromtcp { my ( $self, $sock ) = @_; return -1 unless defined $self->{_tcp}{$sock}; my $peer = $self->{_tcp}{$sock}{peer}; my $buf; my $charsread = $sock->sysread( $buf, 16384 ); $self->{_tcp}{$sock}{inbuffer} .= $buf; $self->{_tcp}{$sock}{timeout} = time() + $self->{IdleTimeout}; # Reset idle timer print "Received $charsread octets from $peer\n" if $self->{Verbose}; if ( $charsread == 0 ) { # 0 octets means socket has closed print "Connection to $peer closed or lost.\n" if $self->{Verbose}; $self->{select}->remove($sock); $sock->close(); delete $self->{_tcp}{$sock}; return $charsread; } return $charsread; } #------------------------------------------------------------------------------ # tcp_connection - Handle a TCP connection. #------------------------------------------------------------------------------ sub tcp_connection { my ( $self, $sock ) = @_; if ( not $self->{_tcp}{$sock} ) { # We go here if we are called with a listener socket. my $client = $sock->accept; if ( not defined $client ) { print "TCP connection closed by peer before we could accept it.\n" if $self->{Verbose}; return 0; } my $peerport = $client->peerport; my $peerhost = $client->peerhost; print "TCP connection from $peerhost:$peerport\n" if $self->{Verbose}; $client->blocking(0); $self->{_tcp}{$client}{peer} = "tcp:" . $peerhost . ":" . $peerport; $self->{_tcp}{$client}{state} = STATE_ACCEPTED; $self->{_tcp}{$client}{socket} = $client; $self->{_tcp}{$client}{timeout} = time() + $self->{IdleTimeout}; $self->{select}->add($client); # After we accepted we will look at the socket again # to see if there is any data there. ---Olaf $self->loop_once(0); } else { # We go here if we are called with a client socket my $peer = $self->{_tcp}{$sock}{peer}; if ( $self->{_tcp}{$sock}{state} == STATE_ACCEPTED ) { if ( not $self->{_tcp}{$sock}{inbuffer} =~ s/^(..)//s ) { return; # Still not 2 octets ready } my $msglen = unpack( "n", $1 ); print "$peer said his query contains $msglen octets\n" if $self->{Verbose}; $self->{_tcp}{$sock}{state} = STATE_GOT_LENGTH; $self->{_tcp}{$sock}{querylength} = $msglen; } # Not elsif, because we might already have all the data if ( $self->{_tcp}{$sock}{state} == STATE_GOT_LENGTH ) { # return if not all data has been received yet. return if $self->{_tcp}{$sock}{querylength} > length $self->{_tcp}{$sock}{inbuffer}; my $qbuf = substr( $self->{_tcp}{$sock}{inbuffer}, 0, $self->{_tcp}{$sock}{querylength} ); substr( $self->{_tcp}{$sock}{inbuffer}, 0, $self->{_tcp}{$sock}{querylength} ) = ""; my $query = Net::DNS::Packet->new( \$qbuf ); if ( my $err = $@ ) { print "Error decoding query packet: $err\n" if $self->{Verbose}; undef $query; # force FORMERR reply } my $reply = $self->make_reply( $query, $sock ); if ( not defined $reply ) { print "I couldn't create a reply for $peer. Closing socket.\n" if $self->{Verbose}; $self->{select}->remove($sock); $sock->close(); delete $self->{_tcp}{$sock}; return; } my $reply_data = $reply->data(65535); # limit to one TCP envelope warn "multi-packet TCP response not implemented" if $reply->header->tc; my $len = length $reply_data; $self->{_tcp}{$sock}{outbuffer} = pack( 'n a*', $len, $reply_data ); print "Queued TCP response (2 + $len octets) to $peer\n" if $self->{Verbose}; # We are done. $self->{_tcp}{$sock}{state} = STATE_SENDING; } } return; } #------------------------------------------------------------------------------ # udp_connection - Handle a UDP connection. #------------------------------------------------------------------------------ sub udp_connection { my ( $self, $sock ) = @_; my $buf = ""; $sock->recv( $buf, PACKETSZ ); my ( $peerhost, $peerport, $sockhost ) = ( $sock->peerhost, $sock->peerport, $sock->sockhost ); unless ( defined $peerhost && defined $peerport ) { print "the Peer host and sock host appear to be undefined: bailing out of handling the UDP connection" if $self->{Verbose}; return; } print "UDP connection from $peerhost:$peerport to $sockhost\n" if $self->{Verbose}; my $query = Net::DNS::Packet->new( \$buf ); if ( my $err = $@ ) { print "Error decoding query packet: $err\n" if $self->{Verbose}; undef $query; # force FORMERR reply } my $reply = $self->make_reply( $query, $sock ) || return; my $max_len = ( $query && $self->{Truncate} ) ? $query->edns->size : undef; if ( $self->{Verbose} ) { local $| = 1; print "Maximum UDP size advertised by $peerhost#$peerport: $max_len\n" if $max_len; print "Writing response - "; print $sock->send( $reply->data($max_len) ) ? "done" : "failed: $!", "\n"; } else { $sock->send( $reply->data($max_len) ); } return; } sub get_open_tcp { my $self = shift; return keys %{$self->{_tcp}}; } #------------------------------------------------------------------------------ # loop_once - Just check "once" on sockets already set up #------------------------------------------------------------------------------ # This function might not actually return immediately. If an AXFR request is # coming in which will generate a huge reply, we will not relinquish control # until our outbuffers are empty. # # NB this method may be subject to change and is therefore left 'undocumented' # sub loop_once { my ( $self, $timeout ) = @_; print ";loop_once called with timeout: " . ( defined($timeout) ? $timeout : "undefined" ) . "\n" if $self->{Verbose} && $self->{Verbose} > 4; foreach my $sock ( keys %{$self->{_tcp}} ) { # There is TCP traffic to handle $timeout = 0.1 if $self->{_tcp}{$sock}{outbuffer}; } my @ready = $self->{select}->can_read($timeout); foreach my $sock (@ready) { my $protonum = $sock->protocol; # This is a weird and nasty hack. Although not incorrect, # I just don't know why ->protocol won't tell me the protocol # on a connected socket. --robert $protonum = getprotobyname('tcp') if not defined $protonum and $self->{_tcp}{$sock}; my $proto = getprotobynumber($protonum); if ( !$proto ) { print "ERROR: connection with unknown protocol\n" if $self->{Verbose}; } elsif ( lc($proto) eq "tcp" ) { $self->readfromtcp($sock) && $self->tcp_connection($sock); } elsif ( lc($proto) eq "udp" ) { $self->udp_connection($sock); } else { print "ERROR: connection with unsupported protocol $proto\n" if $self->{Verbose}; } } my $now = time(); # Lets check if any of our TCP clients has pending actions. # (outbuffer, timeout) foreach my $s ( keys %{$self->{_tcp}} ) { my $sock = $self->{_tcp}{$s}{socket}; if ( $self->{_tcp}{$s}{outbuffer} ) { # If we have buffered output, then send as much as the OS will accept # and wait with the rest my $len = length $self->{_tcp}{$s}{outbuffer}; my $sent = $sock->syswrite( $self->{_tcp}{$s}{outbuffer} ) || 0; print "Sent $sent of $len octets to ", $self->{_tcp}{$s}{peer}, ".\n" if $self->{Verbose}; substr( $self->{_tcp}{$s}{outbuffer}, 0, $sent ) = ""; if ( length $self->{_tcp}{$s}{outbuffer} == 0 ) { delete $self->{_tcp}{$s}{outbuffer}; $self->{_tcp}{$s}{state} = STATE_ACCEPTED; if ( length $self->{_tcp}{$s}{inbuffer} >= 2 ) { # See if the client has send us enough data to process the # next query. # We do this here, because we only want to process (and buffer!!) # a single query at a time, per client. If we allowed a STATE_SENDING # client to have new requests processed. We could be easilier # victims of DoS (client sending lots of queries and never reading # from it's socket). # Note that this does not disable serialisation on part of the # client. The split second it should take for us to lookup the # next query, is likely faster than the time it takes to # send the response... well, unless it's a lot of tiny queries, # in which case we will be generating an entire TCP packet per # reply. --robert $self->tcp_connection( $self->{_tcp}{$s}{socket} ); } } $self->{_tcp}{$s}{timeout} = time() + $self->{IdleTimeout}; } else { # Get rid of idle clients. my $timeout = $self->{_tcp}{$s}{timeout}; if ( $timeout - $now < 0 ) { print $self->{_tcp}{$s}{peer}, " has been idle for too long and will be disconnected.\n" if $self->{Verbose}; $self->{select}->remove($sock); $sock->close(); delete $self->{_tcp}{$s}; } } } return; } #------------------------------------------------------------------------------ # main_loop - Main nameserver loop. #------------------------------------------------------------------------------ sub main_loop { my $self = shift; while (1) { print "Waiting for connections...\n" if $self->{Verbose}; # You really need an argument otherwise you'll be burning CPU. $self->loop_once(10); } return; } 1; __END__ =head1 METHODS =head2 new $nameserver = Net::DNS::Nameserver->new( LocalAddr => ['::1' , '127.0.0.1'], ZoneFile => "filename" ); $nameserver = Net::DNS::Nameserver->new( LocalAddr => '10.1.2.3', LocalPort => 5353, ReplyHandler => \&reply_handler, Verbose => 1, Truncate => 0 ); Returns a Net::DNS::Nameserver object, or undef if the object could not be created. Each instance is configured using the following optional arguments: LocalAddr IP address on which to listen Defaults to loopback address LocalPort Port on which to listen Defaults to 5353 ZoneFile Name of file containing RRs accessed using the default reply-handling subroutine ReplyHandler Reference to customised reply-handling subroutine NotifyHandler Reference to reply-handling subroutine for queries with opcode NOTIFY (RFC1996) UpdateHandler Reference to reply-handling subroutine for queries with opcode UPDATE (RFC2136) Verbose Report internal activity Defaults to 0 (off) Truncate Truncates UDP packets that are too big for the reply Defaults to 1 (on) IdleTimeout TCP clients are disconnected if they are idle longer than this duration Defaults to 120 (secs) The LocalAddr attribute may alternatively be specified as a list of IP addresses to listen to. If the IO::Socket::IP library package is available on the system this may also include IPv6 addresses. 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: NOERROR No error FORMERR Format error SERVFAIL Server failure NXDOMAIN Non-existent domain (name doesn't exist) NOTIMP Not implemented REFUSED Query refused 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 C<< { ad => 1, aa => 0, ra => 1 } >>. EDNS options may be specified in a similar manner using optionmask C<< { $optioncode => $value, $optionname => $value } >>. See RFC 1035 and the IANA dns-parameters file for more information: ftp://ftp.rfc-editor.org/in-notes/rfc1035.txt http://www.isi.edu/in-notes/iana/assignments/dns-parameters The nameserver will listen for both UDP and TCP connections. On Unix-like systems, unprivileged users are denied access to ports below 1024. UDP reply truncation functionality was introduced in VERSION 830. 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 C to 0 and truncate the reply packet in the code of the ReplyHandler. See L for an example. =head2 main_loop $ns->main_loop; Start accepting queries. Calling main_loop never returns. =head2 loop_once $ns->loop_once( [TIMEOUT_IN_SECONDS] ); Start accepting queries, but returns. If called without a parameter, the call will not return until a request has been received (and replied to). Otherwise, the parameter specifies the maximum time to wait for a request. A zero timeout forces an immediate return if there is nothing to do. Handling a request and replying obviously depends on the speed of ReplyHandler. Assuming a fast ReplyHandler, loop_once should spend just a fraction of a second, if called with a timeout value of 0.0 seconds. One exception is when an AXFR has requested a huge amount of data that the OS is not ready to receive in full. In that case, it will remain in a loop (while servicing new requests) until the reply has been sent. In case loop_once accepted a TCP connection it will immediately check if there is data to be read from the socket. If not it will return and you will have to call loop_once() again to check if there is any data waiting on the socket to be processed. In most cases you will have to count on calling "loop_once" twice. A code fragment like: $ns->loop_once(10); while( $ns->get_open_tcp() ){ $ns->loop_once(0); } Would wait for 10 seconds for the initial connection and would then process all TCP sockets until none is left. =head2 get_open_tcp In scalar context returns the number of TCP connections for which state is maintained. In array context it returns IO::Socket objects, these could be useful for troubleshooting but be careful using them. =head1 EXAMPLE The following example will listen on port 5353 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 its basis may be applied. #!/usr/bin/perl 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 => 5353, ReplyHandler => \&reply_handler, Verbose => 1 ) || die "couldn't create nameserver object\n"; $ns->main_loop; =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. This is a problem for machines with multiple IP-addresses and causes violation of RFC2181 section 4. Thus a UDP socket created listening to INADDR_ANY (all available IP-addresses) will reply not necessarily with the source address being the one to which the request was sent, but rather with the address that the operating system chooses. This is also often called "the closest address". This should really only be a problem on a server which has more than one IP-address (besides localhost - any experience with IPv6 complications here, would be nice). If this is a problem for you, a work-around would be to not listen to INADDR_ANY but to specify each address that you want this module to listen on. A separate set of sockets will then be created 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 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, RFC 1035 =cut PK!BBDNS/ZoneFile.pmnu[package Net::DNS::ZoneFile; use strict; use warnings; our $VERSION = (qw$Id: ZoneFile.pm 1855 2021-11-26 11:33:48Z 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 IO::File; use base qw(Exporter); our @EXPORT = qw(parse read readfh); use constant PERLIO => defined eval { require PerlIO }; 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 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 $self = bless {fileopen => {}}, shift; my ( $filename, $origin ) = @_; $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 local $SIG{__DIE__}; if (wantarray) { my @zone; # return entire zone eval { my $rr; push( @zone, $rr ) while $rr = $self->_getRR; }; croak join ' ', $@, ' file', $self->name, 'line', $self->line, "\n " if $@; return @zone; } my $rr = eval { $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 ); $listref = Net::DNS::ZoneFile->parse( $string, $include_dir ); $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 ); $listref = Net::DNS::ZoneFile->parse( $string, $include_dir ); $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 !ref($arg1) && $arg1 eq __PACKAGE__; my $text = shift; return &readfh( Net::DNS::ZoneFile::Text->new($text), @_ ); } ######################################## { 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 ); delete $self->{latest}; # forget previous owner $self->{parent} = bless {%$self}, ref($self); # save state, create link 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 = PERLIO ? join( ':', '<', PerlIO::get_layers $self->{filehandle} ) : '<'; my $filehandle = IO::File->new( $filename, $discipline ) or die qq(\$INCLUDE $filename: $!); delete $self->{latest}; # forget previous owner $self->{parent} = bless {%$self}, ref($self); # save state, create link $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, RFC1035 Section 5.1, RFC2308 L =cut PK!_:: DNS/Update.pmnu[package Net::DNS::Update; use strict; use warnings; our $VERSION = (qw$Id: Update.pm 1855 2021-11-26 11:33:48Z 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 = shift; my $list = $self->_section(shift); my @arg = grep { ref($_) } @_; my ($zone) = $self->zone; my $zclass = $zone->zclass; my @rr = grep { $_->class( $_->class =~ /ANY|NONE/ ? () : $zclass ) } @arg; return CORE::push( @$list, @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 = shift; my $list = $self->_section(shift); my @arg = grep { ref($_) } @_; my ($zone) = $self->zone; my $zclass = $zone->zclass; my @rr = grep { $_->class( $_->class =~ /ANY|NONE/ ? () : $zclass ) } @arg; my %unique = map { ( bless( {%$_, ttl => 0}, ref $_ )->canonical => $_ ) } ( @rr, @$list ); return scalar( @$list = values %unique ); } 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) { if ( $reply->header->rcode eq 'NOERROR' ) { print "Update succeeded\n"; } else { print 'Update failed: ', $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, RFC 2136, RFC 2845 =cut PK!@D ) ) DNS/Header.pmnu[package Net::DNS::Header; use strict; use warnings; our $VERSION = (qw$Id: Header.pm 1855 2021-11-26 11:33:48Z 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 $opt = $$self->edns; my $edns = $opt->_specified ? $opt->string : ''; return <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; return <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. A random value is assigned if the argument value is undefined. =cut sub id { my ( $self, @arg ) = @_; $$self->{id} = shift(@arg) if scalar @arg; return $$self->{id} if defined $$self->{id}; return $$self->{id} = int rand(0xffff); } =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 ) { return rcodebyval( $_ & 0x0f ) unless $opt->_specified; $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 { return shift->_dnsflag( 0x8000, @_ ); } =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 { return shift->_dnsflag( 0x0400, @_ ); } =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 { return shift->_dnsflag( 0x0200, @_ ); } =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 { return shift->_dnsflag( 0x0100, @_ ); } =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 { return shift->_dnsflag( 0x0080, @_ ); } =head2 z Unassigned bit, should always be zero. =cut sub z { return shift->_dnsflag( 0x0040, @_ ); } =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 { return shift->_dnsflag( 0x0020, @_ ); } =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 { return shift->_dnsflag( 0x0010, @_ ); } =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 our $warned; sub qdcount { my $self = shift; return $$self->{count}[0] || scalar @{$$self->{question}} unless scalar @_; carp 'header->qdcount attribute is read-only' unless $warned++; return; } =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 = shift; return $$self->{count}[1] || scalar @{$$self->{answer}} unless scalar @_; carp 'header->ancount attribute is read-only' unless $warned++; return; } =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 = shift; return $$self->{count}[2] || scalar @{$$self->{authority}} unless scalar @_; carp 'header->nscount attribute is read-only' unless $warned++; return; } =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 = shift; return $$self->{count}[3] || scalar @{$$self->{additional}} unless scalar @_; carp 'header->arcount attribute is read-only' unless $warned++; return; } sub zocount { return &qdcount; } sub prcount { return &ancount; } sub upcount { return &nscount; } sub adcount { return &arcount; } =head1 EDNS Protocol Extensions =head2 do print "DNSSEC_OK flag was ", $packet->header->do ? "not" : "", "set\n"; $packet->header->do(1); Gets or sets the EDNS DNSSEC OK flag. =cut sub do { return shift->_ednsflag( 0x8000, @_ ); } =head2 Extended rcode EDNS extended rcodes are handled transparently by $packet->header->rcode(). =head2 UDP packet size $udp_max = $packet->header->size; $udp_max = $packet->edns->size; EDNS offers a mechanism to advertise the maximum UDP packet size which can be assembled by the local network stack. UDP size advertisement can be viewed as either a header extension or an EDNS feature. Endless debate is avoided by supporting both views. =cut sub size { my $self = shift; return $$self->edns->size(@_); } =head2 edns $header = $packet->header; $version = $header->edns->version; @options = $header->edns->options; $option = $header->edns->option(n); $udp_max = $packet->edns->size; 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 = shift; my $flag = shift; for ( $$self->{status} ) { my $set = $_ | $flag; my $not = $set - $flag; $_ = (shift) ? $set : $not if scalar @_; $flag = ( $_ & $flag ) ? 1 : 0; } return $flag; } sub _ednsflag { my ( $self, $flag, @val ) = @_; my $edns = $$self->edns->flags || 0; return $flag & $edns ? 1 : 0 unless scalar @val; my $set = $flag | $edns; my $not = $set - $flag; my $val = shift(@val) ? $set : $not; $$self->edns->flags($val) unless $val == $edns; return ( $val & $flag ) ? 1 : 0; } 1; __END__ ######################################## =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. Portions Copyright (c)2002,2003 Chris Reinhardt. Portions 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, L RFC 1035 Section 4.1.1 =cut PK!ڨ55DNS/Parameters.pmnu[package Net::DNS::Parameters; ################################################ ## ## Domain Name System (DNS) Parameters ## (last updated 2021-11-22) ## ################################################ use strict; use warnings; our $VERSION = (qw$Id: Parameters.pm 1855 2021-11-26 11:33:48Z 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 'NSAP-PTR' => 23, # RFC1706 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 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, # draft-ietf-dnsop-svcb-https-00 HTTPS => 65, # draft-ietf-dnsop-svcb-https-00 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 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 AMTRELAY => 260, # RFC8777 TA => 32768, # http://cameo.library.cmu.edu/ 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 UL => 2, # http://files.dns-sd.org/draft-sekar-dns-ul.txt 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 'SERVER-TAG' => 17, # draft-bellis-dnsop-edns-tags '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; ######## # 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 > 0xffff; return $val; } } sub classbyval { my $val = shift; return $classbyval{$val} || return do { $val += 0; croak qq[classbyval($val) out of range] if $val > 0xffff; return "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"; } sub register { ## register( 'TOY', 1234 ) (NOT part of published API) my ( $mnemonic, $rrtype ) = @_; # uncoverable pod $rrtype = rand(255) + 65280 unless $rrtype; croak qq["$mnemonic" is a CLASS identifier] if defined $classbyname{$mnemonic = uc($mnemonic)}; for ( typebyval( $rrtype = int $rrtype ) ) { return $rrtype if /^$mnemonic$/; # 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; return $typebyname{$mnemonic} = $rrtype; } use constant EXTLANG => defined eval { require Net::DNS::Extlang }; our $DNSEXTLANG = EXTLANG ? eval { Net::DNS::Extlang->new()->domain } : undef; sub _typespec { eval { ## draft-levine-dnsextlang <<'END' } if EXTLANG && $DNSEXTLANG; my ($node) = @_; require Net::DNS::Resolver; my $resolver = Net::DNS::Resolver->new() || return; my $response = $resolver->send( "$node.$DNSEXTLANG", '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+$/; register( $1, $2 ) if $identifier =~ /^(\w+):(\d+)\W*/; return unless defined wantarray; my $extobj = Net::DNS::Extlang->new(); my $recipe = $extobj->xlstorerecord( $identifier, @attribute ); my @source = split /\n/, $extobj->compilerr($recipe); return sub { defined( $_ = shift @source ) }; } END return; } 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 PK! wwDNS/Resolver/MSWin32.pmnu[package Net::DNS::Resolver::MSWin32; use strict; use warnings; our $VERSION = (qw$Id: MSWin32.pm 1856 2021-12-02 14:36:25Z willem $)[2]; =head1 NAME Net::DNS::Resolver::MSWin32 - MS Windows resolver class =cut use base qw(Net::DNS::Resolver::Base); 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(@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 PK!j̾DNS/Resolver/UNIX.pmnu[package Net::DNS::Resolver::UNIX; use strict; use warnings; our $VERSION = (qw$Id: UNIX.pm 1856 2021-12-02 14:36:25Z willem $)[2]; =head1 NAME Net::DNS::Resolver::UNIX - Unix resolver class =cut use base qw(Net::DNS::Resolver::Base); my @config_file = grep { -f $_ && -r _ } '/etc/resolv.conf'; my $dotfile = '.resolv.conf'; my @dotpath = grep {defined} $ENV{HOME}, '.'; my @dotfile = grep { -f $_ && -o _ } map {"$_/$dotfile"} @dotpath; local $ENV{PATH} = join ':', grep {$_} qw(/bin /usr/bin), $ENV{PATH}; my $uname = eval {`uname -n 2>/dev/null`} || ''; chomp $uname; my ( $host, @domain ) = split /\./, $uname, 2; __PACKAGE__->domain(@domain); 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)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 PK!J{  DNS/Resolver/android.pmnu[package Net::DNS::Resolver::android; use strict; use warnings; our $VERSION = (qw$Id: android.pm 1856 2021-12-02 14:36:25Z willem $)[2]; =head1 NAME Net::DNS::Resolver::android - Android resolver class =cut use base qw(Net::DNS::Resolver::Base); 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 $dotfile = '.resolv.conf'; my @dotpath = grep {defined} $ENV{HOME}, '.'; my @dotfile = grep { -f $_ && -o _ } map {"$_/$dotfile"} @dotpath; 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 PK!TDNS/Resolver/os390.pmnu[package Net::DNS::Resolver::os390; use strict; use warnings; our $VERSION = (qw$Id: os390.pm 1856 2021-12-02 14:36:25Z willem $)[2]; =head1 NAME Net::DNS::Resolver::os390 - IBM OS/390 resolver class =cut use base qw(Net::DNS::Resolver::Base); use IO::File; local $ENV{PATH} = join ':', grep {$_} qw(/bin /usr/bin), $ENV{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 $dotfile = '.resolv.conf'; my @dotpath = grep {$_} $ENV{HOME}, '.'; my @dotfile = grep { -f $_ && -o _ } map {"$_/$dotfile"} @dotpath; 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), $ENV{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 PK!=^QVVDNS/Resolver/cygwin.pmnu[package Net::DNS::Resolver::cygwin; use strict; use warnings; our $VERSION = (qw$Id: cygwin.pm 1856 2021-12-02 14:36:25Z willem $)[2]; =head1 NAME Net::DNS::Resolver::cygwin - Cygwin resolver class =cut use base qw(Net::DNS::Resolver::Base); 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 PK!|U||DNS/Resolver/Base.pmnu[package Net::DNS::Resolver::Base; use strict; use warnings; our $VERSION = (qw$Id: Base.pm 1855 2021-11-26 11:33:48Z 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 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; 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 => ( IPv6 ? 0 : 1 ), force_v6 => 0, # only relevant if IPv6 is supported prefer_v4 => 0, prefer_v6 => 0, }, __PACKAGE__; sub _defaults { return $defaults; } } my %warned; sub _deprecate { my $msg = pop(@_); carp join ' ', 'deprecated method;', $msg unless $warned{$msg}++; return; } sub _untaint { 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 = shift; my $file = shift; 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 { print &string; return; } sub searchlist { my ( $self, @domain ) = @_; $self = $self->_defaults unless ref($self); if ( scalar(@domain) || !defined(wantarray) ) { foreach (@domain) { $_ = Net::DNS::Domain->new($_)->name } $self->{searchlist} = [@domain]; } return ( @{$self->{searchlist}} ); } sub domain { my ($head) = &searchlist; return wantarray ? ( grep {defined} $head ) : $head; } sub nameservers { my $self = shift; $self = $self->_defaults unless ref($self); my @ip; foreach my $ns ( grep {defined} @_ ) { 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(@_) || !defined(wantarray) ) { my @ipv4 = grep { _ipv4($_) } @ip; my @ipv6 = grep { _ipv6($_) } @ip; $self->{nameservers} = \@ip; $self->{nameserver4} = \@ipv4; $self->{nameserver6} = \@ipv6; } my @ns4 = $self->{force_v6} ? () : @{$self->{nameserver4}}; my @ns6 = $self->{force_v4} ? () : @{$self->{nameserver6}}; my @nameservers = @{$self->{nameservers}}; @nameservers = ( @ns4, @ns6 ) if $self->{prefer_v4} || !scalar(@ns6); @nameservers = ( @ns6, @ns4 ) if $self->{prefer_v6} || !scalar(@ns4); return @nameservers if scalar @nameservers; my $error = 'no nameservers'; $error = 'IPv4 transport disabled' if scalar(@ns4) < scalar @{$self->{nameserver4}}; $error = 'IPv6 transport disabled' if scalar(@ns6) < scalar @{$self->{nameserver6}}; $self->errorstring($error); return @nameservers; } 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} = ''; $! = $@ = undef; return; } sub errorstring { my $self = shift; my $text = shift || return $self->{errorstring}; $self->_diag( 'errorstring:', $text ); return $self->{errorstring} = $text; } sub query { my $self = shift; my $name = shift || '.'; my @sfix = $self->{defnames} && ( $name !~ m/[.:]/ ) ? $self->domain : (); my $fqdn = join '.', $name, @sfix; $self->_diag( 'query(', $fqdn, @_, ')' ); my $packet = $self->send( $fqdn, @_ ) || return; return $packet->header->ancount ? $packet : undef; } sub search { my $self = shift; return $self->query(@_) unless $self->{dnsrch}; my $name = shift || '.'; 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, @_, ')' ); my $packet = $self->send( $fqname, @_ ) || next; return $packet if $packet->header->ancount; } return; } sub send { my $self = shift; my $packet = $self->_make_query_packet(@_); my $packet_data = $packet->data; $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 $socket = $self->_create_tcp_socket($ip); $self->errorstring($!); my $select = IO::Select->new( $socket || next ); $socket->send($tcp_packet); $self->errorstring($!); my $buffer = _read_tcp($socket); $self->{replyfrom} = $ip; $self->_diag( 'reply from', "[$ip]", length($buffer), 'bytes' ); my $reply = Net::DNS::Packet->decode( \$buffer, $self->{debug} ); $self->errorstring($@); next unless $self->_accept_reply( $reply, $query ); $reply->from($ip); 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 $dst_sockaddr = $self->_create_dst_sockaddr( $ns, $port ); my $socket = $self->_create_udp_socket($ns) || next; $ns = [$socket, $ns, $dst_sockaddr]; } my ( $socket, $ip, $dst_sockaddr, $failed ) = @$ns; next if $failed; $self->_diag( 'udp send', "[$ip]:$port" ); $select->add($socket); $socket->send( $query_data, 0, $dst_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($dst_sockaddr); my $reply; while ( my ($socket) = $select->can_read($timeout) ) { my $peer = $self->{replyfrom} = $socket->peerhost; my $buffer = _read_udp( $socket, $self->_packetsz ); $self->_diag( "reply from [$peer]", length($buffer), 'bytes' ); my $packet = Net::DNS::Packet->decode( \$buffer, $self->{debug} ); $self->errorstring($@); next unless $self->_accept_reply( $packet, $query ); $reply = $packet; $reply->from($peer); 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 = shift; my $packet = $self->_make_query_packet(@_); my $packet_data = $packet->data; $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 { 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); return if $self->{igntc}; return unless $handle->socktype() == SOCK_DGRAM; return unless $query; # SpamAssassin 3.4.1 workaround my $ans = $self->_bgread($handle); $$appendix[2] = [$ans]; return unless $ans; return unless $ans->header->tc; $self->_diag('packet truncated: retrying using TCP'); my $tcp = $self->_bgsend_tcp( $query, $query->data ) || return; return defined( $_[1] = $tcp ); } sub bgisready { ## historical _deprecate('prefer ! bgbusy(...)'); # uncoverable pod return !&bgbusy; } sub bgread { while (&bgbusy) { # side effect: TCP retry IO::Select->new( $_[1] )->can_read(0.02); # reduce my CPU usage by 3 orders of magnitude } 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); my $select = IO::Select->new($handle); unless ( $select->can_read(0) ) { $self->errorstring('timed out'); return; } my $peer = $self->{replyfrom} = $handle->peerhost; my $dgram = $handle->socktype() == SOCK_DGRAM; my $buffer = $dgram ? _read_udp( $handle, $self->_packetsz ) : _read_tcp($handle); $self->_diag( "reply from [$peer]", length($buffer), 'bytes' ); my $reply = Net::DNS::Packet->decode( \$buffer, $self->{debug} ); $self->errorstring($@); return unless $self->_accept_reply( $reply, $query ); $reply->from($peer); 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 return eval { my $self = shift; # initialise iterator state vector my ( $select, $verify, @rr, $soa ) = $self->_axfr_start(@_); 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->encode eq $soa->encode; 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 _deprecate('prefer $iterator = $self->axfr(...)'); # uncoverable pod my $self = shift; return defined( $self->{axfr_iter} = $self->axfr(@_) ); } sub axfr_next { ## historical _deprecate('prefer $iterator->()'); # uncoverable pod return shift->{axfr_iter}->(); } sub _axfr_start { my $self = shift; my $dname = scalar(@_) ? shift : $self->domain; my @class = @_; my $request = $self->_make_query_packet( $dname, 'AXFR', @class ); my $content = $request->data; my $TCP_msg = pack 'n a*', length($content), $content; $self->_diag("axfr( $dname @class )"); my ( $select, $reply, $rcode ); foreach my $ns ( $self->nameservers ) { $self->_diag("axfr send [$ns]"); 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 unless $rcode eq '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_tcp { my $socket = shift; my ( $s1, $s2 ); $socket->recv( $s1, 1 ); # two octet length $socket->recv( $s2, 2 - length $s1 ); # possibly fragmented my $size = unpack 'n', pack( 'a*a*@2', $s1, $s2 ); my $buffer = ''; for (;;) { my $fragment; $socket->recv( $fragment, $size - length($buffer) ); last unless length( $buffer .= $fragment || last ) < $size; } return $buffer; } # # Usage: $data = _read_udp($socket, $length); # sub _read_udp { my $socket = shift; my $buffer = ''; $socket->recv( $buffer, shift ); return $buffer; } sub _create_tcp_socket { my $self = shift; my $ip = shift; my $sock_key = "TCP[$ip]"; my $socket; 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}, ) if USE_SOCKET_IP; unless (USE_SOCKET_IP) { $socket = IO::Socket::INET->new( LocalAddr => $self->{srcaddr4}, LocalPort => $self->{srcport} || undef, PeerAddr => $ip, PeerPort => $self->{port}, Proto => 'tcp', Timeout => $self->{tcp_timeout}, ) unless $ip6_addr; } $self->{persistent}{$sock_key} = $self->{persistent_tcp} ? $socket : undef; return $socket; } sub _create_udp_socket { my $self = shift; my $ip = shift; my $ip6_addr = IPv6 && _ipv6($ip); my $sock_key = IPv6 && $ip6_addr ? 'UDP/IPv6' : 'UDP/IPv4'; my $socket; return $socket if $socket = $self->{persistent}{$sock_key}; $socket = IO::Socket::IP->new( LocalAddr => $ip6_addr ? $self->{srcaddr6} : $self->{srcaddr4}, LocalPort => $self->{srcport}, Proto => 'udp', Type => SOCK_DGRAM ) if USE_SOCKET_IP; unless (USE_SOCKET_IP) { $socket = IO::Socket::INET->new( LocalAddr => $self->{srcaddr4}, LocalPort => $self->{srcport} || undef, Proto => 'udp', Type => SOCK_DGRAM ) unless $ip6_addr; } $self->{persistent}{$sock_key} = $self->{persistent_udp} ? $socket : undef; return $socket; } { no strict 'subs'; ## no critic ProhibitNoStrict use constant AI_NUMERICHOST => Socket::AI_NUMERICHOST; use constant IPPROTO_UDP => Socket::IPPROTO_UDP; 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 = shift; my ($packet) = @_; if ( ref($packet) ) { my $edns = $packet->edns; # advertise UDPsize for local stack $edns->size( $self->{udppacketsize} ) unless defined $edns->{size}; } else { $packet = Net::DNS::Packet->new(@_); $packet->edns->size( $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 = shift; return $self->{dnssec} unless scalar @_; # increase default udppacket size if flag set $self->udppacketsize(2048) if $self->{dnssec} = shift; return $self->{dnssec}; } sub force_v6 { my $self = shift; my $value = scalar(@_) ? $_[0] : $self->{force_v6}; return $self->{force_v6} = $value ? do { $self->{force_v4} = 0; 1 } : 0; } sub force_v4 { my $self = shift; my $value = scalar(@_) ? $_[0] : $self->{force_v4}; return $self->{force_v4} = $value ? do { $self->{force_v6} = 0; 1 } : 0; } sub prefer_v6 { my $self = shift; my $value = scalar(@_) ? $_[0] : $self->{prefer_v6}; return $self->{prefer_v6} = $value ? do { $self->{prefer_v4} = 0; 1 } : 0; } sub prefer_v4 { my $self = shift; my $value = scalar(@_) ? $_[0] : $self->{prefer_v4}; return $self->{prefer_v4} = $value ? do { $self->{prefer_v6} = 0; 1 } : 0; } sub srcaddr { my $self = shift; for (@_) { my $hashkey = _ipv6($_) ? 'srcaddr6' : 'srcaddr4'; $self->{$hashkey} = $_; } return shift; } sub tsig { my $self = shift; $self->{tsig_rr} = eval { local $SIG{__DIE__}; require Net::DNS::RR::TSIG; Net::DNS::RR::TSIG->create(@_); }; 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 = shift; $self->{udppacketsize} = shift if scalar @_; return $self->_packetsz; } # # Keep this method around. Folk depend on it although it is neither documented nor exported. # sub make_query_packet { ## historical _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; } 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; } } our $AUTOLOAD; sub DESTROY { } ## Avoid tickling AUTOLOAD (in cleanup) sub AUTOLOAD { ## Default method my ($self) = @_; my $name = $AUTOLOAD; $name =~ s/.*://; croak qq[unknown method "$name"] unless $public_attr{$name}; no strict 'refs'; ## no critic ProhibitNoStrict *{$AUTOLOAD} = sub { my $self = shift; $self = $self->_defaults unless ref($self); $self->{$name} = shift || 0 if scalar @_; return $self->{$name}; }; goto &{$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.11.4-RedHat-9.11.4-4.fc28 <<>> @b.root-servers.net . -t NS ; (2 servers found) ;; global options: +cmd ;; Got answer: ;; ->>HEADER<<- opcode: QUERY, status: NOERROR, id: 44111 ;; 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: 4096 ;; QUESTION SECTION: ;. IN NS ;; ANSWER SECTION: . 518400 IN NS c.root-servers.net. . 518400 IN NS k.root-servers.net. . 518400 IN NS l.root-servers.net. . 518400 IN NS j.root-servers.net. . 518400 IN NS b.root-servers.net. . 518400 IN NS g.root-servers.net. . 518400 IN NS h.root-servers.net. . 518400 IN NS d.root-servers.net. . 518400 IN NS a.root-servers.net. . 518400 IN NS f.root-servers.net. . 518400 IN NS i.root-servers.net. . 518400 IN NS m.root-servers.net. . 518400 IN NS e.root-servers.net. ;; ADDITIONAL SECTION: a.root-servers.net. 3600000 IN A 198.41.0.4 b.root-servers.net. 3600000 IN A 199.9.14.201 c.root-servers.net. 3600000 IN A 192.33.4.12 d.root-servers.net. 3600000 IN A 199.7.91.13 e.root-servers.net. 3600000 IN A 192.203.230.10 f.root-servers.net. 3600000 IN A 192.5.5.241 g.root-servers.net. 3600000 IN A 192.112.36.4 h.root-servers.net. 3600000 IN A 198.97.190.53 i.root-servers.net. 3600000 IN A 192.36.148.17 j.root-servers.net. 3600000 IN A 192.58.128.30 k.root-servers.net. 3600000 IN A 193.0.14.129 l.root-servers.net. 3600000 IN A 199.7.83.42 m.root-servers.net. 3600000 IN A 202.12.27.33 a.root-servers.net. 3600000 IN AAAA 2001:503:ba3e::2:30 b.root-servers.net. 3600000 IN AAAA 2001:500:200::b c.root-servers.net. 3600000 IN AAAA 2001:500:2::c d.root-servers.net. 3600000 IN AAAA 2001:500:2d::d e.root-servers.net. 3600000 IN AAAA 2001:500:a8::e f.root-servers.net. 3600000 IN AAAA 2001:500:2f::f g.root-servers.net. 3600000 IN AAAA 2001:500:12::d0d h.root-servers.net. 3600000 IN AAAA 2001:500:1::53 i.root-servers.net. 3600000 IN AAAA 2001:7fe::53 j.root-servers.net. 3600000 IN AAAA 2001:503:c27::2:30 k.root-servers.net. 3600000 IN AAAA 2001:7fd::1 l.root-servers.net. 3600000 IN AAAA 2001:500:9f::42 m.root-servers.net. 3600000 IN AAAA 2001:dc3::35 ;; Query time: 173 msec ;; SERVER: 199.9.14.201#53(199.9.14.201) ;; WHEN: Fri Aug 10 19:03:11 BST 2018 ;; MSG SIZE rcvd: 811 PK!I\e66DNS/Resolver/os2.pmnu[package Net::DNS::Resolver::os2; use strict; use warnings; our $VERSION = (qw$Id: os2.pm 1856 2021-12-02 14:36:25Z willem $)[2]; =head1 NAME Net::DNS::Resolver::os2 - OS2 resolver class =cut use base qw(Net::DNS::Resolver::Base); my $config_file = 'resolv'; my @config_path = ( $ENV{ETC} || '/etc' ); my @config_file = grep { -f $_ && -r _ } map {"$_/$config_file"} @config_path; my $dotfile = '.resolv.conf'; my @dotpath = grep {$_} $ENV{HOME}, '.'; my @dotfile = grep { -f $_ && -o _ } map {"$_/$dotfile"} @dotpath; 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 PK!a<<DNS/Resolver/Recurse.pmnu[package Net::DNS::Resolver::Recurse; use strict; use warnings; our $VERSION = (qw$Id: Recurse.pm 1856 2021-12-02 14:36:25Z 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->debug(1); $resolver->hints('198.41.0.4'); # A.ROOT-SERVER.NET. my $packet = $resolver->send( 'www.rob.com.au.', 'A' ); =head1 DESCRIPTION This module is a subclass of Net::DNS::Resolver. =cut use base qw(Net::DNS::Resolver); =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 { shift; return @hints unless scalar @_; $root = []; @hints = @_; return; } =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 = shift; my @conf = ( recurse => 0, udppacketsize => 1024 ); # RFC8109 return bless( {persistent => {'.' => $root}, %$self, @conf}, ref($self) )->_send(@_); } sub query_dorecursion { ## historical my ($self) = @_; # uncoverable pod $self->_deprecate('prefer $resolver->send(...)'); return &send; } sub _send { my $self = shift; my $query = $self->_make_query_packet(@_); unless ( scalar(@$root) ) { $self->_diag("resolver priming query"); $self->nameservers( scalar(@hints) ? @hints : $self->_hints ); my $packet = $self->SUPER::send(qw(. NS)); $self->_callback($packet); $self->_referral($packet); $root = $self->{persistent}->{'.'}; } return $self->_recurse( $query, '.' ); } sub _recurse { my ( $self, $query, $apex ) = @_; $self->_diag("using cached nameservers for $apex"); my $nslist = $self->{persistent}->{$apex}; $self->nameservers(@$nslist); $query->header->id(undef); my $reply = $self->SUPER::send($query); $self->_callback($reply); return unless $reply; my $qname = lc( ( $query->question )[0]->qname ); my $zone = $self->_referral($reply) || return $reply; return $reply if grep { lc( $_->owner ) eq $qname } $reply->answer; return $self->_recurse( $query, $zone ); } sub _referral { my ( $self, $packet ) = @_; return unless $packet; my @auth = grep { $_->type eq 'NS' } $packet->answer, $packet->authority; return unless scalar(@auth); my $owner = lc( $auth[0]->owner ); my $cache = $self->{persistent}->{$owner}; return $owner if $cache && scalar(@$cache); my @addr = grep { $_->can('address') } $packet->additional; my @ip; my @ns = map { lc( $_->nsdname ) } @auth; foreach my $ns (@ns) { push @ip, map { $_->address } grep { $ns eq lc( $_->owner ) } @addr; } $self->_diag("resolving glue for $owner") unless scalar(@ip); @ip = $self->nameservers( $ns[0], $ns[-1] ) unless scalar(@ip); $self->_diag("caching nameservers for $owner"); $self->{persistent}->{$owner} = \@ip; return $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 = shift; ( $self->{callback} ) = grep { ref($_) eq 'CODE' } @_; return; } sub _callback { my $callback = shift->{callback}; $callback->(@_) 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 PK!jnqUU DNS/Text.pmnu[package Net::DNS::Text; use strict; use warnings; our $VERSION = (qw$Id: Text.pm 1855 2021-11-26 11:33:48Z 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; croak 'argument undefined' unless defined $_[0]; local $_ = &_encode_utf8; s/^\042(.*)\042$/$1/s; # strip paired quotes s/\134\134/\134\060\071\062/g; # disguise escaped escape s/\134([\060-\071]{3})/$unescape{$1}/eg; # numeric escape s/\134(.)/$1/g; # character escape 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; # 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, RFC1035, RFC3629, Unicode TR#16 =cut PK!4Y4kUkU DNS/Packet.pmnu[package Net::DNS::Packet; use strict; use warnings; our $VERSION = (qw$Id: Packet.pm 1855 2021-11-26 11:33:48Z 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 { return &decode if ref $_[1]; my $class = shift; my $self = bless { status => 0, question => [], answer => [], authority => [], additional => [], }, $class; $self->{question} = [Net::DNS::Question->new(@_)] if scalar @_; return $self; } #=head2 decode =pod $packet = Net::DNS::Packet->decode( \$data ); $packet = Net::DNS::Packet->decode( \$data, 1 ); # debug $packet = Net::DNS::Packet->new( \$data ... ); If passed a reference to a scalar containing DNS packet data, a new packet object is created by decoding the data. 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; # uncoverable pod my $data = shift; my $debug = shift || 0; my $offset = 0; my $self; eval { local $SIG{__DIE__}; die 'corrupt wire-format data' if length($$data) < HEADER_LENGTH; # header section my ( $id, $status, @count ) = unpack 'n6', $$data; my ( $qd, $an, $ns, $ar ) = @count; my $length = length $$data; $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 ) = decode Net::DNS::Question( $data, $offset, $hash ); CORE::push( @{$self->{question}}, $record ); } # RR sections while ( $an-- ) { ( $record, $offset ) = decode Net::DNS::RR( $data, $offset, $hash ); CORE::push( @{$self->{answer}}, $record ); } while ( $ns-- ) { ( $record, $offset ) = decode Net::DNS::RR( $data, $offset, $hash ); CORE::push( @{$self->{authority}}, $record ); } while ( $ar-- ) { ( $record, $offset ) = decode Net::DNS::RR( $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 $@; $self->print if $self; } return wantarray ? ( $self, $offset ) : $self; } =head2 data $data = $packet->data; $data = $packet->data( $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; } sub encode { my ( $self, $size ) = @_; # uncoverable pod 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->header->id, $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 $edns = $packet->edns; $version = $edns->version; $UDPsize = $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 = shift; my $UDPmax = shift; 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->size($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 $server = $self->{replyfrom}; my $length = $self->{replysize}; my $origin = $server ? ";; Response received from $server ($length octets)\n" : ""; my @record = ( "$origin;; HEADER SECTION", $header->string ); if ( $self->{dso} ) { CORE::push( @record, ";; DSO SECTION" ); foreach ( @{$self->{dso}} ) { my ( $t, $v ) = @$_; CORE::push( @record, pack 'a* A18 a*', ";;\t", dsotypebyval($t), unpack( 'H*', $v ) ); } return join "\n", @record, "\n"; } my @section = $header->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' : ''; CORE::push( @record, "\n;; ADDITIONAL SECTION ($arcount record$ars)", map { $_->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 = shift; $self->{replyfrom} = shift if scalar @_; 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 = shift; my $list = $self->_section(shift); return CORE::push( @$list, grep { ref($_) } @_ ); } =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 = shift; my $list = $self->_section(shift); my @rr = grep { ref($_) } @_; 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( 'Khmac-sha512.example.+165+01018.private', 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 historical simplified syntax is still available, but additional options can not be specified. $packet->sign_tsig( $key_name, $key ); 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 ); $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 = shift; return eval { local $SIG{__DIE__}; require Net::DNS::RR::TSIG; my $tsig = Net::DNS::RR::TSIG->create(@_); $self->push( 'additional' => $tsig ); return $tsig; } || return croak "$@\nTSIG: unable to sign packet"; } =head2 verify and verifyerr $packet->verify() || die $packet->verifyerr; $reply->verify( $query ) || die $reply->verifyerr; Verify TSIG signature of packet or reply to the corresponding query. $opaque = $packet1->verify( $query ) || die $packet1->verifyerr; $opaque = $packet2->verify( $opaque ); $verifed = $packet3->verify( $opaque ) || die $packet3->verifyerr; The opaque intermediate object references returned during multi-packet verify() will be undefined (Boolean false) if verification fails. Access to the object itself, if it exists, is expressly forbidden. Testing at every stage may be omitted, which results in a BADSIG error on the final packet in the absence of more specific information. =cut sub verify { my $self = shift; my $sig = $self->sigrr; return $sig ? $sig->verify( $self, @_ ) : shift; } sub verifyerr { my $self = shift; my $sig = $self->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; return $sig if $sig->type eq 'TSIG'; return $sig if $sig->type eq '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->header->id, $self->{status}, @size, substr( $data, HEADER_LENGTH ); } ######################################## sub dump { ## print internal data structure require Data::Dumper; # uncoverable pod local $Data::Dumper::Maxdepth = $Data::Dumper::Maxdepth || 3; local $Data::Dumper::Sortkeys = $Data::Dumper::Sortkeys || 1; print Data::Dumper::Dumper(@_); return; } 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, RFC1035 Section 4.1, RFC2136 Section 2, RFC2845 =cut PK!{*RRDNS/Resolver.pmnu[package Net::DNS::Resolver; use strict; use warnings; our $VERSION = (qw$Id: Resolver.pm 1855 2021-11-26 11:33:48Z willem $)[2]; =head1 NAME Net::DNS::Resolver - DNS resolver class =cut use constant CONFIG => defined eval "require Net::DNS::Resolver::$^O"; ## no critic use constant OS_CONF => join '::', __PACKAGE__, CONFIG ? $^O : 'UNIX'; use base OS_CONF; 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 B address IP address of a name server that the resolver should query. B localdomain The domain suffix to be appended to a short non-absolute name. B domain ... A space-separated list of domains in the desired search path. B option:value ... 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. # Use my own configuration file $resolver = Net::DNS::Resolver->new( config_file => '/my/dns.conf' ); You can include a configuration file of your own when creating a resolver object. This is supported on both Unix and Windows. If a custom configuration file is specified at first instantiation, all other configuration files and environment variables are ignored. # Set options in the constructor $resolver = Net::DNS::Resolver->new( nameservers => [ '2001:DB8::1', 'ns.example.com' ], recurse => 0 ); 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( 'Khmac-sha1.example.+161+24053.private' ); @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( 'Khmac-sha1.example.+161+24053.private' ); $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); # DNSSEC using default packetsize $resolver->udppacketsize(1250); # lower the 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( $tsig ); $resolver->tsig( 'Khmac-sha1.example.+161+24053.private' ); $resolver->tsig( 'Khmac-sha1.example.+161+24053.key' ); $resolver->tsig( 'Khmac-sha1.example.+161+24053.key', fudge => 60 ); $resolver->tsig( $key_name, $key ); $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 search { $self = shift; $cache{"@_"} ||= $self->SUPER::search(@_); } =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, RFC 1034, RFC 1035 =cut PK!lTT DNS/FAQ.podnu[=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 $ PK!ovDNS/DomainName.pmnu[package Net::DNS::DomainName; use strict; use warnings; our $VERSION = (qw$Id: DomainName.pm 1855 2021-11-26 11:33:48Z 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 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, ''; } =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 $cache = shift || {}; # 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; # uncoverable condition false $self->{origin} = $cache->{$link} ||= Net::DNS::DomainName->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, ''; } ######################################## 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. use Net::DNS::DomainName; $object = Net::DNS::DomainName1035->new('compressible.example.com'); $data = $object->encode( $offset, $hash ); ( $object, $next ) = Net::DNS::DomainName1035->decode( \$data, $offset ); Note that RFC3597 implies that the RR types defined in RFC1035 section 3.3 are the only types eligible for compression. =head2 encode $data = $object->encode( $offset, $hash ); Returns the wire-format representation of the domain name suitable for inclusion in a DNS packet buffer. The optional arguments are the offset within the packet data where the domain name is to be stored and a reference to a hash table used to index compressed names within the packet. If the hash reference is undefined, encode() returns the lowercase uncompressed canonical representation defined in RFC2535(8.1). =cut sub encode { my $self = shift; my $offset = shift || 0; # offset in data buffer my $hash = shift || 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. Note that RFC3597, and latterly RFC4034, specifies that the lower case canonical encoding defined in RFC2535 is to be used for RR types defined prior to RFC3597. use Net::DNS::DomainName; $object = Net::DNS::DomainName2535->new('incompressible.example.com'); $data = $object->encode( $offset, $hash ); ( $object, $next ) = Net::DNS::DomainName2535->decode( \$data, $offset ); =head2 encode $data = $object->encode( $offset, $hash ); Returns the uncompressed wire-format representation of the domain name suitable for inclusion in a DNS packet buffer. If the hash reference is undefined, encode() returns the lowercase canonical form defined in RFC2535(8.1). =cut sub encode { my ( $self, $offset, $hash ) = @_; return $self->canonical unless defined $hash; return join '', map { pack 'C a*', length($_), $_ } $self->_wire, ''; } 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, RFC1035, RFC2535, RFC3597, RFC4034 =cut PK!(( DNS/Domain.pmnu[package Net::DNS::Domain; use strict; use warnings; our $VERSION = (qw$Id: Domain.pm 1855 2021-11-26 11:33:48Z 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(.)/$1/g; # restore character 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 { my $name = &name; return $name =~ /[.]$/ ? $name : $name . '.'; # append trailing dot } =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 ? Net::DNS::Domain->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, RFC1034, RFC1035, RFC5891, Unicode TR#16 =cut PK!ȴ!!DNS/Question.pmnu[package Net::DNS::Question; use strict; use warnings; our $VERSION = (qw$Id: Question.pm 1855 2021-11-26 11:33:48Z 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 $self = bless {}, shift; my ( $data, $offset ) = @_; ( $self->{qname}, $offset ) = Net::DNS::DomainName1035->decode(@_); 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 = shift; return pack 'a* n2', $self->{qname}->encode(@_), @{$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 = shift; croak 'immutable object: argument invalid' if scalar @_; 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 = shift; croak 'immutable object: argument invalid' if scalar @_; 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 = shift; croak 'immutable object: argument invalid' if scalar @_; 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 = shift; croak 'immutable object: argument invalid' if scalar @_; 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, RFC 1035 Section 4.1.2 =cut PK!olBV  DNS/Mailbox.pmnu[package Net::DNS::Mailbox; use strict; use warnings; our $VERSION = (qw$Id: Mailbox.pm 1855 2021-11-26 11:33:48Z 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/\\\@/\\064/g; # disguise escaped @ s/("[^"]*)\@([^"]*")/$1\\064$2/g; # disguise quoted @ my ( $mbox, @host ) = split /\@/; # split on @ if present for ( $mbox ||= '' ) { s/^.*"(.*)".*$/$1/; # strip quotes s/\\\./\\046/g; # disguise escaped dot s/\./\\046/g if @host; # escape dots in local part } return bless __PACKAGE__->SUPER::new( join '.', $mbox, @host ), $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/\\\d\d\d//g; # delete non-printable s/\\\./\./g; # unescape dots s/[\\"]//g; # delete \ " s/^(.*)$/"$1"/ if /["(),:;<>@\[\\\]]/; # quote local part 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, RFC1035, RFC5322 (RFC822) =cut PK!ƅ_ DNS/RR/EUI48.pmnu[package Net::DNS::RR::EUI48; use strict; use warnings; our $VERSION = (qw$Id: EUI48.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; $self->address(shift); 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, RFC7043 =cut PK!a a DNS/RR/AFSDB.pmnu[package Net::DNS::RR::AFSDB; use strict; use warnings; our $VERSION = (qw$Id: AFSDB.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; my ( $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 = shift; $self->subtype(shift); $self->hostname(shift); return; } sub subtype { my $self = shift; $self->{subtype} = 0 + shift if scalar @_; return $self->{subtype} || 0; } sub hostname { my $self = shift; $self->{hostname} = Net::DNS::DomainName2535->new(shift) if scalar @_; 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, RFC1183, RFC5864 =cut PK!+V 6 6 DNS/RR/OPT.pmnu[package Net::DNS::RR::OPT; use strict; use warnings; our $VERSION = (qw$Id: OPT.pm 1857 2021-12-07 13:38:02Z 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 CLASS_TTL_RDLENGTH => length pack 'n N n', (0) x 3; 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 = shift; my ( $data, $offset ) = @_; my $index = $offset - CLASS_TTL_RDLENGTH; # OPT redefines class and TTL fields @{$self}{qw(size rcode version flags)} = unpack "\@$index n C2 n", $$data; @{$self}{rcode} = @{$self}{rcode} << 4; delete @{$self}{qw(class 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; $self->{option}{$code} = $value; $offset += $length + 4; } return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $option = $self->{option} || {}; return join '', map { pack( 'nna*', $_, length $option->{$_}, $option->{$_} ) } keys %$option; } sub encode { ## overide RR method my $self = shift; my $data = $self->_encode_rdata; my $size = $self->size; my @xttl = ( $self->rcode >> 4, $self->version, $self->flags ); return pack 'C n n C2n n a*', 0, OPT, $size, @xttl, length($data), $data; } sub string { ## overide RR method my $self = shift; my $edns = $self->version; my $flags = sprintf '%04x', $self->flags; my $rcode = $self->rcode; my $size = $self->size; my @option = map { join( "\n;;\t\t\t\t", $self->_format_option($_) ) } $self->options; my @format = join "\n;;\t\t", @option; $rcode = 0 if $rcode < 16; # weird: 1 .. 15 not EDNS codes!! my $rc = exists( $self->{rdlength} ) && $rcode ? "$rcode + [4-bits]" : rcodebyval($rcode); $rc = 'BADVERS' if $rcode == 16; # code 16 unambiguous here return <<"QQ"; ;; EDNS version $edns ;; flags: $flags ;; rcode: $rc ;; size: $size ;; option: @format QQ } sub class { ## overide RR method my $self = shift; $self->_deprecate(qq[please use "size()"]); return $self->size(@_); } sub ttl { ## overide RR method my $self = shift; $self->_deprecate(qq[please use "flags()" or "rcode()"]); my @rcode = map { unpack( 'C', pack 'N', $_ ) } @_; my @flags = map { unpack( 'x2n', pack 'N', $_ ) } @_; return pack 'C2n', $self->rcode(@rcode), $self->version, $self->flags(@flags); } sub version { my $self = shift; $self->{version} = 0 + shift if scalar @_; return $self->{version} || 0; } sub size { my $self = shift; $self->{size} = shift if scalar @_; return ( $self->{size} || 0 ) > 512 ? $self->{size} : 512; } sub rcode { my $self = shift; return $self->{rcode} || 0 unless scalar @_; delete $self->{rdlength}; # (ab)used to signal incomplete value my $val = shift || 0; return $self->{rcode} = $val < 16 ? 0 : $val; # discard non-EDNS rcodes 1 .. 15 } sub flags { my $self = shift; $self->{flags} = shift if scalar @_; return $self->{flags} || 0; } sub options { my ($self) = @_; my $option = $self->{option} || {}; my @option = sort { $a <=> $b } keys %$option; return @option; } sub option { my $self = shift; my $number = ednsoptionbyname(shift); return $self->_get_option($number) unless scalar @_; return $self->_set_option( $number, @_ ); } sub _format_option { my ( $self, $number ) = @_; my $option = ednsoptionbyval($number); my $options = $self->{option} || {}; my $payload = $options->{$number}; return () unless defined $payload; my $package = join '::', __PACKAGE__, $option; $package =~ s/-/_/g; my $defined = length($payload) && $package->can('_image'); my @element = $defined ? eval { $package->_image($payload) } : unpack 'H*', $payload; my $protect = pop(@element); return Net::DNS::RR::_wrap( "$option\t=> (", map( {"$_,"} @element ), "$protect )" ); } sub _get_option { my ( $self, $number ) = @_; my $options = $self->{option} || {}; my $payload = $options->{$number}; return $payload unless wantarray; return () unless $payload; my $package = join '::', __PACKAGE__, ednsoptionbyval($number); $package =~ s/-/_/g; return ( 'OPTION-DATA' => $payload ) unless $package->can('_decompose'); return eval { $package->_decompose($payload) }; } sub _set_option { my ( $self, $number, $value, @etc ) = @_; my $options = $self->{option} ||= {}; delete $options->{$number}; return unless defined $value; if ( ref($value) || scalar(@etc) || $value !~ /\D/ ) { my @arg = ( $value, @etc ); @arg = @$value if ref($value) eq 'ARRAY'; @arg = %$value if ref($value) eq 'HASH'; if ( $arg[0] eq 'OPTION-DATA' ) { $value = $arg[1]; } else { my $option = ednsoptionbyval($number); my $package = join '::', __PACKAGE__, $option; $package =~ s/-/_/g; if ( $package->can('_compose') ) { $value = $package->_compose(@arg); } elsif ( scalar(@etc) ) { croak "unable to compose option $option"; } } } return $options->{$number} = $value; } sub _specified { my $self = shift; return scalar grep { $self->{$_} } qw(size flags rcode option); } ######################################## ## no critic ProhibitMultiplePackages package Net::DNS::RR::OPT::DAU; # RFC6975 sub _compose { shift; return pack 'C*', @_; } sub _decompose { my @payload = unpack 'C*', $_[1]; return @payload; } sub _image { return &_decompose; } 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(0 Net::DNS::RR::AAAA 1 Net::DNS::RR::A 2 Net::DNS::RR::AAAA); my @field8 = qw(FAMILY SOURCE-PREFIX-LENGTH SCOPE-PREFIX-LENGTH ADDRESS); sub _compose { my ( $class, %argument ) = ( map( ( $_ => 0 ), @field8 ), @_ ); my $address = bless( {}, $family{$argument{FAMILY}} )->address( $argument{ADDRESS} ); my $bitmask = $argument{'SOURCE-PREFIX-LENGTH'}; pack "a* B$bitmask", pack( 'nC2', @argument{@field8} ), unpack 'B*', $address; } sub _decompose { my %hash; @hash{@field8} = unpack 'nC2a*', $_[1]; $hash{ADDRESS} = bless( {address => $hash{ADDRESS}}, $family{$hash{FAMILY}} )->address; my @payload = map( ( $_ => $hash{$_} ), @field8 ); } sub _image { my %hash = &_decompose; my @image = map "$_ => $hash{$_}", @field8; } package Net::DNS::RR::OPT::EXPIRE; # RFC7314 sub _compose { my ( $class, %argument ) = @_; pack 'N', values %argument; } sub _decompose { my @payload = ( 'EXPIRE-TIMER' => unpack 'N', $_[1] ); } sub _image { join ' => ', &_decompose; } package Net::DNS::RR::OPT::COOKIE; # RFC7873 my @field10 = qw(VERSION RESERVED TIMESTAMP HASH); sub _compose { my ( $class, %argument ) = ( VERSION => 1, RESERVED => '', @_ ); return pack 'a8', $argument{'CLIENT-COOKIE'} if $argument{'CLIENT-COOKIE'}; pack 'Ca3Na*', map $_, @argument{@field10}; } sub _decompose { my ( $class, $argument ) = @_; return ( 'CLIENT-COOKIE', $argument ) unless length($argument) > 8; my %hash; @hash{@field10} = unpack 'Ca3Na*', $argument; my @payload = map( ( $_ => $hash{$_} ), @field10 ); } sub _image { my %hash = &_decompose; return unpack 'H*', $hash{'CLIENT-COOKIE'} if $hash{'CLIENT-COOKIE'}; for (qw(RESERVED HASH)) { $hash{$_} = unpack 'H*', $hash{$_} } my @image = map "$_ => $hash{$_}", @field10; } package Net::DNS::RR::OPT::TCP_KEEPALIVE; # RFC7828 sub _compose { my ( $class, %argument ) = @_; pack 'n', values %argument; } sub _decompose { my @payload = ( 'TIMEOUT' => unpack 'n', $_[1] ); } sub _image { join ' => ', &_decompose; } package Net::DNS::RR::OPT::PADDING; # RFC7830 sub _compose { my ( $class, %argument ) = @_; my ($size) = values %argument; pack "x$size"; } sub _decompose { my @payload = ( 'OPTION-LENGTH' => length( $_[1] ) ); } sub _image { join ' => ', &_decompose; } package Net::DNS::RR::OPT::CHAIN; # RFC7901 sub _compose { my ( $class, %argument ) = @_; my ($trust_point) = values %argument; Net::DNS::DomainName->new($trust_point)->encode; } sub _decompose { my ( $class, $payload ) = @_; my $fqdn = Net::DNS::DomainName->decode( \$payload )->string; my @payload = ( 'CLOSEST-TRUST-POINT' => $fqdn ); } sub _image { join ' => ', &_decompose; } package Net::DNS::RR::OPT::KEY_TAG; # RFC8145 sub _compose { shift; pack 'n*', @_; } sub _decompose { my @payload = unpack 'n*', $_[1]; } sub _image { &_decompose; } package Net::DNS::RR::OPT::EXTENDED_ERROR; # RFC8914 my @field15 = qw(INFO-CODE EXTRA-TEXT); sub _compose { my ( $class, %argument ) = ( 'INFO-CODE' => 0, 'EXTRA-TEXT' => '', @_ ); my ( $code, $text ) = @argument{@field15}; pack 'na*', $code, Net::DNS::Text->new($text)->raw; } sub _decompose { my ( $code, $text ) = unpack 'na*', $_[1]; my @payload = ( 'INFO-CODE' => $code, 'EXTRA-TEXT' => Net::DNS::Text->decode( \$text, 0, length $text )->string ); } sub _image { my %hash = &_decompose; my @image = map "$_ => $hash{$_}", @field15; } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $packet = Net::DNS::Packet->new( ... ); $packet->header->do(1); # extended flag $packet->edns->size(1280); # UDP payload size $packet->edns->option( COOKIE => 'rawbytes' ); $packet->edns->print; ;; EDNS version 0 ;; flags: 8000 ;; rcode: NOERROR ;; size: 1280 ;; option: COOKIE => ( 7261776279746573 ) ;; DAU => ( 8, 10, 13, 14, 15, 16 ) ;; DHU => ( 1, 2, 4 ) ;; EXTENDED-ERROR => ( INFO-CODE => 123, EXTRA-TEXT => ) =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 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 = $rr->version; $rr->version( $version ); The version of EDNS supported by this OPT record. =head2 size $size = $packet->edns->size; $more = $packet->edns->size(1280); size() 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; $incomplete_rcode = $packet->edns->rcode; The 12 bit extended RCODE. The most significant 8 bits reside in the OPT record. The least significant 4 bits can only be obtained from the packet header. =head2 flags $edns_flags = $packet->edns->flags; $do = $packet->header->do; $packet->header->do(1); 16 bit field containing EDNS extended header flags. =head2 options, option @option = $packet->edns->options; $octets = $packet->edns->option($option_code); $packet->edns->option( COOKIE => $octets ); $packet->edns->option( 10 => $octets ); When called in a list context, options() returns a list of option codes found in the OPT record. When called in a scalar context with a single argument, option() returns the uninterpreted octet string corresponding to the specified option. The method returns undef if the specified option is absent. Options can be added or replaced by providing the (name => value) pair. The option is deleted if the value is undefined. When option() is called in a list context with a single argument, the returned values provide a structured interpretation appropriate to the specified option. For example: @algorithms = $packet->edns->option('DAU'); For some options, a hash table is more convenient: %hash_table = $packet->edns->option(15); $info_code = $hash_table{'INFO-CODE'}; $extra_text = $hash_table{'EXTRA-TEXT'}; Similar forms of array or hash syntax may be used to construct the option value: $packet->edns->option( DHU => [1, 2, 4] ); $packet->edns->option( EXPIRE => {'EXPIRE-TIMER' => 604800} ); =head1 COPYRIGHT Copyright (c)2001,2002 RIPE NCC. Author Olaf M. Kolkman. Portions Copyright (c)2012,2017-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, RFC6891, RFC3225 =cut PK! DNS/RR/PTR.pmnu[package Net::DNS::RR::PTR; use strict; use warnings; our $VERSION = (qw$Id: PTR.pm 1857 2021-12-07 13:38:02Z 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 = shift; $self->{ptrdname} = Net::DNS::DomainName1035->decode(@_); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $ptrdname = $self->{ptrdname}; return $ptrdname->encode(@_); } 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 = shift; $self->ptrdname(shift); return; } sub ptrdname { my $self = shift; $self->{ptrdname} = Net::DNS::DomainName1035->new(shift) if scalar @_; 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, RFC1035 Section 3.3.12 =cut PK!e_/DNS/RR/DHCID.pmnu[package Net::DNS::RR::DHCID; use strict; use warnings; our $VERSION = (qw$Id: DHCID.pm 1857 2021-12-07 13:38:02Z 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 _decode_rdata { ## decode rdata from wire-format octet string my $self = shift; my ( $data, $offset ) = @_; my $size = $self->{rdlength} - 3; @{$self}{qw(identifiertype digesttype digest)} = unpack "\@$offset nC a$size", $$data; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'nC a*', map { $self->$_ } qw(identifiertype digesttype digest); } 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 = shift; my $data = MIME::Base64::decode( join "", @_ ); my $size = length($data) - 3; @{$self}{qw(identifiertype digesttype digest)} = unpack "n C a$size", $data; 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 { my $self = shift; $self->{identifiertype} = 0 + shift if scalar @_; return $self->{identifiertype} || 0; } sub digesttype { my $self = shift; $self->{digesttype} = 0 + shift if scalar @_; return $self->{digesttype} || 0; } sub digest { my $self = shift; $self->{digest} = shift if scalar @_; return $self->{digest} || ""; } 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; $rr->identifiertype( $identifiertype ); The 16-bit identifier type describes the form of host identifier used to construct the DHCP identity information. =head2 digesttype $digesttype = $rr->digesttype; $rr->digesttype( $digesttype ); The 8-bit digest type number describes the message-digest algorithm used to obfuscate the DHCP identity information. =head2 digest $digest = $rr->digest; $rr->digest( $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, RFC4701 =cut PK!3e!!DNS/RR/NULL.pmnu[package Net::DNS::RR::NULL; use strict; use warnings; our $VERSION = (qw$Id: NULL.pm 1857 2021-12-07 13:38:02Z 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, RFC1035 Section 3.3.10 =cut PK!+DNS/RR/AAAA.pmnu[package Net::DNS::RR::AAAA; use strict; use warnings; our $VERSION = (qw$Id: AAAA.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; $self->address(shift); 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 = shift; return address_long($self) unless scalar @_; my $addr = shift; 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, RFC3596, RFC3513, RFC5952 =cut PK!]BBDNS/RR/AMTRELAY.pmnu[package Net::DNS::RR::AMTRELAY; use strict; use warnings; our $VERSION = (qw$Id: AMTRELAY.pm 1855 2021-11-26 11:33:48Z 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 = shift; my ( $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 = shift; foreach (qw(precedence dbit relaytype relay)) { $self->$_(shift); } return; } sub _defaults { ## specify RR attribute default values my $self = shift; @{$self}{qw(precedence relaytype relay)} = ( 0, 0, '' ); return; } sub precedence { my $self = shift; $self->{precedence} = 0 + shift if scalar @_; return $self->{precedence} || 0; } sub dbit { my $self = shift; # uncoverable pod $self->{relaytype} = $self->relaytype | ( $_[0] ? 0x80 : 0 ) if scalar @_; return ( $self->{relaytype} || 0 ) >> 7; } sub d {&dbit} # uncoverable pod sub relaytype { my $self = shift; $self->{relaytype} = $self->dbit ? ( 0x80 | shift ) : shift if scalar @_; return 0x7f & ( $self->{relaytype} || 0 ); } sub relay { my $self = shift; for (@_) { /^\.*$/ && 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, RFC8777, RFC7450 =cut PK!QZ DNS/RR/MR.pmnu[package Net::DNS::RR::MR; use strict; use warnings; our $VERSION = (qw$Id: MR.pm 1857 2021-12-07 13:38:02Z 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 = shift; $self->{newname} = Net::DNS::DomainName1035->decode(@_); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $newname = $self->{newname} || return ''; return $newname->encode(@_); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $newname = $self->{newname} || return ''; return $newname->string; } sub _parse_rdata { ## populate RR from rdata in argument list my $self = shift; $self->newname(shift); return; } sub newname { my $self = shift; $self->{newname} = Net::DNS::DomainName1035->new(shift) if scalar @_; 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, RFC1035 Section 3.3.8 =cut PK!]/!4 4 DNS/RR/X25.pmnu[package Net::DNS::RR::X25; use strict; use warnings; our $VERSION = (qw$Id: X25.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; $self->address(shift); return; } sub address { my $self = shift; $self->{address} = Net::DNS::Text->new(shift) if scalar @_; 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, RFC1183 Section 3.1 =cut PK!X~ DNS/RR/L64.pmnu[package Net::DNS::RR::L64; use strict; use warnings; our $VERSION = (qw$Id: L64.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; $self->preference(shift); $self->locator64(shift); return; } sub preference { my $self = shift; $self->{preference} = 0 + shift if scalar @_; 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, RFC6742 =cut PK!chS DNS/RR/L32.pmnu[package Net::DNS::RR::L32; use strict; use warnings; our $VERSION = (qw$Id: L32.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; $self->preference(shift); $self->locator32(shift); return; } sub preference { my $self = shift; $self->{preference} = 0 + shift if scalar @_; 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, RFC6742 =cut PK!yO DNS/RR/RT.pmnu[package Net::DNS::RR::RT; use strict; use warnings; our $VERSION = (qw$Id: RT.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; my ( $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 = shift; $self->preference(shift); $self->intermediate(shift); return; } sub preference { my $self = shift; $self->{preference} = 0 + shift if scalar @_; return $self->{preference} || 0; } sub intermediate { my $self = shift; $self->{intermediate} = Net::DNS::DomainName2535->new(shift) if scalar @_; 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, RFC1183 Section 3.3 =cut PK!VV DNS/RR/SIG.pmnu[ # pre-5.14.0 perl inadvertently destroys signal handlers # http://rt.perl.org/rt3/Public/Bug/Display.html?id=76138 use strict; use warnings; local %SIG = %SIG; package Net::DNS::RR::SIG; use strict; use warnings; our $VERSION = (qw$Id: SIG.pm 1856 2021-12-02 14:36:25Z 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: Downstream distros MUST NOT create dependencies on Net::DNS::SEC (strong crypto prohibited in many territories) use constant USESEC => defined $INC{'Net/DNS/SEC.pm'}; # Discover how we got here, without exposing any crypto use constant # Discourage static code analysers and casual greppers DNSSEC => USESEC && defined eval join '', qw(r e q u i r e), ' Net::DNS', qw(:: SEC :: Private); ## no critic my @index; if (DNSSEC) { foreach my $class ( map {"Net::DNS::SEC::$_"} qw(RSA DSA ECCGOST ECDSA EdDSA) ) { 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 = shift; my ( $data, $offset, @opaque ) = @_; my $limit = $offset + $self->{rdlength}; @{$self}{@field} = unpack "\@$offset n C2 N3 n", $$data; ( $self->{signame}, $offset ) = Net::DNS::DomainName2535->decode( $data, $offset + 18 ); $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 = shift; my ( $offset, @opaque ) = @_; my ( $hash, $packet ) = @opaque; my $signame = $self->{signame}; if ( DNSSEC && !$self->{sigbin} ) { 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->encode, $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 = shift; foreach ( @field, qw(signame) ) { $self->$_(shift) } $self->signature(@_); 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 = shift; # uncoverable pod $self->{typecovered} = typebyname(shift) if scalar @_; 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 = shift; $self->{sigexpiration} = _string2time(shift) if scalar @_; my $time = $self->{sigexpiration}; return unless defined wantarray && defined $time; return UTIL ? Scalar::Util::dualvar( $time, _time2string($time) ) : _time2string($time); } sub siginception { my $self = shift; $self->{siginception} = _string2time(shift) if scalar @_; 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 = shift; no integer; ( $self->{sigval} ) = map { int( 60.0 * $_ ) } @_; return; } sub keytag { my $self = shift; $self->{keytag} = 0 + shift if scalar @_; return $self->{keytag} || 0; } sub signame { my $self = shift; $self->{signame} = Net::DNS::DomainName2535->new(shift) if scalar @_; return $self->{signame} ? $self->{signame}->name : undef; } sub sig { my $self = shift; return MIME::Base64::encode( $self->sigbin(), "" ) unless scalar @_; return $self->sigbin( MIME::Base64::decode( join "", @_ ) ); } sub sigbin { my $self = shift; $self->{sigbin} = shift if scalar @_; 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] '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->data; 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 = shift; my $algorithm = $self->algorithm; my $class = $DNSSEC_siggen{$algorithm}; return eval { die "algorithm $algorithm not supported\n" unless $class; $self->sigbin( $class->sign(@_) ); } || return croak "${@}signature generation failed"; } } sub _VerifySig { if (DNSSEC) { my $self = shift; my $algorithm = $self->algorithm; my $class = $DNSSEC_verify{$algorithm}; my $retval = eval { die "algorithm $algorithm not supported\n" unless $class; $class->verify( @_, $self->sigbin ); }; unless ($retval) { $self->{vrfyerrstr} = "${@}signature verification failed"; print "\n", $self->{vrfyerrstr}, "\n" if DEBUG; return 0; } # uncoverable branch true # bug in Net::DNS::SEC or dependencies croak "unknown error in $class->verify" unless $retval == 1; print "\nalgorithm $algorithm verification successful\n" if DEBUG; return 1; } } sub _ordered() { ## irreflexive 32-bit partial ordering use integer; 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 if ( $n2 < 0 ) { # fold, leaving $n2 non-negative $n1 = ( $n1 & 0xFFFFFFFF ) ^ 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 => 20211201010101, # signature inception sigex => 20211201011101, # 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. =over 4 =item * 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). =back =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 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, RFC2536, RFC2931, RFC3110, RFC4034 L L =cut PK! DNS/RR/HINFO.pmnu[package Net::DNS::RR::HINFO; use strict; use warnings; our $VERSION = (qw$Id: HINFO.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; $self->cpu(shift); $self->os(@_); return; } sub cpu { my $self = shift; $self->{cpu} = Net::DNS::Text->new(shift) if scalar @_; return $self->{cpu} ? $self->{cpu}->value : undef; } sub os { my $self = shift; $self->{os} = Net::DNS::Text->new(shift) if scalar @_; 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, RFC1035 Section 3.3.2 =cut PK!y+kkDNS/RR/ZONEMD.pmnu[package Net::DNS::RR::ZONEMD; use strict; use warnings; our $VERSION = (qw$Id: ZONEMD.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; $self->serial(shift); $self->scheme(shift); $self->algorithm(shift); $self->digest(@_); return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->_parse_rdata( 0, 1, 1, '' ); return; } sub serial { my $self = shift; $self->{serial} = 0 + shift if scalar @_; return $self->{serial} || 0; } sub scheme { my $self = shift; $self->{scheme} = 0 + shift if scalar @_; return $self->{scheme} || 0; } sub algorithm { my $self = shift; $self->{algorithm} = 0 + shift if scalar @_; return $self->{algorithm} || 0; } sub digest { my $self = shift; return unpack "H*", $self->digestbin() unless scalar @_; return $self->digestbin( pack "H*", join "", map { /^"*([\dA-Fa-f]*)"*$/ || croak("corrupt hex"); $1 } @_ ); } sub digestbin { my $self = shift; $self->{digestbin} = shift if scalar @_; 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, RFC8976 =cut PK!{{ DNS/RR/NID.pmnu[package Net::DNS::RR::NID; use strict; use warnings; our $VERSION = (qw$Id: NID.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; $self->preference(shift); $self->nodeid(shift); return; } sub preference { my $self = shift; $self->{preference} = 0 + shift if scalar @_; return $self->{preference} || 0; } sub nodeid { my $self = shift; my $idnt = shift; $self->{nodeid} = pack 'n4', map { hex($_) } split /:/, $idnt if defined $idnt; return $self->{nodeid} ? sprintf( '%0.4x:%0.4x:%0.4x:%0.4x', unpack 'n4', $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'); $rr = Net::DNS::RR->new( name => 'example.com', type => 'NID', preference => 10, nodeid => '8:800:200C:417A' ); =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, RFC6742 =cut PK!iAbDNS/RR/SMIMEA.pmnu[package Net::DNS::RR::SMIMEA; use strict; use warnings; our $VERSION = (qw$Id: SMIMEA.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; $self->usage(shift); $self->selector(shift); $self->matchingtype(shift); $self->cert(@_); return; } sub usage { my $self = shift; $self->{usage} = 0 + shift if scalar @_; return $self->{usage} || 0; } sub selector { my $self = shift; $self->{selector} = 0 + shift if scalar @_; return $self->{selector} || 0; } sub matchingtype { my $self = shift; $self->{matchingtype} = 0 + shift if scalar @_; return $self->{matchingtype} || 0; } sub cert { my $self = shift; return unpack "H*", $self->certbin() unless scalar @_; return $self->certbin( pack "H*", join "", map { /^"*([\dA-Fa-f]*)"*$/ || croak("corrupt hex"); $1 } @_ ); } sub certbin { my $self = shift; $self->{certbin} = shift if scalar @_; 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, RFC8162, RFC6698 =cut PK!Q DNS/RR/LP.pmnu[package Net::DNS::RR::LP; use strict; use warnings; our $VERSION = (qw$Id: LP.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; $self->preference(shift); $self->target(shift); return; } sub preference { my $self = shift; $self->{preference} = 0 + shift if scalar @_; return $self->{preference} || 0; } sub target { my $self = shift; $self->{target} = Net::DNS::DomainName->new(shift) if scalar @_; 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'); $rr = Net::DNS::RR->new( name => 'example.com', type => 'LP', preference => 10, target => 'target.example.com.' ); =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, RFC6742 =cut PK!;x5DNS/RR/IPSECKEY.pmnu[package Net::DNS::RR::IPSECKEY; use strict; use warnings; our $VERSION = (qw$Id: IPSECKEY.pm 1857 2021-12-07 13:38:02Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::IPSECKEY - DNS IPSECKEY resource record =cut use integer; use Carp; use MIME::Base64; 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 = shift; my ( $data, $offset ) = @_; my $limit = $offset + $self->{rdlength}; @{$self}{qw(precedence gatetype algorithm)} = unpack "\@$offset C3", $$data; $offset += 3; my $gatetype = $self->{gatetype}; if ( not $gatetype ) { $self->{gateway} = undef; # 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 ); $self->{gateway} = $name; } 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; if ( not $gatetype ) { return pack 'C3 a*', $precedence, $gatetype, $algorithm, $keybin; } elsif ( $gatetype == 1 ) { return pack 'C3 a4 a*', $precedence, $gatetype, $algorithm, $gateway, $keybin; } elsif ( $gatetype == 2 ) { return pack 'C3 a16 a*', $precedence, $gatetype, $algorithm, $gateway, $keybin; } elsif ( $gatetype == 3 ) { my $namebin = $gateway->encode; return pack 'C3 a* a*', $precedence, $gatetype, $algorithm, $namebin, $keybin; } die "unknown gateway type ($gatetype)"; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @params = map { $self->$_ } qw(precedence gatetype algorithm); my @base64 = split /\s+/, encode_base64( $self->keybin ); my @rdata = ( @params, $self->gateway, @base64 ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my $self = shift; foreach (qw(precedence gatetype algorithm gateway)) { $self->$_(shift) } $self->key(@_); return; } sub precedence { my $self = shift; $self->{precedence} = 0 + shift if scalar @_; return $self->{precedence} || 0; } sub gatetype { return shift->{gatetype} || 0; } sub algorithm { my $self = shift; $self->{algorithm} = 0 + shift if scalar @_; return $self->{algorithm} || 0; } sub gateway { my $self = shift; for (@_) { /^\.*$/ && do { $self->{gatetype} = 0; $self->{gateway} = undef; # 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($_); last; }; croak 'unrecognised gateway type'; } if ( defined wantarray ) { my $gatetype = $self->{gatetype}; return wantarray ? '.' : undef unless $gatetype; my $gateway = $self->{gateway}; for ($gatetype) { /^1$/ && return Net::DNS::RR::A::address( {address => $gateway} ); /^2$/ && return Net::DNS::RR::AAAA::address( {address => $gateway} ); /^3$/ && return wantarray ? $gateway->string : $gateway->name; die "unknown gateway type ($gatetype)"; } } return; } sub key { my $self = shift; return MIME::Base64::encode( $self->keybin(), "" ) unless scalar @_; return $self->keybin( MIME::Base64::decode( join "", @_ ) ); } sub keybin { my $self = shift; $self->{keybin} = shift if scalar @_; 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, RFC4025 =cut PK!G,<)<) DNS/RR/DS.pmnu[package Net::DNS::RR::DS; use strict; use warnings; our $VERSION = (qw$Id: DS.pm 1856 2021-12-02 14:36:25Z 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 eval { require Digest::GOST12 }; eval { require Digest::GOST::CryptoPro }; my %digest = ( '1' => scalar( eval { Digest::SHA->new(1) } ), '2' => scalar( eval { Digest::SHA->new(256) } ), '3' => scalar( eval { Digest::GOST::CryptoPro->new() } ), '4' => scalar( eval { Digest::SHA->new(384) } ), '5' => scalar( eval { Digest::GOST12->new() } ), ); sub _decode_rdata { ## decode rdata from wire-format octet string my $self = shift; my ( $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; $self->_annotation( $self->babble ) if BABBLE && $self->{algorithm}; my @param = @{$self}{qw(keytag algorithm digtype)}; my @rdata = ( @param, split /(\S{64})/, $self->digest || '-' ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my $self = shift; my $keytag = shift; ## avoid destruction by CDS algorithm(0) $self->algorithm(shift); $self->keytag($keytag); $self->digtype(shift); $self->digest(@_); return; } sub keytag { my $self = shift; $self->{keytag} = 0 + shift if scalar @_; 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 = shift; return unpack "H*", $self->digestbin() unless scalar @_; return $self->digestbin( pack "H*", join "", map { /^"*([\dA-Fa-f]*)"*$/ || croak("corrupt hex"); $1 } @_ ); } sub digestbin { my $self = shift; $self->{digestbin} = shift if scalar @_; return $self->{digestbin} || ""; } sub babble { return BABBLE ? Digest::BubbleBabble::bubblebabble( Digest => shift->digestbin ) : ''; } sub create { my $class = shift; my $keyrr = shift; my %args = @_; my ($type) = reverse split '::', $class; croak "Unable to create $type record for non-zone key" unless $keyrr->zone; croak "Unable to create $type record for revoked key" if $keyrr->revoke; croak "Unable to create $type record for invalid key" unless $keyrr->protocol == 3; my $self = Net::DNS::RR->new( owner => $keyrr->owner, # per definition, same as keyrr type => $type, class => $keyrr->class, ttl => $keyrr->{ttl}, keytag => $keyrr->keytag, algorithm => $keyrr->algorithm, digtype => 1, # SHA1 by default %args ); my $hash = $digest{$self->digtype}; croak join ' ', 'digtype', $self->digtype('MNEMONIC'), 'not supported' unless $hash; my $clone = $hash->clone; $clone->add( $keyrr->{owner}->canonical ); $clone->add( $keyrr->_encode_rdata ); $self->digestbin( $clone->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, # [RFC5933bis] ); my @digestalias = ( 'SHA' => 1, 'GOST94' => 3, 'GOST12' => 5, ); 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] '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, RFC4034 L L =cut PK!ooDNS/RR/MINFO.pmnu[package Net::DNS::RR::MINFO; use strict; use warnings; our $VERSION = (qw$Id: MINFO.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $data, $offset, @opaque ) = @_; ( $self->{rmailbx}, $offset ) = Net::DNS::Mailbox1035->decode(@_); ( $self->{emailbx}, $offset ) = Net::DNS::Mailbox1035->decode( $data, $offset, @opaque ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my ( $offset, @opaque ) = @_; my $rdata = $self->{rmailbx}->encode(@_); $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 = shift; $self->rmailbx(shift); $self->emailbx(shift); return; } sub rmailbx { my $self = shift; $self->{rmailbx} = Net::DNS::Mailbox1035->new(shift) if scalar @_; return $self->{rmailbx} ? $self->{rmailbx}->address : undef; } sub emailbx { my $self = shift; $self->{emailbx} = Net::DNS::Mailbox1035->new(shift) if scalar @_; 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, RFC1035 Section 3.3.7 =cut PK! defined eval { require Digest::BubbleBabble }; sub _decode_rdata { ## decode rdata from wire-format octet string my $self = shift; my ( $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 = shift; $self->algorithm(shift); $self->fptype(shift); $self->fp(@_); return; } sub algorithm { my $self = shift; $self->{algorithm} = 0 + shift if scalar @_; return $self->{algorithm} || 0; } sub fptype { my $self = shift; $self->{fptype} = 0 + shift if scalar @_; return $self->{fptype} || 0; } sub fp { my $self = shift; return unpack "H*", $self->fpbin() unless scalar @_; return $self->fpbin( pack "H*", join "", map { /^"*([\dA-Fa-f]*)"*$/ || croak("corrupt hex"); $1 } @_ ); } sub fpbin { my $self = shift; $self->{fpbin} = shift if scalar @_; 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, RFC4255 =cut PK![H$H$DNS/RR/DNSKEY.pmnu[package Net::DNS::RR::DNSKEY; use strict; use warnings; our $VERSION = (qw$Id: DNSKEY.pm 1856 2021-12-02 14:36:25Z 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 = shift; my ( $data, $offset ) = @_; my $rdata = substr $$data, $offset, $self->{rdlength}; $self->{keybin} = unpack '@4 a*', $rdata; @{$self}{qw(flags protocol algorithm)} = unpack 'n C*', $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 $algorithm = $self->{algorithm}; $self->_annotation( 'Key ID =', $self->keytag ) if $algorithm; return $self->SUPER::_format_rdata() unless BASE64; my @param = ( @{$self}{qw(flags protocol)}, $algorithm ); my @rdata = ( @param, split /\s+/, MIME::Base64::encode( $self->{keybin} ) || '-' ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my $self = shift; my $flags = shift; ## avoid destruction by CDNSKEY algorithm(0) $self->protocol(shift); $self->algorithm(shift); $self->flags($flags); $self->key(@_); return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->algorithm(1); $self->flags(256); $self->protocol(3); $self->keybin(''); return; } sub flags { my $self = shift; $self->{flags} = 0 + shift if scalar @_; return $self->{flags} || 0; } sub zone { my $self = shift; if ( scalar @_ ) { for ( $self->{flags} ) { $_ = 0x0100 | ( $_ || 0 ); $_ ^= 0x0100 unless shift; } } return 0x0100 & ( $self->{flags} || 0 ); } sub revoke { my $self = shift; if ( scalar @_ ) { for ( $self->{flags} ) { $_ = 0x0080 | ( $_ || 0 ); $_ ^= 0x0080 unless shift; } } return 0x0080 & ( $self->{flags} || 0 ); } sub sep { my $self = shift; if ( scalar @_ ) { for ( $self->{flags} ) { $_ = 0x0001 | ( $_ || 0 ); $_ ^= 0x0001 unless shift; } } return 0x0001 & ( $self->{flags} || 0 ); } sub protocol { my $self = shift; $self->{protocol} = 0 + shift if scalar @_; 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 = shift; return MIME::Base64::encode( $self->keybin(), "" ) unless scalar @_; return $self->keybin( MIME::Base64::decode( join "", @_ ) ); } sub keybin { my $self = shift; $self->{keybin} = shift if scalar @_; return $self->{keybin} || ""; } sub publickey { return shift->key(@_); } 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 0; # 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] '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 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, RFC4034 L L =cut PK! DNS/RR/CSYNC.pmnu[package Net::DNS::RR::CSYNC; use strict; use warnings; our $VERSION = (qw$Id: CSYNC.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; $self->soaserial(shift); $self->flags(shift); $self->typelist(@_); return; } sub soaserial { my $self = shift; $self->{soaserial} = 0 + shift if scalar @_; return $self->{soaserial} || 0; } sub flags { my $self = shift; $self->{flags} = 0 + shift if scalar @_; return $self->{flags} || 0; } sub immediate { my $self = shift; if ( scalar @_ ) { for ( $self->{flags} ) { $_ = 0x0001 | ( $_ || 0 ); $_ ^= 0x0001 unless shift; } } return 0x0001 & ( $self->{flags} || 0 ); } sub soaminimum { my $self = shift; if ( scalar @_ ) { for ( $self->{flags} ) { $_ = 0x0002 | ( $_ || 0 ); $_ ^= 0x0002 unless shift; } } return 0x0002 & ( $self->{flags} || 0 ); } 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, RFC7477 =cut PK!Ӏ} } DNS/RR/ISDN.pmnu[package Net::DNS::RR::ISDN; use strict; use warnings; our $VERSION = (qw$Id: ISDN.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; $self->address(shift); $self->sa(@_); return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->sa(''); return; } sub address { my $self = shift; $self->{address} = Net::DNS::Text->new(shift) if scalar @_; return $self->{address} ? $self->{address}->value : undef; } sub sa { my $self = shift; $self->{sa} = Net::DNS::Text->new(shift) if scalar @_; 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, RFC1183 Section 3.2 =cut PK!DNS/RR/GPOS.pmnu[package Net::DNS::RR::GPOS; use strict; use warnings; our $VERSION = (qw$Id: GPOS.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $data, $offset ) = @_; my $limit = $offset + $self->{rdlength}; ( $self->{latitude}, $offset ) = Net::DNS::Text->decode( $data, $offset ) if $offset < $limit; ( $self->{longitude}, $offset ) = Net::DNS::Text->decode( $data, $offset ) if $offset < $limit; ( $self->{altitude}, $offset ) = Net::DNS::Text->decode( $data, $offset ) if $offset < $limit; 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 '' unless defined $self->{altitude}; return join '', map { $self->{$_}->encode } qw(latitude longitude altitude); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return '' unless defined $self->{altitude}; return join ' ', map { $self->{$_}->string } qw(latitude longitude altitude); } sub _parse_rdata { ## populate RR from rdata in argument list my $self = shift; $self->latitude(shift); $self->longitude(shift); $self->altitude(shift); die 'too many arguments for GPOS' if scalar @_; 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 = shift; $self->{latitude} = _fp2text(shift) if scalar @_; return defined(wantarray) ? _text2fp( $self->{latitude} ) : undef; } sub longitude { my $self = shift; $self->{longitude} = _fp2text(shift) if scalar @_; return defined(wantarray) ? _text2fp( $self->{longitude} ) : undef; } sub altitude { my $self = shift; $self->{altitude} = _fp2text(shift) if scalar @_; return defined(wantarray) ? _text2fp( $self->{altitude} ) : undef; } ######################################## sub _fp2text { return Net::DNS::Text->new( sprintf( '%1.10g', shift ) ); } sub _text2fp { no integer; return ( 0.0 + shift->value ); } ######################################## 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, RFC1712 =cut PK!=)5  DNS/RR/MG.pmnu[package Net::DNS::RR::MG; use strict; use warnings; our $VERSION = (qw$Id: MG.pm 1857 2021-12-07 13:38:02Z 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 = shift; $self->{mgmname} = Net::DNS::DomainName1035->decode(@_); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $mgmname = $self->{mgmname} || return ''; return $mgmname->encode(@_); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $mgmname = $self->{mgmname} || return ''; return $mgmname->string; } sub _parse_rdata { ## populate RR from rdata in argument list my $self = shift; $self->mgmname(shift); return; } sub mgmname { my $self = shift; $self->{mgmname} = Net::DNS::DomainName1035->new(shift) if scalar @_; 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, RFC1035 Section 3.3.6 =cut PK! DNS/RR/CNAME.pmnu[package Net::DNS::RR::CNAME; use strict; use warnings; our $VERSION = (qw$Id: CNAME.pm 1857 2021-12-07 13:38:02Z 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 = shift; $self->{cname} = Net::DNS::DomainName1035->decode(@_); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $cname = $self->{cname}; return $cname->encode(@_); } 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 = shift; $self->cname(shift); return; } sub cname { my $self = shift; $self->{cname} = Net::DNS::DomainName1035->new(shift) if scalar @_; 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, RFC1035 Section 3.3.1 =cut PK!.  DNS/RR/NAPTR.pmnu[package Net::DNS::RR::NAPTR; use strict; use warnings; our $VERSION = (qw$Id: NAPTR.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; my ( $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 = shift; foreach (qw(order preference flags service regexp replacement)) { $self->$_(shift) } return; } sub order { my $self = shift; $self->{order} = 0 + shift if scalar @_; return $self->{order} || 0; } sub preference { my $self = shift; $self->{preference} = 0 + shift if scalar @_; return $self->{preference} || 0; } sub flags { my $self = shift; $self->{flags} = Net::DNS::Text->new(shift) if scalar @_; return $self->{flags} ? $self->{flags}->value : undef; } sub service { my $self = shift; $self->{service} = Net::DNS::Text->new(shift) if scalar @_; return $self->{service} ? $self->{service}->value : undef; } sub regexp { my $self = shift; $self->{regexp} = Net::DNS::Text->new(shift) if scalar @_; return $self->{regexp} ? $self->{regexp}->value : undef; } sub replacement { my $self = shift; $self->{replacement} = Net::DNS::DomainName2535->new(shift) if scalar @_; 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, RFC2915, RFC2168, RFC3403 =cut PK!f.DNS/RR/TKEY.pmnu[package Net::DNS::RR::TKEY; use strict; use warnings; our $VERSION = (qw$Id: TKEY.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $data, $offset ) = @_; my $limit = $offset + $self->{rdlength}; ( $self->{algorithm}, $offset ) = Net::DNS::DomainName->decode(@_); @{$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 { ## overide RR method return 'ANY'; } sub encode { ## overide 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 = shift; $self->{algorithm} = Net::DNS::DomainName->new(shift) if scalar @_; return $self->{algorithm} ? $self->{algorithm}->name : undef; } sub inception { my $self = shift; $self->{inception} = 0 + shift if scalar @_; return $self->{inception} || 0; } sub expiration { my $self = shift; $self->{expiration} = 0 + shift if scalar @_; return $self->{expiration} || 0; } sub mode { my $self = shift; $self->{mode} = 0 + shift if scalar @_; return $self->{mode} || 0; } sub error { my $self = shift; $self->{error} = 0 + shift if scalar @_; return $self->{error} || 0; } sub key { my $self = shift; $self->{key} = shift if scalar @_; return $self->{key} || ""; } sub other { my $self = shift; $self->{other} = shift if scalar @_; return $self->{other} || ""; } sub other_data { return &other; } # uncoverable pod 1; __END__ =head1 SYNOPSIS use Net::DNS; =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, RFC2930 =cut PK!r DNS/RR/LOC.pmnu[package Net::DNS::RR::LOC; use strict; use warnings; our $VERSION = (qw$Id: LOC.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; my @lat; while ( scalar @_ ) { my $this = shift; push( @lat, $this ); last if $this =~ /[NSns]/; } $self->latitude(@lat); my @long; while ( scalar @_ ) { my $this = shift; push( @long, $this ); last if $this =~ /[EWew]/; } $self->longitude(@long); foreach my $attr (qw(altitude size hp vp)) { $self->$attr(@_); shift; } 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 = shift; $self->{latitude} = _encode_angle(@_) if scalar @_; return _decode_angle( $self->{latitude} || return, 'N', 'S' ); } sub longitude { my $self = shift; $self->{longitude} = _encode_angle(@_) if scalar @_; return _decode_angle( $self->{longitude} || return, 'E', 'W' ); } sub altitude { my $self = shift; $self->{altitude} = _encode_alt(shift) if scalar @_; return _decode_alt( $self->{altitude} ); } sub size { my $self = shift; $self->{size} = _encode_prec(shift) if scalar @_; return _decode_prec( $self->{size} ); } sub hp { my $self = shift; $self->{hp} = _encode_prec(shift) if scalar @_; return _decode_prec( $self->{hp} ); } sub horiz_pre { return &hp; } # uncoverable pod sub vp { my $self = shift; $self->{vp} = _encode_prec(shift) if scalar @_; return _decode_prec( $self->{vp} ); } sub vert_pre { return &vp; } # uncoverable pod sub latlon { my $self = shift; my ( $lat, @lon ) = @_; return ( scalar $self->latitude(@_), scalar $self->longitude(@lon) ); } 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 = scalar @_ > 1 ? (@_) : ( split /[\s\260'"]+/, shift ); 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, RFC1876 =cut PK!ZӠ DNS/RR/TXT.pmnu[package Net::DNS::RR::TXT; use strict; use warnings; our $VERSION = (qw$Id: TXT.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $data, $offset ) = @_; my $limit = $offset + $self->{rdlength}; my $text; my $txtdata = $self->{txtdata} = []; while ( $offset < $limit ) { ( $text, $offset ) = Net::DNS::Text->decode( $data, $offset ); push @$txtdata, $text; } croak('corrupt TXT data') unless $offset == $limit; # more or less FUBAR 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 = shift; $self->{txtdata} = [map { Net::DNS::Text->new($_) } @_]; return; } sub txtdata { my $self = shift; $self->{txtdata} = [map { Net::DNS::Text->new($_) } @_] if scalar @_; my $txtdata = $self->{txtdata} || []; return ( map { $_->value } @$txtdata ) if wantarray; return defined(wantarray) ? join( ' ', map { $_->value } @$txtdata ) : ''; } sub char_str_list { return (&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, RFC1035 Section 3.3.14, RFC3629 =cut PK!4ll DNS/RR/RP.pmnu[package Net::DNS::RR::RP; use strict; use warnings; our $VERSION = (qw$Id: RP.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; my ( $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 = shift; $self->mbox(shift); $self->txtdname(shift); return; } sub mbox { my $self = shift; $self->{mbox} = Net::DNS::Mailbox2535->new(shift) if scalar @_; return $self->{mbox} ? $self->{mbox}->address : undef; } sub txtdname { my $self = shift; $self->{txtdname} = Net::DNS::DomainName2535->new(shift) if scalar @_; 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, RFC1183 Section 2.2 =cut PK!2$DDNS/RR/HTTPS.pmnu[package Net::DNS::RR::HTTPS; use strict; use warnings; our $VERSION = (qw$Id: HTTPS.pm 1857 2021-12-07 13:38:02Z 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 =cut PK!n>**DNS/RR/SVCB.pmnu[package Net::DNS::RR::SVCB; use strict; use warnings; our $VERSION = (qw$Id: SVCB.pm 1857 2021-12-07 13:38:02Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::SVCB - DNS SVCB resource record =cut use integer; use Carp; use MIME::Base64; use Net::DNS::DomainName; use Net::DNS::RR::A; use Net::DNS::RR::AAAA; use Net::DNS::Text; my %keybyname = ( mandatory => 'key0', alpn => 'key1', 'no-default-alpn' => 'key2', port => 'key3', ipv4hint => 'key4', ech => 'key5', ipv6hint => 'key6', ); sub _decode_rdata { ## decode rdata from wire-format octet string my $self = shift; my ( $data, $offset ) = @_; my $rdata = substr $$data, $offset, $self->{rdlength}; $self->{SvcPriority} = unpack( 'n', $rdata ); my $index; ( $self->{TargetName}, $index ) = Net::DNS::DomainName->decode( \$rdata, 2 ); my $params = $self->{SvcParams} = []; my $limit = length($rdata) - 3; while ( $index < $limit ) { my ( $key, $size ) = unpack( "\@$index n2", $rdata ); push @$params, ( $key, substr $rdata, $index + 4, $size ); $index += ( $size + 4 ); } die $self->type . ': corrupt RDATA' unless $index == length($rdata); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; 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 $priority = $self->{SvcPriority}; my $target = $self->{TargetName}->string; my $params = $self->{SvcParams} || []; return ( $priority, $target ) unless scalar @$params; my $encode = $self->{TargetName}->encode(); my $length = 2 + length $encode; my @target = split /(\S{32})/, unpack 'H*', $encode; my @rdata = unpack 'H4', pack 'n', $priority; push @rdata, "\t; priority: $priority\n"; push @rdata, shift @target; push @rdata, join '', "\t\t; target: ", substr( $target, 0, 50 ), "\n"; push @rdata, @target; my @params = @$params; while (@params) { my $key = shift @params; my $val = shift @params; push @rdata, "\n"; push @rdata, "; key$key=...\n" if $key > 15; push @rdata, unpack 'H4H4', pack( 'n2', $key, length $val ); push @rdata, split /(\S{32})/, unpack 'H*', $val; $length += 4 + length $val; } return ( "\\# $length", @rdata ); } sub _parse_rdata { ## populate RR from rdata in argument list my $self = shift; $self->svcpriority(shift); $self->targetname(shift); local $SIG{__WARN__} = sub { die @_ }; while ( my $svcparam = shift ) { for ($svcparam) { my @value; if (/^key\d+=(.*)$/i) { push @value, length($1) ? $1 : shift; } elsif (/=(.*)$/) { local $_ = length($1) ? $1 : shift; s/^"(.*)"$/$1/; # strip enclosing quotes push @value, split /,/; } else { push @value, '' unless $keybyname{lc $_}; # empty | Boolean } s/[-]/_/g; # extract identifier m/^([^=]+)/; $self->$1(@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} ) { croak( $self->type . qq[: unexpected "key0" in mandatory list] ) if $unique{0}; croak( $self->type . qq[: duplicate "key$_" in mandatory list] ) if --$unique{$_}; croak( $self->type . qq[: mandatory "key$_" not present] ) unless defined $svcparam{$_}; } $self->mandatory( keys %unique ); # restore mandatory key list } croak( $self->type . qq[: expected alpn="..." not present] ) if defined( $svcparam{2} ) and !$svcparam{1}; return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->_parse_rdata(qw(0 .)); return; } sub svcpriority { my $self = shift; # uncoverable pod $self->{SvcPriority} = 0 + shift if scalar @_; return $self->{SvcPriority} || 0; } sub targetname { my $self = shift; # uncoverable pod $self->{TargetName} = Net::DNS::DomainName->new(shift) if scalar @_; 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 = shift; my @list = map { $keybyname{lc $_} || $_ } map { split /,/ } @_; my @keys = map { /(\d+)$/ ? $1 : croak( $self->type . qq[: unexpected "$_"] ) } @list; return $self->key0( _integer16( sort { $a <=> $b } @keys ) ); } sub alpn { ## alpn=h3,h2,... my $self = shift; return $self->key1( _string(@_) ); } sub no_default_alpn { ## no-default-alpn my $self = shift; # uncoverable pod return $self->key2( ( defined(wantarray) ? @_ : '' ), @_ ); } sub port { ## port=1234 my $self = shift; return $self->key3( map { _integer16($_) } @_ ); } sub ipv4hint { ## ipv4hint=192.0.2.1,... my $self = shift; return $self->key4( _ipv4(@_) ); } sub ech { ## ech=base64string my $self = shift; return $self->key5( map { _base64($_) } @_ ); } sub ipv6hint { ## ipv6hint=2001:DB8::1,... my $self = shift; return $self->key6( _ipv6(@_) ); } ######################################## sub _presentation { ## render octet string(s) in presentation format return () unless scalar @_; my $raw = join '', @_; return Net::DNS::Text->decode( \$raw, 0, length($raw) )->string; } sub _base64 { return _presentation( map { MIME::Base64::decode($_) } @_ ); } sub _integer16 { return _presentation( map { pack( 'n', $_ ) } @_ ); } sub _ipv4 { return _presentation( map { Net::DNS::RR::A::address( {}, $_ ) } @_ ); } sub _ipv6 { return _presentation( map { Net::DNS::RR::AAAA::address( {}, $_ ) } @_ ); } sub _string { local $_ = join ',', '', @_; # reassemble argument string s/\\092,/\\044/g; ### tolerate unnecessary double-escape nonsense in s/\\092\\092/\\092/g; ### draft-ietf-dnsop-svcb-https that contradicts RFC1035 s/\\,/\\044/g; # disguise (RFC1035) escaped comma my ( undef, @reparsed ) = split /,/; # multi-valued argument return _presentation( map { Net::DNS::Text->new($_)->encode() } @reparsed ); } our $AUTOLOAD; sub AUTOLOAD { ## Dynamic constructor/accessor methods my $self = shift; my ($method) = reverse split /::/, $AUTOLOAD; my $super = "SUPER::$method"; return $self->$super(@_) unless $method =~ /^key[0]*(\d+)$/i; my $key = $1; my $paramsref = $self->{SvcParams} || []; my %svcparams = @$paramsref; if ( scalar @_ ) { my $arg = shift; # keyNN($value); delete $svcparams{$key} unless defined $arg; croak( $self->type . qq[: duplicate SvcParam "key$key"] ) if defined $svcparams{$key}; $svcparams{$key} = Net::DNS::Text->new("$arg")->raw if defined $arg; $self->{SvcParams} = [map { ( $_, $svcparams{$_} ) } sort { $a <=> $b } keys %svcparams]; croak( $self->type . qq[: unexpected number of values for "key$key"] ) if scalar @_; } else { croak( $self->type . qq[: no value specified for "key$key"] ) unless defined wantarray; } my $value = $svcparams{$key}; return defined($value) ? _presentation($value) : $value; } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name HTTPS 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); $string = $rr->port(); # \004\210 $rr->key3($string); Constructor methods for mnemonic SvcParams defined in draft-ietf-dnsop-svcb-https. When invoked without arguments, the methods return the presentation format value for the underlying key. 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 and returned value are both presentation format strings. The method returns the undefined value if the key is not present. The specified key will be deleted if the value is undefined. =head1 COPYRIGHT Copyright (c)2020-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, draft-ietf-dnsop-svcb-https =cut PK!29 DNS/RR/PX.pmnu[package Net::DNS::RR::PX; use strict; use warnings; our $VERSION = (qw$Id: PX.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 + 0, @opaque ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my ( $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 = shift; $self->preference(shift); $self->map822(shift); $self->mapx400(shift); return; } sub preference { my $self = shift; $self->{preference} = 0 + shift if scalar @_; return $self->{preference} || 0; } sub map822 { my $self = shift; $self->{map822} = Net::DNS::DomainName2535->new(shift) if scalar @_; return $self->{map822} ? $self->{map822}->name : undef; } sub mapx400 { my $self = shift; $self->{mapx400} = Net::DNS::DomainName2535->new(shift) if scalar @_; 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, RFC2163 =cut PK!6|  DNS/RR/OPENPGPKEY.pmnu[package Net::DNS::RR::OPENPGPKEY; use strict; use warnings; our $VERSION = (qw$Id: OPENPGPKEY.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; $self->key(@_); return; } sub key { my $self = shift; return MIME::Base64::encode( $self->keybin(), "" ) unless scalar @_; return $self->keybin( MIME::Base64::decode( join "", @_ ) ); } sub keybin { my $self = shift; $self->{keybin} = shift if scalar @_; 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, RFC7929 =cut PK!X/ DNS/RR/APL.pmnu[package Net::DNS::RR::APL; use strict; use warnings; our $VERSION = (qw$Id: APL.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; $self->aplist(@_); return; } sub aplist { my $self = shift; while ( scalar @_ ) { # parse apitem strings last unless $_[0] =~ m#[!:./]#; shift =~ 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 = @_ ) { # 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 = shift; return $self->{negate} = shift if scalar @_; return $self->{negate}; } sub family { my $self = shift; $self->{family} = 0 + shift if scalar @_; return $self->{family} || 0; } sub prefix { my $self = shift; $self->{prefix} = 0 + shift if scalar @_; return $self->{prefix} || 0; } sub address { my $self = shift; my $family = $family{$self->family} || die 'unknown address family'; return bless( {%$self}, $family )->address unless scalar @_; my $bitmask = $self->prefix; my $address = bless( {}, $family )->address(shift); 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, RFC3123 =cut PK!w DNS/RR/TLSA.pmnu[package Net::DNS::RR::TLSA; use strict; use warnings; our $VERSION = (qw$Id: TLSA.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; $self->usage(shift); $self->selector(shift); $self->matchingtype(shift); $self->cert(@_); return; } sub usage { my $self = shift; $self->{usage} = 0 + shift if scalar @_; return $self->{usage} || 0; } sub selector { my $self = shift; $self->{selector} = 0 + shift if scalar @_; return $self->{selector} || 0; } sub matchingtype { my $self = shift; $self->{matchingtype} = 0 + shift if scalar @_; return $self->{matchingtype} || 0; } sub cert { my $self = shift; return unpack "H*", $self->certbin() unless scalar @_; return $self->certbin( pack "H*", join "", map { /^"*([\dA-Fa-f]*)"*$/ || croak("corrupt hex"); $1 } @_ ); } sub certbin { my $self = shift; $self->{certbin} = shift if scalar @_; 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, RFC6698 =cut PK! DNS/RR/HIP.pmnu[package Net::DNS::RR::HIP; use strict; use warnings; our $VERSION = (qw$Id: HIP.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; foreach (qw(algorithm hit key)) { $self->$_(shift) } $self->servers(@_); return; } sub algorithm { my $self = shift; $self->{algorithm} = 0 + shift if scalar @_; return $self->{algorithm} || 0; } sub hit { my $self = shift; return unpack "H*", $self->hitbin() unless scalar @_; return $self->hitbin( pack "H*", join "", map { /^"*([\dA-Fa-f]*)"*$/ || croak("corrupt hex"); $1 } @_ ); } sub hitbin { my $self = shift; $self->{hitbin} = shift if scalar @_; return $self->{hitbin} || ""; } sub key { my $self = shift; return MIME::Base64::encode( $self->keybin(), "" ) unless scalar @_; return $self->keybin( MIME::Base64::decode( join "", @_ ) ); } sub keybin { my $self = shift; $self->{keybin} = shift if scalar @_; return $self->{keybin} || ""; } sub servers { my $self = shift; my $servers = $self->{servers} ||= []; @$servers = map { Net::DNS::DomainName->new($_) } @_ if scalar @_; return defined(wantarray) ? map( { $_->name } @$servers ) : (); } sub rendezvousservers { ## historical $_[0]->_deprecate('prefer $rr->servers()'); # uncoverable pod my @servers = &servers; 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 hexadecimal 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, RFC8005 =cut PK!lXL3 DNS/RR/CDNSKEY.pmnu[package Net::DNS::RR::CDNSKEY; use strict; use warnings; our $VERSION = (qw$Id: CDNSKEY.pm 1857 2021-12-07 13:38:02Z willem $)[2]; use base qw(Net::DNS::RR::DNSKEY); =head1 NAME Net::DNS::RR::CDNSKEY - DNS CDNSKEY 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(flags protocol algorithm)} = ( 0, 3, 0 ); return; } sub key { my $self = shift; return $self->SUPER::key(@_) unless defined( $_[0] ) && length( $_[0] ) < 2; return $self->SUPER::keybin( $_[0] ? '' : chr(0) ); } 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, RFC7344, RFC8078(erratum 5049) =cut PK!r? DNS/RR/MB.pmnu[package Net::DNS::RR::MB; use strict; use warnings; our $VERSION = (qw$Id: MB.pm 1857 2021-12-07 13:38:02Z 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 = shift; $self->{madname} = Net::DNS::DomainName1035->decode(@_); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $madname = $self->{madname} || return ''; return $madname->encode(@_); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $madname = $self->{madname} || return ''; return $madname->string; } sub _parse_rdata { ## populate RR from rdata in argument list my $self = shift; $self->madname(shift); return; } sub madname { my $self = shift; $self->{madname} = Net::DNS::DomainName1035->new(shift) if scalar @_; 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, RFC1035 Section 3.3.3 =cut PK!KxW  DNS/RR/URI.pmnu[package Net::DNS::RR::URI; use strict; use warnings; our $VERSION = (qw$Id: URI.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; $self->$_(shift) foreach qw(priority weight target); return; } sub priority { my $self = shift; $self->{priority} = 0 + shift if scalar @_; return $self->{priority} || 0; } sub weight { my $self = shift; $self->{weight} = 0 + shift if scalar @_; return $self->{weight} || 0; } sub target { my $self = shift; $self->{target} = Net::DNS::Text->new(shift) if scalar @_; 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, RFC7553 =cut PK!` DNS/RR/MX.pmnu[package Net::DNS::RR::MX; use strict; use warnings; our $VERSION = (qw$Id: MX.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; my ( $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 = shift; $self->preference(shift); $self->exchange(shift); return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->preference(10); return; } sub preference { my $self = shift; $self->{preference} = 0 + shift if scalar @_; return $self->{preference} || 0; } sub exchange { my $self = shift; $self->{exchange} = Net::DNS::DomainName1035->new(shift) if scalar @_; 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, RFC1035 Section 3.3.9 =cut PK!>> > DNS/RR/DNAME.pmnu[package Net::DNS::RR::DNAME; use strict; use warnings; our $VERSION = (qw$Id: DNAME.pm 1857 2021-12-07 13:38:02Z 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 = shift; $self->{target} = Net::DNS::DomainName2535->decode(@_); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $target = $self->{target}; return $target->encode(@_); } 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 = shift; $self->target(shift); return; } sub target { my $self = shift; $self->{target} = Net::DNS::DomainName2535->new(shift) if scalar @_; 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, RFC6672 =cut PK!? DNS/RR/EUI64.pmnu[package Net::DNS::RR::EUI64; use strict; use warnings; our $VERSION = (qw$Id: EUI64.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; $self->address(shift); 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, RFC7043 =cut PK! ((DNS/RR/NSEC.pmnu[package Net::DNS::RR::NSEC; use strict; use warnings; our $VERSION = (qw$Id: NSEC.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $data, $offset ) = @_; my $limit = $offset + $self->{rdlength}; ( $self->{nxtdname}, $offset ) = Net::DNS::DomainName->decode(@_); $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 = shift; $self->nxtdname(shift); $self->typelist(@_); return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->_parse_rdata('.'); return; } sub nxtdname { my $self = shift; $self->{nxtdname} = Net::DNS::DomainName->new(shift) if scalar @_; return $self->{nxtdname} ? $self->{nxtdname}->name : undef; } sub typelist { my $self = shift; if ( scalar(@_) || !defined(wantarray) ) { $self->{typebm} = &_type2bm; return; } my @type = &_bm2type( $self->{typebm} ); return wantarray ? (@type) : "@type"; } sub typemap { my $self = shift; my $number = typebyname(shift); 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 = shift; my $name = Net::DNS::DomainName->new(shift)->canonical; return $name eq $self->{owner}->canonical; } sub covers { my $self = shift; my $name = join chr(0), reverse Net::DNS::DomainName->new(shift)->_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 = shift; my @qname = Net::DNS::Domain->new(shift)->label; my @owner = $self->{owner}->label; my $depth = scalar(@owner); my $next; while ( scalar(@qname) > $depth ) { $next = shift @qname; } return unless defined $next; my $nextcloser = join( '.', $next, @qname ); return if lc($nextcloser) ne lc( join '.', $next, @owner ); $self->{nextcloser} = $nextcloser; $self->{wildcard} = join( '.', '*', @qname ); return $self->owner; } sub nextcloser { return shift->{nextcloser}; } sub wildcard { return shift->{wildcard}; } ######################################## sub _type2bm { my @typearray; foreach my $typename ( map { split() } @_ ) { 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 @typelist; my $bitmap = shift || return @typelist; my $index = 0; my $limit = length $bitmap; 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 = shift; # uncoverable pod $self->{typebm} = shift if scalar @_; $self->_deprecate('prefer $rr->typelist() or $rr->typemap()'); return $self->{typebm}; } sub covered { ## historical my $self = shift; # uncoverable pod return $self->covers(@_); } ######################################## 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, RFC4034, RFC9077 =cut PK! DNS/RR/SPF.pmnu[package Net::DNS::RR::SPF; use strict; use warnings; our $VERSION = (qw$Id: SPF.pm 1857 2021-12-07 13:38:02Z 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 @spf = shift->char_str_list(@_); return wantarray ? @spf : join '', @spf; } sub txtdata { return &spfdata; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name SPF spfdata ...'); $rr = Net::DNS::RR->new( name => 'name', type => 'SPF', spfdata => 'single text string' ); $rr = Net::DNS::RR->new( name => 'name', type => 'SPF', spfdata => [ 'multiple', 'strings', ... ] ); =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, RFC7208 =cut PK!rCl]]DNS/RR/RRSIG.pmnu[package Net::DNS::RR::RRSIG; use strict; use warnings; our $VERSION = (qw$Id: RRSIG.pm 1856 2021-12-02 14:36:25Z 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: Downstream distros MUST NOT create dependencies on Net::DNS::SEC (strong crypto prohibited in many territories) use constant USESEC => defined $INC{'Net/DNS/SEC.pm'}; # Discover how we got here, without exposing any crypto use constant # Discourage static code analysers and casual greppers DNSSEC => USESEC && defined eval join '', qw(r e q u i r e), ' Net::DNS', qw(:: SEC :: Private); ## no critic my @index; if (DNSSEC) { foreach my $class ( map {"Net::DNS::SEC::$_"} qw(RSA DSA ECCGOST ECDSA EdDSA) ) { 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 = shift; my ( $data, $offset ) = @_; my $limit = $offset + $self->{rdlength}; @{$self}{@field} = unpack "\@$offset n C2 N3 n", $$data; ( $self->{signame}, $offset ) = Net::DNS::DomainName->decode( $data, $offset + 18 ); $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 ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my $self = shift; foreach ( @field, qw(signame) ) { $self->$_(shift) } $self->signature(@_); return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->sigval(30); return; } sub typecovered { my $self = shift; $self->{typecovered} = typebyname(shift) if scalar @_; 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 = shift; $self->{labels} = 0 + shift if scalar @_; return $self->{labels} || 0; } sub orgttl { my $self = shift; $self->{orgttl} = 0 + shift if scalar @_; return $self->{orgttl} || 0; } sub sigexpiration { my $self = shift; $self->{sigexpiration} = _string2time(shift) if scalar @_; my $time = $self->{sigexpiration}; return unless defined wantarray && defined $time; return UTIL ? Scalar::Util::dualvar( $time, _time2string($time) ) : _time2string($time); } sub siginception { my $self = shift; $self->{siginception} = _string2time(shift) if scalar @_; 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 = shift; no integer; return ( $self->{sigval} ) = map { int( 86400 * $_ ) } @_; } sub keytag { my $self = shift; $self->{keytag} = 0 + shift if scalar @_; return $self->{keytag} || 0; } sub signame { my $self = shift; $self->{signame} = Net::DNS::DomainName->new(shift) if scalar @_; return $self->{signame} ? $self->{signame}->name : undef; } sub sig { my $self = shift; return MIME::Base64::encode( $self->sigbin(), "" ) unless scalar @_; return $self->sigbin( MIME::Base64::decode( join "", @_ ) ); } sub sigbin { my $self = shift; $self->{sigbin} = shift if scalar @_; 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] '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 = shift; my $algorithm = $self->algorithm; my $class = $DNSSEC_siggen{$algorithm}; return eval { die "algorithm $algorithm not supported\n" unless $class; $self->sigbin( $class->sign(@_) ); } || return croak "${@}signature generation failed"; } } sub _VerifySig { if (DNSSEC) { my $self = shift; my $algorithm = $self->algorithm; my $class = $DNSSEC_verify{$algorithm}; my $retval = eval { die "algorithm $algorithm not supported\n" unless $class; $class->verify( @_, $self->sigbin ); }; unless ($retval) { $self->{vrfyerrstr} = "${@}signature verification failed"; print "\n", $self->{vrfyerrstr}, "\n" if DEBUG; return 0; } # uncoverable branch true # bug in Net::DNS::SEC or dependencies croak "unknown error in $class->verify" unless $retval == 1; print "\nalgorithm $algorithm verification successful\n" if DEBUG; return 1; } } sub _ordered() { ## irreflexive 32-bit partial ordering use integer; 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 if ( $n2 < 0 ) { # fold, leaving $n2 non-negative $n1 = ( $n1 & 0xFFFFFFFF ) ^ 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 => 20211231010101 sigin => 20211201010101 ); $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 => 20211231010101 sigin => 20211201010101 ); $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 => 20211231010101, # signature expiration sigin => 20211201010101, # signature inception sigval => 30, # validity window (days) ttl => 3600 # TTL 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 -f ksk rsa.example. dnssec-keygen -a 10 -b 1024 rsa.example. dnssec-keygen -a 14 -f ksk ecdsa.example. dnssec-keygen -a 14 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, RFC4034 L L =cut PK!n/ZZ DNS/RR/KX.pmnu[package Net::DNS::RR::KX; use strict; use warnings; our $VERSION = (qw$Id: KX.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; my ( $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 = shift; $self->preference(shift); $self->exchange(shift); return; } sub preference { my $self = shift; $self->{preference} = 0 + shift if scalar @_; return $self->{preference} || 0; } sub exchange { my $self = shift; $self->{exchange} = Net::DNS::DomainName2535->new(shift) if scalar @_; 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, RFC2230 =cut PK!'X~QPQPDNS/RR/TSIG.pmnu[package Net::DNS::RR::TSIG; use strict; use warnings; our $VERSION = (qw$Id: TSIG.pm 1856 2021-12-02 14:36:25Z 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 = shift; my ( $data, $offset ) = @_; my $limit = $offset + $self->{rdlength}; ( $self->{algorithm}, $offset ) = Net::DNS::DomainName->decode(@_); # 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 $macbin = $self->macbin; unless ($macbin) { my ( $offset, undef, $packet ) = @_; my $sigdata = $self->sig_data($packet); # form data to be signed $macbin = $self->macbin( $self->_mac_function($sigdata) ); $self->original_id( $packet->header->id ); } 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 { ## overide RR method my $self = shift; my $kname = $self->{owner}->encode(); # uncompressed key name my $rdata = eval { $self->_encode_rdata(@_) } || ''; return pack 'a* n2 N n a*', $kname, TSIG, ANY, 0, length $rdata, $rdata; } sub string { ## overide 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 = shift; return MIME::Base64::encode( $self->keybin(), "" ) unless scalar @_; return $self->keybin( MIME::Base64::decode( join "", @_ ) ); } sub keybin { return &_keybin; } sub time_signed { my $self = shift; $self->{time_signed} = 0 + shift if scalar @_; return $self->{time_signed} ? $self->{time_signed} : ( $self->{time_signed} = time() ); } sub fudge { my $self = shift; $self->{fudge} = 0 + shift if scalar @_; return $self->{fudge} || 0; } sub mac { my $self = shift; return MIME::Base64::encode( $self->macbin(), "" ) unless scalar @_; return $self->macbin( MIME::Base64::decode( join "", @_ ) ); } sub macbin { my $self = shift; $self->{macbin} = shift if scalar @_; return $self->{macbin} || ""; } sub prior_mac { my $self = shift; return MIME::Base64::encode( $self->prior_macbin(), "" ) unless scalar @_; return $self->prior_macbin( MIME::Base64::decode( join "", @_ ) ); } sub prior_macbin { my $self = shift; $self->{prior_macbin} = shift if scalar @_; return $self->{prior_macbin} || ""; } sub request_mac { my $self = shift; return MIME::Base64::encode( $self->request_macbin(), "" ) unless scalar @_; return $self->request_macbin( MIME::Base64::decode( join "", @_ ) ); } sub request_macbin { my $self = shift; $self->{request_macbin} = shift if scalar @_; return $self->{request_macbin} || ""; } sub original_id { my $self = shift; $self->{original_id} = 0 + shift if scalar @_; return $self->{original_id} || 0; } sub error { my $self = shift; $self->{error} = rcodebyname(shift) if scalar @_; return rcodebyval( $self->{error} ); } sub other { my $self = shift; $self->{other} = shift if scalar @_; my $time = $self->{error} == 18 ? pack 'xxN', time() : ''; return $self->{other} ? $self->{other} : ( $self->{other} = $time ); } sub other_data { return &other; } # uncoverable pod sub sig_function { my $self = shift; $self->{sig_function} = shift if scalar @_; 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->data; my $hbin = pack 'n6', $message->{id}, $message->{status}, @size; $message = join '', $hbin, substr $data, length $hbin; } } # 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 = shift; my $karg = shift; 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, @_ ); } 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, @_ ); } croak "Usage: $class->create( \$keyfile, \@options )"; } elsif ( scalar(@_) == 1 ) { $class->_deprecate('create( $keyname, $key )'); # ( keyname, key ) return Net::DNS::RR->new( name => $karg, type => 'TSIG', key => shift ); } else { 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, $x ); while ( $keyfile->_getline ) { /^key "([^"]+)"/ and $keyname = $1; # BIND tsig key /algorithm ([^;]+);/ and $algorithm = $1; /secret "([^"]+)";/ and $secret = $1; /^Algorithm:/ and ( $x, $algorithm ) = split; # BIND dnssec private key /^Key:/ and ( $x, $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 $keytag and ( $keytag == $keyrr->keytag ); return $class->create( $keyrr, @_ ); } foreach ( $keyname, $algorithm, $secret ) { croak 'key file incompatible with TSIG' unless $_; } return Net::DNS::RR->new( name => $keyname, type => 'TSIG', algorithm => $algorithm, key => $secret, @_ ); } } sub verify { my $self = shift; my $data = shift; if ( scalar @_ ) { my $arg = shift; unless ( ref($arg) ) { $self->error(16); # BADSIG (multi-packet) return; } my $signerkey = lc( join '+', $self->name, $self->algorithm ); if ( $arg->isa('Net::DNS::Packet') ) { my $request = $arg->sigrr; # request TSIG my $rqstkey = lc( join '+', $request->name, $request->algorithm ); $self->error(17) unless $signerkey eq $rqstkey; # BADKEY $self->request_macbin( $request->macbin ); } elsif ( $arg->isa(__PACKAGE__) ) { my $priorkey = lc( join '+', $arg->name, $arg->algorithm ); $self->error(17) unless $signerkey eq $priorkey; # BADKEY $self->prior_macbin( $arg->macbin ); } else { croak 'Usage: $tsig->verify( $reply, $query )'; } } return 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; my $minlen = length($tsigmac) >> 1; # per RFC4635, 3.1 $self->error(16) if $macbin ne substr $tsigmac, 0, $maclen; # BADSIG $self->error(22) if $maclen < $minlen or $maclen < 10 or $maclen > length $tsigmac; # BADTRUNC $self->error(18) if abs( time() - $self->time_signed ) > $self->fudge; # BADTIME return $self->{error} ? undef : $tsig; } sub vrfyerrstr { my $self = shift; return $self->error; } ######################################## { # source: http://www.iana.org/assignments/tsig-algorithm-names 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 = shift; croak 'Unauthorised access to TSIG key material denied' unless scalar @_; my $keyref = $keytable{$self->{owner}->canonical} ||= {}; my $private = shift; # 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 = shift; 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(@_); } } # _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 shared secret keys 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. TSIG verification, BIND keyfile handling and support for HMAC-SHA1, HMAC-SHA224, HMAC-SHA256, HMAC-SHA384 and HMAC-SHA512 functions was added by Dick Franks. =head1 BUGS A 32-bit representation of time is used, contrary to RFC2845 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, RFC8945 L =cut PK!CC DNS/RR/SOA.pmnu[package Net::DNS::RR::SOA; use strict; use warnings; our $VERSION = (qw$Id: SOA.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $data, $offset, @opaque ) = @_; ( $self->{mname}, $offset ) = Net::DNS::DomainName1035->decode(@_); ( $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 = shift; my ( $offset, @opaque ) = @_; my $rname = $self->{rname}; my $rdata = $self->{mname}->encode(@_); $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 = shift; $self->mname(shift); $self->rname(shift); $self->serial(shift); for (qw(refresh retry expire minimum)) { $self->$_( Net::DNS::RR::ttl( {}, shift ) ) if scalar @_; } 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 = shift; $self->{mname} = Net::DNS::DomainName1035->new(shift) if scalar @_; return $self->{mname} ? $self->{mname}->name : undef; } sub rname { my $self = shift; $self->{rname} = Net::DNS::Mailbox1035->new(shift) if scalar @_; return $self->{rname} ? $self->{rname}->address : undef; } sub serial { my $self = shift; return $self->{serial} || 0 unless scalar @_; # current/default value my $value = shift; # 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 = shift; $self->{refresh} = 0 + shift if scalar @_; return $self->{refresh} || 0; } sub retry { my $self = shift; $self->{retry} = 0 + shift if scalar @_; return $self->{retry} || 0; } sub expire { my $self = shift; $self->{expire} = 0 + shift if scalar @_; return $self->{expire} || 0; } sub minimum { my $self = shift; $self->{minimum} = 0 + shift if scalar @_; return $self->{minimum} || 0; } ######################################## sub _ordered() { ## irreflexive 32-bit partial ordering use integer; 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 if ( $n2 < 0 ) { # fold, leaving $n2 non-negative $n1 = ( $n1 & 0xFFFFFFFF ) ^ 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 auxilliary SEQUENTIAL() function can never satisfy the serial number ordering constraint. =head2 Date Encoded $successor = $soa->serial( YYYYMMDDxx ); The 32 bit value returned by the auxilliary 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 auxilliary 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, RFC1035 Section 3.3.13, RFC1982 =cut PK!J-tW DNS/RR/CDS.pmnu[package Net::DNS::RR::CDS; use strict; use warnings; our $VERSION = (qw$Id: CDS.pm 1857 2021-12-07 13:38:02Z 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)} = ( 0, 0, 0 ); return; } sub digtype { my ( $self, $arg ) = @_; return $self->SUPER::digtype( $arg ? $arg : () ); } sub digest { my $self = shift; return $self->SUPER::digest(@_) unless defined( $_[0] ) && length( $_[0] ) < 2; return $self->SUPER::digestbin( $_[0] ? '' : chr(0) ); } 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, RFC7344, RFC8078(erratum 5049) =cut PK!kyww DNS/RR/SRV.pmnu[package Net::DNS::RR::SRV; use strict; use warnings; our $VERSION = (qw$Id: SRV.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; my ( $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 = shift; foreach my $attr (qw(priority weight port target)) { $self->$attr(shift); } return; } sub priority { my $self = shift; $self->{priority} = 0 + shift if scalar @_; return $self->{priority} || 0; } sub weight { my $self = shift; $self->{weight} = 0 + shift if scalar @_; return $self->{weight} || 0; } sub port { my $self = shift; $self->{port} = 0 + shift if scalar @_; return $self->{port} || 0; } sub target { my $self = shift; $self->{target} = Net::DNS::DomainName2535->new(shift) if scalar @_; 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, RFC2782 =cut PK!zg g DNS/RR/NS.pmnu[package Net::DNS::RR::NS; use strict; use warnings; our $VERSION = (qw$Id: NS.pm 1857 2021-12-07 13:38:02Z 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 = shift; $self->{nsdname} = Net::DNS::DomainName1035->decode(@_); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $nsdname = $self->{nsdname}; return $nsdname->encode(@_); } 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 = shift; $self->nsdname(shift); return; } sub nsdname { my $self = shift; $self->{nsdname} = Net::DNS::DomainName1035->new(shift) if scalar @_; 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, RFC1035 Section 3.3.11 =cut PK!Ǝ;hh DNS/RR/CAA.pmnu[package Net::DNS::RR::CAA; use strict; use warnings; our $VERSION = (qw$Id: CAA.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; $self->flags(shift); $self->tag( lc shift ); $self->value(shift); return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->flags(0); return; } sub flags { my $self = shift; $self->{flags} = 0 + shift if scalar @_; return $self->{flags} || 0; } sub critical { my $self = shift; if ( scalar @_ ) { for ( $self->{flags} ) { $_ = 0x0080 | ( $_ || 0 ); $_ ^= 0x0080 unless shift; } } return 0x0080 & ( $self->{flags} || 0 ); } sub tag { my $self = shift; $self->{tag} = Net::DNS::Text->new(shift) if scalar @_; return $self->{tag} ? $self->{tag}->value : undef; } sub value { my $self = shift; $self->{value} = Net::DNS::Text->new(shift) if scalar @_; 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 ); The property identifier, a sequence of ASCII characters. Tag values may contain ASCII characters a-z, hyphen and 0-9. Tag values should not contain any other characters. Matching of tag values 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, RFC8659 =cut PK!vA DNS/RR/A.pmnu[package Net::DNS::RR::A; use strict; use warnings; our $VERSION = (qw$Id: A.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; $self->address(shift); 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, RFC1035 Section 3.4.1 =cut PK!|DNS/RR/CERT.pmnu[package Net::DNS::RR::CERT; use strict; use warnings; our $VERSION = (qw$Id: CERT.pm 1856 2021-12-02 14:36:25Z 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 = shift; my ( $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 = shift; $self->certtype(shift); $self->keytag(shift); $self->algorithm(shift); $self->cert(@_); return; } sub certtype { my $self = shift; return $self->{certtype} unless scalar @_; my $certtype = shift || 0; 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 = shift; $self->{keytag} = 0 + shift if scalar @_; 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 = shift; $self->{certbin} = shift if scalar @_; return $self->{certbin} || ""; } sub cert { my $self = shift; return MIME::Base64::encode( $self->certbin(), "" ) unless scalar @_; return $self->certbin( MIME::Base64::decode( join "", @_ ) ); } 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] '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, RFC4398 L =cut PK!77DNS/RR/NSEC3PARAM.pmnu[package Net::DNS::RR::NSEC3PARAM; use strict; use warnings; our $VERSION = (qw$Id: NSEC3PARAM.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; $self->algorithm(shift); $self->flags(shift); $self->iterations(shift); my $salt = shift; $self->salt($salt) unless $salt eq '-'; return; } sub algorithm { my $self = shift; $self->{algorithm} = 0 + shift if scalar @_; return $self->{algorithm} || 0; } sub flags { my $self = shift; $self->{flags} = 0 + shift if scalar @_; return $self->{flags} || 0; } sub iterations { my $self = shift; $self->{iterations} = 0 + shift if scalar @_; return $self->{iterations} || 0; } sub salt { my $self = shift; return unpack "H*", $self->saltbin() unless scalar @_; return $self->saltbin( pack "H*", join "", map { /^"*([\dA-Fa-f]*)"*$/ || croak("corrupt hex"); $1 } @_ ); } sub saltbin { my $self = shift; $self->{saltbin} = shift if scalar @_; 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 Hash Algorithm field is represented as an unsigned decimal integer. The value has a maximum of 255. =head2 flags $flags = $rr->flags; $rr->flags( $flags ); The Flags field is represented as an unsigned decimal integer. The value has a maximum of 255. =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, RFC5155 =cut PK!?[  DNS/RR/KEY.pmnu[package Net::DNS::RR::KEY; use strict; use warnings; our $VERSION = (qw$Id: KEY.pm 1857 2021-12-07 13:38:02Z 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, RFC4034, RFC3755, RFC3008, RFC2535 L =cut PK! K1K1DNS/RR/NSEC3.pmnu[package Net::DNS::RR::NSEC3; use strict; use warnings; our $VERSION = (qw$Id: NSEC3.pm 1857 2021-12-07 13:38:02Z 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 = shift; my ( $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 = shift; my $alg = $self->algorithm(shift); $self->flags(shift); my $iter = $self->iterations(shift); my $salt = shift; $self->salt($salt) unless $salt eq '-'; $self->hnxtname(shift); $self->typelist(@_); $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 = shift; $self->{flags} = 0 + shift if scalar @_; return $self->{flags} || 0; } sub optout { my $self = shift; if ( scalar @_ ) { for ( $self->{flags} ) { $_ = 0x01 | ( $_ || 0 ); $_ ^= 0x01 unless shift; } } return 0x01 & ( $self->{flags} || 0 ); } sub iterations { my $self = shift; $self->{iterations} = 0 + shift if scalar @_; return $self->{iterations} || 0; } sub salt { my $self = shift; return unpack "H*", $self->saltbin() unless scalar @_; return $self->saltbin( pack "H*", join "", map { /^"*([\dA-Fa-f]*)"*$/ || croak("corrupt hex"); $1 } @_ ); } sub saltbin { my $self = shift; $self->{saltbin} = shift if scalar @_; return $self->{saltbin} || ""; } sub hnxtname { my $self = shift; $self->{hnxtname} = _decode_base32hex(shift) if scalar @_; 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 Hash Algorithm field is represented as an unsigned decimal integer. The value has a maximum of 255. 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, RFC5155, RFC9077 L =cut PK!nMVV DNS/RR.pmnu[package Net::DNS::RR; use strict; use warnings; our $VERSION = (qw$Id: RR.pm 1856 2021-12-02 14:36:25Z 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 { return eval { local $SIG{__DIE__}; scalar @_ > 2 ? &_new_hash : &_new_string; } || do { my $class = shift || __PACKAGE__; my @param = map { defined($_) ? split /\s+/ : 'undef' } @_; 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; local $_; ( $base, $_ ) = @_; croak 'argument absent or undefined' unless defined $_; croak 'non-scalar argument' if ref $_; # parse into quoted strings, contiguous non-whitespace and (discarded) comments 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; croak '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); $self->class($class) if defined $class; # specify CLASS $self->ttl($ttl) if defined $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 ); croak '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 ) = decode Net::DNS::RR( \$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. Remaining arguments, if any, are passed as opaque data to subordinate decoders. 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. Any remaining arguments are passed as opaque data to subordinate decoders and do not form part of the published interface. =cut use constant RRFIXEDSZ => length pack 'n2 N n', (0) x 4; sub decode { my $base = shift; my ( $data, $offset, @opaque ) = @_; my ( $owner, $fixed ) = decode Net::DNS::DomainName1035(@_); my $index = $fixed + RRFIXEDSZ; 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; $self->{offset} = $offset || 0; $self->_decode_rdata( $data, $index, @opaque ) if $next > $index or $self->type eq 'OPT'; delete $self->{offset}; 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 = shift; my ( $offset, @opaque ) = scalar(@_) ? @_ : ( 0x4000, {} ); 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 lower case 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 ); my $empty = $self->_empty; my @rdata = $empty ? () : eval { $self->_format_rdata }; carp $@ if $@; my $tab = length($name) < 72 ? "\t" : ' '; $self->_annotation('no data') if $empty; my @line = _wrap( join( $tab, @core, '(' ), @rdata, ')' ); my $last = pop(@line); # last or only line $last = join $tab, @core, "@rdata" unless scalar(@line); 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 = shift; $self->{owner} = Net::DNS::DomainName1035->new(shift) if scalar @_; 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 = shift; croak 'not possible to change RR->type' if scalar @_; return typebyval( $self->{type} ); } =head2 class $class = $rr->class; Resource record class. =cut sub class { my $self = shift; return $self->{class} = classbyname(shift) if scalar @_; 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 require Data::Dumper; # uncoverable pod local $Data::Dumper::Maxdepth = $Data::Dumper::Maxdepth || 6; local $Data::Dumper::Sortkeys = $Data::Dumper::Sortkeys || 1; return print Data::Dumper::Dumper(@_); } sub rdatastr { ## historical RR subtype method return &rdstring; # uncoverable pod } =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 || ''; my $hash = {}; $self->_decode_rdata( \$data, 0, $hash ) if ( $self->{rdlength} = length $data ); croak 'compression pointer in rdata' if keys %$hash; return; } =head2 rdstring $rdstring = $rr->rdstring; Returns a string representation of the RR-specific data. =cut sub rdstring { my $self = shift; 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 push @INC, sub { Net::DNS::Parameters::_typespec("$rrtype.RRTYPE"); }; $subclass = join '::', __PACKAGE__, "TYPE$rrtype"; 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 = shift; $self->{annotation} = ["@_"] if scalar @_; return wantarray ? @{$self->{annotation} || []} : (); } my %warned; sub _deprecate { my $msg = pop(@_); carp join ' ', 'deprecated method;', $msg unless $warned{$msg}++; 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) { s/\\034/\\"/g; # tart up escaped " s/\\092/\\\\/g; # tart up escaped escape $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; } push @line, join ' ', @fill; return @line; } ################################################################################ our $AUTOLOAD; sub DESTROY { } ## Avoid tickling AUTOLOAD (in cleanup) sub AUTOLOAD { ## Default method my $self = shift; my ($method) = reverse split /::/, $AUTOLOAD; for ($method) { ## tolerate mixed-case attribute name return $self->$_(@_) if tr [A-Z-] [a-z_]; } no strict 'refs'; ## no critic ProhibitNoStrict *{$AUTOLOAD} = sub {undef}; ## suppress repetition and deep recursion my $oref = ref($self); 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, RFC1035 Section 4.1.3, RFC1123, RFC3597 =cut PK!uz?z?DNS.pmnu[package Net::DNS; use strict; use warnings; our $VERSION; $VERSION = '1.33'; $VERSION = eval { $VERSION }; our $SVNVERSION = (qw$Id: DNS.pm 1861 2021-12-16 11:21:07Z willem $)[2]; =head1 NAME Net::DNS - Perl Interface to the Domain Name System =head1 SYNOPSIS use Net::DNS; =head1 DESCRIPTION Net::DNS is a collection of Perl modules that act as a Domain Name System (DNS) resolver. It allows the programmer to perform DNS queries that are beyond the capabilities of "gethostbyname" and "gethostbyaddr". The programmer should be familiar with the structure of a DNS packet. See RFC 1035 or DNS and BIND (Albitz & Liu) for details. =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 ($arg1) = @_; my $res = ref($arg1) ? shift : Net::DNS::Resolver->new(); my $reply = $res->query(@_); my @list = $reply ? $reply->answer : (); return @list; } # # mx() # # Usage: # @mx = mx('example.com'); # @mx = mx($res, 'example.com'); # sub mx { my ($arg1) = @_; my @res = ( ref($arg1) ? shift : () ); my ( $name, @class ) = @_; # 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 $rrtype = uc shift; my ( $attribute, @rr ) = @_; ## NB: attribute is optional ( @rr, $attribute ) = @_ 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; } # # Auxilliary 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; } # # Auxilliary functions to support dynamic update. # sub yxrrset { my $rr = Net::DNS::RR->new(@_); $rr->ttl(0); $rr->class('ANY') unless $rr->rdata; return $rr; } sub nxrrset { my $rr = Net::DNS::RR->new(@_); return Net::DNS::RR->new( name => $rr->name, type => $rr->type, class => 'NONE' ); } sub yxdomain { my ( $domain, @etc ) = map {split} @_; my $rr = Net::DNS::RR->new( scalar(@etc) ? @_ : ( name => $domain ) ); return Net::DNS::RR->new( name => $rr->name, type => 'ANY', class => 'ANY' ); } sub nxdomain { my ( $domain, @etc ) = map {split} @_; my $rr = Net::DNS::RR->new( scalar(@etc) ? @_ : ( name => $domain ) ); return Net::DNS::RR->new( name => $rr->name, type => 'ANY', class => 'NONE' ); } sub rr_add { my $rr = Net::DNS::RR->new(@_); $rr->{ttl} = 86400 unless defined $rr->{ttl}; return $rr; } sub rr_del { my ( $domain, @etc ) = map {split} @_; my $rr = Net::DNS::RR->new( scalar(@etc) ? @_ : ( 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 auxilliary 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 auxilliary 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 auxilliary 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 auxilliary 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"); if ($reply) { foreach my $rr ($reply->answer) { print $rr->address, "\n" if $rr->can("address"); } } else { warn "query failed: ", $res->errorstring, "\n"; } =head2 Find the nameservers for a domain. use Net::DNS; my $res = Net::DNS::Resolver->new; my $reply = $res->query("example.com", "NS"); if ($reply) { foreach $rr (grep { $_->type eq "NS" } $reply->answer) { print $rr->nsdname, "\n"; } } else { warn "query failed: ", $res->errorstring, "\n"; } =head2 Find the MX records for a domain. use Net::DNS; my $name = "example.com"; my $res = Net::DNS::Resolver->new; my @mx = mx($res, $name); if (@mx) { foreach $rr (@mx) { print $rr->preference, "\t", $rr->exchange, "\n"; } } else { warn "Can not find MX records for $name: ", $res->errorstring, "\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"); if ($reply) { foreach my $rr ($reply->answer) { $rr->print; } } else { warn "query failed: ", $res->errorstring, "\n"; } =head2 Perform a zone transfer and print all the records. use Net::DNS; my $res = Net::DNS::Resolver->new; $res->tcp_timeout(20); $res->nameservers("ns.example.com"); my @zone = $res->axfr("example.com"); foreach $rr (@zone) { $rr->print; } warn $res->errorstring if $res->errorstring; =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("host.example.com", "AAAA"); while ( $res->bgbusy($socket) ) { # do some work here while waiting for the response # ...and some more here } my $packet = $res->bgread($socket); if ($packet) { $packet->print; } else { warn "query failed: ", $res->errorstring, "\n"; } =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. 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, RFC1035, L, I by Paul Albitz & Cricket Liu =cut PK!7""IP.pmnu[# Copyright (c) 1999 - 2002 RIPE NCC # # All Rights Reserved # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, # provided that the above copyright notice appear in all copies and that # both that copyright notice and this permission notice appear in # supporting documentation, and that the name of the author not be # used in advertising or publicity pertaining to distribution of the # software without specific, written prior permission. # # THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING # ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS; IN NO EVENT SHALL # AUTHOR BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY # DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN # AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. #------------------------------------------------------------------------------ # Module Header # Filename : IP.pm # Purpose : Provide functions to manipulate IPv4/v6 addresses # Author : Manuel Valente # Date : 19991124 # Description : # Language Version : Perl 5 # OSs Tested : BSDI 3.1 - Linux # Command Line : ipcount # Input Files : # Output Files : # External Programs : Math::BigInt.pm # Problems : # To Do : # Comments : Based on ipv4pack.pm (Monica) and iplib.pm (Lee) # Math::BigInt is only loaded if int functions are used # $Id: IP.pm,v 1.23 2003/02/18 16:13:01 manuel Exp $ #------------------------------------------------------------------------------ package Net::IP; use strict; use Math::BigInt; # Global Variables definition use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $ERROR $ERRNO %IPv4ranges %IPv6ranges $useBigInt $IP_NO_OVERLAP $IP_PARTIAL_OVERLAP $IP_A_IN_B_OVERLAP $IP_B_IN_A_OVERLAP $IP_IDENTICAL); $VERSION = '1.26'; require Exporter; @ISA = qw(Exporter); # Functions and variables exported in all cases @EXPORT = qw(&Error &Errno $IP_NO_OVERLAP $IP_PARTIAL_OVERLAP $IP_A_IN_B_OVERLAP $IP_B_IN_A_OVERLAP $IP_IDENTICAL ); # Functions exported on demand (with :PROC) @EXPORT_OK = qw(&Error &Errno &ip_iptobin &ip_bintoip &ip_bintoint &ip_inttobin &ip_get_version &ip_is_ipv4 &ip_is_ipv6 &ip_expand_address &ip_get_mask &ip_last_address_bin &ip_splitprefix &ip_prefix_to_range &ip_is_valid_mask &ip_bincomp &ip_binadd &ip_get_prefix_length &ip_range_to_prefix &ip_compress_address &ip_is_overlap &ip_get_embedded_ipv4 &ip_aggregate &ip_iptype &ip_check_prefix &ip_reverse &ip_normalize &ip_normal_range &ip_iplengths $IP_NO_OVERLAP $IP_PARTIAL_OVERLAP $IP_A_IN_B_OVERLAP $IP_B_IN_A_OVERLAP $IP_IDENTICAL ); %EXPORT_TAGS = (PROC => [@EXPORT_OK],); # Definition of the Ranges for IPv4 IPs %IPv4ranges = ( '00000000' => 'PRIVATE', # 0/8 '00001010' => 'PRIVATE', # 10/8 '0110010001' => 'SHARED', # 100.64/10 '01111111' => 'LOOPBACK', # 127.0/8 '1010100111111110' => 'LINK-LOCAL', # 169.254/16 '101011000001' => 'PRIVATE', # 172.16/12 '110000000000000000000000' => 'RESERVED', # 192.0.0/24 '110000000000000000000010' => 'TEST-NET', # 192.0.2/24 '110000000101100001100011' => '6TO4-RELAY', # 192.88.99.0/24 '1100000010101000' => 'PRIVATE', # 192.168/16 '110001100001001' => 'RESERVED', # 198.18/15 '110001100011001101100100' => 'TEST-NET', # 198.51.100/24 '110010110000000001110001' => 'TEST-NET', # 203.0.113/24 '1110' => 'MULTICAST', # 224/4 '1111' => 'RESERVED', # 240/4 '11111111111111111111111111111111' => 'BROADCAST', # 255.255.255.255/32 ); # Definition of the Ranges for Ipv6 IPs %IPv6ranges = ( '00000000' => 'RESERVED', # ::/8 ('0' x 128) => 'UNSPECIFIED', # ::/128 ('0' x 127) . '1' => 'LOOPBACK', # ::1/128 ('0' x 80) . ('1' x 16) => 'IPV4MAP', # ::FFFF:0:0/96 '00000001' => 'RESERVED', # 0100::/8 '0000000100000000' . ('0' x 48) => 'DISCARD', # 0100::/64 '0000001' => 'RESERVED', # 0200::/7 '000001' => 'RESERVED', # 0400::/6 '00001' => 'RESERVED', # 0800::/5 '0001' => 'RESERVED', # 1000::/4 '001' => 'GLOBAL-UNICAST', # 2000::/3 '0010000000000001' . ('0' x 16) => 'TEREDO', # 2001::/32 '00100000000000010000000000000010' . ('0' x 16) => 'BMWG', # 2001:0002::/48 '00100000000000010000110110111000' => 'DOCUMENTATION', # 2001:DB8::/32 '0010000000000001000000000001' => 'ORCHID', # 2001:10::/28 '0010000000000010' => '6TO4', # 2002::/16 '010' => 'RESERVED', # 4000::/3 '011' => 'RESERVED', # 6000::/3 '100' => 'RESERVED', # 8000::/3 '101' => 'RESERVED', # A000::/3 '110' => 'RESERVED', # C000::/3 '1110' => 'RESERVED', # E000::/4 '11110' => 'RESERVED', # F000::/5 '111110' => 'RESERVED', # F800::/6 '1111110' => 'UNIQUE-LOCAL-UNICAST', # FC00::/7 '111111100' => 'RESERVED', # FE00::/9 '1111111010' => 'LINK-LOCAL-UNICAST', # FE80::/10 '1111111011' => 'RESERVED', # FEC0::/10 '11111111' => 'MULTICAST', # FF00::/8 ); # Overlap constants $IP_NO_OVERLAP = 0; $IP_PARTIAL_OVERLAP = 1; $IP_A_IN_B_OVERLAP = -1; $IP_B_IN_A_OVERLAP = -2; $IP_IDENTICAL = -3; # ---------------------------------------------------------- # OVERLOADING use overload ( '+' => 'ip_add_num', 'bool' => sub { @_ }, ); #------------------------------------------------------------------------------ # Subroutine ip_num_add # Purpose : Add an integer to an IP # Params : Number to add # Returns : New object or undef # Note : Used by overloading - returns undef when # the end of the range is reached sub ip_add_num { my $self = shift; my ($value) = @_; my $ip = $self->intip + $value; my $last = $self->last_int; # Reached the end of the range ? if ($ip > $self->last_int) { return; } my $newb = ip_inttobin($ip, $self->version); $newb = ip_bintoip($newb, $self->version); my $newe = ip_inttobin($last, $self->version); $newe = ip_bintoip($newe, $self->version); my $new = new Net::IP("$newb - $newe"); return ($new); } # ----------------------------------------------------------------------------- #------------------------------------------------------------------------------ # Subroutine new # Purpose : Create an instance of an IP object # Params : Class, IP prefix, IP version # Returns : Object reference or undef # Note : New just allocates a new object - set() does all the work sub new { my ($class, $data, $ipversion) = (@_); # Allocate new object my $self = {}; bless($self, $class); # Pass everything to set() unless ($self->set($data, $ipversion)) { return; } return $self; } #------------------------------------------------------------------------------ # Subroutine set # Purpose : Set the IP for an IP object # Params : Data, IP type # Returns : 1 (success) or undef (failure) sub set { my $self = shift; my ($data, $ipversion) = @_; # Normalize data as received - this should return 2 IPs my ($begin, $end) = ip_normalize($data, $ipversion) or do { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; }; # Those variables are set when the object methods are called # We need to reset everything for ( qw(ipversion errno prefixlen binmask reverse_ip last_ip iptype binip error ip intformat hexformat mask last_bin last_int prefix is_prefix) ) { delete($self->{$_}); } # Determine IP version for this object return unless ($self->{ipversion} = $ipversion || ip_get_version($begin)); # Set begin IP address $self->{ip} = $begin; # Set Binary IP address return unless ($self->{binip} = ip_iptobin($self->ip(), $self->version())); $self->{is_prefix} = 0; # Set end IP address # If single IP: begin and end IPs are identical $end ||= $begin; $self->{last_ip} = $end; # Try to determine the IP version my $ver = ip_get_version($end) || return; # Check if begin and end addresses have the same version if ($ver != $self->version()) { $ERRNO = 201; $ERROR = "Begin and End addresses have different IP versions - $begin - $end"; $self->{errno} = $ERRNO; $self->{error} = $ERROR; return; } # Get last binary address return unless ($self->{last_bin} = ip_iptobin($self->last_ip(), $self->version())); # Check that End IP >= Begin IP unless (ip_bincomp($self->binip(), 'le', $self->last_bin())) { $ERRNO = 202; $ERROR = "Begin address is greater than End address $begin - $end"; $self->{errno} = $ERRNO; $self->{error} = $ERROR; return; } # Find all prefixes (eg:/24) in the current range my @prefixes = $self->find_prefixes() or return; # If there is only one prefix: if (scalar(@prefixes) == 1) { # Get length of prefix return unless ((undef, $self->{prefixlen}) = ip_splitprefix($prefixes[0])); # Set prefix boolean var # This value is 1 if the IP range only contains a single /nn prefix $self->{is_prefix} = 1; } # If the range is a single prefix: if ($self->{is_prefix}) { # Set mask property $self->{binmask} = ip_get_mask($self->prefixlen(), $self->version()); # Check that the mask is valid unless ( ip_check_prefix( $self->binip(), $self->prefixlen(), $self->version() ) ) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } } return ($self); } sub print { my $self = shift; if ($self->{is_prefix}) { return ($self->short() . '/' . $self->prefixlen()); } else { return (sprintf("%s - %s", $self->ip(), $self->last_ip())); } } #------------------------------------------------------------------------------ # Subroutine error # Purpose : Return the current error message # Returns : Error string sub error { my $self = shift; return $self->{error}; } #------------------------------------------------------------------------------ # Subroutine errno # Purpose : Return the current error number # Returns : Error number sub errno { my $self = shift; return $self->{errno}; } #------------------------------------------------------------------------------ # Subroutine binip # Purpose : Return the IP as a binary string # Returns : binary string sub binip { my $self = shift; return $self->{binip}; } #------------------------------------------------------------------------------ # Subroutine prefixlen # Purpose : Get the IP prefix length # Returns : prefix length sub prefixlen { my $self = shift; return $self->{prefixlen}; } #------------------------------------------------------------------------------ # Subroutine version # Purpose : Return the IP version # Returns : IP version sub version { my $self = shift; return $self->{ipversion}; } #------------------------------------------------------------------------------ # Subroutine version # Purpose : Return the IP in quad format # Returns : IP string sub ip { my $self = shift; return $self->{ip}; } #------------------------------------------------------------------------------ # Subroutine is_prefix # Purpose : Check if range of IPs is a prefix # Returns : boolean sub is_prefix { my $self = shift; return $self->{is_prefix}; } #------------------------------------------------------------------------------ # Subroutine binmask # Purpose : Return the binary mask of an IP prefix # Returns : Binary mask (as string) sub binmask { my $self = shift; return $self->{binmask}; } #------------------------------------------------------------------------------ # Subroutine size # Purpose : Return the number of addresses contained in an IP object # Returns : Number of addresses sub size { my $self = shift; my $size = new Math::BigInt($self->last_int); $size->badd(1); $size->bsub($self->intip); } # All the following functions work the same way: the method is just a frontend # to the real function. When the real function is called, the output is cached # so that next time the same function is called,the frontend function directly # returns the result. #------------------------------------------------------------------------------ # Subroutine intip # Purpose : Return the IP in integer format # Returns : Integer sub intip { my $self = shift; return ($self->{intformat}) if defined($self->{intformat}); my $int = ip_bintoint($self->binip()); # this then fails for 0.0.0.0 , which is wrong. # if (not defined $int) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } $self->{intformat} = $int; return ($int); } #------------------------------------------------------------------------------ # Subroutine hexip # Purpose : Return the IP in hex format # Returns : hex string sub hexip { my $self = shift; return $self->{'hexformat'} if(defined($self->{'hexformat'})); $self->{'hexformat'} = $self->intip->as_hex(); return $self->{'hexformat'}; } #------------------------------------------------------------------------------ # Subroutine hexmask # Purpose : Return the mask back in hex # Returns : hex string sub hexmask { my $self = shift; return $self->{hexmask} if(defined($self->{hexmask})); my $intmask = ip_bintoint($self->binmask); $self->{'hexmask'} = $intmask->as_hex(); return ($self->{'hexmask'}); } #------------------------------------------------------------------------------ # Subroutine prefix # Purpose : Return the Prefix (n.n.n.n/s) # Returns : IP Prefix sub prefix { my $self = shift; if (not $self->is_prefix()) { $self->{error} = "IP range $self->{ip} is not a Prefix."; $self->{errno} = 209; return; } return ($self->{prefix}) if defined($self->{prefix}); my $prefix = $self->ip() . '/' . $self->prefixlen(); if (!$prefix) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } $self->{prefix} = $prefix; return ($prefix); } #------------------------------------------------------------------------------ # Subroutine mask # Purpose : Return the IP mask in quad format # Returns : Mask (string) sub mask { my $self = shift; if (not $self->is_prefix()) { $self->{error} = "IP range $self->{ip} is not a Prefix."; $self->{errno} = 209; return; } return ($self->{mask}) if defined($self->{mask}); my $mask = ip_bintoip($self->binmask(), $self->version()); if (!$mask) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } $self->{mask} = $mask; return ($mask); } #------------------------------------------------------------------------------ # Subroutine short # Purpose : Get the short format of an IP address or a Prefix # Returns : short format IP or undef sub short { my $self = shift; my $r; if ($self->version == 6) { $r = ip_compress_address($self->ip(), $self->version()); } else { $r = ip_compress_v4_prefix($self->ip(), $self->prefixlen()); } if (!defined($r)) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } return ($r); } #------------------------------------------------------------------------------ # Subroutine iptype # Purpose : Return the type of an IP # Returns : Type or undef (failure) sub iptype { my ($self) = shift; return ($self->{iptype}) if defined($self->{iptype}); my $type = ip_iptype($self->binip(), $self->version()); if (!$type) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } $self->{iptype} = $type; return ($type); } #------------------------------------------------------------------------------ # Subroutine reverse_ip # Purpose : Return the Reverse IP # Returns : Reverse IP or undef(failure) sub reverse_ip { my ($self) = shift; if (not $self->is_prefix()) { $self->{error} = "IP range $self->{ip} is not a Prefix."; $self->{errno} = 209; return; } return ($self->{reverse_ip}) if defined($self->{reverse_ip}); my $rev = ip_reverse($self->ip(), $self->prefixlen(), $self->version()); if (!$rev) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } $self->{reverse_ip} = $rev; return ($rev); } #------------------------------------------------------------------------------ # Subroutine last_bin # Purpose : Get the last IP of a range in binary format # Returns : Last binary IP or undef (failure) sub last_bin { my ($self) = shift; return ($self->{last_bin}) if defined($self->{last_bin}); my $last; if ($self->is_prefix()) { $last = ip_last_address_bin($self->binip(), $self->prefixlen(), $self->version()); } else { $last = ip_iptobin($self->last_ip(), $self->version()); } if (!$last) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } $self->{last_bin} = $last; return ($last); } #------------------------------------------------------------------------------ # Subroutine last_int # Purpose : Get the last IP of a range in integer format # Returns : Last integer IP or undef (failure) sub last_int { my ($self) = shift; return ($self->{last_int}) if defined($self->{last_int}); my $last_bin = $self->last_bin(); return unless defined $last_bin; my $last_int = ip_bintoint($last_bin, $self->version()); return unless defined $last_int; $self->{last_int} = $last_int; return ($last_int); } #------------------------------------------------------------------------------ # Subroutine last_ip # Purpose : Get the last IP of a prefix in IP format # Returns : IP or undef (failure) sub last_ip { my ($self) = shift; return ($self->{last_ip}) if defined($self->{last_ip}); my $last = ip_bintoip($self->last_bin(), $self->version()); if (!$last) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } $self->{last_ip} = $last; return ($last); } #------------------------------------------------------------------------------ # Subroutine find_prefixes # Purpose : Get all prefixes in the range defined by two IPs # Params : IP # Returns : List of prefixes or undef (failure) sub find_prefixes { my ($self) = @_; my @list = ip_range_to_prefix($self->binip(), $self->last_bin(), $self->version()); if (!scalar(@list)) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } return (@list); } #------------------------------------------------------------------------------ # Subroutine bincomp # Purpose : Compare two IPs # Params : Operation, IP to compare # Returns : 1 (True), 0 (False) or undef (problem) # Comments : Operation can be lt, le, gt, ge sub bincomp { my ($self, $op, $other) = @_; my $a = ip_bincomp($self->binip(), $op, $other->binip()); unless (defined $a) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } return ($a); } #------------------------------------------------------------------------------ # Subroutine binadd # Purpose : Add two IPs # Params : IP to add # Returns : New IP object or undef (failure) sub binadd { my ($self, $other) = @_; my $ip = ip_binadd($self->binip(), $other->binip()); if (!$ip) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } my $new = new Net::IP(ip_bintoip($ip, $self->version())) or return; return ($new); } #------------------------------------------------------------------------------ # Subroutine aggregate # Purpose : Aggregate (append) two IPs # Params : IP to add # Returns : New IP object or undef (failure) sub aggregate { my ($self, $other) = @_; my $r = ip_aggregate( $self->binip(), $self->last_bin(), $other->binip(), $other->last_bin(), $self->version() ); if (!$r) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } return (new Net::IP($r)); } #------------------------------------------------------------------------------ # Subroutine overlaps # Purpose : Check if two prefixes overlap # Params : Prefix to compare # Returns : $NO_OVERLAP (no overlap) # $IP_PARTIAL_OVERLAP (overlap) # $IP_A_IN_B_OVERLAP (range1 is included in range2) # $IP_B_IN_A_OVERLAP (range2 is included in range1) # $IP_IDENTICAL (range1 == range2) # or undef (problem) sub overlaps { my ($self, $other) = @_; my $r = ip_is_overlap( $self->binip(), $self->last_bin(), $other->binip(), $other->last_bin() ); if (!defined($r)) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } return ($r); } #------------------------------------------------------------------------------ # Subroutine auth # Purpose : Return Authority information from IP::Authority # Params : IP object # Returns : Authority Source sub auth { my ($self) = shift; return ($self->{auth}) if defined($self->{auth}); my $auth = ip_auth($self->ip, $self->version); if (!$auth) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } $self->{auth} = $auth; return ($self->{auth}); } #------------------------------ PROCEDURAL INTERFACE -------------------------- #------------------------------------------------------------------------------ # Subroutine Error # Purpose : Return the ERROR string # Returns : string sub Error { return ($ERROR); } #------------------------------------------------------------------------------ # Subroutine Error # Purpose : Return the ERRNO value # Returns : number sub Errno { return ($ERRNO); } #------------------------------------------------------------------------------ # Subroutine ip_iplengths # Purpose : Get the length in bits of an IP from its version # Params : IP version # Returns : Number of bits sub ip_iplengths { my ($version) = @_; if ($version == 4) { return (32); } elsif ($version == 6) { return (128); } else { return; } } #------------------------------------------------------------------------------ # Subroutine ip_iptobin # Purpose : Transform an IP address into a bit string # Params : IP address, IP version # Returns : bit string on success, undef otherwise sub ip_iptobin { my ($ip, $ipversion) = @_; # v4 -> return 32-bit array if ($ipversion == 4) { return unpack('B32', pack('C4C4C4C4', split(/\./, $ip))); } # Strip ':' $ip =~ s/://g; # Check size unless (length($ip) == 32) { $ERROR = "Bad IP address $ip"; $ERRNO = 102; return; } # v6 -> return 128-bit array return unpack('B128', pack('H32', $ip)); } #------------------------------------------------------------------------------ # Subroutine ip_bintoip # Purpose : Transform a bit string into an IP address # Params : bit string, IP version # Returns : IP address on success, undef otherwise sub ip_bintoip { my ($binip, $ip_version) = @_; # Define normal size for address my $len = ip_iplengths($ip_version); if ($len < length($binip)) { $ERROR = "Invalid IP length for binary IP $binip\n"; $ERRNO = 189; return; } # Prepend 0s if address is less than normal size $binip = '0' x ($len - length($binip)) . $binip; # IPv4 if ($ip_version == 4) { return join '.', unpack('C4C4C4C4', pack('B32', $binip)); } # IPv6 return join(':', unpack('H4H4H4H4H4H4H4H4', pack('B128', $binip))); } #------------------------------------------------------------------------------ # Subroutine ip_bintoint # Purpose : Transform a bit string into an Integer # Params : bit string # Returns : BigInt sub ip_bintoint { my $binip = shift; # $n is the increment, $dec is the returned value my ($n, $dec) = (Math::BigInt->new(1), Math::BigInt->new(0)); # Reverse the bit string foreach (reverse(split '', $binip)) { # If the nth bit is 1, add 2**n to $dec $_ and $dec += $n; $n *= 2; } # Strip leading + sign $dec =~ s/^\+//; return $dec; } #------------------------------------------------------------------------------ # Subroutine ip_inttobin # Purpose : Transform a BigInt into a bit string # Comments : sets warnings (-w) off. # This is necessary because Math::BigInt is not compliant # Params : BigInt, IP version # Returns : bit string sub ip_inttobin { my $dec = Math::BigInt->new(shift); # Find IP version my $ip_version = shift; unless ($ip_version) { $ERROR = "Cannot determine IP version for $dec"; $ERRNO = 101; return; } my $binip = $dec->as_bin(); $binip =~ s/^0b//; # Define normal size for address my $len = ip_iplengths($ip_version); # Prepend 0s if result is less than normal size $binip = '0' x ($len - length($binip)) . $binip; return $binip; } #------------------------------------------------------------------------------ # Subroutine ip_get_version # Purpose : Get an IP version # Params : IP address # Returns : 4, 6, 0(don't know) sub ip_get_version { my $ip = shift; # If the address does not contain any ':', maybe it's IPv4 $ip !~ /:/ and ip_is_ipv4($ip) and return '4'; # Is it IPv6 ? ip_is_ipv6($ip) and return '6'; return; } #------------------------------------------------------------------------------ # Subroutine ip_is_ipv4 # Purpose : Check if an IP address is version 4 # Params : IP address # Returns : 1 (yes) or 0 (no) sub ip_is_ipv4 { my $ip = shift; # Check for invalid chars unless ($ip =~ m/^[\d\.]+$/) { $ERROR = "Invalid chars in IP $ip"; $ERRNO = 107; return 0; } if ($ip =~ m/^\./) { $ERROR = "Invalid IP $ip - starts with a dot"; $ERRNO = 103; return 0; } if ($ip =~ m/\.$/) { $ERROR = "Invalid IP $ip - ends with a dot"; $ERRNO = 104; return 0; } # Single Numbers are considered to be IPv4 if ($ip =~ m/^(\d+)$/ and $1 < 256) { return 1 } # Count quads my $n = ($ip =~ tr/\./\./); # IPv4 must have from 1 to 4 quads unless ($n >= 0 and $n < 4) { $ERROR = "Invalid IP address $ip"; $ERRNO = 105; return 0; } # Check for empty quads if ($ip =~ m/\.\./) { $ERROR = "Empty quad in IP address $ip"; $ERRNO = 106; return 0; } foreach (split /\./, $ip) { # Check for invalid quads unless ($_ >= 0 and $_ < 256) { $ERROR = "Invalid quad in IP address $ip - $_"; $ERRNO = 107; return 0; } } return 1; } #------------------------------------------------------------------------------ # Subroutine ip_is_ipv6 # Purpose : Check if an IP address is version 6 # Params : IP address # Returns : 1 (yes) or 0 (no) sub ip_is_ipv6 { my $ip = shift; # Count octets my $n = ($ip =~ tr/:/:/); return 0 unless ($n > 0 and $n < 8); # $k is a counter my $k; foreach (split /:/, $ip) { $k++; # Empty octet ? next if ($_ eq ''); # Normal v6 octet ? next if (/^[a-f\d]{1,4}$/i); # Last octet - is it IPv4 ? if ( ($k == $n + 1) && ip_is_ipv4($_) ) { $n++; # ipv4 is two octets next; } $ERROR = "Invalid IP address $ip"; $ERRNO = 108; return 0; } # Does the IP address start with : ? if ($ip =~ m/^:[^:]/) { $ERROR = "Invalid address $ip (starts with :)"; $ERRNO = 109; return 0; } # Does the IP address finish with : ? if ($ip =~ m/[^:]:$/) { $ERROR = "Invalid address $ip (ends with :)"; $ERRNO = 110; return 0; } # Does the IP address have more than one '::' pattern ? if ($ip =~ s/:(?=:)/:/g > 1) { $ERROR = "Invalid address $ip (More than one :: pattern)"; $ERRNO = 111; return 0; } # number of octets if ($n != 7 && $ip !~ /::/) { $ERROR = "Invalid number of octets $ip"; $ERRNO = 112; return 0; } # valid IPv6 address return 1; } #------------------------------------------------------------------------------ # Subroutine ip_expand_address # Purpose : Expand an address from compact notation # Params : IP address, IP version # Returns : expanded IP address or undef on failure sub ip_expand_address { my ($ip, $ip_version) = @_; unless ($ip_version) { $ERROR = "Cannot determine IP version for $ip"; $ERRNO = 101; return; } # v4 : add .0 for missing quads if ($ip_version == 4) { my @quads = split /\./, $ip; # check number of quads if (scalar(@quads) > 4) { $ERROR = "Not a valid IPv address $ip"; $ERRNO = 102; return; } my @clean_quads = (0, 0, 0, 0); foreach my $q (reverse @quads) { #check quad data if ($q !~ m/^\d{1,3}$/) { $ERROR = "Not a valid IPv4 address $ip"; $ERRNO = 102; return; } # build clean ipv4 unshift(@clean_quads, $q + 1 - 1); } return (join '.', @clean_quads[ 0 .. 3 ]); } # Keep track of :: my $num_of_double_colon = ($ip =~ s/::/:!:/g); if ($num_of_double_colon > 1) { $ERROR = "Too many :: in ip"; $ERRNO = 102; return; } # IP as an array my @ip = split /:/, $ip; # Number of octets my $num = scalar(@ip); foreach (0 .. (scalar(@ip) - 1)) { # Embedded IPv4 if ($ip[$_] =~ /\./) { # Expand Ipv4 address # Convert into binary # Convert into hex # Keep the last two octets $ip[$_] = substr( ip_bintoip( ip_iptobin( ip_expand_address($ip[$_], 4), 4), 6), -9); # Has an error occured here ? return unless (defined($ip[$_])); # $num++ because we now have one more octet: # IPv4 address becomes two octets $num++; next; } # Add missing trailing 0s $ip[$_] = ('0' x (4 - length($ip[$_]))) . $ip[$_]; } # Now deal with '::' ('000!') foreach (0 .. (scalar(@ip) - 1)) { # Find the pattern next unless ($ip[$_] eq '000!'); # @empty is the IP address 0 my @empty = map { $_ = '0' x 4 } (0 .. 7); # Replace :: with $num '0000' octets $ip[$_] = join ':', @empty[ 0 .. 8 - $num ]; last; } return (lc(join ':', @ip)); } #------------------------------------------------------------------------------ # Subroutine ip_get_mask # Purpose : Get IP mask from prefix length. # Params : Prefix length, IP version # Returns : Binary Mask sub ip_get_mask { my ($len, $ip_version) = @_; unless ($ip_version) { $ERROR = "Cannot determine IP version"; $ERRNO = 101; return; } my $size = ip_iplengths($ip_version); # mask is $len 1s plus the rest as 0s return (('1' x $len) . ('0' x ($size - $len))); } #------------------------------------------------------------------------------ # Subroutine ip_last_address_bin # Purpose : Return the last binary address of a range # Params : First binary IP, prefix length, IP version # Returns : Binary IP sub ip_last_address_bin { my ($binip, $len, $ip_version) = @_; unless ($ip_version) { $ERROR = "Cannot determine IP version"; $ERRNO = 101; return; } my $size = ip_iplengths($ip_version); # Find the part of the IP address which will not be modified $binip = substr($binip, 0, $len); # Fill with 1s the variable part return ($binip . ('1' x ($size - length($binip)))); } #------------------------------------------------------------------------------ # Subroutine ip_splitprefix # Purpose : Split a prefix into IP and prefix length # Comments : If it was passed a simple IP, it just returns it # Params : Prefix # Returns : IP, optionally length of prefix sub ip_splitprefix { my $prefix = shift; # Find the '/' return unless ($prefix =~ m!^([^/]+?)(/\d+)?$!); my ($ip, $len) = ($1, $2); defined($len) and $len =~ s!/!!; return ($ip, $len); } #------------------------------------------------------------------------------ # Subroutine ip_prefix_to_range # Purpose : Get a range from a prefix # Params : IP, Prefix length, IP version # Returns : First IP, last IP sub ip_prefix_to_range { my ($ip, $len, $ip_version) = @_; unless ($ip_version) { $ERROR = "Cannot determine IP version"; $ERRNO = 101; return; } # Expand the first IP address $ip = ip_expand_address($ip, $ip_version); # Turn into a binary # Get last address # Turn into an IP my $binip = ip_iptobin($ip, $ip_version) ; return unless defined $binip; return unless (ip_check_prefix($binip, $len, $ip_version)); my $lastip = ip_last_address_bin($binip, $len, $ip_version); return unless defined $lastip; return unless ($lastip = ip_bintoip($lastip, $ip_version)); return ($ip, $lastip); } #------------------------------------------------------------------------------ # Subroutine ip_is_valid_mask # Purpose : Check the validity of an IP mask (11110000) # Params : Mask # Returns : 1 or undef (invalid) sub ip_is_valid_mask { my ($mask, $ip_version) = @_; unless ($ip_version) { $ERROR = "Cannot determine IP version for $mask"; $ERRNO = 101; return; } my $len = ip_iplengths($ip_version); if (length($mask) != $len) { $ERROR = "Invalid mask length for $mask"; $ERRNO = 150; return; } # The mask should be of the form 111110000000 unless ($mask =~ m/^1*0*$/) { $ERROR = "Invalid mask $mask"; $ERRNO = 151; return; } return 1; } #------------------------------------------------------------------------------ # Subroutine ip_bincomp # Purpose : Compare binary Ips with <, >, <=, >= # Comments : Operators are lt(<), le(<=), gt(>), and ge(>=) # Params : First binary IP, operator, Last binary Ip # Returns : 1 (yes), 0 (no), or undef (problem) sub ip_bincomp { my ($begin, $op, $end) = @_; my ($b, $e); if ($op =~ /^l[te]$/) # Operator is lt or le { ($b, $e) = ($end, $begin); } elsif ($op =~ /^g[te]$/) # Operator is gt or ge { ($b, $e) = ($begin, $end); } else { $ERROR = "Invalid Operator $op\n"; $ERRNO = 131; return; } # le or ge -> return 1 if IPs are identical return (1) if ($op =~ /e/ and ($begin eq $end)); # Check IP sizes unless (length($b) eq length($e)) { $ERROR = "IP addresses of different length\n"; $ERRNO = 130; return; } my $c; # Foreach bit for (0 .. length($b) - 1) { # substract the two bits $c = substr($b, $_, 1) - substr($e, $_, 1); # Check the result return (1) if ($c == 1); return (0) if ($c == -1); } # IPs are identical return 0; } #------------------------------------------------------------------------------ # Subroutine ip_binadd # Purpose : Add two binary IPs # Params : First binary IP, Last binary Ip # Returns : Binary sum or undef (problem) sub ip_binadd { my ($b, $e) = @_; # Check IP length unless (length($b) eq length($e)) { $ERROR = "IP addresses of different length\n"; $ERRNO = 130; return; } # Reverse the two IPs $b = scalar(reverse $b); $e = scalar(reverse $e); my ($carry, $result, $c) = (0); # Foreach bit (reversed) for (0 .. length($b) - 1) { # add the two bits plus the carry $c = substr($b, $_, 1) + substr($e, $_, 1) + $carry; $carry = 0; # sum = 0 => $c = 0, $carry = 0 # sum = 1 => $c = 1, $carry = 0 # sum = 2 => $c = 0, $carry = 1 # sum = 3 => $c = 1, $carry = 1 if ($c > 1) { $c -= 2; $carry = 1; } $result .= $c; } # Reverse result return scalar(reverse($result)); } #------------------------------------------------------------------------------ # Subroutine ip_get_prefix_length # Purpose : Get the prefix length for a given range of IPs # Params : First binary IP, Last binary IP # Returns : Length of prefix or undef (problem) sub ip_get_prefix_length { my ($bin1, $bin2) = @_; # Check length of IPs unless (length($bin1) eq length($bin2)) { $ERROR = "IP addresses of different length\n"; $ERRNO = 130; return; } # reverse IPs $bin1 = scalar(reverse $bin1); $bin2 = scalar(reverse $bin2); # foreach bit for (0 .. length($bin1) - 1) { # If bits are equal it means we have reached the longest prefix return ("$_") if (substr($bin1, $_, 1) eq substr($bin2, $_, 1)); } # Return 32 (IPv4) or 128 (IPv6) return length($bin1); } #------------------------------------------------------------------------------ # Subroutine ip_range_to_prefix # Purpose : Return all prefixes between two IPs # Params : First IP, Last IP, IP version # Returns : List of Prefixes or undef (problem) sub ip_range_to_prefix { my ($binip, $endbinip, $ip_version) = @_; unless ($ip_version) { $ERROR = "Cannot determine IP version"; $ERRNO = 101; return; } unless (length($binip) eq length($endbinip)) { $ERROR = "IP addresses of different length\n"; $ERRNO = 130; return; } my ($len, $nbits, $current, $add, @prefix); # 1 in binary my $one = ('0' x (ip_iplengths($ip_version) - 1)) . '1'; # While we have not reached the last IP while (ip_bincomp($binip, 'le', $endbinip) == 1) { # Find all 0s at the end if ($binip =~ m/(0+)$/) { # nbits = nb of 0 bits $nbits = length($1); } else { $nbits = 0; } do { $current = $binip; $add = '1' x $nbits; # Replace $nbits 0s with 1s $current =~ s/0{$nbits}$/$add/; $nbits--; # Decrease $nbits if $current >= $endbinip } while (ip_bincomp($current, 'le', $endbinip) != 1); # Find Prefix length $len = (ip_iplengths($ip_version)) - ip_get_prefix_length($binip, $current); # Push prefix in list push(@prefix, ip_bintoip($binip, $ip_version) . "/$len"); # Add 1 to current IP $binip = ip_binadd($current, $one); # Exit if IP is 32/128 1s last if ($current =~ m/^1+$/); } return (@prefix); } #------------------------------------------------------------------------------ # Subroutine ip_compress_v4_prefix # Purpose : Compress an IPv4 Prefix # Params : IP, Prefix length # Returns : Compressed IP - ie: 194.5 sub ip_compress_v4_prefix { my ($ip, $len) = @_; my @quads = split /\./, $ip; my $qlen = int(($len - 1) / 8); $qlen = 0 if ($qlen < 0); my $newip = join '.', @quads[ 0 .. $qlen ]; return ($newip); } #------------------------------------------------------------------------------ # Subroutine ip_compress_address # Purpose : Compress an IPv6 address # Params : IP, IP version # Returns : Compressed IP or undef (problem) sub ip_compress_address { my ($ip, $ip_version) = @_; unless ($ip_version) { $ERROR = "Cannot determine IP version for $ip"; $ERRNO = 101; return; } # Just return if IP is IPv4 return ($ip) if ($ip_version == 4); # already compressed addresses must be expanded first $ip = ip_expand_address( $ip, $ip_version); # Remove leading 0s: 0034 -> 34; 0000 -> 0 $ip =~ s/ (^|:) # Find beginning or ':' -> $1 0+ # 1 or several 0s (?= # Look-ahead [a-fA-F\d]+ # One or several Hexs (?::|$)) # ':' or end /$1/gx; my $reg = ''; # Find the longuest :0:0: sequence while ( $ip =~ m/ ((?:^|:) # Find beginning or ':' -> $1 0(?::0)+ # 0 followed by 1 or several ':0' (?::|$)) # ':' or end /gx ) { $reg = $1 if (length($reg) < length($1)); } # Replace sequence by '::' $ip =~ s/$reg/::/ if ($reg ne ''); return $ip; } #------------------------------------------------------------------------------ # Subroutine ip_is_overlap # Purpose : Check if two ranges overlap # Params : Four binary IPs (begin of range 1,end1,begin2,end2) # Returns : $NO_OVERLAP (no overlap) # $IP_PARTIAL_OVERLAP (overlap) # $IP_A_IN_B_OVERLAP (range1 is included in range2) # $IP_B_IN_A_OVERLAP (range2 is included in range1) # $IP_IDENTICAL (range1 == range2) # or undef (problem) sub ip_is_overlap { my ($b1, $e1, $b2, $e2) = (@_); my $swap; $swap = 0; unless ((length($b1) eq length($e1)) and (length($b2) eq length($e2)) and (length($b1) eq length($b2))) { $ERROR = "IP addresses of different length\n"; $ERRNO = 130; return; } # begin1 <= end1 ? unless (ip_bincomp($b1, 'le', $e1) == 1) { $ERROR = "Invalid range $b1 - $e1"; $ERRNO = 140; return; } # begin2 <= end2 ? unless (ip_bincomp($b2, 'le', $e2) == 1) { $ERROR = "Invalid range $b2 - $e2"; $ERRNO = 140; return; } # b1 == b2 ? if ($b1 eq $b2) { # e1 == e2 return ($IP_IDENTICAL) if ($e1 eq $e2); # e1 < e2 ? return ( ip_bincomp($e1, 'lt', $e2) ? $IP_A_IN_B_OVERLAP : $IP_B_IN_A_OVERLAP ); } # e1 == e2 ? if ($e1 eq $e2) { # b1 < b2 return ( ip_bincomp($b1, 'lt', $b2) ? $IP_B_IN_A_OVERLAP : $IP_A_IN_B_OVERLAP ); } # b1 < b2 if ((ip_bincomp($b1, 'lt', $b2) == 1)) { # e1 < b2 return ($IP_NO_OVERLAP) if (ip_bincomp($e1, 'lt', $b2) == 1); # e1 < e2 ? return ( ip_bincomp($e1, 'lt', $e2) ? $IP_PARTIAL_OVERLAP : $IP_B_IN_A_OVERLAP ); } else # b1 > b2 { # e2 < b1 return ($IP_NO_OVERLAP) if (ip_bincomp($e2, 'lt', $b1) == 1); # e2 < e1 ? return ( ip_bincomp($e2, 'lt', $e1) ? $IP_PARTIAL_OVERLAP : $IP_A_IN_B_OVERLAP ); } } #------------------------------------------------------------------------------ # Subroutine get_embedded_ipv4 # Purpose : Get an IPv4 embedded in an IPv6 address # Params : IPv6 # Returns : IPv4 or undef (not found) sub ip_get_embedded_ipv4 { my $ipv6 = shift; my @ip = split /:/, $ipv6; # Bugfix by Norbert Koch return unless (@ip); # last octet should be ipv4 return ($ip[-1]) if (ip_is_ipv4($ip[-1])); return; } #------------------------------------------------------------------------------ # Subroutine aggregate # Purpose : Aggregate 2 ranges # Params : 1st range (1st IP, Last IP), last range (1st IP, last IP), # IP version # Returns : prefix or undef (invalid) sub ip_aggregate { my ($binbip1, $bineip1, $binbip2, $bineip2, $ip_version) = @_; unless ($ip_version) { $ERROR = "Cannot determine IP version for $binbip1"; $ERRNO = 101; return; } # Bin 1 my $one = (('0' x (ip_iplengths($ip_version) - 1)) . '1'); # $eip1 + 1 = $bip2 ? unless (ip_binadd($bineip1, $one) eq $binbip2) { $ERROR = "Ranges not contiguous - $bineip1 - $binbip2"; $ERRNO = 160; return; } # Get ranges my @prefix = ip_range_to_prefix($binbip1, $bineip2, $ip_version); # There should be only one range return if scalar(@prefix) < 1; if (scalar(@prefix) > 1) { $ERROR = "$binbip1 - $bineip2 is not a single prefix"; $ERRNO = 161; return; } return ($prefix[0]); } #------------------------------------------------------------------------------ # Subroutine ip_iptype # Purpose : Return the type of an IP (Public, Private, Reserved) # Params : IP to test, IP version # Returns : type or undef (invalid) sub ip_iptype { my ($ip, $ip_version) = @_; # handle known ip versions return ip_iptypev4($ip) if $ip_version == 4; return ip_iptypev6($ip) if $ip_version == 6; # unsupported ip version $ERROR = "IP version $ip not supported"; $ERRNO = 180; return; } #------------------------------------------------------------------------------ # Subroutine ip_iptypev4 # Purpose : Return the type of an IP (Public, Private, Reserved) # Params : IP to test, IP version # Returns : type or undef (invalid) sub ip_iptypev4 { my ($ip) = @_; # check ip if ($ip !~ m/^[01]{1,32}$/) { $ERROR = "$ip is not a binary IPv4 address $ip"; $ERRNO = 180; return; } # see if IP is listed foreach (sort { length($b) <=> length($a) } keys %IPv4ranges) { return ($IPv4ranges{$_}) if ($ip =~ m/^$_/); } # not listed means IP is public return 'PUBLIC'; } #------------------------------------------------------------------------------ # Subroutine ip_iptypev6 # Purpose : Return the type of an IP (Public, Private, Reserved) # Params : IP to test, IP version # Returns : type or undef (invalid) sub ip_iptypev6 { my ($ip) = @_; # check ip if ($ip !~ m/^[01]{1,128}$/) { $ERROR = "$ip is not a binary IPv6 address"; $ERRNO = 180; return; } foreach (sort { length($b) <=> length($a) } keys %IPv6ranges) { return ($IPv6ranges{$_}) if ($ip =~ m/^$_/); } # How did we get here? All IPv6 addresses should match $ERROR = "Cannot determine type for $ip"; $ERRNO = 180; return; } #------------------------------------------------------------------------------ # Subroutine ip_check_prefix # Purpose : Check the validity of a prefix # Params : binary IP, length of prefix, IP version # Returns : 1 or undef (invalid) sub ip_check_prefix { my ($binip, $len, $ipversion) = (@_); # Check if len is longer than IP if ($len > length($binip)) { $ERROR = "Prefix length $len is longer than IP address (" . length($binip) . ")"; $ERRNO = 170; return; } my $rest = substr($binip, $len); # Check if last part of the IP (len part) has only 0s unless ($rest =~ /^0*$/) { $ERROR = "Invalid prefix $binip/$len"; $ERRNO = 171; return; } # Check if prefix length is correct unless (length($rest) + $len == ip_iplengths($ipversion)) { $ERROR = "Invalid prefix length /$len"; $ERRNO = 172; return; } return 1; } #------------------------------------------------------------------------------ # Subroutine ip_reverse # Purpose : Get a reverse name from a prefix # Comments : From Lee's iplib.pm # Params : IP, length of prefix, IP version # Returns : Reverse name or undef (error) sub ip_reverse { my ($ip, $len, $ip_version) = (@_); $ip_version ||= ip_get_version($ip); unless ($ip_version) { $ERROR = "Cannot determine IP version for $ip"; $ERRNO = 101; return; } if ($ip_version == 4) { my @quads = split /\./, $ip; my $no_quads = 4 - int($len / 8); my @reverse_quads = reverse @quads; while (@reverse_quads and $reverse_quads[0] == 0 and $no_quads > 0) { shift(@reverse_quads); --$no_quads; } return join '.', @reverse_quads, 'in-addr', 'arpa.'; } elsif ($ip_version == 6) { my @rev_groups = reverse split /:/, ip_expand_address($ip, 6); my @result; foreach (@rev_groups) { my @revhex = reverse split //; push @result, @revhex; } # This takes the zone above if it's not exactly on a nibble my $first_nibble_index = $len ? 32 - (int($len / 4)) : 0; return join '.', @result[ $first_nibble_index .. $#result ], 'ip6', 'arpa.'; } } #------------------------------------------------------------------------------ # Subroutine ip_normalize # Purpose : Normalize data to a range of IP addresses # Params : IP or prefix or range # Returns : ip1, ip2 (if range) or undef (error) sub ip_normalize { my ($data) = shift; my $ipversion; my ($len, $ip, $ip2, $real_len, $first, $last, $curr_bin, $addcst, $clen); # Prefix if ($data =~ m!^(\S+?)(/\S+)$!) { ($ip, $len) = ($1, $2); return unless ($ipversion = ip_get_version($ip)); return unless ($ip = ip_expand_address($ip, $ipversion)); return unless ($curr_bin = ip_iptobin($ip, $ipversion)); my $one = '0' x (ip_iplengths($ipversion) - 1) . '1'; while ($len) { last unless ($len =~ s!^/(\d+)(\,|$)!!); $clen = $1; $addcst = length($2) > 0; return unless (ip_check_prefix($curr_bin, $clen, $ipversion)); return unless ($curr_bin = ip_last_address_bin($curr_bin, $clen, $ipversion)); if ($addcst) { return unless ($curr_bin = ip_binadd($curr_bin, $one)); } } return ($ip, ip_bintoip($curr_bin, $ipversion)); } # Range elsif ($data =~ /^(.+?)\s*\-\s*(.+)$/) { ($ip, $ip2) = ($1, $2); return unless ($ipversion = ip_get_version($ip)); return unless ($ip = ip_expand_address($ip, $ipversion)); return unless ($ip2 = ip_expand_address($ip2, $ipversion)); return ($ip, $ip2); } # IP + Number elsif ($data =~ /^(.+?)\s+\+\s+(.+)$/) { ($ip, $len) = ($1, $2); return unless ($ipversion = ip_get_version($ip)); return unless ($ip = ip_expand_address($ip, $ipversion)); my ($bin_ip); return unless ($bin_ip = ip_iptobin($ip, $ipversion)); return unless ($len = ip_inttobin($len, $ipversion)); return unless ($ip2 = ip_binadd($bin_ip, $len)); return unless ($ip2 = ip_bintoip($ip2, $ipversion)); return ($ip, $ip2); } # Single IP else { $ip = $data; return unless ($ipversion = ip_get_version($ip)); return unless ($ip = ip_expand_address($ip, $ipversion)); return $ip; } } #------------------------------------------------------------------------------ # Subroutine normal_range # Purpose : Return the normalized format of a range # Params : IP or prefix or range # Returns : "ip1 - ip2" or undef (error) sub ip_normal_range { my ($data) = shift; my ($ip1, $ip2) = ip_normalize($data); return unless ($ip1); $ip2 ||= $ip1; return ("$ip1 - $ip2"); } #------------------------------------------------------------------------------ # Subroutine ip_auth # Purpose : Get Authority information from IP::Authority Module # Comments : Requires IP::Authority # Params : IP, length of prefix # Returns : Reverse name or undef (error) sub ip_auth { my ($ip, $ip_version) = (@_); unless ($ip_version) { $ERROR = "Cannot determine IP version for $ip"; $ERRNO = 101; die; return; } if ($ip_version != 4) { $ERROR = "Cannot get auth information: Not an IPv4 address"; $ERRNO = 308; die; return; } require IP::Authority; my $reg = new IP::Authority; return ($reg->inet_atoauth($ip)); } 1; __END__ =encoding utf8 =head1 NAME Net::IP - Perl extension for manipulating IPv4/IPv6 addresses =head1 SYNOPSIS use Net::IP; my $ip = new Net::IP ('193.0.1/24') or die (Net::IP::Error()); print ("IP : ".$ip->ip()."\n"); print ("Sho : ".$ip->short()."\n"); print ("Bin : ".$ip->binip()."\n"); print ("Int : ".$ip->intip()."\n"); print ("Mask: ".$ip->mask()."\n"); print ("Last: ".$ip->last_ip()."\n"); print ("Len : ".$ip->prefixlen()."\n"); print ("Size: ".$ip->size()."\n"); print ("Type: ".$ip->iptype()."\n"); print ("Rev: ".$ip->reverse_ip()."\n"); =head1 DESCRIPTION This module provides functions to deal with B addresses. The module can be used as a class, allowing the user to instantiate IP objects, which can be single IP addresses, prefixes, or ranges of addresses. There is also a procedural way of accessing most of the functions. Most subroutines can take either B or B addresses transparently. =head1 OBJECT-ORIENTED INTERFACE =head2 Object Creation A Net::IP object can be created from a single IP address: $ip = new Net::IP ('193.0.1.46') || die ... Or from a Classless Prefix (a /24 prefix is equivalent to a C class): $ip = new Net::IP ('195.114.80/24') || die ... Or from a range of addresses: $ip = new Net::IP ('20.34.101.207 - 201.3.9.99') || die ... Or from a address plus a number: $ip = new Net::IP ('20.34.10.0 + 255') || die ... The new() function accepts IPv4 and IPv6 addresses: $ip = new Net::IP ('dead:beef::/32') || die ... Optionally, the function can be passed the version of the IP. Otherwise, it tries to guess what the version is (see B<_is_ipv4()> and B<_is_ipv6()>). $ip = new Net::IP ('195/8',4); # Class A =head1 OBJECT METHODS Most of these methods are front-ends for the real functions, which use a procedural interface. Most functions return undef on failure, and a true value on success. A detailed description of the procedural interface is provided below. =head2 set Set an IP address in an existing IP object. This method has the same functionality as the new() method, except that it reuses an existing object to store the new IP. C<$ip-Eset('130.23.1/24',4);> Like new(), set() takes two arguments - a string used to build an IP address, prefix, or range, and optionally, the IP version of the considered address. It returns an IP object on success, and undef on failure. =head2 error Return the current object error string. The error string is set whenever one of the methods produces an error. Also, a global, class-wide B function is available. Cerror());> =head2 errno Return the current object error number. The error number is set whenever one of the methods produces an error. Also, a global B<$ERRNO> variable is set when an error is produced. Cerrno());> =head2 ip Return the IP address (or first IP of the prefix or range) in quad format, as a string. Cip());> =head2 binip Return the IP address as a binary string of 0s and 1s. Cbinip());> =head2 prefixlen Return the length in bits of the current prefix. Cprefixlen());> =head2 version Return the version of the current IP object (4 or 6). Cversion());> =head2 size Return the number of IP addresses in the current prefix or range. Use of this function requires Math::BigInt. Csize());> =head2 binmask Return the binary mask of the current prefix, if applicable. Cbinmask());> =head2 mask Return the mask in quad format of the current prefix. Cmask());> =head2 prefix Return the full prefix (ip+prefix length) in quad (standard) format. Cprefix());> =head2 print Print the IP object (IP/Prefix or First - Last) Cprint());> =head2 intip Convert the IP in integer format and return it as a Math::BigInt object. Cintip());> =head2 hexip Return the IP in hex format Chexip());> =head2 hexmask Return the mask in hex format Chexmask());> =head2 short Return the IP in short format: IPv4 addresses: 194.5/16 IPv6 addresses: ab32:f000:: Cshort());> =head2 iptype Return the IP Type - this describes the type of an IP (Public, Private, Reserved, etc.) See procedural interface ip_iptype for more details. Ciptype());> =head2 reverse_ip Return the reverse IP for a given IP address (in.addr. format). Creserve_ip());> =head2 last_ip Return the last IP of a prefix/range in quad format. Clast_ip());> =head2 last_bin Return the last IP of a prefix/range in binary format. Clast_bin());> =head2 last_int Return the last IP of a prefix/range in integer format. Clast_int());> =head2 find_prefixes This function finds all the prefixes that can be found between the two addresses of a range. The function returns a list of prefixes. C<@list = $ip-Efind_prefixes($other_ip));> =head2 bincomp Binary comparaison of two IP objects. The function takes an operation and an IP object as arguments. It returns a boolean value. The operation can be one of: lt: less than (smaller than) le: smaller or equal to gt: greater than ge: greater or equal to Cbincomp('lt',$ip2) {...}> =head2 binadd Binary addition of two IP objects. The value returned is an IP object. Cbinadd($ip2);> =head2 aggregate Aggregate 2 IPs - Append one range/prefix of IPs to another. The last address of the first range must be the one immediately preceding the first address of the second range. A new IP object is returned. Caggregate($ip2);> =head2 overlaps Check if two IP ranges/prefixes overlap each other. The value returned by the function should be one of: $IP_PARTIAL_OVERLAP (ranges overlap) $IP_NO_OVERLAP (no overlap) $IP_A_IN_B_OVERLAP (range2 contains range1) $IP_B_IN_A_OVERLAP (range1 contains range2) $IP_IDENTICAL (ranges are identical) undef (problem) Coverlaps($ip2)==$IP_A_IN_B_OVERLAP) {...};> =head2 looping The C<+> operator is overloaded in order to allow looping though a whole range of IP addresses: my $ip = new Net::IP ('195.45.6.7 - 195.45.6.19') || die; # Loop do { print $ip->ip(), "\n"; } while (++$ip); The ++ operator returns undef when the last address of the range is reached. =head2 auth Return IP authority information from the IP::Authority module C<$auth = ip->auth ();> Note: IPv4 only =head1 PROCEDURAL INTERFACE These functions do the real work in the module. Like the OO methods, most of these return undef on failure. In order to access error codes and strings, instead of using $ip-Eerror() and $ip-Eerrno(), use the global functions C and C. The functions of the procedural interface are not exported by default. In order to import these functions, you need to modify the use statement for the module: C =head2 Error Returns the error string corresponding to the last error generated in the module. This is also useful for the OO interface, as if the new() function fails, we cannot call $ip-Eerror() and so we have to use Error(). warn Error(); =head2 Errno Returns a numeric error code corresponding to the error string returned by Error. =head2 ip_iptobin Transform an IP address into a bit string. Params : IP address, IP version Returns : binary IP string on success, undef otherwise C<$binip = ip_iptobin ($ip,6);> =head2 ip_bintoip Transform a bit string into an IP address Params : binary IP, IP version Returns : IP address on success, undef otherwise C<$ip = ip_bintoip ($binip,6);> =head2 ip_bintoint Transform a bit string into a BigInt. Params : binary IP Returns : BigInt C<$bigint = new Math::BigInt (ip_bintoint($binip));> =head2 ip_inttobin Transform a BigInt into a bit string. I: sets warnings (C<-w>) off. This is necessary because Math::BigInt is not compliant. Params : BigInt, IP version Returns : binary IP C<$binip = ip_inttobin ($bigint);> =head2 ip_get_version Try to guess the IP version of an IP address. Params : IP address Returns : 4, 6, undef(unable to determine) C<$version = ip_get_version ($ip)> =head2 ip_is_ipv4 Check if an IP address is of type 4. Params : IP address Returns : 1 (yes) or 0 (no) C =head2 ip_is_ipv6 Check if an IP address is of type 6. Params : IP address Returns : 1 (yes) or 0 (no) C =head2 ip_expand_address Expand an IP address from compact notation. Params : IP address, IP version Returns : expanded IP address or undef on failure C<$ip = ip_expand_address ($ip,4);> =head2 ip_get_mask Get IP mask from prefix length. Params : Prefix length, IP version Returns : Binary Mask C<$mask = ip_get_mask ($len,6);> =head2 ip_last_address_bin Return the last binary address of a prefix. Params : First binary IP, prefix length, IP version Returns : Binary IP C<$lastbin = ip_last_address_bin ($ip,$len,6);> =head2 ip_splitprefix Split a prefix into IP and prefix length. If it was passed a simple IP, it just returns it. Params : Prefix Returns : IP, optionally length of prefix C<($ip,$len) = ip_splitprefix ($prefix)> =head2 ip_prefix_to_range Get a range of IPs from a prefix. Params : Prefix, IP version Returns : First IP, last IP C<($ip1,$ip2) = ip_prefix_to_range ($prefix,6);> =head2 ip_bincomp Compare binary Ips with <, >, <=, >=. Operators are lt(<), le(<=), gt(>), and ge(>=) Params : First binary IP, operator, Last binary IP Returns : 1 (yes), 0 (no), or undef (problem) C =head2 ip_binadd Add two binary IPs. Params : First binary IP, Last binary IP Returns : Binary sum or undef (problem) C<$binip = ip_binadd ($bin1,$bin2);> =head2 ip_get_prefix_length Get the prefix length for a given range of 2 IPs. Params : First binary IP, Last binary IP Returns : Length of prefix or undef (problem) C<$len = ip_get_prefix_length ($ip1,$ip2);> =head2 ip_range_to_prefix Return all prefixes between two IPs. Params : First IP (binary format), Last IP (binary format), IP version Returns : List of Prefixes or undef (problem) The prefixes returned have the form q.q.q.q/nn. C<@prefix = ip_range_to_prefix ($ip1,$ip2,6);> =head2 ip_compress_v4_prefix Compress an IPv4 Prefix. Params : IP, Prefix length Returns : Compressed Prefix C<$ip = ip_compress_v4_prefix ($ip, $len);> =head2 ip_compress_address Compress an IPv6 address. Just returns the IP if it is an IPv4. Params : IP, IP version Returns : Compressed IP or undef (problem) C<$ip = ip_compress_adress ($ip, $version);> =head2 ip_is_overlap Check if two ranges of IPs overlap. Params : Four binary IPs (begin of range 1,end1,begin2,end2), IP version $IP_PARTIAL_OVERLAP (ranges overlap) $IP_NO_OVERLAP (no overlap) $IP_A_IN_B_OVERLAP (range2 contains range1) $IP_B_IN_A_OVERLAP (range1 contains range2) $IP_IDENTICAL (ranges are identical) undef (problem) C<(ip_is_overlap($rb1,$re1,$rb2,$re2,4) eq $IP_A_IN_B_OVERLAP) and do {};> =head2 ip_get_embedded_ipv4 Get an IPv4 embedded in an IPv6 address Params : IPv6 Returns : IPv4 string or undef (not found) C<$ip4 = ip_get_embedded($ip6);> =head2 ip_check_mask Check the validity of a binary IP mask Params : Mask Returns : 1 or undef (invalid) C Checks if mask has only 1s followed by 0s. =head2 ip_aggregate Aggregate 2 ranges of binary IPs Params : 1st range (1st IP, Last IP), last range (1st IP, last IP), IP version Returns : prefix or undef (invalid) C<$prefix = ip_aggregate ($bip1,$eip1,$bip2,$eip2) || die ...> =head2 ip_iptypev4 Return the type of an IPv4 address. Params: binary IP Returns: type as of the following table or undef (invalid ip) See RFC 5735 and RFC 6598 S
S<-------------------------------------------------------------------> S<0.0.0.0/8 "This" Network RFC 1122 PRIVATE> S<10.0.0.0/8 Private-Use Networks RFC 1918 PRIVATE> S<100.64.0.0/10 CGN Shared Address Space RFC 6598 SHARED> S<127.0.0.0/8 Loopback RFC 1122 LOOPBACK> S<169.254.0.0/16 Link Local RFC 3927 LINK-LOCAL> S<172.16.0.0/12 Private-Use Networks RFC 1918 PRIVATE> S<192.0.0.0/24 IETF Protocol Assignments RFC 5736 RESERVED> S<192.0.2.0/24 TEST-NET-1 RFC 5737 TEST-NET> S<192.88.99.0/24 6to4 Relay Anycast RFC 3068 6TO4-RELAY> S<192.168.0.0/16 Private-Use Networks RFC 1918 PRIVATE> S<198.18.0.0/15 Network Interconnect> S< Device Benchmark Testing RFC 2544 RESERVED> S<198.51.100.0/24 TEST-NET-2 RFC 5737 TEST-NET> S<203.0.113.0/24 TEST-NET-3 RFC 5737 TEST-NET> S<224.0.0.0/4 Multicast RFC 3171 MULTICAST> S<240.0.0.0/4 Reserved for Future Use RFC 1112 RESERVED> S<255.255.255.255/32 Limited Broadcast RFC 919 BROADCAST> S< RFC 922> =head2 ip_iptypev6 Return the type of an IPv6 address. Params: binary ip Returns: type as of the following table or undef (invalid) See L and L S S<-------------------------------------------------------------> S<0000::/8 Reserved by IETF [RFC4291] RESERVED> S<0100::/8 Reserved by IETF [RFC4291] RESERVED> S<0200::/7 Reserved by IETF [RFC4048] RESERVED> S<0400::/6 Reserved by IETF [RFC4291] RESERVED> S<0800::/5 Reserved by IETF [RFC4291] RESERVED> S<1000::/4 Reserved by IETF [RFC4291] RESERVED> S<2000::/3 Global Unicast [RFC4291] GLOBAL-UNICAST> S<4000::/3 Reserved by IETF [RFC4291] RESERVED> S<6000::/3 Reserved by IETF [RFC4291] RESERVED> S<8000::/3 Reserved by IETF [RFC4291] RESERVED> S S S S S S S S S S S S<---------------------------------------------------------------------> S<::1/128 Loopback Address [RFC4291] UNSPECIFIED> S<::/128 Unspecified Address [RFC4291] LOOPBACK> S<::FFFF:0:0/96 IPv4-mapped Address [RFC4291] IPV4MAP> S<0100::/64 Discard-Only Prefix [RFC6666] DISCARD> S<2001:0000::/32 TEREDO [RFC4380] TEREDO> S<2001:0002::/48 BMWG [RFC5180] BMWG> S<2001:db8::/32 Documentation Prefix [RFC3849] DOCUMENTATION> S<2001:10::/28 ORCHID [RFC4843] ORCHID> S<2002::/16 6to4 [RFC3056] 6TO4> S S S =head2 ip_iptype Return the type of an IP (Public, Private, Reserved) Params : Binary IP to test, IP version (defaults to 6) Returns : type (see ip_iptypev4 and ip_iptypev6 for details) or undef (invalid) C<$type = ip_iptype ($ip);> =head2 ip_check_prefix Check the validity of a prefix Params : binary IP, length of prefix, IP version Returns : 1 or undef (invalid) Checks if the variant part of a prefix only has 0s, and the length is correct. C =head2 ip_reverse Get a reverse name from a prefix Params : IP, length of prefix, IP version Returns : Reverse name or undef (error) C<$reverse = ip_reverse ($ip);> =head2 ip_normalize Normalize data to a range/prefix of IP addresses Params : Data String (Single IP, Range, Prefix) Returns : ip1, ip2 (if range/prefix) or undef (error) C<($ip1,$ip2) = ip_normalize ($data);> =head2 ip_auth Return IP authority information from the IP::Authority module Params : IP, version Returns : Auth info (RI for RIPE, AR for ARIN, etc) C<$auth = ip_auth ($ip,4);> Note: IPv4 only =head1 BUGS The Math::BigInt library is needed for functions that use integers. These are ip_inttobin, ip_bintoint, and the size method. In a next version, Math::BigInt will become optional. =head1 AUTHORS Manuel Valente . Original IPv4 code by Monica Cortes Sack . Original IPv6 code by Lee Wilmot . =head1 BASED ON ipv4pack.pm, iplib.pm, iplibncc.pm. =head1 SEE ALSO perl(1), IP::Authority =cut PK!}7EhhDNS/Nameserver.pmnu[PK!BB\hDNS/ZoneFile.pmnu[PK!_:: zDNS/Update.pmnu[PK!@D ) ) DNS/Header.pmnu[PK!ڨ559DNS/Parameters.pmnu[PK! wwz)DNS/Resolver/MSWin32.pmnu[PK!j̾88DNS/Resolver/UNIX.pmnu[PK!J{  :ADNS/Resolver/android.pmnu[PK!TJDNS/Resolver/os390.pmnu[PK!=^QVV\DNS/Resolver/cygwin.pmnu[PK!|U||npDNS/Resolver/Base.pmnu[PK!I\e66jDNS/Resolver/os2.pmnu[PK!a<<DNS/Resolver/Recurse.pmnu[PK!jnqUU f DNS/Text.pmnu[PK!4Y4kUkU *DNS/Packet.pmnu[PK!{*RRDNS/Resolver.pmnu[PK!lTT DNS/FAQ.podnu[PK!ovbDNS/DomainName.pmnu[PK!(( nDNS/Domain.pmnu[PK!ȴ!!DNS/Question.pmnu[PK!olBV  @DNS/Mailbox.pmnu[PK!ƅ_ PDNS/RR/EUI48.pmnu[PK!a a ]DNS/RR/AFSDB.pmnu[PK!+V 6 6 dkDNS/RR/OPT.pmnu[PK! DNS/RR/PTR.pmnu[PK!e_/ڬDNS/RR/DHCID.pmnu[PK!3e!!.DNS/RR/NULL.pmnu[PK!+DNS/RR/AAAA.pmnu[PK!]BB{DNS/RR/AMTRELAY.pmnu[PK!QZ DNS/RR/MR.pmnu[PK!]/!4 4 EDNS/RR/X25.pmnu[PK!X~ DNS/RR/L64.pmnu[PK!chS  DNS/RR/L32.pmnu[PK!yO ='DNS/RR/RT.pmnu[PK!VV \6DNS/RR/SIG.pmnu[PK! DNS/RR/HINFO.pmnu[PK!y+kkDNS/RR/ZONEMD.pmnu[PK!{{ DNS/RR/NID.pmnu[PK!iAb\DNS/RR/SMIMEA.pmnu[PK!Q ADNS/RR/LP.pmnu[PK!;x5~DNS/RR/IPSECKEY.pmnu[PK!G,<)<) aDNS/RR/DS.pmnu[PK!oo$DNS/RR/MINFO.pmnu[PK!**p'DNS/RR/SVCB.pmnu[PK!29 QDNS/RR/PX.pmnu[PK!6|  cDNS/RR/OPENPGPKEY.pmnu[PK!X/ ToDNS/RR/APL.pmnu[PK!w 4DNS/RR/TLSA.pmnu[PK! [DNS/RR/HIP.pmnu[PK!lXL3 sDNS/RR/CDNSKEY.pmnu[PK!r? qDNS/RR/MB.pmnu[PK!KxW  DNS/RR/URI.pmnu[PK!` DNS/RR/MX.pmnu[PK!>> > DNS/RR/DNAME.pmnu[PK!? mDNS/RR/EUI64.pmnu[PK! ((SDNS/RR/NSEC.pmnu[PK! DNS/RR/SPF.pmnu[PK!rCl]]*DNS/RR/RRSIG.pmnu[PK!n/ZZ DNS/RR/KX.pmnu[PK!'X~QPQPODNS/RR/TSIG.pmnu[PK!CC DNS/RR/SOA.pmnu[PK!J-tW ^DNS/RR/CDS.pmnu[PK!kyww DNS/RR/SRV.pmnu[PK!zg g E#DNS/RR/NS.pmnu[PK!Ǝ;hh .DNS/RR/CAA.pmnu[PK!vA ?DNS/RR/A.pmnu[PK!|eKDNS/RR/CERT.pmnu[PK!77(eDNS/RR/NSEC3PARAM.pmnu[PK!?[  xDNS/RR/KEY.pmnu[PK! K1K1DNS/RR/NSEC3.pmnu[PK!nMVV nDNS/RR.pmnu[PK!uz?z? DNS.pmnu[PK!7""1J IP.pmnu[PKVV[l