File Coverage

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

Criterion	Covered	Total	%
statement	78	78	100.0
branch	24	24	100.0
condition	4	4	100.0
subroutine	12	12	100.0
pod	3	5	100.0
total	121	123	100.0

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

use strict;
use warnings;
our $VERSION = (qw$Id: Recurse.pm 1930 2023-08-21 14:10:10Z 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 {
	my ( undef, @argument ) = @_;
	return @hints unless scalar @argument;
	$root  = [];
	@hints = @argument;
	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, @q ) = @_;
	my @conf = ( recurse => 0, udppacketsize => 1024 );	# RFC8109
	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 ( 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 @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 $owner if $cache && scalar(@$cache);
	my @addr = grep { $_->can('address') } $packet->additional, @ans;
	my @ip;
	my @ns = map { lc( $_->nsdname ) } @auth;

	foreach my $ns (@ns) {
		push @ip, map { $ns eq lc( $_->owner ) ? $_->address : () } @addr;
	}
	$self->_diag("resolving missing glue for $owner") unless scalar(@ip);
	@ip = $self->nameservers( $ns[0], $ns[-1] )	  unless scalar(@ip);
	$self->_diag("caching nameserver addresses 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, @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__