package Net::DNS::Resolver::Base;
#
# $Id: Base.pm,v 1.3 2003/07/29 04:53:23 ctriv Exp $
#

use strict;

use vars qw(
	$VERSION
	$AUTOLOAD
);

use Carp;
use Config ();
use Socket;
use IO::Socket;

use Net::DNS;
use Net::DNS::Packet;
use Net::DNS::Select;

$VERSION = $Net::DNS::Resolver::VERSION;

#
# Set up a closure to be our class data.
#
{
	my %defaults = (
		nameservers	   => ['127.0.0.1'],
		port		   => 53,
		srcaddr        => '0.0.0.0',
		srcport        => 0,
		domain	       => '',
		searchlist	   => [],
		retrans	       => 5,
		retry		   => 4,
		usevc		   => 0,
		stayopen       => 0,
		igntc          => 0,
		recurse        => 1,
		defnames       => 1,
		dnsrch         => 1,
		debug          => 0,
		errorstring	   => 'unknown error or no error',
		tsig_rr        => undef,
		answerfrom     => '',
		answersize     => 0,
		querytime      => undef,
		tcp_timeout    => 120,
		udp_timeout    => undef,
		axfr_sel       => undef,
		axfr_rr        => [],
		axfr_soa_count => 0,
		persistent_tcp => 0,
		dnssec         => 0,
		udppacketsize  => 0,  # The actual default is lower bound by Net::DNS::PACKETSZ
		cdflag         => 1,  # this is only used when {dnssec} == 1
	);
	
	# If we're running under a SOCKSified Perl, use TCP instead of UDP
	# and keep the sockets open.
	if ($Config::Config{'usesocks'}) {
		$defaults{'usevc'} = 1;
		$defaults{'persistent_tcp'} = 1;
	}
	
	sub defaults { \%defaults }
}

# These are the attributes that we let the user specify in the new().
# We also deprecate access to these with AUTOLOAD (some may be useful).
my %public_attr = map { $_ => 1 } qw(
	nameservers
	port
	srcaddr
	srcport
	domain
	searchlist
	retrans
	retry
	usevc
	stayopen
	igntc
	recurse
	defnames
	dnsrch
	debug
	tcp_timeout
	udp_timeout
	persistent_tcp
	dnssec
);


sub new {
	my $class = shift;

	my $self = bless({ %{$class->defaults} }, $class);

	$self->_process_args(@_) if @_ and @_ % 2 == 0;
			
	return $self;
}

sub _process_args {
	my ($self, %args) = @_;
	
	if ($args{'config_file'}) {
		$self->read_config_file($args{'config_file'});
	}
	
	foreach my $attr (keys %args) {
		next unless $public_attr{$attr};
	
		if ($attr eq 'nameservers' || $attr eq 'searchlist') {
			die "Net::DNS::Resolver->new(): $attr must be an arrayref\n" unless
				UNIVERSAL::isa($args{$attr}, 'ARRAY');
		}
		
		$self->{$attr} = $args{$attr};
	}
}
			
			
			


#
# Some people have reported that Net::DNS dies because AUTOLOAD picks up
# calls to DESTROY.
#
sub DESTROY {}


sub read_env {
	my ($invocant) = @_;
	my $config     = ref $invocant ? $invocant : $invocant->defaults;
	
	$config->{'nameservers'} = [ split(' ', $ENV{'RES_NAMESERVERS'}) ]
		if exists $ENV{'RES_NAMESERVERS'};

	$config->{'searchlist'}  = [ split(' ', $ENV{'RES_SEARCHLIST'})  ]
		if exists $ENV{'RES_SEARCHLIST'};
	
	$config->{'domain'} = $ENV{'LOCALDOMAIN'}
		if exists $ENV{'LOCALDOMAIN'};

	if (exists $ENV{'RES_OPTIONS'}) {
		foreach (split(' ', $ENV{'RES_OPTIONS'})) {
			my ($name, $val) = split(/:/);
			$val = 1 unless defined $val;
			$config->{$name} = $val if exists $config->{$name};
		}
	}
}

#
# $class->read_config_file($filename) or $self->read_config_file($file)
#
sub read_config_file {
	my ($invocant, $file) = @_;
	my $config            = ref $invocant ? $invocant : $invocant->defaults;

	
	my @ns;
	my @searchlist;
	
	local *FILE;

	open(FILE, "< $file") or croak "Could not open $file: $!";
	local $/ = "\n";
	local $_;
	
	while (<FILE>) {
		s/\s*[;#].*//;
		
		# Skip ahead unless there's non-whitespace characters 
		next unless m/\S/;

		SWITCH: {
			/^\s*domain\s+(\S+)/ && do {
				$config->{'domain'} = $1;
				last SWITCH;
			};

			/^\s*search\s+(.*)/ && do {
				push(@searchlist, split(' ', $1));
				last SWITCH;
			};

			/^\s*nameserver\s+(.*)/ && do {
				foreach my $ns (split(' ', $1)) {
					$ns = '0.0.0.0' if $ns eq '0';
					next if $ns =~ m/:/;  # skip IPv6 nameservers
					push @ns, $ns;
				}
				last SWITCH;
			};
		}
	}
	close FILE || croak "Could not close $file: $!";

	$config->{'nameservers'} = [ @ns ]         if @ns;
	$config->{'searchlist'}  = [ @searchlist ] if @searchlist;
}


sub print { print $_[0]->string }

sub string {
	my $self = shift;

	my $timeout = defined $self->{'tcp_timeout'} ? $self->{'tcp_timeout'} : 'indefinite';
	
	return <<END;
;; RESOLVER state:
;;  domain       = $self->{domain}
;;  searchlist   = @{$self->{searchlist}}
;;  nameservers  = @{$self->{nameservers}}
;;  port         = $self->{port}
;;  srcport      = $self->{srcport}
;;  srcaddr      = $self->{srcaddr}
;;  tcp_timeout  = $timeout
;;  retrans  = $self->{retrans}  retry    = $self->{retry}
;;  usevc    = $self->{usevc}  stayopen = $self->{stayopen}    igntc = $self->{igntc}
;;  defnames = $self->{defnames}  dnsrch   = $self->{dnsrch}
;;  recurse  = $self->{recurse}  debug    = $self->{debug}
END
}


sub searchlist {
	my $self = shift;
	$self->{'searchlist'} = [ @_ ] if @_;
	return @{$self->{'searchlist'}};
}

sub nameservers {
	my $self   = shift;
	my $defres = Net::DNS::Resolver->new;

	if (@_) {
		my @a;
		foreach my $ns (@_) {
			if ($ns =~ /^\d+(\.\d+){0,3}$/) {
				push @a, ($ns eq '0') ? '0.0.0.0' : $ns;
			}
			else {
				my @names;

				if ($ns !~ /\./) {
					if (defined $defres->searchlist) {
						@names = map { $ns . '.' . $_ }
							    $defres->searchlist;
					}
					elsif (defined $defres->domain) {
						@names = ($ns . '.' . $defres->domain);
					}
				}
				else {
					@names = ($ns);
				}

				my $packet = $defres->search($ns);
				$self->errorstring($defres->errorstring);
				if (defined($packet)) {
					push @a, cname_addr([@names], $packet);
				}
			}
		}

		$self->{'nameservers'} = [ @a ];
	}

	return @{$self->{'nameservers'}};
}

sub nameserver { &nameservers }

sub cname_addr {
	my $names  = shift;
	my $packet = shift;
	my @addr;
	my @names = @{$names};

	my $oct2 = '(?:2[0-4]\d|25[0-5]|[0-1]?\d\d|\d)';

	RR: foreach my $rr ($packet->answer) {
		next RR unless grep {$rr->name} @names;
				
		if ($rr->type eq 'CNAME') {
			push(@names, $rr->cname);
		} elsif ($rr->type eq 'A') {
			# Run a basic taint check.
			next RR unless $rr->address =~ m/^($oct2\.$oct2\.$oct2\.$oct2)$/o;
			
			push(@addr, $1)
		}
	}
	
	
	return @addr;
}


# if ($self->{"udppacketsize"}  > &Net::DNS::PACKETSZ 
# then we use EDNS and $self->{"udppacketsize"} 
# should be taken as the maximum packet_data length
sub _packetsz {
	my ($self) = @_;

	return $self->{"udppacketsize"} > &Net::DNS::PACKETSZ ? 
		   $self->{"udppacketsize"} : &Net::DNS::PACKETSZ; 
}

sub _reset_errorstring {
	my ($self) = @_;
	
	$self->errorstring($self->defaults->{'errorstring'});
}


sub search {
	my $self = shift;
	my ($name, $type, $class) = @_;
	my $ans;

	$type  = 'A'  unless defined($type);
	$class = 'IN' unless defined($class);

	# If the name looks like an IP address then do an appropriate
	# PTR query.
	if ($name =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) {
		$name = "$4.$3.$2.$1.in-addr.arpa.";
		$type = 'PTR';
	}

	# If the name contains at least one dot then try it as is first.
	if (index($name, '.') >= 0) {
		print ";; search($name, $type, $class)\n" if $self->{'debug'};
		$ans = $self->query($name, $type, $class);
		return $ans if $ans and $ans->header->ancount;
	}

	# If the name doesn't end in a dot then apply the search list.
	if (($name !~ /\.$/) && $self->{'dnsrch'}) {
		foreach my $domain (@{$self->{'searchlist'}}) {
			my $newname = "$name.$domain";
			print ";; search($newname, $type, $class)\n"
				if $self->{'debug'};
			$ans = $self->query($newname, $type, $class);
			return $ans if $ans and $ans->header->ancount;
		}
	}

	# Finally, if the name has no dots then try it as is.
	if (index($name, '.') < 0) {
		print ";; search($name, $type, $class)\n" if $self->{'debug'};
		$ans = $self->query("$name.", $type, $class);
		return $ans if $ans and $ans->header->ancount;
	}

	# No answer was found.
	return undef;
}


sub query {
	my ($self, $name, $type, $class) = @_;

	$type  = 'A'  unless defined($type);
	$class = 'IN' unless defined($class);

	# If the name doesn't contain any dots then append the default domain.
	if ((index($name, '.') < 0) && $self->{'defnames'}) {
		$name .= ".$self->{domain}";
	}

	# If the name looks like an IP address then do an appropriate
	# PTR query.
	if ($name =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) {
		$name = "$4.$3.$2.$1.in-addr.arpa";
		$type = 'PTR';
	}

	print ";; query($name, $type, $class)\n" if $self->{'debug'};
	my $packet = Net::DNS::Packet->new($name, $type, $class);


	
	my $ans = $self->send($packet);

	return $ans && $ans->header->ancount   ? $ans : undef;
}


sub send {
	my $self = shift;
	my $packet = $self->make_query_packet(@_);
	my $packet_data = $packet->data;

	my $ans;

	if ($self->{'usevc'} || length $packet_data > $self->_packetsz) {
	  
	    $ans = $self->send_tcp($packet, $packet_data);
	    
	} else {
	    $ans = $self->send_udp($packet, $packet_data);
	    
	    if ($ans && $ans->header->tc && !$self->{'igntc'}) {
			print ";;\n;; packet truncated: retrying using TCP\n" if $self->{'debug'};
			$ans = $self->send_tcp($packet, $packet_data);
	    }
	}
	
	return $ans;
}



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

	unless (@{$self->{'nameservers'}}) {
		$self->errorstring('no nameservers');
		print ";; ERROR: send_tcp: no nameservers\n" if $self->{'debug'};
		return;
	}

	$self->_reset_errorstring;
	my $timeout = $self->{'tcp_timeout'};

	foreach my $ns (@{$self->{'nameservers'}}) {
		my $srcport = $self->{'srcport'};
		my $srcaddr = $self->{'srcaddr'};
		my $dstport = $self->{'port'};

		print ";; send_tcp($ns:$dstport) (src port = $srcport)\n"
			if $self->{'debug'};

		my $sock;
		my $sock_key = "$ns:$dstport";

		if ($self->persistent_tcp && $self->{'sockets'}{$sock_key}) {
			$sock = $self->{'sockets'}{$sock_key};
			print ";; using persistent socket\n"
				if $self->{'debug'};
		}
		else {

			# IO::Socket carps on errors if Perl's -w flag is
			# turned on.  Uncomment the next two lines and the
			# line following the "new" call to turn off these
			# messages.

			#my $old_wflag = $^W;
			#$^W = 0;

			$sock = IO::Socket::INET->new(
			    PeerAddr  => $ns,
			    PeerPort  => $dstport,
			    LocalAddr => $srcaddr,
			    LocalPort => ($srcport || undef),
			    Proto     => 'tcp',
			    Timeout   => $timeout
			);

			#$^W = $old_wflag;

			unless ($sock) {
				$self->errorstring('connection failed');
				print ';; ERROR: send_tcp: connection ',
				      "failed: $!\n" if $self->{'debug'};
				next;
			}

			$self->{'sockets'}{$sock_key} = $sock;
		}

		my $lenmsg = pack('n', length($packet_data));
		print ';; sending ', length($packet_data), " bytes\n"
			if $self->{'debug'};

		# note that we send the length and packet data in a single call
		# as this produces a single TCP packet rather than two. This
		# is more efficient and also makes things much nicer for sniffers.
		# (ethereal doesn't seem to reassemble DNS over TCP correctly)
		unless ($sock->send($lenmsg . $packet_data)) {
			$self->errorstring($!);
			print ";; ERROR: send_tcp: data send failed: $!\n"
				if $self->{'debug'};
			next;
		}

		my $sel = Net::DNS::Select->new($sock);

		if ($sel->can_read($timeout)) {
			my $buf = read_tcp($sock, &Net::DNS::INT16SZ, $self->{'debug'});
			next unless length($buf);
			my ($len) = unpack('n', $buf);
			next unless $len;

			unless ($sel->can_read($timeout)) {
				$self->errorstring('timeout');
				print ";; TIMEOUT\n" if $self->{'debug'};
				next;
			}

			$buf = read_tcp($sock, $len, $self->{'debug'});

			$self->answerfrom($sock->peerhost);
			$self->answersize(length $buf);

			print ';; received ', length($buf), " bytes\n"
				if $self->{'debug'};

			unless (length($buf) == $len) {
				$self->errorstring("expected $len bytes, " .
						   'received ' . length($buf));
				next;
			}

			my ($ans, $err) = Net::DNS::Packet->new(\$buf, $self->{'debug'});
			if (defined $ans) {
				$self->errorstring($ans->header->rcode);
				$ans->answerfrom($self->answerfrom);
				$ans->answersize($self->answersize);
			}
			elsif (defined $err) {
				$self->errorstring($err);
			}

			return $ans;
		}
		else {
			$self->errorstring('timeout');
			next;
		}
	}

	return;
}

sub send_udp {
	my ($self, $packet, $packet_data) = @_;
	my $retrans = $self->{'retrans'};
	my $timeout = $retrans;

	my $stop_time = time + $self->{'udp_timeout'} if $self->{'udp_timeout'};

	$self->_reset_errorstring;

	my $dstport = $self->{'port'};
	my $srcport = $self->{'srcport'};
	my $srcaddr = $self->{'srcaddr'};

	# IO::Socket carps on errors if Perl's -w flag is turned on.
	# Uncomment the next two lines and the line following the "new"
	# call to turn off these messages.

	#my $old_wflag = $^W;
	#$^W = 0;

	# XXX Why is PeerPort defined here?
	my $sock = IO::Socket::INET->new(
			    PeerPort  => $dstport,
			    LocalAddr => $srcaddr,
			    LocalPort => ($srcport || undef),
			    Proto     => 'udp',
	);

	#$^W = $old_wflag;

	unless ($sock) {
		$self->errorstring("couldn't create socket: $!");
		return;
	}

	my @ns = grep { $_->[0] && $_->[1] }
	         map  { [ $_, scalar(sockaddr_in($dstport, inet_aton($_))) ] }
	         @{$self->{'nameservers'}};

	unless (@ns) {
		$self->errorstring('no nameservers');
		return;
	}

	my $sel = Net::DNS::Select->new($sock);

	# Perform each round of retries.
	for (my $i = 0;
	     $i < $self->{'retry'};
	     ++$i, $retrans *= 2, $timeout = int($retrans / (@ns || 1))) {

		$timeout = 1 if ($timeout < 1);

		# Try each nameserver.
		foreach my $ns (@ns) {
			if ($stop_time) {
				my $now = time;
				if ($stop_time < $now) {
					$self->errorstring('query timed out');
					return;
				}
				if ($timeout > 1 && $timeout > ($stop_time-$now)) {
					$timeout = $stop_time-$now;
				}
			}
			my $nsname = $ns->[0];
			my $nsaddr = $ns->[1];

			print ";; send_udp($nsname:$dstport)\n"
				if $self->{'debug'};

			unless ($sock->send($packet_data, 0, $nsaddr)) {
				print ";; send error: $!\n" if $self->{'debug'};
				@ns = grep { $_->[0] ne $nsname } @ns;
				next;
			}

			my @ready = $sel->can_read($timeout);

			foreach my $ready (@ready) {
				my $buf = '';

				if ($ready->recv($buf, $self->_packetsz)) {
				
					$self->answerfrom($ready->peerhost);
					$self->answersize(length $buf);