File Coverage

blib/lib/Net/DNS/Resolver/Recurse.pm

Criterion	Covered	Total	%
statement	87	87	100.0
branch	30	30	100.0
path			n/a
condition	2	2	100.0
subroutine	12	12	100.0
pod	3	5	100.0
total	134	136	100.0

package Net::DNS::Resolver::Recurse;

use strict;
use warnings;
our $VERSION = (qw$Id: Recurse.pm 2002 2025-01-07 09:57:46Z willem $)[2];


=head1 NAME

Net::DNS::Resolver::Recurse - DNS recursive resolver


=head1 SYNOPSIS

	use Net::DNS::Resolver::Recurse;

	my $resolver = new Net::DNS::Resolver::Recurse();

	$resolver->hints('198.41.0.4');	# A.ROOT-SERVER.NET.

	my $packet = $resolver->send( 'www.rob.com.au.', 'A' );


=head1 DESCRIPTION

This module resolves queries by following the delegation path from the DNS root.

=cut


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


=head1 METHODS

This module inherits almost all the methods from Net::DNS::Resolver.
Additional module-specific methods are described below.


=head2 hints

This method specifies a list of the IP addresses of nameservers to
be used to discover the addresses of the root nameservers.

	$resolver->hints(@ip);

If no hints are passed, the priming query is directed to nameservers
drawn from a built-in list of IP addresses.

=cut

my @hints;
my $root;

sub hints {
	my ( undef, @argument ) = @_;
	return @hints unless scalar @argument;
	undef $root;
	return @hints = @argument;
}


=head2 query, search, send

The query(), search() and send() methods produce the same result
as their counterparts in Net::DNS::Resolver.

	$packet = $resolver->send( 'www.example.com.', 'A' );

Server-side recursion is suppressed by clearing the recurse flag in
query packets and recursive name resolution is performed explicitly.

The query() and search() methods are inherited from Net::DNS::Resolver
and invoke send() indirectly.

=cut

sub send {
	my ( $self, @q ) = @_;
	my @conf = ( recurse => 0, udppacketsize => 1232 );
	return bless( {persistent => {'.' => $root}, %$self, @conf}, ref($self) )->_send(@q);
}


sub query_dorecursion {			## historical
	my ($self) = @_;					# uncoverable pod
	$self->_deprecate('prefer  $resolver->send(...)');
	return &send;
}


sub _send {
	my ( $self, @q ) = @_;
	my $query = $self->_make_query_packet(@q);

	unless ($root) {
		$self->_diag('resolver priming query');
		$self->nameservers( scalar(@hints) ? @hints : $self->_hints );
		$self->_referral( $self->SUPER::send(qw(. NS)) );
		$root = $self->{persistent}->{'.'};
	}

	return $self->_recurse( $query, '.' );
}


sub _recurse {
	my ( $self, $query, $apex ) = @_;
	$self->_diag("using cached nameservers for $apex");
	my $cache  = $self->{persistent}->{$apex};
	my @nslist = keys %$cache;
	my @glue   = grep { $$cache{$_} } @nslist;
	my @noglue = grep { !$$cache{$_} } @nslist;
	my $reply;
	foreach my $ns ( @glue, @noglue ) {
		if ( my $iplist = $$cache{$ns} ) {
			$self->nameservers(@$iplist);
		} else {
			$self->_diag("recover missing glue for $ns");
			next if substr( lc($ns), -length($apex) ) eq $apex;
			my @ip = $self->nameservers($ns);
			$$cache{$ns} = \@ip;
		}
		$query->header->id(undef);
		last if $reply = $self->SUPER::send($query);
		$$cache{$ns} = undef;				# park non-responder
	}
	$self->_callback($reply);
	return unless $reply;
	my $zone = $self->_referral($reply) || return $reply;
	die '_recurse exceeded depth limit' if $self->{recurse_depth}++ > 50;
	my $qname  = lc( ( $query->question )[0]->qname );
	my $suffix = substr( $qname, -length($zone) );
	return $zone eq $suffix ? $self->_recurse( $query, $zone ) : undef;
}


sub _referral {
	my ( $self, $packet ) = @_;
	return unless $packet;
	my @ans	 = $packet->answer;
	my @auth = grep { $_->type eq 'NS' } $packet->authority, @ans;
	return unless scalar(@auth);
	my $owner = lc( $auth[0]->owner );
	my $cache = $self->{persistent}->{$owner};
	return scalar(@ans) ? undef : $owner if $cache;

	$self->_diag("caching nameservers for $owner");
	my %addr;
	my @addr = grep { $_->can('address') } $packet->additional;
	push @{$addr{lc $_->owner}}, $_->address foreach @addr;

	my %cache;
	foreach my $ns ( map { lc( $_->nsdname ) } @auth ) {
		$cache{$ns} = $addr{$ns};
	}

	$self->{persistent}->{$owner} = \%cache;
	return scalar(@ans) ? undef : $owner;
}


=head2 callback

This method specifies a code reference to a subroutine,
which is then invoked at each stage of the recursive lookup.

For example to emulate dig's C<+trace> function:

	my $coderef = sub {
	my $packet = shift;

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

	$resolver->callback($coderef);

The callback subroutine is not called
for queries for missing glue records.

=cut

sub callback {
	my ( $self, @argument ) = @_;
	for ( grep { ref($_) eq 'CODE' } @argument ) {
		$self->{callback} = $_;
	}
	return;
}

sub _callback {
	my ( $self, @argument ) = @_;
	my $callback = $self->{callback};
	$callback->(@argument) if $callback;
	return;
}

sub recursion_callback {		## historical
	my ($self) = @_;					# uncoverable pod
	$self->_deprecate('prefer  $resolver->callback(...)');
	&callback;
	return;
}


1;

__END__