#!/afs/athena/contrib/perl/perl

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

# $Id: resolv.pl,v 1.20 1996/05/11 01:59:27 marc Exp $

# 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 the first reply
#	which answers the question, or an error reply.
#
# res_search_simple($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.  This basically does a little postprocessing
#	on the return from res_search
#
# 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.
#
# Not implemented yet:
# Only one query is sent out.  That is, RES_DNSRCH is ignored, and
#	only the primary nameserver is used.
#	

## Everything after this is code.  If you look at it, you're
## violating an abstraction barrier.  Shame on you.  :-)

# hack! hack!  This is to confuse the byte order stuff in arpa/nameser.h
# nothing here depends on it anyway.

sub vax {1;}
sub NeXT {0;}

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

# who? me? kludge?

undef &vax;

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 = "";

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

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

sub read_conf {
    return if ($domain);

    local($addr);

    if (!$ENV{"LOCALRESOLVERS"} || !$ENV{"LOCALDOMAIN"}) {
	print "Reading /etc/resolv.conf\n" if &debug;

	if (open(CONF,"/etc/resolv.conf")) {
	    local($") = ",";
	    while(<CONF>) {
		chop;
		if (/^domain\s+/) { $domain = $'; }
		elsif (/^nameserver\s+/) {
		    if ($addr = &ipaddr($')) { push(@servers,$addr); }
		}
	    }
	    close(CONF);
	} else {
	    $domain = '';
	    @servers = ("\0\0\0\0");
	}
    }

    (@servers = grep($_=&ipaddr($_), split(/:/,$ENV{"LOCALRESOLVERS"})))
	if ($ENV{"LOCALRESOLVERS"});
    ($domain = $ENV{"LOCALDOMAIN"})
	if ($ENV{"LOCALDOMAIN"});

    if (&debug) {
	print "domain is ",$domain,"\nresolvers are";
	foreach $machine (@servers) { 
	    printf " %s.%s.%s.%s",unpack("CCCC",$machine);
	}
	print "\n";
    }
}

# one-time initialization

$inited = 0;

sub main'res_init {
    return if ($options & &main'RES_INIT);

    local($fh);

    socket(NSUDP, &main'AF_INET, &main'SOCK_DGRAM, &main'PF_UNSPEC) ||
	die "socket: $!";

    $options |= &main'RES_INIT;
    &read_conf;

    $fh = select(NSUDP); $| = 1;   # set nonbufferred
    select($fh);
}

# begin a conversation with a nameserver

sub main'res_open {			# @_ = ($nameserver)
    local($saddr,$port);

    &main'res_init if (!($options & &main'RES_INIT));

    if ($_[0]) {
	if ($_[0] =~ /(\d+)\.(\d+)\.(\d+)\.(\d+)/) {
	    $saddr = pack("CCCC", $1, $2, $3, $4);
	} else {
	    ($saddr = ((gethostbyname($_[0]))[4] || undef)) ||
		return(undef);
	}
    } else {
	$saddr = $servers[0];
    }

    # lossage in /etc/services.  hardcode for now.
    #$port = (getservbyname("nameserver","tcp"))[2];
    $port = 53;

    pack("S n a4 x8",&main'AF_INET,$port,$saddr);
}

sub main'res_mkquery { # @_ = ($name,$type,$class,$id)
    local($tnum, $cnum);

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

    $tnum = &qtype_strtonum($_[1]);
    $cnum = &qclass_strtonum($_[2]);

    warn "Unknown query type $_[1] while building query\n" if $tnum == -1;
    warn "Unknown query class $_[2] while building query\n" if $cnum == -1;

    pack("n6",$_[3],
	 ($options & &main'RES_RECURSE)?0x0100:0x0000,
	 1,0,0,0)
	.
	    &unparse_name($_[0])
		.
		    pack("n n",&qtype_strtonum($_[1]),
			 &qclass_strtonum($_[2]));
}

sub unparse_name {
	local($label,$labellen,$str);
	$str = "";
	foreach $label (split(/\./,$_[0])) {
		$labellen = length($label);
		$str .= pack("Ca$labellen",$labellen,$label);
	}
	$str .= pack("C",0);		# root octet
}

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

sub sysread_nchars { # @_ = ($fh,$len)
    local($fh,$len) = @_;
    local($tresp, $resp);

    $tresp = "";
    while(length($resp) < $len) {
	sysread($fh,$tresp,$len - length($resp)) || die "recv: $!";
	print "Got a partial response (size=",length($tresp),")\n"
	    if (&debug && length($tresp) < $len);
	$resp.=$tresp;
    }
    return($resp);
}

sub main'res_send { # @_ = ($socket,$query)
    local($sin,$len,$packet) = ($_[0],pack("n",length($_[1])),$_[1]);
    local($fh,$tresp,$resp);

    if ($options & &main'RES_USEVC) { # 
	$fh = $nstcp{$sin};
	if (!$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) ||
		die "socket: $!";
	    connect($fh, $sin) || die "connect: $!";

	    $nstcp{$sin} = $fh;
	}

	if ($packet) {
	    if (&debug) {
		print "Sending to ",join(".",(unpack("S n C4",$sin))[2..5,1])
		    ," via TCP\n"; # 
	    }

	    send($fh,$len,0);
	    send($fh,$packet,0);
	}

	if (&debug) {
	    print "Receiving from ",join(".",(unpack("S n C4",$sin))[2..5,1])
		," via TCP\n";
	}


	$len = &sysread_nchars($fh,2);
	if ($len = unpack("n",$len)) {
	    print "Got a size (size=$len)\n" if (&debug);
	    $resp = &sysread_nchars($fh,$len);
	}

	print "Got a response (size=",length($resp),")\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 {
	print "Sending to ",join(".",(unpack("S n C4",$sin))[2..5,1])
	    ," via UDP\n" if &debug;

	send(NSUDP,$packet,0,$sin) || die "send: $!";

	print "Receiving from ",join(".",(unpack("S n C4",$sin))[2..5,1])
	    ," via UDP\n" if &debug;

	# this used to be 512, which is what 4.2.1 specifies, but some
	# servers send out larger packets in error.  However, it is easy
	# to be liberal, and accept large packets, so I will.  The ethernet
	# MTU seems like a good size.
	$len = 1500;
	recv(NSUDP,$resp,$len,0) || die "recv: $!";

	print "Got a response (size=",length($resp),")\n" if (&debug);
    }

    &parse_response($resp);
}

$localns = "";

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

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

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

    if ($ans[3] &&
	(substr($name,-1,1) ne ".") &&
	(($options & &main'RES_DEFNAMES) ||
	 ($options & &main'RES_DNSRCH))) {
	
	$q = &main'res_mkquery($name.".".$domain,$type,$class);
	@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($name.".".$domain,$type,$class);
	    @ans = &main'res_send($localns, $q);
	}
    }

    @ans;
}

sub main'res_search_simple {
    local(@ans) = &main'res_search;

    if ($ans[3]) {
	return($;.$ans[3]);
    }

    local(@s, $ret);

    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);

#	open(CV,"|cat -v");print CV @_;close(CV);print"\n";

	($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,$rcode);
	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";

	if (length($_[0]) <= $_[1]) {
	    return();
	}

	$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;