File Coverage

blib/lib/Net/DNS.pm

Criterion	Covered	Total	%
statement	68	68	100.0
branch	22	22	100.0
condition			n/a
subroutine	17	17	100.0
pod	13	13	100.0
total	120	120	100.0

package Net::DNS;

use strict;
use warnings;

our $VERSION;
$VERSION = '1.40';
$VERSION = eval {$VERSION};
our $SVNVERSION = (qw$Id: DNS.pm 1936 2023-08-30 18:05:44Z 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
and the zone file presentation format described in RFC1035.

=cut


use integer;

use base qw(Exporter);
our @EXPORT = qw(SEQUENTIAL UNIXTIME YYYYMMDDxx
		yxrrset nxrrset yxdomain nxdomain rr_add rr_del
		mx rr rrsort);


local $SIG{__DIE__};
require Net::DNS::Resolver;
require Net::DNS::Packet;
require Net::DNS::RR;
require Net::DNS::Update;


sub version { return $VERSION; }


#
# rr()
#
# Usage:
#	@rr = rr('example.com');
#	@rr = rr('example.com', 'A', 'IN');
#	@rr = rr($res, 'example.com' ... );
#
sub rr {
	my @arg = @_;
	my $res = ( ref( $arg[0] ) ? shift @arg : Net::DNS::Resolver->new() );

	my $reply = $res->query(@arg);
	my @list  = $reply ? $reply->answer : ();
	return @list;
}


#
# mx()
#
# Usage:
#	@mx = mx('example.com');
#	@mx = mx($res, 'example.com');
#
sub mx {
	my @arg = @_;
	my @res = ( ref( $arg[0] ) ? shift @arg : () );
	my ( $name, @class ) = @arg;

	# This construct is best read backwards.
	#
	# First we take the answer section of the packet.
	# Then we take just the MX records from that list
	# Then we sort the list by preference
	# We do this into an array to force list context.
	# Then we return the list.

	my @list = sort { $a->preference <=> $b->preference }
			grep { $_->type eq 'MX' } &rr( @res, $name, 'MX', @class );
	return @list;
}


#
# rrsort()
#
# Usage:
#    @prioritysorted = rrsort( "SRV", "priority", @rr_array );
#
sub rrsort {
	my @arg	   = @_;
	my $rrtype = uc shift @arg;
	my ( $attribute, @rr ) = @arg;	## NB: attribute is optional
	( @rr, $attribute ) = @arg if ref($attribute) =~ /^Net::DNS::RR/;

	my @extracted = grep { $_->type eq $rrtype } @rr;
	return @extracted unless scalar @extracted;
	my $func   = "Net::DNS::RR::$rrtype"->get_rrsort_func($attribute);
	my @sorted = sort $func @extracted;
	return @sorted;
}


#
# Auxiliary functions to support policy-driven zone serial numbering.
#
#	$successor = $soa->serial(SEQUENTIAL);
#	$successor = $soa->serial(UNIXTIME);
#	$successor = $soa->serial(YYYYMMDDxx);
#

sub SEQUENTIAL { return (undef) }

sub UNIXTIME { return CORE::time; }

sub YYYYMMDDxx {
	my ( $dd, $mm, $yy ) = (localtime)[3 .. 5];
	return 1900010000 + sprintf '%d%0.2d%0.2d00', $yy, $mm, $dd;
}


#
# Auxiliary functions to support dynamic update.
#

sub yxrrset {
	my @arg = @_;
	my $rr	= Net::DNS::RR->new(@arg);
	$rr->ttl(0);
	$rr->class('ANY') unless $rr->rdata;
	return $rr;
}

sub nxrrset {
	my @arg = @_;
	my $rr	= Net::DNS::RR->new(@arg);
	return Net::DNS::RR->new(
		name  => $rr->name,
		type  => $rr->type,
		class => 'NONE'
		);
}

sub yxdomain {
	my @arg = @_;
	my ( $domain, @etc ) = map {split} @arg;
	my $rr = Net::DNS::RR->new( scalar(@etc) ? @arg : ( name => $domain ) );
	return Net::DNS::RR->new(
		name  => $rr->name,
		type  => 'ANY',
		class => 'ANY'
		);
}

sub nxdomain {
	my @arg = @_;
	my ( $domain, @etc ) = map {split} @arg;
	my $rr = Net::DNS::RR->new( scalar(@etc) ? @arg : ( name => $domain ) );
	return Net::DNS::RR->new(
		name  => $rr->name,
		type  => 'ANY',
		class => 'NONE'
		);
}

sub rr_add {
	my @arg = @_;
	my $rr	= Net::DNS::RR->new(@arg);
	$rr->{ttl} = 86400 unless defined $rr->{ttl};
	return $rr;
}

sub rr_del {
	my @arg = @_;
	my ( $domain, @etc ) = map {split} @arg;
	my $rr = Net::DNS::RR->new( scalar(@etc) ? @arg : ( name => $domain, type => 'ANY' ) );
	$rr->class( $rr->rdata ? 'NONE' : 'ANY' );
	$rr->ttl(0);
	return $rr;
}


1;
__END__