view release on metacpan or  search on metacpan

lib/Net/DNS/Resolver/Base.pm  view on Meta::CPAN

	return $self->_bgsend_tcp( $packet, $packet_data )
			if $self->{usevc} || length $packet_data > $self->_packetsz;

	return $self->_bgsend_udp( $packet, $packet_data );
}


sub _bgsend_tcp {
	my ( $self, $packet, $packet_data ) = @_;

	my $tcp_packet = pack 'n a*', length($packet_data), $packet_data;

	foreach my $ip ( $self->nameservers ) {
		$self->_diag( 'bgsend', "[$ip]" );

		my $socket = $self->_create_tcp_socket($ip);
		$self->errorstring($!);
		next unless $socket;

		$socket->blocking(0);
		$socket->send($tcp_packet);
		$self->errorstring($!);
		$socket->blocking(1);

		my $expire = time() + $self->{tcp_timeout};
		${*$socket}{net_dns_bg} = [$expire, $packet];
		return $socket;
	}

	return;
}


sub _bgsend_udp {
	my ( $self, $packet, $packet_data ) = @_;

	my $port = $self->{port};

	foreach my $ip ( $self->nameservers ) {
		my $sockaddr = $self->_create_dst_sockaddr( $ip, $port );
		my $socket   = $self->_create_udp_socket($ip) || next;

		$self->_diag( 'bgsend', "[$ip]:$port" );

		$socket->send( $packet_data, 0, $sockaddr );
		$self->errorstring($!);

		# handle failure to detect taint inside $socket->send()
		die 'Insecure dependency while running with -T switch'
				if TESTS && Scalar::Util::tainted($sockaddr);

		my $expire = time() + $self->{udp_timeout};
		${*$socket}{net_dns_bg} = [$expire, $packet];
		return $socket;
	}

	return;
}


sub bgbusy {				## no critic		# overwrites user UDP handle
	my ( $self, $handle ) = @_;
	return unless $handle;

	my $appendix = ${*$handle}{net_dns_bg} ||= [time() + $self->{udp_timeout}];
	my ( $expire, $query, $read ) = @$appendix;
	return if ref($read);

	return time() < $expire unless IO::Select->new($handle)->can_read(0.02);    # limit CPU burn

	return unless $query;					# SpamAssassin 3.4.1 workaround
	return unless $handle->socktype() == SOCK_DGRAM;

	my $ans = $self->_bgread($handle);
	$$appendix[0] = time();
	$$appendix[2] = [$ans];
	return unless $ans;
	return if $self->{igntc};
	return unless $ans->header->tc;

	$self->_diag('packet truncated: retrying using TCP');
	my $tcp = $self->_bgsend_tcp( $query, $query->encode ) || return;
	return defined( $_[1] = $tcp );				# caller's UDP handle now TCP
}


sub bgisready {				## historical
	__PACKAGE__->_deprecate('prefer ! bgbusy(...)');	# uncoverable pod
	return !&bgbusy;
}


sub bgread {
	1 while &bgbusy;		## side effect: TCP retry if TC flag set
	return &_bgread;
}


sub _bgread {
	my ( $self, $handle ) = @_;
	return unless $handle;

	my $appendix = ${*$handle}{net_dns_bg};
	my ( $expire, $query, $read ) = @$appendix;
	return shift(@$read) if ref($read);

	return unless IO::Select->new($handle)->can_read(0.2);

	my $dgram  = $handle->socktype() == SOCK_DGRAM;
	my $buffer = $dgram ? _read_udp($handle) : _read_tcp($handle);

	my $peerhost = $self->{replyfrom} = $handle->peerhost;
	$self->_diag( "packet from [$peerhost]", length($buffer), 'octets' );

	my $reply = Net::DNS::Packet->decode( \$buffer, $self->{debug} );
	$self->errorstring($@);

	return unless $self->_accept_reply( $reply, $query );
	$reply->from($peerhost);

	return $reply unless $self->{tsig_rr} && !$reply->verify($query);
	$self->errorstring( $reply->verifyerr );
	return;
}


sub _accept_reply {
	my ( $self, $reply, $query ) = @_;

	return unless $reply;

	my $header = $reply->header;
	return unless $header->qr;

	return if $query && ( $header->id != $query->header->id );

	return $self->errorstring( $header->rcode );		# historical quirk
}


sub axfr {				## zone transfer
	my ( $self, @argument ) = @_;
	my $zone  = scalar(@argument) ? shift @argument : $self->domain;
	my @class = @argument;

	my $request = $self->_make_query_packet( $zone, 'AXFR', @class );

	return eval {
		$self->_diag("axfr( $zone @class )");
		my ( $select, $verify, @rr, $soa ) = $self->_axfr_start($request);

		my $iterator = sub {	## iterate over RRs
			my $rr = shift(@rr);

lib/Net/DNS/Resolver/Base.pm  view on Meta::CPAN

		}
		return map {@$_} values %glue;
	};

	my @ip;

	sub _hints {			## default hints
		@ip = &$parse_dig unless scalar @ip;		# once only, on demand
		splice @ip, 0, 0, splice( @ip, int( rand scalar @ip ) );    # cut deck
		return @ip;
	}
}


sub DESTROY { }				## Avoid tickling AUTOLOAD (in cleanup)

sub AUTOLOAD {				## Default method
	my ($self) = @_;

	no strict 'refs';		## no critic ProhibitNoStrict
	our $AUTOLOAD;
	my $name = $AUTOLOAD;
	$name =~ s/.*://;
	croak qq[unknown method "$name"] unless $public_attr{$name};

	*{$AUTOLOAD} = sub {
		my $self = shift;
		$self = $self->_defaults unless ref($self);
		$self->{$name} = shift || 0 if scalar @_;
		return $self->{$name};
	};

	return &$AUTOLOAD;
}


1;


=head1 NAME

Net::DNS::Resolver::Base - DNS resolver base class

=head1 SYNOPSIS

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

=head1 DESCRIPTION

This class is the common base class for the different platform
sub-classes of L<Net::DNS::Resolver>.

No user serviceable parts inside, see L<Net::DNS::Resolver>
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<Net::DNS::Resolver>.


=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<perl> L<Net::DNS> L<Net::DNS::Resolver>

=cut


########################################

__DATA__	## DEFAULT HINTS

; <<>> DiG 9.18.20 <<>> @b.root-servers.net . -t NS
; (2 servers found)
;; global options: +cmd
;; Got answer:
;; ->>HEADER<<- opcode: QUERY, status: NOERROR, id: 938
;; flags: qr aa rd; QUERY: 1, ANSWER: 13, AUTHORITY: 0, ADDITIONAL: 27
;; WARNING: recursion requested but not available

;; OPT PSEUDOSECTION: