;#
;# DNS resolver library.  See RFC1035 for more details.
;# by Marc Horowitz <marc@mit.edu>

;# $Id: resolv.pl,v 1.14 92/11/17 23:04:42 marc Exp $
;#
;# @(#)resolv.pl	1.1 10/13/93 (cc.utexas.edu)
;# @(#) /tmp_mnt/usr/share/src/public/languages/perl-stuff/resolv/SCCS/s.resolv.pl

;# The interface works like this (all functions are in the main package)
;#
;# res_init()
;#	One-time initialization
;#
;# res_open($nameserver)
;#	Sets up a connection to $nameserver.
;#	If $nameserver is undefined or empty, then the server is
;#	looked up in /etc/resolv.conf.  Returns the filehandle.
;#
;# res_mkquery($name, $type, $class, $id)
;#	builds and returns a query for the given name, type, class,
;#	and id.  If no id is given, a random ID is chosen.
;#
;# res_send($fh, $query)
;#	sends $query to the server at $fh.  Returns the response from the
;#	server.
;#
;# res_search($name, $type, $class);
;#	attempts to resolve <$name,$type,$class>.  Returns all appropriate
;#	answers, join'd by $;.  if the first response is "", the next will
;#	be the error code.
;#
;# response format:
;# [0] = id
;# [1] = authoritative
;# [2] = recursion available
;# [3] = response code
;# [4] = start of questions
;# [5] = number of questions
;# [6] = start of answers
;# [7] = number of answers
;# [8] = start of authority records
;# [9] = number of authority records
;# [10] = start of add'l records
;# [11] = number of add'l records
;# [12] ... query and resource records
;#
;# The variable res'options can be set to any of the values
;# which _res.options can be set to.  The constants will be in the 
;# main package.
;#
;# Routines return undef on error. 
;#
;# Not implemented yet:
;# Only one query is sent out.  That is, RES_DNSRCH is ignored.
;#	

require 'sys/socket.ph' || die "can\'t do sys/socket.ph: $@";
require 'nameser.ph' || die "can\'t do nameser.ph: $@";
require 'resolv.ph' || die "can\'t do resolv.ph: $@";

package res;

;# Create conversion arrays. unfortunately, I need to hardcode lists
;# of the types and classes.

@qtypes = ("A", "NS", "MD", "MF", "CNAME", "SOA", "MB", "MG", "MR", "NULL",
	    "WKS", "PTR", "HINFO", "MINFO", "MX", "TXT", "UINFO", "UID", "GID",
	    "UNSPEC", "UNSPECA", "AXFR", "MAILB", "MAILA", "ANY");

@qclasses = ("IN", "CHAOS", "HS", "ANY");

@rcodes = ("No Error","Format Error","Server Failure","Name Error",
	   "Not Implemented","Refused");

for (@qtypes) {
    eval "\$qtype[&main'T_$_] = \"$_\";\$qtype{\$_} = &main'T_$_;";
}

for (@qclasses) {
    eval "\$qclass[&main'C_$_] = \"$_\";\$qclass{\$_} = &main'C_$_;";
}

sub qtype_strtonum {
    $qtype{$_[0]} || -1;
}

sub qclass_strtonum {
    $qclass{$_[0]} || -1;
}

sub qtype_numtostr {
    $qtype[$_[0]] || $_[0];
}

sub qclass_numtostr {
    $qclass[$_[0]] || $_[0];
}

sub rcode_text {
    $_[0] ? ($rcodes[$_[0]] || "Unknown rcode") : "";
}
;#
;# option bits and defaults
;#
$options = &main'RES_DEFAULT;
$domain = "";
$error = '';

sub debug { $options & &main'RES_DEBUG; }

sub ipaddr {
	if ($_[0] =~ /(\d+)\.(\d+)\.(\d+)\.(\d+)/) {
		pack('C4', $1, $2, $3, $4);
	} else {
		(gethostbyname($_[0]))[4] || undef;
	}
}

sub main'_PATH_RESCONF { "./resolv.conf" };

;#
;# res_init - Initialize resolver
;#
sub main'res_init {
	return if ($options & &main'RES_INIT);
	local($addr);

	$domain = '';
	$retry = 3;
	$timeout = 5;
	@servers = ("\0\0\0\0");
	if (open(CONF, &'_PATH_RESCONF)) {
		print "Reading " . &'_PATH_RESCONF . "\n" if &debug;
		@servers = ();
		local($") = ".";
		while(<CONF>) {
			chop;
			$domain = $' if (/^domain\s+/io);
			$timeout = $' if (/^timeout\s+/io);
			$retry = $' if (/^retry\s+/io);
			if (/^nameserver\s+/io) {
				if ($addr = &ipaddr($')) {
					push(@pservers, $');
					push(@servers,$addr);
				}
			}
		}
		close(CONF);
	}
	(@servers = grep($_ = &ipaddr($_), split(/:/,$ENV{"LOCALRESOLVERS"})))
		if ($ENV{"LOCALRESOLVERS"});
	$domain = $ENV{"LOCALDOMAIN"}
		if ($ENV{"LOCALDOMAIN"});
	print "Domain is $domain\nResolvers are @pservers\n" if &debug;

	unless (socket(NSUDP, &main'AF_INET, &main'SOCK_DGRAM,
		&main'PF_UNSPEC)) {
			$error = "res_init (socket) :$!";
			return undef;
	}
	$options |= &main'RES_INIT;
	select((select(NSUDP), $| = 1)[$[]);
	1;
}

;#
;# res_open - Begin a conversation with a nameserver
;#
sub main'res_open {			# @_ = ($nameserver)
	local($saddr, $port);

	unless ($options & &main'RES_INIT) {
	    &'res_init || return undef;
	}

	$port = (getservbyname('domain', 'tcp'))[2] unless($port);
	return undef unless($port);

	sub _pingtime {
		close(PORT); alarm(0); $SIG{'ALRM'} = $savealrm;
		next ping;
	}
	if ($_[0]) {
		if ($_[0] =~ /(\d+)\.(\d+)\.(\d+)\.(\d+)/) {
			$saddr = pack("CCCC", $1, $2, $3, $4);
		} else {
			$saddr = (gethostbyname($_[0]))[4];
		}
		return undef unless($saddr);
		return pack('S n a4 x8', &main'AF_INET, $port, $saddr);
	} else {
		#
		# Go through list of nameservers until one is found up
		#
		local(*PORT, $that, $savealrm, $rc);

		ping: foreach $saddr (@servers) {
			if (&debug) {
				local($") = '.';
				local(@a) = unpack('C4', $saddr);
				print "Trying @a\n";
			}
			socket(PORT, &main'AF_INET, &main'SOCK_STREAM,
				&main'PF_UNSPEC) || next;
			$that = pack('S n a4 x8', &main'AF_INET, $port, $saddr);
			$savealrm = $SIG{'ALRM'};
			$SIG{'ALRM'} = '_pingtime';
			alarm($timeout);
			$rc = connect(PORT, $that);
			close(PORT);
			alarm(0);
			$SIG{'ALRM'} = $savealrm;
			return $that if ($rc);
		}
		$error = 'Unknown server error';
		return undef;
	}
}

;#
;# res_mkquery - Build a DNS query message
;#
sub main'res_mkquery { # @_ = ($name,$type,$class,$id)
	local($tnum, $cnum, $label, $labellen, $str);

	print "building query for <$_[0],$_[1],$_[2]>\n" if &debug;

	if (($tnum = &qtype_strtonum($_[1])) == -1) {
		$error = "Unknown query type $_[1] while building query\n";
		return undef;
	}
	if (($cnum = &qclass_strtonum($_[2])) == -1) {
		$error =  "Unknown query class $_[2] while building query\n";
		return undef;
	}
	$str = '';
	foreach $label (split(/\./,$_[0])) {
		$labellen = length($label);
		$str .= pack("Ca$labellen", $labellen, $label);
	}
	$str .= pack("C", 0);		# root octet
	pack("n6", $_[3],
		($options & &main'RES_RECURSE) ? 0x0100 : 0x0000, 1,0,0,0) .
		$str .  pack("n2", $tnum, $cnum);
}

%nstcp = ();			# assoc array of open VC's
$sockcnt = "nstcp000";

;#
;# res_send - Send a DNS query and handle replies
;#
sub main'res_send {		# @_ = ($socket, $query)
	local($sin, $len, $packet) = ($_[0], pack("n",length($_[1])),$_[1]);
	local($fh, $resp, $i, $rc);
	
	if ($options & &main'RES_USEVC) {
		$fh = $nstcp{$sin};
		unless ($fh) {
			$fh = $sockcnt++;
			if (&debug) {
				local($,) = (".");
				print "Connecting to ",
					(unpack("S n C4",$sin))[2..5,1],"\n";
			}
			socket($fh, &main'AF_INET, &main'SOCK_STREAM,
				&main'PF_UNSPEC) || return undef;
			foreach $i (1 ... $retry) {
				last if ($rc = connect($fh, $sin));
			}
			return undef unless $rc;
			$nstcp{$sin} = $fh;
		}
		if ($packet) {
			if (&debug) {
				local($,) = (".");
				print "Sending to ",
					(unpack("S n C4",$sin))[2..5,1]
					," via TCP\n";
			}
			send($fh,$len,0);
			send($fh,$packet,0);
		}
		if (&debug) {
			local($,) = (".");
			print "Receiving from ",(unpack("S n C4",$sin))[2..5,1]
			," via TCP\n";
		}
		read($fh,$len,2) || return undef;
		if ($len = unpack("n",$len)) {
			print "Got a size (size=$len)\n" if (&debug);
			read($fh,$resp,$len) || return undef;
		}
		print "Got a response (size=$len)\n" if (&debug);
	
		if (! ($options & &main'RES_STAYOPEN)) {
			foreach (keys(%nstcp)) {
				if (&debug) {
					local($,) = (".");
					print "Disconnecting from ",
						(unpack("S n C4",$_))[2..5,1] ,"\n";
				}
				close($_);
			}
			%nstcp = ();
		}
	} else {
		if (&debug) {
			local($,) = (".");
			print "Sending to ",(unpack("S n C4",$sin))[2..5,1],"
				via UDP\n";
		}
		foreach $i (1 ... $retry) {
			last if ($rc = send(NSUDP,$packet,0,$sin));
		}
		return undef unless $rc;
		if (&debug) {
			local($,) = (".");
			print "Receiving from ",
				(unpack("S n C4",$sin))[2..5,1]," via UDP\n";
		}
		$len = 512;
		read(NSUDP,$resp,$len) || return undef;
		print "Got a response (size=$len)\n" if (&debug);
	}
	&parse_response($resp);
}

;#
;# res_search - resolve <$name,$type,$class>. 
;#
$localns = "";

sub main'res_search { # @_ = ($name, $type, $class)
    local($q, @ans, $dom, $ret);

    $localns = &main'res_open() if !$localns;

    $q = &main'res_mkquery(@_);
    @ans = &main'res_send($localns, $q);

    if ($ans[3] &&
	(substr($_[0],-1,1) ne ".") &&
	(($options & &main'RES_DEFNAMES) ||
	 ($options & &main'RES_DNSRCH))) {

	$q = &main'res_mkquery($_[0].".".$domain,$_[1],$_[2]);
	@ans = &main'res_send($localns, $q);
    }
    if ($ans[3] &&
	($options & &main'RES_DNSRCH)) {
	$dom = $domain;

	while($ans[3]) {
	    $dom =~ s/^[^\.]+\.//;
	    last if ((&main'LOCALDOMAINPARTS-1 > ($dom =~ tr/\./\./)) ||
		     !$dom);
	
	    $q = &main'res_mkquery($_[0].".".$dom,$_[1],$_[2]);
	    @ans = &main'res_send($localns, $q);
	}
    }
    if ($ans[3]) {
	return($;.$ans[3]);
    }

    local(@s);

    for (@ans[$ans[6]..($ans[6]+$ans[7]-1)]) {
	@s = split(' ',$_,5);
	$ret .= $s[4].$; if ($s[1] eq $_[1]) && ($s[2] eq $_[2]);
    }
    chop $ret;

    return($ret);
}

sub parse_response { # @_ = ($response)
	local(@resp);

	push(@_,0);

	($id,$bits,$qdcount,$ancount,$nscount,$adcount) =
	    unpack("n6",&next_chars(12,@_));

	$auth = ($bits >> 10) & 0x01;
	$recurse = ($bits >> 8) & 0x01;
	$rcode = $bits & 0x0f;
	if ((!$auth) && ($options & &main'RES_AAONLY)) {
	    ($ancount,$nscount,$adcount) = (0,0,0);
	}

	$rrs = $ancount+$nscount+$adcount;
	@resp = ($id,$auth,$recurse);			#	[0..2]
	push(@resp,&rcode_text($rcode));		#	[3]
	push(@resp,12,$qdcount);			#	[4,5]
	push(@resp,$resp[$#resp-1]+$resp[$#resp],$ancount);   # [6,7]
	push(@resp,$resp[$#resp-1]+$resp[$#resp],$nscount);   # [8,9]
	push(@resp,$resp[$#resp-1]+$resp[$#resp],$adcount);   # [10,11]
	
	while($qdcount--) {
	    push(@resp,join(" ",&parse_name,
			    &qtype_numtostr(&next_netshort),
			    &qclass_numtostr(&next_netshort)));
	}
	while($rrs--) {
	    @new = &parse_rrbits;
	    if (@new) {
		push(@resp,@new);
	    } else {
		warn "Malformed packet: missing resource records.\n";
		last;
	    }
	}
	return(@resp);
}

sub parse_name {
	local($ch,$name) = (substr($_[0],$_[1],1));
	while (ord($ch = substr($_[0],$_[1],1)) != 0) {
		# Message compression (RFC1035 4.1.4)
		if (ord($ch) >= 0xc0) {
			return($name.
			       &parse_name($_[0],&next_netshort & 0x3fff));
		}
		$name .= &next_str.".";
	}
	&skip_char;		# move past \0
	$name = ".." if ($name eq "");
	chop($name);  # remove trailing "."
	return($name);
}

sub parse_rrbits {
	local($rrec,$type,$tstr,$rdlen,$pfct);

;#	print STDERR "--\n",substr($_[0],0,$_[1]),"\n--\n",substr($_[0],$_[1]),"\n--\n";
	return if (length($_[0]) <= $_[1]);
	$rrec = &parse_name;					# NAME
	$tstr = &qtype_numtostr($type = &next_netshort);
	$rrec .= " ".$tstr;					# TYPE
	$rrec .= " ".&qclass_numtostr(&next_netshort);		# CLASS
	$rrec .= " ".&next_netlong;				# TTL (integer)

	$rdlen = &next_netshort;
	$pfct = "rrparse_".$tstr;
	if ($pfct =~ /^rrparse_\d*$/) {
	    warn "Unknown query type \"$type\" in parse_rrbits, using NULL\n";
	    $pfct = "rrparse_NULL";
	}
	$rrec .= " ".&$pfct(@_,$rdlen);			# RDATA
}

;# strips the first character-string from the argument, and returns it as a
;# perl string
sub next_str {
    local($cslen);
    $cslen = unpack("C",&next_chars(1,@_));
    &next_chars($cslen,@_);
}

;# returns the first $_[0] chars at position $_[2] in string $_[1]
;# and increments $_[2]
sub next_chars {
    $_[2] += $_[0];
    substr($_[1],$_[2]-$_[0],$_[0]);
}

;# get the next network byte order short/long from the input

sub next_netshort {
    $_[1] += 2;
    unpack("n",substr($_[0],$_[1]-2));
}

sub next_netlong {
    $_[1] += 4;
    unpack("N",substr($_[0],$_[1]-4));
}

;# skip a character
sub skip_char {
    $_[1]++;
}

;# routines to parse apart the rrdata

sub rrparse_A {
    join('.',unpack("C4",&next_chars(4,@_)));
}

sub rrparse_NS {
    &parse_name;
}

sub rrparse_MD {
    &parse_name;
}

sub rrparse_MF {
    &parse_name;
}

sub rrparse_CNAME {
    &parse_name;
}

sub rrparse_SOA {
    join(' ',
	 &parse_name,
	 &parse_name,
	 &next_netlong,
	 &next_netlong,
	 &next_netlong,
	 &next_netlong,
	 &next_netlong);
}

sub rrparse_MB {
    &parse_name;
}

sub rrparse_MG {
    &parse_name;
}

sub rrparse_MR {
    &parse_name;
}

sub rrparse_NULL {
    &next_chars(@_[2,0,1]);
}

sub rrparse_WKS {
    local(@resp,$bitmap,$len,%bit);

    push(@resp,
	 &rrparse_A,
	 ord(&next_chars(1,@_)));
    $bitmap = &next_chars($_[2]-5,@_);
    @bit{0..(length($bitmap)*8)} = split(//,unpack("B*", $bitmap));
    push(@resp, grep($bit{$_},keys(%bit)));

    join(' ',@resp);
}

sub rrparse_PTR {
    &parse_name;
}

sub rrparse_HINFO {
    &next_str.",".&next_str;
}

sub rrparse_MINFO {
    &parse_name.",".&parse_name;
}

sub rrparse_MX {
    &next_netshort." ".&parse_name;
}

sub rrparse_TXT {
    local($str,$end);
    $end = $_[1]+$_[2];
    while ($_[1] < $end) {
	$str .= &next_str;
    }
    if ($_[1] > $end) { print STDERR "Something weird in rrparse_TXT\n"; }
    return($str);
}

sub rrparse_UINFO {
    &next_chars(@_[2,0,1]);
}

sub rrparse_UNSPEC {
    &next_chars(@_[2,0,1]);
}

sub rrparse_UNSPECA {
    &next_chars(@_[2,0,1]);
}
1;
;#
;# End resolv.pl