{$M-,X+}
program rrup;

{ This file contains obsolete routines that still use the exp_ data
  types, use naddrr for new programs }

include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:hash.hdr';
include {NOLIST} 'domain:msub.hdr';
include {NOLIST} 'domain:alloc.hdr';
include {NOLIST} 'domain:iomsg.hdr';
include {NOLIST} 'domain:eutil.hdr';

procedure walklabel(var myzone:zone_entry;
			procedure callee);

{	WALKULABEL walks the label table of a zone and
	calls its target procedure with an argument of
	a ulabel_pointer
}

var	i,j:integer;
	pscan:^secondary_label_table;
	sscan:ulabel_pointer;

begin
with myzone.ltable
do	begin
	if direct<>NIL	{ do the root entry }
	then	callee(direct);
	for i:=0 to 255
	do	begin
		pscan:=stable[i];	{ scan all of the secondary tables }
		if pscan<>NIL
		then	begin
			if pscan^.direct<>NIL
			then	callee(pscan^.direct);
			for j:=0 to 255
			do	begin
				sscan:=pscan^.lchain[j];
				while sscan<>NIL
				do	begin
					callee(sscan);
					sscan:=sscan^.next
					end
				end
			end
		end
	end
end; { walklabel }
procedure makeulabel(	var myzone:zone_entry;
			var mylabel:exp_label;
			    point:ulabel_pointer);

{	MAKEULABEL creates a new ulabel, and is used after a 
	failure of findulabel
}

var	i,j:integer;
	leroy:ulabel_pointer;
	temp:^secondary_label_table;
	
begin
a_ulabel(myzone,leroy,max_lab_chars-mylabel.labinfo[0]); { get a new one }
copyls(xseto(mylabel.labinfo),xseto(leroy^.text));
leroy^.nodeptr:=NIL;
leroy^.next:=NIL;
if point<>NIL	{ if POINT is non-NIL, do list insertion }
then	begin
	leroy^.next:=point^.next;
	point^.next:=leroy
	end
else	begin	{ otherwise insert in the primary or secondary table }
	i:=mylabel.labinfo[0];
	if i=0
	then	{ zero length goes into the primary direct entry }
		myzone.ltable.direct:=leroy
	else	begin	{ off secondary table }
		temp:=myzone.ltable.stable[mylabel.labinfo[1]];
		if temp=NIL
		then	{ construct the secondary }
			begin
			a_slt(myzone,temp);
			temp^.direct:=NIL;
			for j:=0 to 255
			do	temp^.lchain[j]:=NIL;
			myzone.ltable.stable[mylabel.labinfo[1]]:=temp
			end;
		if i=1
		then	{ direct entry of secondary table }
			temp^.direct:=leroy
		else	begin
			leroy^.next:=temp^.lchain[mylabel.labinfo[2]];
			temp^.lchain[mylabel.labinfo[2]]:=leroy
			end
		end
	end
end; { makeulabel }

function findulabel(	var myzone:zone_entry;
			var mylabel:exp_label;
			var point:ulabel_pointer):boolean;

{	FINDULABEL looks for a unique label in the specified zone.

	If it finds the label, it returns true and sets the
	POINT argument to the ulable's index in the zone's
	label_table.

	If it cannot find the label, it returns false, and sets
	POINT to be either NIL if the label is the first on its
	chain or to point to the existing label it should follow
}

var	i,cresult:integer;
	temp:^secondary_label_table;
	spoint:ulabel_pointer;

begin
i:=mylabel.labinfo[0];
findulabel:=false;

if i>1
then	begin	{ normal case, search chain }
	temp:=myzone.ltable.stable[mylabel.labinfo[1]];
	if temp=NIL
	then	point:=NIL
	else	begin	{ search for label down chain }
		point:=NIL;
		spoint:=temp^.lchain[mylabel.labinfo[2]];
		while spoint<>NIL
		do	begin
			cresult:=lcomp(mylabel.labinfo,spoint^.text);
			if cresult=0
			then	begin
				point:=spoint;
				findulabel:=true;
				spoint:=NIL	{ kick out of loop }
				end
			else	if cresult>0
				then	begin   { after this one }
					point:=spoint;
					spoint:=spoint^.next
					end
				else	spoint:=NIL	{ before here }
			end
		end
	end
else	begin
	if i=0
	then	{ special case for root }
		point:=myzone.ltable.direct
	else	{ length is one, direct from secondary }
		begin
		temp:=myzone.ltable.stable[mylabel.labinfo[1]];
		if temp=NIL
		then	point:=NIL
		else	point:=temp^.direct
		end;
	findulabel:=point<>NIL
	end

end; { findulabel }

function goulabel(var myzone:zone_entry;
		  var mylabel:exp_label):ulabel_pointer;

{	GOULABEL returns a ulabel pointer for the label specified
	by mylabel, creating it if necessary
}

var	point:ulabel_pointer;

begin
while not findulabel(myzone,mylabel,point)
do	makeulabel(myzone,mylabel,point);

goulabel:=point

end; { goulabel }

function finddname(var myzone:zone_entry;
			var myname:exp_dname;
			var missing:integer;
			var point:dname_pointer):boolean;

var	found:boolean;
	current_level:integer;
	ltpoint:label_hashtable_pointer;
	spoint,last_match:dname_pointer;
	lcheck:ulabel_pointer;

begin
current_level:=1;
last_match:=NIL;

repeat	found:=false;
	if findulabel(myzone,myname.dlabels[myname.count-current_level+1],lcheck)
	then	{ if the label exists, it is worth doing a search }
		begin
		ltpoint:=myzone.dtable[current_level];
		if ltpoint=NIL
		then	spoint:=NIL
		else	spoint:=ltpoint^.dname_hash[hashls(
				myname.dlabels[myname.count-current_level+1].labinfo)];
		while (spoint<>NIL) and not(found)
		do	if spoint^.more<>last_match
			then	spoint:=spoint^.dname_chain
			else	if lcheck=spoint^.dlabel.labptr
				then	if elcomp(myname.dlabels[myname.count-current_level+1],
							spoint)
					then	begin	{ labels are the same }
						found:=true;
						last_match:=spoint
						end
					else	spoint:=spoint^.dname_chain
				else	spoint:=spoint^.dname_chain;
		if spoint<>nil
		then	current_level:=current_level+1
		end
until	not(found) or (current_level>myname.count);

point:=last_match;
finddname:=found;
if found
then	missing:=0
else	missing:=myname.count-current_level+1

end; { finddname }

function makedname(var myzone:zone_entry;
		   var myname:exp_label;
		       level:integer;
		       point:dname_pointer):dname_pointer;

{	MAKEDNAME makes a new dname with LEVEL labels using the
	LEVEL-1 labels pointed to by POINT.
}

var	j:integer;
	child:dname_pointer;

begin
a_dname(myzone,child);
with child^
do	begin
	dlabel.labptr:=goulabel(myzone,myname);
	dlabel.case_mod:=myname.case_mod;
	more:=point;
	j:=hashls(myname.labinfo);
	if myzone.dtable[level]=NIL
	then	a_lht(myzone,myzone.dtable[level]);
	dname_chain:=myzone.dtable[level]^.dname_hash[j];
	myzone.dtable[level]^.dname_hash[j]:=child
	end;

makedname:=child

end; { makedname }

function godname(var myzone:zone_entry;
		 var myname:exp_dname):dname_pointer;

{	GODNAME returns a pointer to the specified domain name,
	creating one if necessary
}

var	i,missing:integer;
	point:dname_pointer;

begin
if not finddname(myzone,myname,missing,point)
then	for i:=missing downto 1
	do	point:=makedname(myzone,
				myname.dlabels[i],
				myname.count-i+1,
				point);

godname:=point;

end; { godname }

function newnode(var myzone:zone_entry):node_pointer;

{	NEWNODE gets a new node from free storage and initializes
	all of its pointers to NIL
}
var	foo:node_pointer;

begin
a_node(myzone,foo);
with foo^
do	begin
	node_lchain:=NIL;
	up_ptr:=NIL;
	side_ptr:=NIL;
	down_ptr:=NIL;
	down_tbl:=NIL;
	rr_ptr:=NIL
	end;

newnode:=foo

end; { newnode }

procedure hashson(var myzone:zone_entry;
		      mynode:node_pointer);

{	HASHSON creates a has table for the specified node	}

var	chain:node_pointer;
	break:node_pointer;
	insert:node_pointer;
	done:boolean;
	index:label_hashrange;

begin
if mynode^.down_tbl=NIL
then	begin
	a_lht(myzone,mynode^.down_tbl);
	for index:=0 to label_hashmod-1
	do	mynode^.down_tbl^.node_hash[index]:=NIL;
	chain:=mynode^.down_ptr;
	mynode^.down_ptr:=NIL;
	while	chain<>NIL
	do	begin
		break:=chain^.side_ptr;
		chain^.side_ptr:=NIL;
		index:=hashls(chain^.node_label.labptr^.text);
		insert:=mynode^.down_tbl^.node_hash[index];
		if insert=NIL
		then	mynode^.down_tbl^.node_hash[index]:=chain
		else	if lcomp(chain^.node_label.labptr^.text,
				insert^.node_label.labptr^.text)
			> 0
			then	begin (* insert after first node *)
				done:=false;
				while not(done)
				do if insert^.side_ptr=NIL
					then	done:=true
					else	if lcomp(chain^.node_label.labptr^.text,
							insert^.side_ptr^.node_label.labptr^.text)
						<0
						then	done:=true
						else	insert:=insert^.side_ptr;
				chain^.side_ptr:=insert^.side_ptr;
				insert^.side_ptr:=chain
				end
			else	begin (* insert at head of list *)
				chain^.side_ptr:=insert;
				mynode^.down_tbl^.node_hash[index]:=chain
				end;
		chain:=break
		end
	end
end; { hashson }

function makeson(var myzone:zone_entry;
		     father:node_pointer;	{ new father }
		 var leroy:exp_label;		{ name of child }
		     brother:node_pointer	{ prior brother, if any }
		):node_pointer;

{	MAKESON creates a new child node using an insertion pointer
	supplied in brother.  In general, this function will be called
	after a call to FINDSON fails, and uses the insertion data supplied
	by a losing findson call.
}
var	child:node_pointer;
	temp:label_hashrange;
begin
child:=newnode(myzone);
with child^
do	begin
	up_ptr:=father;
	if brother=NIL	{ insert child }
	then	{ first child of this father }
		begin
		if father^.down_tbl=NIL
		then	begin
			side_ptr:=father^.down_ptr;
			father^.down_ptr:=child
			end
		else	begin
			temp:=hashls(leroy.labinfo);
			side_ptr:=father^.down_tbl^.node_hash[temp];
			father^.down_tbl^.node_hash[temp]:=child
			end
		end
	else	begin	{ just another kid }
		side_ptr:=brother^.side_ptr;
		brother^.side_ptr:=child
		end;
	{ set up the child's node label }
	node_label.case_mod:=leroy.case_mod;
	node_label.labptr:=goulabel(myzone,leroy)
	end;

makeson:=child;

end; { makeson }

function findson(var mynode:node_pointer;
		var mylabel:exp_label;
		var return_ptr:node_pointer;
		var n_searched:integer):boolean;

{	FINDSON looks for the node labeled MYLABEL at the father node
	specified by MYNODE.  If the son is found , the function returns
	true, and returns a pointer to the specified node via return_ptr

	If the function returns false, return_ptr is set to indicate where
	such a son should be inserted.  If at the start of the list,
	NIL is returned, otherwise a pointer to a node to which the new
	son should be appended

	In any case, n_searched is set to be the number of label
	comparisons which were necessary to determine the result.  This
	information is used to guide the use of hashson.}

var	anchor,comp_ptr:node_pointer;
	cresult:integer;

begin
n_searched:=0;	{ have not searched any yet }
anchor:=nil;	{ remember insert value in anchor }
{ can we use fast pointer table ? }
if (mynode^.down_tbl<>NIL) { table exists }
then	comp_ptr:=mynode^.down_tbl^.node_hash[hashls(mylabel.labinfo)]
else	comp_ptr:=mynode^.down_ptr;

if comp_ptr=NIL
then	{ easy case, nothing to search }
	begin
	return_ptr:=anchor;
	findson:=false
	end
else	begin
	repeat	cresult:=lcomp(mylabel.labinfo
				,comp_ptr^.node_label.labptr^.text);
		n_searched:=n_searched+1;
		if cresult>0
		then	{ move on to next comparison }
			begin
			anchor:=comp_ptr;
			comp_ptr:=anchor^.side_ptr
			end
	until	(cresult<=0) or (comp_ptr=NIL);
	findson:=cresult=0;
	if cresult=0
	then	return_ptr:=comp_ptr
	else	return_ptr:=anchor
	end;

end; { findson }

function findnode(var myzone:zone_entry;
		  var myplace:exp_dname;
		  var return_ptr:node_pointer)
		:integer;

{	FINDNODE looks for the specified node.  The value of the FINDNODE
	function is the number of labels that could not be matched.

	return_ptr is set to point to the last node that matched.
}

var	i:integer;
	toss:integer;
	now_at:node_pointer;

begin
return_ptr:=myzone.zone_node;	{ match root without thought }
i:=myplace.count-1;

repeat	if i>0
	then	if findson(return_ptr,myplace.dlabels[i],now_at,toss)
		then	begin
			i:=i-1;
			return_ptr:=now_at
			end
until	(i=0) or (return_ptr=NIL);

findnode:=i

end; { findnode }

function gonode(var myzone:zone_entry;
		var myplace:exp_dname):node_pointer;

{	GONODE finds the node in the specified zone and returns a pointer
	to it, creating it if it must.
}

const	search_thresh=50;	{ how bad findson can get before hash table
				  is created }

var	son_ptr,now_at:node_pointer;
	search_count,i:integer;

begin
now_at:=myzone.zone_node;	{ match root without thought }

for i:=myplace.count-1 downto 1
do	begin
	if findson(now_at,myplace.dlabels[i],son_ptr,search_count)
	then	now_at:=son_ptr
	else	now_at:=makeson(myzone,now_at,myplace.dlabels[i],son_ptr);

	if (search_count>search_thresh)	{ create hash table if required }
		AND
	   (now_at^.up_ptr^.down_tbl=NIL)
	then	hashson(myzone,now_at^.up_ptr)
	end;

gonode:=now_at

end; { gonode }

procedure walknode(mynode:node_pointer;
		   procedure callee;
		   table_index:integer;
		   sequence:integer);

{	WALKNODE walks the node tree below the specified node,
	calling the specified procedure with an argument of a
	node pointer.

	Tbale index refers to the hash index of this node or -1
	if parent's down pointer isn't hashed.

	Sequence is the position of this label on its hash chain or whatever
}

var	callnode:node_pointer;
	hashed:boolean;
	child_slot,child_sequence:integer;

begin
callee(mynode,table_index,sequence);
hashed:=mynode^.down_tbl<>NIL;
child_slot:=-1;	{ assume not hashed }

repeat	if hashed
	then	begin
		child_slot:=child_slot+1;
		callnode:=mynode^.down_tbl^.node_hash[child_slot];
		end
	else	callnode:=mynode^.down_ptr;
	child_sequence:=1;

	while callnode<>NIL
	do	begin
		walknode(callnode,callee,child_slot,child_sequence);
		callnode:=callnode^.side_ptr;
		child_sequence:=child_sequence+1
		end;

until	(child_slot=(label_hashmax)) or not(hashed)
end;

function makechunk(var	myzone:zone_entry;
		   var	newchunk:exp_chunk;
			level:integer;
			splice:rdchunk_pointer)
		:rdchunk_pointer;

var	created:rdchunk_pointer;
	i:integer;
begin
a_rdchunk(myzone,created);	{ allocate a new chunk }
with created^
do	begin
	more:=splice;	{ splice on tail of other chunks }

	i:=hashchunk(newchunk);
	rdchain:=myzone.rdtable[level,i];	{ add to zone chunk list }
	myzone.rdtable[level,i]:=created;

	ckind:=newchunk.ckind;	{ make the chunk }
	case ckind of

	lit_chunk:	begin
			a_litstring(myzone,litdata,
				   max_binary_octets-newchunk.lit_data_count);
			litdata^.lcount:=newchunk.lit_data_count;
			for i:=1 to litdata^.lcount
			do	litdata^.ldata[i]:=newchunk.lit_data[i]
			end;	

	name_chunk:	rrname:=godname(myzone,newchunk.rrname);

	end { case }
	end;

makechunk:=created

end; { makechunk }

function findrdata(var myzone:zone_entry;	{ zone for chunks }
		var newrr:exp_rr;	{ rr with imbedded chunks }
		var missing:integer;	{ number of chunks	  }
		var point:rdchunk_pointer
		):boolean;

{	FINDRDATA looks for encoded version of the chunk chain specified
	in NEWRR.  It does so by first looking for a chunk that matches
	the last chunk, then a chunk chain that matches the last 2 chunks
	etc.

	FINDRDATA can obviously find 0 or more of the required chunks.
	If it finds them all it returns true.

	In any case, it returns with missing set to the number of
	chunks which must be added to the chain, and POINT set to the
	chain it did find.  
}

var	current_level:integer;
	spoint:rdchunk_pointer;		{ chunk being examined for match }
	last_match:rdchunk_pointer;	{ match so far }
	found:boolean;

begin
if newrr.chunk_count=0
then	begin
	missing:=0;
	point:=NIL;
	findrdata:=true
	end
else	begin
	current_level:=0;
	last_match:=NIL;
	repeat	current_level:=current_level+1;
		spoint:=myzone.rdtable[current_level,
			hashchunk(newrr.chunks[newrr.chunk_count-current_level+1])];
		found:=false;
		repeat	if spoint<>NIL
			then	if spoint^.more<>last_match
				then	spoint:=spoint^.rdchain
				else	if chcomp(newrr.chunks[newrr.chunk_count-current_level+1],
							spoint,
							true)
					then	begin
						last_match:=spoint;
						found:=true
						end
					else	spoint:=spoint^.rdchain
		until	(spoint=NIL) or (found=true)
	until	(found=false) or (current_level=newrr.chunk_count);
	if found
	then	missing:=0
	else	missing:=newrr.chunk_count-current_level+1;
	findrdata:=found;
	point:=last_match
	end

end; { findrdata }

function gordata(var myzone:zone_entry;	{ zone for chunks }
		var newrr:exp_rr	{ rr with imbedded chunks }
		):rdchunk_pointer;

{	GORDATA looks for a preexisting set of rdchunks that match
	a set of rdchunks in the new RR, if not found, they are
	created.  Note that this matching must be exact, i.e. case
	sensitive.

}

var	point:rdchunk_pointer;
	missing,i:integer;

begin
if newrr.chunk_count=0
then	gordata:=NIL
else	begin
	if not findrdata(myzone,newrr,missing,point)
	then	for i:=missing downto 1
		do	point:=makechunk(myzone,
					newrr.chunks[i],
					newrr.chunk_count-i+1,
					point);
	gordata:=point
	end

end; { gordata }

procedure zinit(var myzone:zone_entry);

{	ZINIT initializes a zone entry to be empty.  Note that
	the loaded switch may require locking to ensure synchronization
	with other processes
}

var	i,j:integer;
	myclass:dclass;
	mytype:dtype;
	rnode:exp_label;

begin
with myzone
do	begin
	zsoa:=NIL;	{ initialize SOA information }
	zsoa_rr:=NIL;

	loaded:=false;

{	for myclass:=dclass_l_bound to dclass_h_bound
	do	for mytype:=dtype_l_bound to dtype_h_bound
		do	rrtable[mytype,myclass]:=NIL;	  }

	for i:=1 to 255
	do	dtable[i]:=NIL;

	for i:=1 to max_chunk
	do	for j:=0 to 255
		do	rdtable[i,j]:=NIL;

	{ initialize the label table }
	ltable.direct:=NIL;
	for i:=0 to 255
	do	ltable.stable[i]:=NIL;

	{ make a null label }
	zone_node:=newnode(myzone);

	{ make the root node }
	rnode.labinfo[0]:=0;
	zone_node^.node_label.labptr:=goulabel(myzone,rnode);

	end

end; { zinit }

function makerr(var myzone:zone_entry;
		    mynode:node_pointer;
		var myrr:exp_rr):rr_pointer;

{	MAKERR creates a new RR block at the end of the RRs which
	already exist at a specific node, but does not create the chunk
	chains.
}

var	child:rr_pointer;
	rr_anchor:rr_pointer;

begin
{	create the block	}
a_rr(myzone,child);
with child^
do	begin
	next:=NIL;	{ always insert at end }
{	node:=mynode;	}
	ttl:=myrr.ttl;
	rrtype:=myrr.rrtype;
	rrclass:=myrr.rrclass;
	rdata:=NIL;
{	rrchain:=NIL}
	end;

if mynode^.rr_ptr=NIL	{ add to node's RR chain }
then	mynode^.rr_ptr:=child
else	begin
	rr_anchor:=mynode^.rr_ptr;
	while rr_anchor^.next<>NIL
	do	rr_anchor:=rr_anchor^.next;
	rr_anchor^.next:=child
	end;

{	add it to the zone list by type and class	
if myzone.rrtable[child^.rrtype,child^.rrclass]=NIL
then	myzone.rrtable[child^.rrtype,child^.rrclass]:=child
else	begin
	rr_anchor:=myzone.rrtable[child^.rrtype,child^.rrclass];
	while rr_anchor^.rrchain<>NIL
	do	rr_anchor:=rr_anchor^.rrchain;
	rr_anchor^.rrchain:=child
	end;	   }

makerr:=child;

end; { makerr }
procedure makelt(var myzone:zone_entry);

{	MAKELT makes a label table for the specified zone
}

var	now_at:node_pointer;
	myfbp:file_blk_ptr;

	procedure ltindex(input_node:node_pointer);

	{	LTINDEX adds the specified node to the label table
		specified in the call to makelt.  Note the use of
		circular chains.
	}

	
	begin
	with input_node^.node_label.labptr^
	do	if nodeptr=NIL
		then	begin	{ first addition }
			nodeptr:=input_node;
			input_node^.node_lchain:=input_node
			end
		else	begin	{ add to circular list }
			input_node^.node_lchain:=nodeptr^.node_lchain;
			nodeptr^.node_lchain:=input_node
			end
	end; { ltindex }

	procedure lttry(input_node:node_pointer);

	{	This procedure tests a node to see if it should be added to
		its zone's label table.

		If the zone is the cache zone, then all nodes are so
		added.

		If the zone is an authoritative one, then the test is
		whether the father is authoritative, and no NS records
		are present.  Note that the top node of a zone is indexed
		by force in the main code of makelt
	}

	var	found_ns:boolean;
		scan:rr_pointer;

	begin
	if myzone.zone_is_cache
	then	ltindex(input_node)	{ always index cache nodes }
	else	{ nodes in authoritative zones must have a father }
		if input_node^.up_ptr<>NIL
		then	{ and the father must be authoritative }
			if input_node^.up_ptr^.node_lchain<>NIL
			then	{ and must be free of NS delegations }
				begin	{ look for NS records }
				found_ns:=false;
				scan:=input_node^.rr_ptr;
				while not(found_ns)
					AND
				      (scan<>NIL)
				do	if scan^.rrtype=NS
					then	found_ns:=true
					else	scan:=scan^.next;
				if not(found_ns)
				then	ltindex(input_node)
				end
	end; { lttry }

begin

if myzone.zone_is_cache
then	now_at:=myzone.zone_node
else	begin
	now_at:=myzone.zsoa;
	if now_at<>NIL
	then	ltindex(now_at)
	else	begin
		myfbp:=ofile(fatl);
		writeln(myfbp^.fident, 'ADDRR internal error during makelt');
		cfile(myfbp);
		end
	end;

if now_at<>NIL
then	walknode(now_at,lttry,-1,1)
end; { makelt }
function rrbin(myrr:rr_pointer;
		 first:integer;
		 last:integer):integer;

{	RRBIN returns an right shifted integer equal to the concatenation
	of the FIRST through last bytes of binary data in a RR
}

var	sum,index,length:integer;
	scan:rdchunk_pointer;
	myfbp:file_blk_ptr;

begin
sum:=0;
scan:=myrr^.rdata;

repeat	if scan=NIL
	then	begin
		    myfbp:=ofile(fatl);
		    writeln(myfbp^.fident, 'ADDRR internal error');
		    cfile(myfbp);
		end
	else	if scan^.ckind=name_chunk
		then	scan:=scan^.more
		else	begin
			length:=scan^.litdata^.lcount;
			if first<=length
			then	for index:=first to min(last,length)
				do	sum:=bshift(sum,8)+scan^.litdata^.ldata[index];
			first:=first-length;
			last:=last-length
			end
until	first<=0;

rrbin:=sum;

end; { rrbin }
procedure soa_setup(var myzone:zone_entry);

{	SOA_setup copies data from the zone SOA RR to the zone entry
	and checks to see that all authoritative TTLs are
	at least equal to the zone minimum
}

var	mynode:node_pointer;
	scanrr,myrr:rr_pointer;
	myfbp:file_blk_ptr;

	procedure ttl_check(mynode:node_pointer);

	var	scanrr:rr_pointer;

	begin
	if mynode^.node_lchain<>NIL
	then	begin
		scanrr:=mynode^.rr_ptr;
		while scanrr<>NIL
		do	begin
			if scanrr^.ttl<myzone.zone_config.zone_minimum
			then	scanrr^.ttl:=myzone.zone_config.zone_minimum;
			scanrr:=scanrr^.next
			end
		end
	end; { ttl check }

begin
if myzone.zsoa=NIL
then	begin
	myfbp:=ofile(fatl);
	writeln(myfbp^.fident, 'No SOA for SOA setup');
	cfile(myfbp);
	end
else	begin
	scanrr:=myzone.zsoa^.rr_ptr;	{ set myrr to point to the SOA RR }
	myrr:=NIL;
	while myrr=NIL
	do	if scanrr=NIL
		then begin	
			 myfbp:=ofile(fatl);
			 writeln(myfbp^.fident, 'ADDRR internal error');
			 cfile(myfbp);
		     end
		else	if scanrr^.rrtype=SOA
			then	myrr:=scanrr
			else	scanrr:=scanrr^.next
	end;

{ setup fields in the zone entry }
with myzone
do	begin
	zsoa_rr:=myrr;
	with zone_config
	do	begin
		zone_serial:=rrbin(myrr,1,4);
		zone_refresh:=rrbin(myrr,5,8);
		zone_retry:=rrbin(myrr,9,12);
		zone_expire:=rrbin(myrr,13,16);
		zone_minimum:=rrbin(myrr,17,20)
		end
	end;

walknode(mynode,ttl_check,-1,1);

end; { soa_setup }
function concrr(	var myzone:zone_entry;
			    mynode:node_pointer;
			var myrr:exp_rr):boolean;

{	CONCRR adds the specified RR to the specified node	}

var	child:rr_pointer;
begin
{	***** should check for duplicates someday ***** }
child:=makerr(myzone,mynode,myrr);	{ create new rr block on end }
child^.rdata:=gordata(myzone,myrr);
concrr:=true
end; { concrr }

function addrr(	var myzone:zone_entry;
		var myplace:exp_dname;
		var mynode:node_pointer;	{ set on return }
		var myrr:exp_rr):boolean;

{	ADDRR adds the specified RR to the specified zone,
	returning TRUE if all went well
}

begin
mynode:=gonode(myzone,myplace);	{ find the node to begin work at }
addrr:=concrr(myzone,mynode,myrr)

end { addrr }
.
{$M-}
program alloc;

include {NOLIST} 'pascal:extern.pas';		
include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:lparse.def';
include {NOLIST} 'domain:msub.hdr';
include {NOLIST} 'domain:mdep.hdr';
include {NOLIST} 'domain:iomsg.hdr';
include {NOLIST} 'domain:addrr.hdr';
include {NOLIST} 'domain:dump.hdr';

var	y:integer_pointer;
	master:master_block_pointer;

{	**********************************************************

	This file contains procedures for storage allocation

	********************************************************** }

function getdbpage(count:integer):pagenumber;

{	DBPAGE takes a page count as an argument, and returns
	the page number of a that many free pages
}

var	anyused,done:boolean;
	i,j:pagenumber;
	block:free_block_pointer;
	myfbp:file_blk_ptr;

begin
master:=getmaster;
done:=false;
i:=db_first_page;

repeat	anyused:=false;
	for j:=i to i+count-1
	do	anyused:=anyused or master^.used_pages[j];
	if anyused
	then	if i+count>db_last_page
		then	begin
			myfbp:=ofile(fatl);
			writeln(myfbp^.fident, 'Data Base Full');
			cfile(myfbp);
			quit
			end
		else	i:=i+1
	else	begin
		done:=true;
		for j:=i to i+count-1
		do	master^.used_pages[j]:=true;
		getdbpage:=i;
		block:=aofpage(i);
		blkzero(au_per_page*count,block)
		end
until	done;


end; { getdbpage }
function free_round(x:integer):integer;

{	FREE_ROUND is used to round the size of a free block.  While
	block size may be rounded to increase storage efficiency,
	FREE_ROUND must guarantee that a block is at least big enough to
	contain a FREE_BLOCK }

var	y:integer;

begin
if x<au_min_size
then	y:=au_min_size
else	y:=x;

if (y mod au_mod)=0
then	free_round:=y
else	free_round:=((y div au_mod)*au_mod)+au_mod

end; { free_round }

procedure fret(var myzone:zone_entry;
		   poolid:sapool;
		   block:free_block_pointer);

{	FRET releases a block of free storage into a pool for
	a zone.  Note that the page map is unaffected
}

var	done:boolean;
	anchor,search:free_block_pointer;
	newsize:integer;

begin
anchor:=NIL;
search:=myzone.zone_pools[poolid];
block^.size:=free_round(block^.size);

while not done
do	begin
	done:=true;	{ assume it will work }
	{ end of chain ? }
	if search=NIL
	then	begin
		block^.next:=NIL;
		if anchor=NIL
		then	myzone.zone_pools[poolid]:=block
		else	anchor^.next:=block
		end
	else	{ front of next block ? }
		if quotep(block) < quotep(search)
		then	{ either in front or on front }
			begin
			if (quotep(block)+block^.size)=quotep(search)
			then	{ on front }
				begin
				block^.size:=block^.size+search^.size;
				block^.next:=search^.next
				end
			else	{ in front }
				block^.next:=search;
			if anchor=NIL
			then	myzone.zone_pools[poolid]:=block
			else	anchor^.next:=block
			end
		else	{ fits on back ? }
			if (quotep(search)+search^.size)=quotep(block)
			then	begin
				newsize:=search^.size+block^.size;
				{ combine with next ? }
				if (quotep(search)+newsize)=quotep(search^.next)
				then	{ combine three blocks}
					begin
					search^.size:=newsize+search^.next^.size;
					search^.next:=search^.next^.next
					end
				else	{ just two }
					search^.size:=newsize
				end
			else	{ advance }
				begin
				done:=false;
				anchor:=search;
				search:=anchor^.next
				end
	end

end; { fret }
procedure getzpages(var myzone:zone_entry;
		        poolid:sapool;
			size:integer);

{	GETZPAGES is called when an allocation fails and it is
	necessary to acquire new pages.  Because an allocation may exceed
	a page size is passed to specify how large a block is required }

var	page_count:integer;
	page:pagenumber;
	block:free_block_pointer;
	i:integer;

begin
page_count:=(size+au_per_page-1) div au_per_page;
page:=getdbpage(page_count);

{ remember that this zone has the pages }
for i:=0 to page_count-1
do	myzone.zone_pages[page+i]:=true;

{ create a free block }
block:=aofpage(page);
block^.size:=au_per_page*page_count;
fret(myzone,poolid,block);	{ fake a free of this block }

end; { getzpages }
procedure free(var myzone:zone_entry;
		   poolid:sapool;
	       var x:integer_pointer;
		   size:integer);

{	FREE obtains a block of free storage from the specified zone
	pool.
}

var	req_size:integer;
	anchor,scan,left_over:free_block_pointer;

begin
req_size:=free_round(size);	{ get next bigger size }

x:=NIL;
repeat	anchor:=NIL;				{ place to splice }
	scan:=myzone.zone_pools[poolid];	{ place to examine }
	while (x=NIL) and (scan<>NIL)
	do	if scan^.size>=req_size
		then	{ block fits }
			begin
			cpyptr(scan,x);
			if scan^.size=req_size
			then	{ block fits exactly }
				if anchor=NIL
				then	myzone.zone_pools[poolid]:=scan^.next
				else	anchor^.next:=scan^.next
			else	{ left overs }
				begin
				cpyptr(scan,left_over);
				modptr(left_over,req_size);
				left_over^.size:=scan^.size-req_size;
				left_over^.next:=scan^.next;
				if anchor=NIL
				then	myzone.zone_pools[poolid]:=left_over
				else	anchor^.next:=left_over
				end;
			blkzero(req_size,x)
			end
		else	{ advance to next block }
			begin
			anchor:=scan;
			scan:=scan^.next
			end;
	if x=NIL
	then	getzpages(myzone,poolid,req_size) { get adequate contig pages }
until	x<>NIL

end; {free}
procedure a_slt(var myzone:zone_entry;
		var x:secondary_label_table_pointer);

begin
with myzone
do	begin
	sadata[sd_slt,sa_units]:=sadata[sd_slt,sa_units]+1;
	sadata[sd_slt,sa_aus]:=sadata[sd_slt,sa_aus]+free_round(sizeof(x));
	free(myzone,sa_search,y,sizeof(x));
	cpyptr(y,x)
	end
end; { a_slt }

procedure a_ulabel(var myzone:zone_entry;
		var x:ulabel_pointer;
		less_bytes:integer);

var	asize:integer;

begin
with myzone
do	begin
	sadata[sd_ulabel,sa_units]:=sadata[sd_ulabel,sa_units]+1;
	asize:=free_round(sizeof(x)-(less_bytes div bytes_per_au));
	sadata[sd_ulabel,sa_aus]:=sadata[sd_ulabel,sa_aus]+asize;
	free(myzone,sa_search,y,asize);
	cpyptr(y,x)
	end
end; { a_ulabel }

procedure a_dname(var myzone:zone_entry;
		var x:dname_pointer);

begin
with myzone
do	begin
	sadata[sd_dname,sa_units]:=sadata[sd_dname,sa_units]+1;
	sadata[sd_dname,sa_aus]:=sadata[sd_dname,sa_aus]+free_round(sizeof(x));
	free(myzone,sa_data,y,sizeof(x));
	cpyptr(y,x)
	end
end; { a_dname }

procedure a_node(var myzone:zone_entry;
		var x:node_pointer);

begin
with myzone
do	begin
	sadata[sd_node,sa_units]:=sadata[sd_node,sa_units]+1;
	sadata[sd_node,sa_aus]:=sadata[sd_node,sa_aus]+free_round(sizeof(x));
	free(myzone,sa_search,y,sizeof(x));
	cpyptr(y,x)
	end
end; { a_node }

procedure a_lht(var myzone:zone_entry;
		var x:label_hashtable_pointer);

{	allocate a label hashtable }
begin
with myzone
do	begin
	sadata[sd_lht,sa_units]:=sadata[sd_lht,sa_units]+1;
	sadata[sd_lht,sa_aus]:=sadata[sd_lht,sa_aus]+free_round(sizeof(x));
	free(myzone,sa_search,y,sizeof(x));
	cpyptr(y,x)
	end
end; { a_lht }

procedure a_rr(var myzone:zone_entry;
		var x:rr_pointer);

begin
with myzone
do	begin
	sadata[sd_rr,sa_units]:=sadata[sd_rr,sa_units]+1;
	sadata[sd_rr,sa_aus]:=sadata[sd_rr,sa_aus]+free_round(sizeof(x));
	free(myzone,sa_data,y,sizeof(x));
	cpyptr(y,x)
	end
end; { a_rr }

procedure a_rdchunk(var myzone:zone_entry;
		var x:rdchunk_pointer);

begin
with myzone
do	begin
	sadata[sd_rdchunk,sa_units]:=sadata[sd_rdchunk,sa_units]+1;
	sadata[sd_rdchunk,sa_aus]:=sadata[sd_rdchunk,sa_aus]+free_round(sizeof(x));
	free(myzone,sa_data,y,sizeof(x));
	cpyptr(y,x)
	end
end; { a_rdchunk }

procedure a_litstring(var myzone:zone_entry;
		      var x:litstring_pointer;
			  less_bytes:integer);

var	asize:integer;
begin
with myzone
do	begin
	sadata[sd_litstring,sa_units]:=sadata[sd_litstring,sa_units]+1;
	asize:=free_round(sizeof(x)-(less_bytes div bytes_per_au));
	sadata[sd_litstring,sa_aus]:=sadata[sd_litstring,sa_aus]+asize;
	free(myzone,sa_data,y,asize);
	cpyptr(y,x)
	end
end; { a_litstring }

procedure a_zone(var mzp:zone_entry_pointer);

{	This procedure is called to allocate a new zone.

	The allocation procedure is special because we must create the
	zone before we can assign the zone_entry's pages to itself.
}

var	page_count:integer;
	page:pagenumber;
	block:free_block_pointer;
	i:integer;
       
begin
page_count:=(sizeof(mzp)+au_per_page-1) div au_per_page;
page:=getdbpage(page_count);

block:=aofpage(page);
cpyptr(block,mzp);

for i:=0 to page_count-1 (* setup storage allocation *)
do	mzp^.zone_pages[page+i]:=true;
mzp^.sadata[sd_zone,sa_units]:=1;
mzp^.sadata[sd_zone,sa_aus]:=free_round(sizeof(mzp));

zinit(mzp^)

end. { a_zone }

{$M-,X+}

include {NOLIST}'domain:mdep.def';
include {NOLIST}'domain:master.def';
include {NOLIST}'domain:msub.hdr';
include {NOLIST}'domain:irdata.hdr';
include {NOLIST}'domain:eutil.hdr';

const	max_data_octets = 500;  {dg_data_limit-dmn_hdr_sz}



function etoi_edname(var pkt:message_template;
		     var offset:integer;        
		     var name:exp_dname;
		     var ovfl:boolean):boolean;

{ Given an input pkt and an offset into the data area, 
  extract the exp_dname beginning at that offset and 
  place it in name.  A root record will be placed at the
  end of each dname.  Upon return, offset will contain 
  the value of the position after the null terminator 
  of the exp_dname.  Return false if an error found
  during processing.  Set ovfl if everything ok but
  ran out of input. }

var	j, saved_offset, temp, total:integer;
	case_flag, indirect_done, done, ok:boolean;

begin {etoi_edname}

with pkt.raw_pkt, name do
begin
    ok:=true;
    done:=false;
    ovfl:=false;
    count:=1;
    total:=0;
    saved_offset:=0;  {note zero denotes nothing saved}

    while (not done) and ok and (not ovfl) do
    begin  {extract next exp_dname segment}  

	{ Check for compression and adjust offset accordingly. }
	repeat
	    if data_recs[offset]>=300b {high bit set?}
	    then if (pkt.octet_cnt-offset)<1 {need at least 2 bytes}
		 then ovfl:=true
		 else begin
			  indirect_done:=false;
			  if saved_offset=0
			  then {set offset first time for return}
			      saved_offset:=offset+2;

			  temp:=bshift(data_recs[offset]-300b, 8) +
				       data_recs[offset+1];

			  if temp > pkt.octet_cnt  
			  then ovfl:=true
			  else  {check offset validity}
			      if (temp < 12) or  {can't offset into header}
                                 (temp-11 >= offset) {no forward reference}
                              then ok:=false
			      else offset:=temp-11;  {relative to data section}
		      end
	    else indirect_done:=true;
	until (not ok) or ovfl or indirect_done;
	
	{bounds checks}
	if (data_recs[offset]<0)
	   or (data_recs[offset]>max_lab_chars)  {valid label length?}
	   or ((data_recs[offset]+total) >
		   max_dname_chars)  {valid total length?}
	   or ((pkt.octet_cnt-offset)<data_recs[offset])
	   or (count>max_lab_levels)
	then ok:=false
	else begin  {copy segment to name}
		 if pkt.octet_cnt-data_recs[offset] < 0
		 then ovfl:=true
		 else begin
			  dlabels[count].labinfo[0]:=data_recs[offset];
			  total:=total+data_recs[offset];
			  offset:=offset+1;
			  
			  {copy label}
			  for j:=1 to data_recs[offset-1] do
			  begin
			      case_flag:=(data_recs[offset]>=141b)  { a }
				    and (data_recs[offset]<=172b); { z }
			      dlabels[count].case_mod[j]:=case_flag;
			      if case_flag
			      then {lower case}
				  dlabels[count].labinfo[j]:= 
						 data_recs[offset]-40b
			      else dlabels[count].labinfo[j]:= 
						  data_recs[offset];
			      offset:=offset+1;
			  end; {loop}
	      
			  if dlabels[count].labinfo[0]=0 {null terminator}
			  then begin
				   done:=true;
				   if saved_offset>0  {compression}
				   then offset:=saved_offset;
			       end
			  else count:=count+1;
		     end
	         end  {copy segment to dname}
	 end;  {loop}  {extract next exp_dname segment}  
    etoi_edname:=ok;  {set return value of function}	       
end; {with}
end; {etoi_edname}



function etoi_qsctn( var pkt:message_template;
		     var offset:integer; 
		     var qsctn:qsection;
		     var count:integer;
		     var ovfl:boolean):boolean;

{ Parse pkt beginning at offset for the number of
  question section(s) specified by count.  Use 
  etoi_edname to extract the owner name, then type,
  and class.  Return false if an error found while
  parsing.  Set ovfl if ok but ran out of input. }

var   	i, temp:integer;
	ok:boolean;

begin {etoi_qsctn}

with pkt.raw_pkt, qsctn do
begin    
    i:=1;
    if count>max_exp_rrs
    then count:=max_exp_rrs;
    ok:=true;
    ovfl:= offset>pkt.octet_cnt;

    while (i<=count) and ok and (not ovfl) do
    begin
	{extract the qname}
	ok:=etoi_edname(pkt, offset, qnames[i], ovfl);

	if ok and (not ovfl)
	then begin  {extract qtype}
		 if (pkt.octet_cnt-offset) < 3
		 then ovfl:=true
		 else begin
			  temp:= bshift(data_recs[offset], 8) +
				   data_recs[offset+1];
			  offset:=offset+2;
			  if ((temp>ord(dtype_l_bound)) and
			      (temp<ord(dtype_h_bound)) ) or
			      ((temp>=axfr) and (temp<=star))
			  then begin
				   qtypes[i]:=temp;
				   {extract qclass}
				   temp:=bshift(data_recs[offset], 8) +
				   data_recs[offset+1];
				   offset := offset+2;
				   if ((temp>ord(dclass_l_bound)) and
				       (temp<ord(dclass_h_bound)))
				       or (temp=star)
				   then qclasses[i]:=temp
				       else ok:=false;    
			       end
			  else ok:=false;
		      end
		 end  {extract qtype}
	else ok:=false;
	i := i+1;
    end;  { loop }

    {set return values}
    if ovfl
    then count:=i-1;
    etoi_qsctn:=ok;
end;  {with}
end;  {etoi_qsctn}



function etoi_sctn( var pkt:message_template;
		    var offset:integer;
		    var sctn:section;
		    var ovfl:boolean):boolean;

{ Given an input pkt and an offset into the data area, 
  extract the number of answer, authority, or additional
  sections specified by exp_count and place them in
  the sctn provided.  Use etoi_edname to extract the
  owner name, then type, class, ttl, rdlength, and rdata.
  Return false if an error found while parsing; set ovfl 
  if ok but ran out of input. }

var   	i, j, k, count, old_offset, rdlen, rdcnt, strlen:integer;
	ok:boolean;
	tbl:rdata_table_pointer;

begin {etoi_sctn}

with pkt.raw_pkt do
begin
    i:=1;
    ovfl:= offset>pkt.octet_cnt;
    ok:=true;
    if sctn.exp_count>max_exp_rrs
    then sctn.exp_count:=max_exp_rrs;

    {get data from pkt}
    while (i<=sctn.exp_count) and ok and (not ovfl) do
    begin
	{extract the owner name}
	ok:=etoi_edname(pkt, offset, sctn.exp[i].owner, ovfl);

	{bounds check for inclusion of type(2 octets), 
	 class(2 octets), ttl(4 octets), and rdata 
	 length(2 octets) }

	if (offset+9)>pkt.octet_cnt
	then ovfl:=true
	else with sctn.exp[i].rr_data do
	     begin  {get rrtype}
		 rrtype:=chrtype( bshift(data_recs[offset], 8) +
				  data_recs[offset+1] );
		 offset:=offset+2;

		 if (rrtype<=dtype_l_bound) or
		     (rrtype>=dtype_h_bound)
		 then ok:=false    
		 else begin  {get rrclass}
			  rrclass:=chrclass( bshift(data_recs[offset], 8)
					     + data_recs[offset+1]);
			  offset:=offset+2;

			  if (rrclass<=dclass_l_bound) or
			      (rrclass>=dclass_h_bound)
			  then ok:=false    
			  else begin  {get ttl}
				   ttl:=bshift(data_recs[offset], 24) +
				        bshift(data_recs[offset+1], 16) +
					bshift(data_recs[offset+2], 8) +
					data_recs[offset+3];
				   offset:=offset+4;
	
				   rdlen:=bshift(data_recs[offset],8) +
					  data_recs[offset+1];
				   offset:=offset+2;
			       end;
		      end;
	     end;  {do this for indentation}

	if offset+rdlen-1>pkt.octet_cnt  {bounds check}
	then ovfl:=true;

	if (rdlen>max_chunk*max_binary_octets) {implementation restriction}
        then ok:=false
        else if not ovfl
	     then if rdlen<>0  {don't interpret 0 rdata length as error}
		  then with sctn.exp[i].rr_data do
		  begin  {get rdata}
		      old_offset:=offset;
		      if i=1
		      then {only create table once}
			  tbl:=irdata(rrclass);  {get ^rdata descriptor}

		      {rdcnt and j will lose alignment if chunk
		       is larger than max allowed for 1 exp_chunk}
		      rdcnt:=1; {index into tbl}
		      j:=1;  {chunk count}

		      {Store rdata segments distinguishing
		       segment types}
		      repeat
			  case tbl^[rrtype].rdata_item[rdcnt] of
			      dname_field: 
				   begin
				       chunks[j].ckind:=name_chunk;
				       ok:=etoi_edname(pkt, offset,
					       chunks[j].rrname, ovfl);
				   end;
			      
			      cstring_field:
				    begin
					{make length checks based on
					 string length which is first octet}
					strlen:=data_recs[offset];
					if ((max_chunk-j)*max_binary_octets<
					    strlen) {enough space}
					    or (offset+strlen>
						old_offset+rdlen) {bad strlen}
					then ok:=false
					else begin  {copy string}
						 strlen:=strlen+1; {strlen too}
						 chunks[j].ckind:=lit_chunk;
						 chunks[j].lit_data_count:=
								   strlen;
						 k:=1;
						 repeat
						     chunks[j].lit_data[k]:= 
						       data_recs[offset];
						     offset:=offset+1;
						     strlen:=strlen-1;
						     if k=max_binary_octets
						     then begin
						          chunks[j].
							    lit_data_count:=k;
							  k:=1;
							  if strlen<>0
							  then begin 
							       {didn't end
							        on a chunk
							        boundary}
							       j:=j+1;
							       chunks[j].
							       ckind:=
							         lit_chunk;
							       end;
							  end
						     else k:=k+1;
						 until strlen=0;
					     end;
				    end;

			      int16_field: 
				    begin
					if offset+2>rdlen+old_offset
					then {bad rdlen}
					    ok:=false    
					else begin
						 chunks[j].ckind:=lit_chunk;
						 chunks[j].lit_data_count:=2;
						 for k:=1 to 2 do
						 begin
						     chunks[j].lit_data[k]:= 
						       data_recs[offset];
						     offset:=offset+1;
						 end;
					     end;
				    end;

			      time_field,
			      int32_field,
			      inet_a_field: 
				    begin
					if offset+4>rdlen+old_offset
					then {bad rdlen}
					    ok:=false    
					else begin
						 chunks[j].ckind:=lit_chunk;
						 chunks[j].lit_data_count:=4;
						 for k:=1 to 4 do
						 begin
						     chunks[j].lit_data[k]:= 
						       data_recs[offset];
						     offset:=offset+1;
						 end;
					     end;
				    end;
			      
			      inet_p_field:
				   begin
				       if offset+1>rdlen+old_offset
				       then ok:=false    
				       else begin
						chunks[j].ckind:=lit_chunk;
						chunks[j].lit_data_count:=1;
						chunks[j].lit_data[1]:= 
							  data_recs[offset];
						offset:=offset+1;
					    end;
				   end;

			      inet_s_field:
				   begin
				       chunks[j].ckind:=lit_chunk;
				       chunks[j].lit_data_count:=
						 rdlen-(offset-old_offset);
				       for k:=1 to chunks[j].lit_data_count do
				       begin
					   chunks[j].lit_data[k]:=
						     data_recs[offset];
					   offset:=offset+1;
				       end;
				   end;

			      vbinary_field:
				    begin
					chunks[j].ckind:=lit_chunk;
					k:=1;
					for count:=1 to rdlen do
					begin    
					    chunks[j].lit_data[k]:= 
						      data_recs[offset];
					    offset:=offset+1;
					    if k=max_binary_octets
					    then begin
						     chunks[j].
						       lit_data_count:=k;
						     k:=1;
						     if count<>rdlen
						     then begin 
							  {didn't end
							   on a chunk
							   boundary}
							   j:=j+1;
						           chunks[j].ckind:=
							     lit_chunk;
							   end;
						 end
					    else k:=k+1;
				        end;
			            end;
			  end;  {case}
			  rdcnt:=rdcnt+1;
			  j:=j+1;
		      until (tbl^[rrtype].rdata_item[rdcnt]=no_more_field)
			    or (not ok) or ovfl;
		      chunk_count:=j-1;

		      if ok  {compress data chunks}
		      then ok:=rrsquash(sctn.exp[i].rr_data);
		  end; {get rdata}
	     i := i+1;
    end; { main loop }
    
    {set return values}
    if ovfl
    then sctn.exp_count:=i-1;
    etoi_sctn:=ok;
end;  {with}
end;  {etoi_sctn}


function itoe_rrdname(    dptr:dname_pointer;
			  nptr:node_pointer;
		      var pkt: message_template;
		      var offset:integer):boolean;

{ Either dptr or nptr will be non nil.  Build the dname
  by one of two methods.  1) dptr<>nil: write the dname
  held in rdata.  2) nptr<>nil:  reverse the node path
  to the root, writing each node label in the pkt.
  Return true if overflow occured. }

var	i, len:integer;
	ovfl, done, node_path:boolean;
	segment:lab_use;

begin {itoe_rrdname}

with pkt.raw_pkt do
begin
    done:=false;
    ovfl:= offset>max_data_octets;

    { Strategy:  at each iteration, segment will contain the
      lab_use which will be copied into pkt.  Use the
      variable "owner" to determine how to increment the
      structure pointer (nptr or dptr) and subsequently,
      fill-in segment. }

    if nptr<>nil
    then begin
	     segment:=nptr^.node_label;
	     node_path:=true;
	 end
    else begin
	     segment:=dptr^.dlabel;	
	     node_path:=false;
	 end;
    
    while (not done) and (not ovfl) do
    begin	
	len:=segment.labptr^.text[0];
	if (len+offset)>max_data_octets
	then begin
		 ovfl:=true;
		 len:=max_data_octets-offset;
	     end;
	
	data_recs[offset]:=segment.labptr^.text[0];
	offset:=offset+1;

	{copy text}
	for i:=1 to len do
	begin    
	    if segment.case_mod[i]  {map octet to lower case}
	    then data_recs[offset]:=segment.labptr^.text[i]+40b
	    else data_recs[offset]:=segment.labptr^.text[i];
	    offset:=offset+1;
	end;
		     
	{update pointers}
	if node_path
	then begin  
		 nptr:=nptr^.up_ptr;
		 if nptr=nil
		 then done:=true
		 else segment:=nptr^.node_label;
	     end
	else begin  
		 dptr:=dptr^.more;
		 if dptr=nil
		 then done:=true
		 else segment:=dptr^.dlabel;	
		 end;
    end;  {loop}
    itoe_rrdname:=ovfl;  {set return value}
end; {with}
end; {itoe_rrdname}


function itoe_dname(	 name:exp_dname;
		     var pkt:message_template;
		     var offset:integer):boolean;

{ Given an exp_dname, place it in pkt beginning
  at offset.  A true return implies overflow. }

var	i, j, len:integer;
	ovfl:boolean;

begin {itoe_dname}

with pkt.raw_pkt do
begin

    ovfl:= offset>max_data_octets;
    i:=1; 

    while (i<=name.count) and (not ovfl) do
    with name.dlabels[i] do
    begin    
	len:=labinfo[0];
	if len >= 300b  {compression preset}
	then begin
		 if (offset+2) > max_data_octets
		 then ovfl:=true
		 else begin
			  data_recs[offset]:=labinfo[0];
			  data_recs[offset+1]:=labinfo[1];
			  offset:=offset+2;
		      end
	     end
	else begin
		 if (offset+len) > max_data_octets
		 then begin
			  ovfl:=true;
			  len:=max_data_octets-offset;
		      end;
		 
		 {length field}
		 data_recs[offset]:=labinfo[0];
		 offset:=offset+1;

		 for j:=1 to len do
		 begin  {copy text}
		     if case_mod[j]  { map octet to lower case }
		     then data_recs[offset]:=labinfo[j]+40b
		     else data_recs[offset]:=labinfo[j];
		     offset:=offset+1;
		 end;
	     end;
	i:=i+1;    
    end; {i loop}

    itoe_dname:=ovfl;  {set return value}
end; {with}
end; {itoe_dname}


function itoe_qsctn(var qsec:qsection;
		    var pkt:message_template;
		    var offset:integer;
		    var count:integer):boolean;

{ Copy the data from the q_section into
  pkt beginning at offset.  If overflow
  occurs, return true and change count to
  reflect number of complete records copied. }

var	i, j:integer;
	ovfl:boolean;

begin {itoe_qsctn}

with qsec, pkt.raw_pkt do
begin
    ovfl:= offset>max_data_octets;
    i:=1;

    if header.opcode=inv_query
    then  {copy from qanswer}
	while (i<=count) and (not ovfl) do
	begin	
	    ovfl:=itoe_rrdname(nil, qanswer[i]^.node, pkt, offset);
	    
	    if not ovfl
	    then with qanswer[i]^ do
		 begin
		     j:=1;
		     while (j<=4) and (offset<=max_data_octets) do
		     begin
			 {type and class} 
			 case j of
			     1: data_recs[offset]:=ord(rrtype) div "100;
			     2: data_recs[offset]:=ord(rrtype) mod "100;
			     3: data_recs[offset]:=ord(rrclass) div "100;
			     4: data_recs[offset]:=ord(rrclass) mod "100;
			 end;
			 offset:=offset+1;
			 j:=j+1;
		     end;
		 end;
	    if offset>max_data_octets
	    then ovfl:=true;
	    i:=i+1;
	end
    else  {copy from qnames, qtypes, and qclasses} 
	while (i<=count) and (not ovfl) do
	begin	
	    ovfl:=itoe_dname(qnames[i], pkt, offset); 
	
	    if not ovfl
	    then begin
		     j:=1;
		     while (j<=4) and (offset<=max_data_octets) do
		     begin
			 {type and class} 
			 case j of
			     1: data_recs[offset]:=qtypes[i] div "100;
			     2: data_recs[offset]:=qtypes[i] mod "100;
			     3: data_recs[offset]:=qclasses[i] div "100;
			     4: data_recs[offset]:=qclasses[i] mod "100;
			 end;
			 offset:=offset+1;
			 j:=j+1;
		     end;
		 end;
	    if offset>max_data_octets
	    then ovfl:=true;
	    i:=i+1;
	end;

    if ovfl
    then count:=i-1;
    itoe_qsctn:=ovfl;
end; {with}
end; {itoe_qsctn}


function itoe_isctn(var sec:section;
		    var pkt:message_template;
		    var offset:integer):boolean;

{ Copy the int_ information from sec to pkt beginning
  at offset.  If overflow occurs, return true and
  change the section counts to reflect actual records
  copied. }

var	i, j, temp, howmany, len, old_off, filled:integer;
	ovfl:boolean;
	np_old:node_pointer;
	ptr:rdchunk_pointer;

begin {itoe_isctn}

with sec do
begin
    ovfl:= offset>max_data_octets;
    i:=1;
    filled:=0;
    old_off:=0;
    np_old:=nil;

    while (i<=int_count) and (not ovfl) do
    begin
	if int[i].owner_used
	then {copy the expanded dname}
	    ovfl:=itoe_dname(int[i].owner, pkt, offset)
	else {internal dname--compress if possible}
	    if (np_old = int[i].rr_ptr^.node)
	    then if (offset + 2) > max_data_octets
		 then ovfl:=true
		 else begin
			  pkt.raw_pkt.data_recs[offset]:=
				      300b + (old_off div "100);
			  pkt.raw_pkt.data_recs[offset+1]:=
				      old_off mod "100;
			  offset:=offset+2;
		      end
	    else begin
		     old_off:=offset+dmn_hdr_sz-1;
		     np_old:=int[i].rr_ptr^.node;
		     ovfl:=itoe_rrdname(nil, int[i].rr_ptr^.node,
				      pkt, offset);
		 end;
	    
	if not ovfl 
	then with int[i].rr_ptr^, pkt.raw_pkt do
	     begin
		 if (offset+7)>max_data_octets
	         then begin
			  ovfl:=true;
			  howmany:=max_data_octets-offset+1;
		      end
		 else howmany:=8;

		 for j:=1 to howmany do
		 begin
		     case j of 
			 {type and class}
			 1: data_recs[offset]:=ord(rrtype) div "100;
			 2: data_recs[offset]:=ord(rrtype) mod "100;
			 3: data_recs[offset]:=ord(rrclass) div "100;
			 4: data_recs[offset]:=ord(rrclass) mod "100;;
			 {ttl}
			 5, 6, 7, 8: 
			    data_recs[offset]:=band(bshift(ttl,-((8-j)*8)),
						      377b);
		     end;
		     offset:=offset+1;
		 end;
		 
		 {rdlength and rdata}
		 if not ovfl
		 then begin
			  ptr:=rdata;
			  if (offset+2) > max_data_octets
			  then ovfl:=true
			  else begin
				   if ptr<>nil  {designate 0 length rdata}
				   then temp:=offset;  {for rdlength}
				   offset:=offset+2;
			       end;
			  
			  while (ptr<>nil) and (not ovfl) do
			  begin	 {ptr loop}
			      if ptr^.ckind=name_chunk
			      then ovfl:=itoe_rrdname(ptr^.rrname, nil,
						    pkt, offset)

			      else with ptr^.litdata^ do
				   begin  {literal data}
				       len:=lcount;
				       if (offset+len) > max_data_octets
				       then begin
						ovfl:=true;
						len:=max_data_octets-offset+1;
					    end;
				       for j:=1 to len do
				       begin
					   data_recs[offset]:=ldata[j];
					   offset:=offset+1;
				       end;
				   end; {literal data}
			      ptr:=ptr^.more;
		          end; {ptr loop}
			  if not ovfl
			  then begin  {fill-in rdlength}
				   data_recs[temp]:=(offset-temp-2)
						   div "100;
				   data_recs[temp+1]:=(offset-temp-2)
						     mod "100;
				   filled:=filled+1;  {count of actual records
						       to send}
			       end;
		    end;
	     end; {with}
	i:=i+1;
    end; {i loop}
    if ovfl
    then sec.int_count:=filled;
    itoe_isctn:=ovfl;		 
end; {with}
end; {itoe_isctn}


function itoe_esctn(var sec:section;
		    var pkt:message_template;
		    var offset:integer):boolean;

{ Copy the data from the exp_ portion of section into
  pkt beginning at offset. }

var	i, j, k, temp, len, howmany, filled:integer;
	ovfl:boolean;
	
begin {itoe_esctn}

with pkt.raw_pkt do
begin
    ovfl:= offset>max_data_octets;
    i:=1;
    filled:=0;

    while (i<=sec.exp_count) and (not ovfl) do
    with sec.exp[i] do	
    begin  {main loop}	
	if owner.count>0
	then ovfl:=itoe_dname(owner, pkt, offset)
	else begin  {null section}
		 data_recs[offset]:=0;
		 offset:=offset+1;
	     end;
	
	if not ovfl
	then with rr_data do
	     begin  {everything else}
		 if (offset+7) > max_data_octets
		 then begin
			  ovfl:=true;
			  howmany:=max_data_octets-offset+1;
		      end
		 else howmany:=8;
		 for j:=1 to howmany do
		 begin
		     case j of
			  {type, class}
			 1: data_recs[offset]:=ord(rrtype) div "100;
			 2: data_recs[offset]:=ord(rrtype) mod "100;
			 3: data_recs[offset]:=ord(rrclass) div "100;
			 4: data_recs[offset]:=ord(rrclass) mod "100;
			 5, 6, 7, 8:  {ttl}
			    data_recs[offset]:=
				       band( bshift(ttl,-((8-j)*8)), 377b );
		     end;
		     offset:=offset+1;
		 end;
		 
		 if not ovfl
		 then begin  {rdlength and rdata}
			  if chunk_count=0 
			  then if (offset+2) <= max_data_octets
			       then offset:=offset+2 {designate 0 length rdata}
			       else ovfl:=true
			  else if (offset+2) <= max_data_octets
			       then begin
				   temp:=offset; {placeholder for rdata length}
				   offset:=offset+2;
			       end
			  else ovfl:=true;

			  j:=1;
			  while (j<=chunk_count) and (not ovfl) do
			  with chunks[j] do
			  begin
			      if ckind=name_chunk
			      then ovfl:=itoe_dname(rrname,
						  pkt, offset) 
			      else begin {literal data}
				       len:=lit_data_count;
				       if (offset+len-1)>max_data_octets
				       then begin
						ovfl:=true;
						len:=max_data_octets-offset+1;
					    end;
				       for k:=1 to len do
				       begin
					   data_recs[offset]:=lit_data[k];
					   offset:=offset+1;
				       end;
				   end;
			      j:=j+1;
			  end; {j loop}
			  {rdata length}
			  if not ovfl
			  then begin
				   data_recs[temp]:=(offset-temp-2) div "100;
				   data_recs[temp+1]:=(offset-temp-2) mod "100;
				   filled:=filled+1;  {count of records 
						       to send}
			       end;
		      end; {else}
	      end;
        i:=i+1;
    end;  {main loop}
    if ovfl
    then sec.exp_count:=filled;
    itoe_esctn:=ovfl;
end; {with}
end. {itoe_esctn}
{$M-,X+}
program dump;

include {NOLIST} 'domain:jsys.def';
include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:lparse.def';
include {NOLIST} 'domain:addrr.hdr';
include {NOLIST} 'domain:alloc.hdr';
include {NOLIST} 'domain:msub.hdr';
include {NOLIST} 'domain:pp.hdr';
include {NOLIST} 'domain:irdata.hdr';
include {NOLIST} 'domain:iomsg.hdr';
include {NOLIST} 'domain:mdep.hdr';

{	**********************************************************

	This file contains procedures for dumping zone data

	********************************************************** }

function dmpa(var dfile:file;
	          z:integer):integer;

{	DMPA dumps a pointer	}

begin
write(dfile,'^');
write(dfile,z:8:o);
dmpa:=8;
end; { dmpa }

function dmpelabel(var dfile:file;
		   var mylabel:exp_label
		  ):integer;

var	i,count:integer;
	c:char;

begin
count:=0;
with mylabel
do	for i:=1 to labinfo[0]
	do	begin
		if case_mod[i]
		then	c:=chr(labinfo[i]+ord('a')-ord('A'))
		else	c:=chr(labinfo[i]);
		count:=count+1;
		write(dfile,c)
		end;

dmpelabel:=count

end; { dmpelabel }

function dmpedn(var dfile:file;
		var myname:exp_dname
		):integer;

{	DMPEDN dumps an expanded domain name	}

var	i,count:integer;

begin
count:=0;
if myname.count=1
then	begin
	count:=1;
	write(dfile,'.')
	end
else	for i:=1 to myname.count-1
	do	begin
		count:=count+dmpelabel(dfile,myname.dlabels[i]);
		write(dfile,'.');
		count:=count+1
		end;

dmpedn:=count

end; { dmpedn }
function dmpdns(var dfile:file;
		    dname:G1bpt):integer;

{	DMPDNS dumps a domain_string to a file	}

var	i,j,ll,count:integer;

begin { dmpdns }
i:=1;
count:=0;
repeat	ll:=xildb(dname);
	if ((ll<>0) and (count>0)) or ((ll=0) and (count=0))
	then	begin
		    count:=count+1;
		    write(dfile,'.')
		end;
        if ll<>0
	then	for j:=1 to ll
		do	write(dfile,chr(xildb(dname)));
	count:=count+ll;
until	ll=0;
dmpdns:=count

end; { dmpdns }

procedure dmpltable(var dfile:file;
		    var myzone:zone_entry);

var	i:integer;

	procedure print_label(lpoint:ulabel_pointer);

	var	discard,j:integer;

	begin
	write(dfile,i:4,' ');
	i:=i+1;
	discard:=dmpa(dfile,quotep(lpoint));
	write(dfile,' ');
	discard:=dmpa(dfile,quotep(lpoint^.nodeptr));
	write(dfile,' ');
	with lpoint^
	do	begin
		for j:=1 to text[0]
		do	write(dfile,chr(text[j]));
		writeln(dfile,' ')
		end

	end; { print_label }

begin
writeln(dfile,'***** Label Table *****');
writeln(dfile,' ');
i:=1;
walklabel(myzone,print_label);

end; { dmpltable }

function dmpquote(var dfile:file;
		      c:octet):integer;

begin
if (chr(c)='.')
	OR
   (chr(c)='\')
	OR
   (chr(c)=' ')
	OR
   (chr(c)=';')
then	begin
	dmpquote:=1;
	write(dfile,'\')
	end
else	dmpquote:=0

end; { dmpquote }

function dmplu(var dfile:file;
	       var lu:lab_use):integer;

{	DMPLU dumps a lab_use	}

var	i,count:integer;
	c:octet;

begin
count:=0;
with lu
do	for i:=1 to labptr^.text[0]
	do	begin
		c:=labptr^.text[i];
		count:=count+dmpquote(dfile,c);
		if case_mod[i]
		then	write(dfile,chr(c+ord('a')-ord('A')))
		else	write(dfile,chr(c));
		count:=count+1
		end;

dmplu:=count;

end; { dmplu }

function dmpdn(var dfile:file;
		   dpoint:dname_pointer):integer;

{	DMPDN dumps a domain name given a dname_pointer	}
var	count:integer;

begin
count:=0;
if (dpoint^.dlabel.labptr^.text[0]=0)
	AND
   (dpoint^.more=NIL)
then	begin
	write(dfile,'.');
	count:=1
	end
else	while dpoint<>NIL
	do	begin
		count:=count+dmplu(dfile,dpoint^.dlabel);
		dpoint:=dpoint^.more;
		if dpoint<>NIL
		then	begin
			write(dfile,'.');
			count:=count+1
			end
		end;

dmpdn:=count

end; { dmpdn }

function dmpnn(var dfile:file;
		   mynode:node_pointer):integer;

{	DMPNN dumps a node name given a node pointer	}

var	count:integer;

begin
count:=dmplu(dfile,mynode^.node_label)+1;
write(dfile,'.');
if mynode^.up_ptr<>NIL
then	if mynode^.up_ptr^.up_ptr<>NIL
	then	count:=count+dmpnn(dfile,mynode^.up_ptr);

dmpnn:=count

end;

function dmpatom(var dfile:file;
		 var myatom:atom):integer;

var	last,i:integer;
	c:char;

begin
last:=max_atom_chars;
repeat	c:=myatom[last];
	if c=' '
	then	last:=last-1
until	(last=0) or (c<>' ');

for i:=1 to last
	do	write(dfile,myatom[i]);

dmpatom:=last

end; { dmpatom }
function dmpina(var dfile:file;
		      ina:integer):integer;

var	myatom:atom;

begin
ppina(ina,myatom);
dmpina:=dmpatom(dfile,myatom)
end;
procedure dmphst(var dfile:file;
		     ina:integer);

var hn:packed array[1..100] of char;
    rval,i:integer;

begin
jsys(gthst,-2,rval;2,hn,ina);
if rval<>3
then begin (* GTHST knew it *)
	 i:=1;
	 while (i<100) and (ord(hn[i])<>0)
	 do begin
		write(dfile,hn[i]);
		i:=i+1
	    end
     end
else i:=dmpina(dfile,ina)
end;

procedure dmpcc(var dfile:file;
		   scan:rdchunk_pointer);

{	DMPCC dumps a chunk chain.  DMPCC is not as bright about
	dumping the chain as DMPRDATA, because it doesn't assume
	that it knows the format of the RR.
}

var	myatom:atom;
	i,discard:integer;

begin
while scan<>NIL
do	begin
	if scan^.ckind=name_chunk
	then	discard:=dmpdn(dfile,scan^.rrname)
	else	with scan^.litdata^
		do	for i:=1 to lcount
			do	begin
				ppint(ldata[i],myatom);
				discard:=dmpatom(dfile,myatom);
				write(dfile,' ')
				end;
	write(dfile,' ');
	scan:=scan^.more
	end

end; { dmpcc }

procedure dmprdata(var dfile:file;
		       mytype:dtype;
		       myclass:dclass;
		       scan:rdchunk_pointer);

{	DMPRDATA dumps a RDATA chain using knowledge of the
	desired structure
}

var	table:rdata_table_pointer;
	oscan:integer;			{ next unused octet this chunk }
	rdindex:integer;
	value:integer;
	myatom:atom;
	i,discard:integer;

	procedure dump_error;

	begin
	write(dfile,'***** DATA ERROR *****');
	end; { dump error }

	function getn(n:integer):boolean;

	{	GETN peels off N octets from a lit chunk
		and puts the integer in value
	}
	
	var	j:integer;

	begin
	if (scan^.ckind<>lit_chunk)
		OR
	   ((scan^.litdata^.lcount-oscan+1)<n)

	then	begin
		dump_error;
		getn:=false
		end
	else	begin
		value:=0;
		for j:=oscan to oscan+(n-1)
		do	value:=(value*256)+scan^.litdata^.ldata[j];
		oscan:=oscan+n;
		if oscan>scan^.litdata^.lcount
		then	begin
			oscan:=1;
			scan:=scan^.more;
			end;
		getn:=true
		end
	end; { getn }

begin
oscan:=1;
rdindex:=1;
table:=irdata(myclass);
with	table^[mytype]
do	while rdata_item[rdindex]<>no_more_field
	do
	begin
	if scan<>NIL
	then	case rdata_item[rdindex] of

		dname_field:	if scan^.ckind<>name_chunk
				then	dump_error
				else	begin
					discard:=dmpdn(dfile,scan^.rrname);
					write(dfile,' ');
					scan:=scan^.more
					end;

		cstring_field:	if scan^.ckind<>lit_chunk
				then	dump_error
				else	begin
					for i:=oscan+1 to scan^.litdata^.ldata[oscan]+oscan
					do write(dfile,chr(scan^.litdata^.ldata[i]));
					write(dfile,' ');
					oscan:=oscan+scan^.litdata^.ldata[oscan]+1;
					if oscan>scan^.litdata^.lcount
					then	begin
						oscan:=1;
						scan:=scan^.more
						end
					end;

		int16_field:	if getn(2)
				then	begin
					ppint(value,myatom);
					discard:=dmpatom(dfile,myatom);
					write(dfile,' ')
					end
				else	dump_error;

		time_field,
		int32_field:	if getn(4)
				then	begin
					ppint(value,myatom);
					discard:=dmpatom(dfile,myatom);
					write(dfile,' ')
					end
				else	dump_error;

		inet_a_field:	if getn(4)
				then	begin
					ppina(value,myatom);
					discard:=dmpatom(dfile,myatom);
					write(dfile,' ')
					end
				else	dump_error;


		inet_p_field:	;

		inet_s_field:	;

		vbinary_field:	if scan^.ckind=lit_chunk
				then	begin
					for i:=oscan to scan^.litdata^.lcount
					do	begin	{ dump an octet }
						ppint(scan^.litdata^.ldata[i]
							,myatom);
						discard:=dmpatom(dfile,myatom)
						end;
					scan:=scan^.more
					end
				else	dump_error;		

		others:	dump_error;

		end; { case }

	rdindex:=rdindex+1
	end;

if scan<>NIL
then	write(dfile,'***** EXTRA DATA *****');

end; { dmprdata }

procedure dtct(var dfile:file;
		   myttl:integer;
		   myclass:dclass;
		   mytype:dtype);

var	myatom:atom;

	procedure padout;

	var	i:integer;

	begin
	for i:=dmpatom(dfile,myatom) to 8
	do	write(dfile,' ')
	end; { padout }

begin
if myttl>9999999	{ output 7 digits of TTL or stars }
then	write(dfile,'******* ')
else	begin
	ppint(myttl,myatom);
	padout
	end;

ppclass(myclass,myatom);	{ output class }
padout;

pptype(mytype,myatom);
padout;

end; { dtct }
procedure dmprr(var dfile:file;
		var rpt:rr_pointer);

{	DMPRR dumps the TTL, TYPE, CLASS, and RDATA parts of a RR }


begin
with rpt^
do	begin
	dtct(dfile,ttl,rrclass,rrtype);

	dmprdata(dfile,rrtype,rrclass,rdata)
	end

end; { dmprr }

procedure dmpdtable(var dfile:file;
		    var myzone:zone_entry);

var	discard,i,j:integer;
	scan:dname_pointer;

begin
writeln(dfile,'***** Domain name table *****');
writeln(dfile,' ');
for i:=1 to 255
do	if myzone.dtable[i]<>NIL
	then	begin
		writeln(dfile,'Length= ',i:3);
		for j:=0 to label_hashmax
		do	begin
			writeln(dfile,' Hash=',j:3);
			scan:=myzone.dtable[i]^.dname_hash[j];
			while scan<>NIL
			do	begin
				discard:=dmpa(dfile,quotep(scan));
				write(dfile,' ');
				discard:=dmpa(dfile,quotep(scan^.more));
				write(dfile,' ');
				discard:=dmpdn(dfile,scan);
				writeln(dfile,' ');
				scan:=scan^.dname_chain
				end
			end;
		writeln(dfile)
		end;

writeln(dfile,' ')

end; { dmpdtable }

procedure dmprrtable(var dfile:file;
		     var myzone:zone_entry);

var	discard:integer;
	i:dtype;
	j:dclass;
	scan:rr_pointer;
	myatom:atom;

begin
{writeln(dfile,'***** RR table *****');
writeln(dfile,' ');

for i:=succ(dtype_l_bound) to pred(dtype_h_bound)
do	for j:=succ(dclass_l_bound) to pred(dclass_h_bound)
	do	begin
		scan:=myzone.rrtable[i,j];
		if scan<>NIL
		then	begin
			ppclass(j,myatom);
			discard:=dmpatom(dfile,myatom);
			write(dfile,chr(TAB));
			pptype(i,myatom);
			discard:=dmpatom(dfile,myatom);
			write(dfile,chr(TAB));
			dmprdata(dfile,i,j,scan^.rdata);
			writeln(dfile,' ');
			scan:=scan^.rrchain;
			while scan<>NIL
			do	begin
				write(dfile,chr(TAB),chr(TAB));
				dmprdata(dfile,i,j,scan^.rdata);
				writeln(dfile,' ');
				scan:=scan^.rrchain
				end
			end
		end
}
end; { dmprrtable }

procedure dmprdtable(var dfile:file;
		     var myzone:zone_entry);

{	DMPRDTABLE dumps the chunk table for a zone	}

var	discard,i,j:integer;
	any:boolean;
	scan:rdchunk_pointer;
begin
writeln(dfile,'***** Chunk table *****');
writeln(dfile,' ');
for i:=1 to max_chunk
do	begin
	any:=false;
	j:=0;
	while (j<255) and not(any)
	do	if myzone.rdtable[i,j]=NIL
		then	j:=j+1
		else	any:=true;
	if any
	then	for j:=0 to 255
		do	begin
			writeln(dfile,'Length=',i:2,' Hash=',j:3);
			scan:=myzone.rdtable[i,j];
			while scan<>NIL
			do	begin discard:=dmpa(dfile,quotep(scan));
				write(dfile,' ');
				discard:=dmpa(dfile,quotep(scan^.more));
				write(dfile,' '); dmpcc(dfile,scan);
				writeln(dfile,' '); scan:=scan^.rdchain
				end
			end
	end;

writeln(dfile,' ')

end; { dmprdtable }
procedure dmpmfile(var dfile:file;
		   var myzone:zone_entry);

{	DMPMFILE dumps a zone in master file format	}

var	scan:node_pointer;

	procedure dmpnode(mynode:node_pointer;
			  slot:integer;
			  sequence:integer);

	var	indent:integer;
		scan_rr:rr_pointer;
		myatom:atom;
		discard,i:integer;

	begin
	if mynode^.rr_ptr<>NIL
	then	begin
		indent:=dmpnn(dfile,mynode);
		repeat	indent:=indent+1;	{ indent integral tabs }
			write(dfile,' ')
		until ( (indent mod 8)=0);
		while indent<24			{ by at least 3 }
		do	begin
			indent:=indent+1;
			write(dfile,' ');
			end;

		scan_rr:=mynode^.rr_ptr;
		while scan_rr<>NIL
		do	begin
			{ if not first, indent to class }
			if scan_rr<>mynode^.rr_ptr
			then	for i:=1 to indent
				do	write(dfile,' ');

			{ if first record or cache tree output class }
			if (scan_rr=mynode^.rr_ptr)
				OR
			   (myzone.zone_is_cache)
			then	begin
				ppclass(scan_rr^.rrclass,myatom);
				discard:=dmpatom(dfile,myatom)
				end;
			write(dfile,chr(TAB));
			
			{ dump TTL }
			ppint(scan_rr^.ttl,myatom);
			discard:=dmpatom(dfile,myatom);
			write(dfile,chr(TAB));

			{ dump type }
			pptype(scan_rr^.rrtype,myatom);
			discard:=dmpatom(dfile,myatom);
			write(dfile,chr(TAB));

			{ dump the RR }
			dmprdata(dfile,
				scan_rr^.rrtype,
				scan_rr^.rrclass,
				scan_rr^.rdata);

			{ on first line, output address and node position }
			if scan_rr=mynode^.rr_ptr
			then	begin
				write(dfile,' ;');
				discard:=dmpa(dfile,quotep(mynode));
				if slot<>-1
				then write(dfile,slot:5);
				write(dfile,sequence:4)
				end;
				
			writeln(dfile,' ');

			{ move on }
			scan_rr:=scan_rr^.next
			end;
		writeln(dfile,' ')
		end
	end; { dmpnode }

begin
walknode(myzone.zone_node,dmpnode,-1,1)
end;
function del_count(var myzone:zone_entry):integer;

{	DEL_COUNT counts the number of delegated domains	}

var	answer:integer;

	procedure del_test(mynode:node_pointer;
			   slot:integer;
			   sequence:integer);

	begin
	if mynode^.up_ptr<>NIL { not root }
	then if mynode^.node_lchain=NIL {I'm not authoritative}
             then if mynode^.up_ptr^.node_lchain<>NIL { but daddy is }
		  then answer:=answer+1
	end;
	
begin
answer:=0;
walknode(myzone.zone_node,del_test,-1,1);
del_count:=answer
end;
procedure dmp_dels(var dfile:file;
		     var myzone:zone_entry);

{	DMP_DELS dumps all NS RRs in a zone in master file format }

var	scan:node_pointer;
	first:boolean;

	procedure dmpnode(mynode:node_pointer;
			  slot:integer;
			  sequence:integer);

	var	indent:integer;
		scan_rr:rr_pointer;
		myatom:atom;
		discard,i:integer;

	begin
	if mynode^.rr_ptr<>NIL
	then	begin
		scan_rr:=mynode^.rr_ptr;
		while scan_rr<>NIL
		do if scan_rr^.rrtype<>ns
	           then scan_rr:=scan_rr^.next
	           else begin (* Dump NS RRs *)
			      first:=true;
			      indent:=dmpnn(dfile,mynode); (* dump node name *)
			      repeat indent:=indent+1; { indent integral tabs }
				     write(dfile,' ')
			      until ( (indent mod 8)=0);
			      while indent<24 { by at least 3 }
			      do begin
				      indent:=indent+1;
				      write(dfile,' ');
				 end;
			      while scan_rr<>NIL (* now dump RRs *)
			      do if scan_rr^.rrtype<>NS
				 then scan_rr:=scan_rr^.next
 				 else begin
					  if first
					  then first:=false
					  else begin
						   first:=false;
						   for i:=1 to indent
						   do	write(dfile,' ')
					       end;
					  { dump TTL }
					  ppint(scan_rr^.ttl,myatom);
					  discard:=dmpatom(dfile,myatom);
					  write(dfile,chr(TAB));
					  { dump type }
					  pptype(scan_rr^.rrtype,myatom);
					  discard:=dmpatom(dfile,myatom);
					  write(dfile,chr(TAB));
					  { dump the RR }
					  dmprdata(dfile,
						   scan_rr^.rrtype,
						   scan_rr^.rrclass,
						   scan_rr^.rdata);
					  writeln(dfile,' ');
					  scan_rr:=scan_rr^.next
				      end;
		               writeln(dfile,' ');
			end
		end
	end; { dmpnode }

begin
walknode(myzone.zone_node,dmpnode,-1,1)
end; { dmp_dels }
procedure dmpzone(var dfile:file;
		  var myzone:zone_entry);

var	discard:integer;

begin
if myzone.zone_is_cache
then	writeln(dfile,'This is the cache zone.')
else	if myzone.zsoa<>NIL
	then	begin
		write(dfile,'Zone prefix is ');
		discard:=dmpnn(dfile,myzone.zsoa);
		writeln(dfile,' ')
		end
	else	writeln(dfile,'No zone prefix');
writeln(dfile,' ');

dmpltable(dfile,myzone);
dmpdtable(dfile,myzone);
dmprrtable(dfile,myzone);
dmprdtable(dfile,myzone);

writeln(dfile,' ');
writeln(dfile,'***** Zone Dump *****');
writeln(dfile,' ');
dmpmfile(dfile,myzone);

end; { dmpzone }
procedure dumpbuffer(mybuf:rawmsg;	(* buffer to dump *)
		     dlength:integer; (* number of bytes to dump *)
		     ftype:file_type;
		     var fp:file_blk_ptr);

(* Dump a raw packet buffer *)

var	myebp,hbp:g1bpt;
	i,j:integer;
	db:array[1..4] of integer;
	fromh,toh:integer;

begin
myebp:=xseto(mybuf.unspec);
hbp:=myebp;
xadjbp(hbp,12);
fromh:=xildb4(hbp);
toh:=xildb4(hbp);

pheader(ftype,fp);
write(fp^.fident,mybuf.rec_count:6,mybuf.count:6,' ');
dmphst(fp^.fident,fromh);
write(fp^.fident,' ');
dmphst(fp^.fident,toh);
writeln(fp^.fident);

i:=0; (* set done count to zero *)

repeat  pheader(ftype,fp);
	Write(fp^.fident,i:5,':    ');
	for j:=1 to 4
	do  if (i+j)<=dlength
	    then begin
		     db[j]:=xildb(myebp);
		     write(fp^.fident,db[j]:3,' ')
		 end
	    else write(fp^.fident,'    ');
	for j:=1 to 4
	do if (i+j)<=dlength
	   then write(fp^.fident,db[j]:2:h,' ')
	   else	write(fp^.fident,'   ');
	for j:=1 to 4
	do  if (i+j)<=dlength
	    then if band(db[j],"7f)>=32 
	    then write(fp^.fident,chr(db[j]))
	    else write(fp^.fident,' ');

	writeln(fp^.fident);
	i:=i+4
until	i>=dlength

end; { dumpbuffer }
procedure dmp_stg(var dfile:file;
		    var sadata:stgmap;
		        pages:integer);	(* non-zero for page usage stats *)

var	idex:satype;
	toss,upct,usum,wsum,ufuzz,wfuzz:integer;
	pdata:array[satype,sakind] of integer;
	an_zone_entry:zone_entry_pointer;
	an_slt:secondary_label_table_pointer;
	an_ulabel:ulabel_pointer;
	an_dname:dname_pointer;
	an_node:node_pointer;
	an_lht:label_hashtable_pointer;
	an_rdchunk:rdchunk_pointer;
	an_litstring:litstring_pointer;
	an_rr:rr_pointer;
	zb_size:integer;
begin
zb_size:=free_round(sizeof(an_zone_entry));(* count of AUs allocated *)

usum:=0;       (* count of blocks allocated *)
wsum:=0;       (* count of AUs allocated *)

for idex:=sd_slt to sd_litstring
do	begin
	usum:=usum+sadata[idex,sa_units];
	wsum:=wsum+sadata[idex,sa_aus]
	end;

ufuzz:=usum div 200; (* half a percent round constants *)
wfuzz:=wsum div 200;

for idex:=sd_slt to sd_litstring
do	begin
	pdata[idex,sa_units]:=((sadata[idex,sa_units]+ufuzz)*100) div usum;
	pdata[idex,sa_aus]:=((sadata[idex,sa_aus]+wfuzz)*100) div wsum
	end;

writeln(dfile,'BLOCK                  COUNT  PCT AU_PER USED_AU  PCT  UPCT');
writeln(dfile);

writeln(dfile,'zone entries           ',
		sadata[sd_zone,sa_units]:5,' (',
		pdata[sd_zone,sa_units]:2,'%) ',
		zb_size:5,' ',
		sadata[sd_zone,sa_aus]:6,' (',
		pdata[sd_zone,sa_aus]:2,'%)'
	);

writeln(dfile,'secondary label tables ',
		sadata[sd_slt,sa_units]:5,' (',
		pdata[sd_slt,sa_units]:2,'%) ',
		free_round(sizeof(an_slt)):5,' ',
		sadata[sd_slt,sa_aus]:6,' (',
		pdata[sd_slt,sa_aus]:2,'%)'
	);

if sadata[sd_ulabel,sa_units]=0
then upct:=0
else upct:=	 (sadata[sd_ulabel,sa_aus]*100) div
		 (sadata[sd_ulabel,sa_units]*free_round(sizeof(an_ulabel)));

writeln(dfile,'unique labels          ',
		sadata[sd_ulabel,sa_units]:5,' (',
		pdata[sd_ulabel,sa_units]:2,'%) ',
		free_round(sizeof(an_ulabel)):5,' ',
		sadata[sd_ulabel,sa_aus]:6,' (',
		pdata[sd_ulabel,sa_aus]:2,'%) (',
		upct:2,'%)'
	);

writeln(dfile,'domain names           ',
		sadata[sd_dname,sa_units]:5,' (',
		pdata[sd_dname,sa_units]:2,'%) ',
		free_round(sizeof(an_dname)):5,' ',
		sadata[sd_dname,sa_aus]:6,' (',
		pdata[sd_dname,sa_aus]:2,'%)'
	);

writeln(dfile,'nodes                  ',
		sadata[sd_node,sa_units]:5,' (',
		pdata[sd_node,sa_units]:2,'%) ',
		free_round(sizeof(an_node)):5,' ',
		sadata[sd_node,sa_aus]:6,' (',
		pdata[sd_node,sa_aus]:2,'%)'
	);

writeln(dfile,'label hash tables      ',
		sadata[sd_lht,sa_units]:5,' (',
		pdata[sd_lht,sa_units]:2,'%) ',
		free_round(sizeof(an_lht)):5,' ',
		sadata[sd_lht,sa_aus]:6,' (',
		pdata[sd_lht,sa_aus]:2,'%)'
	);

writeln(dfile,'RRs                    ',
		sadata[sd_rr,sa_units]:5,' (',
		pdata[sd_rr,sa_units]:2,'%) ',
		free_round(sizeof(an_rr)):5,' ',
		sadata[sd_rr,sa_aus]:6,' (',
		pdata[sd_rr,sa_aus]:2,'%)'
	);

writeln(dfile,'resource data chunks   ',
		sadata[sd_rdchunk,sa_units]:5,' (',
		pdata[sd_rdchunk,sa_units]:2,'%) ',
		free_round(sizeof(an_rdchunk)):5,' ',
		sadata[sd_rdchunk,sa_aus]:6,' (',
		pdata[sd_rdchunk,sa_aus]:2,'%)'
	);

if sadata[sd_litstring,sa_aus]=0
then upct:=0
else upct:=	 (sadata[sd_litstring,sa_aus]*100) div
		 (sadata[sd_litstring,sa_units]*free_round(sizeof(an_litstring)));

writeln(dfile,'literal strings        ',
		sadata[sd_litstring,sa_units]:5,' (',
		pdata[sd_litstring,sa_units]:2,'%) ',
		free_round(sizeof(an_litstring)):5,' ',
		sadata[sd_litstring,sa_aus]:6,' (',
		pdata[sd_litstring,sa_aus]:2,'%) (',
		upct:2,'%)'
	);

writeln(dfile,'                       ------------------------------');

write(dfile,'TOTALS                ',
		usum:6,'            ',
		wsum:7);

if (wsum=0) or (pages=0)
then writeln(dfile)
else begin
	 upct:=(wsum*100) div (pages*au_per_page);
	 writeln(dfile,'      ',upct:2,'% of ',pages:3,' pages')
     end;

end; {dmp_stg}
procedure dmp_zstg(var dfile:file;
		     var myzone:zone_entry);
var     toss:integer;
begin
if myzone.zone_is_cache
then writeln(dfile,'This is the cache zone.')
else begin
	 write(dfile,'Zone: ');
	 toss:=dmpnn(dfile,myzone.zsoa);
	 writeln(dfile)
     end;
writeln(dfile);

dmp_stg(dfile,myzone.sadata,cntpage(myzone.zone_pages));
end; {dmp_zstg}
procedure d_file(var dfile:file;
		 var data:filename);

var i:integer;

begin
i:=1;
repeat write(dfile,data[i]);
	     i:=i+1
until  (data[i]=' ') or (ord(data[i])=0) or (i>max_fn_chars)
end; { d_file }


procedure d_gtad(var dfile:file;
		     gtad_time:integer);

var timestr:packed array[1..25] of char;
    i:integer;

begin
jsys(odtim,-1;timestr,gtad_time,0);
i:=1;
repeat write(dfile,timestr[i]);
       i:=i+1
until  (ord(timestr[i])=0) or (i=26)
end;
procedure d_databp(var dfile:file;
		         data:g1bpt);

{	D_DATABP dumps an RR string using knowledge of the desired structure }

var	table:rdata_table_pointer;
	i,j,bits,socket,isize,discard,rdindex:integer;
	mytype:dtype;
	myclass:dclass;
	myttl:integer;
	mylength:integer;
	myatom:atom;
begin
if v_type(xildb2(data),mytype)
then if v_class(xildb2(data),myclass)
     then begin
	      myttl:=sildb4(data);
	      mylength:=xildb2(data);
	      dtct(dfile,myttl,myclass,mytype);
	      table:=irdata(myclass);
	      rdindex:=1;
	      with table^[mytype]
	      do while (rdata_item[rdindex]<>no_more_field) and (mylength>0)
		 do begin
			case rdata_item[rdindex] of

		        dname_field:	begin
					     discard:=dmpdns(dfile,data);
					     isize:=lendns(data);
					     xadjbp(data,isize)
					end;
			
			cstring_field:	begin
					    isize:=xildb(data);
					    for i:=1 to isize
					    do write(dfile,chr(xildb(data)));
					    isize:=isize+1;
					end;

			int16_field:	begin
					     isize:=2;
					     ppint(xildb2(data),myatom);
					     discard:=dmpatom(dfile,myatom);
					end;

			time_field,
			int32_field:	begin
					     isize:=4;
					     ppint(xildb4(data),myatom);
					     discard:=dmpatom(dfile,myatom);
					end;

			inet_a_field:	begin
					     isize:=4;
					     ppina(xildb4(data),myatom);
					     discard:=dmpatom(dfile,myatom);
					end;

			inet_p_field:	begin
					    isize:=1;
					    ppptcl(xildb(data),myatom);
					    discard:=dmpatom(dfile,myatom)
					end;

			inet_s_field:	begin
					    isize:=mylength;
					    socket:=0;
					    for i:=1 to isize
					    do begin
						   bits:=xildb(data);
						   for j:=1 to 8
						   do begin
						      if band(bits,128)<>0
						      then begin
							   ppport(socket,0,myatom);
							   discard:=dmpatom(dfile,myatom);
							   write(dfile,' ')
							   end;
						      socket:=socket+1;
						      end
					       end
					end;

			vbinary_field:	begin
					    isize:=mylength;
					    for i:=1 to isize
					    do begin	{ dump an octet }
					       ppint(xildb(data),myatom);
					       discard:=dmpatom(dfile,myatom)
					       end;
					end;

			others:		isize:=mylength;

			end; { case }
			mylength:=mylength-isize;
			rdindex:=rdindex+1;
			write(dfile,' ');
		    end;
	      writeln(dfile)
	  end;
end; { d_databp }
procedure d_rdv(var dfile:file;
		  var anrdv:rrdv);

{ Dump a single RR specified by the rrdv }

var	toss:integer;

begin
for toss:=dmpdns(dfile,anrdv.namebp) to 19
do write(dfile,' ');
d_databp(dfile,anrdv.databp)
end; { d_rdv }
procedure d_sect(var dfile:file;
		   var mydomsg:domsg;
		       sect:sectcode);

var	i,toss:integer;
	myatom:atom;
	tdv:g1bpt;
begin
with mydomsg.parse[sect]
do if truncated or (count>0) (* dump if truncated or something there *)
   then begin
	    ppsect(sect,myatom); (* dump the section header *)
	    write(dfile,'<<');
	    toss:=dmpatom(dfile,myatom);
	    write(dfile,'>> count=',count:5);
	    if truncated then writeln(dfile,' TRUNCATED')
			 else writeln(dfile);
	    for i:=1 to count (* dump every RR in the section *)
	    do if sect=question
	       then begin
			for toss:=dmpdns(dfile,rdv[i].namebp) to 19
			do write(dfile,' ');
			tdv:=rdv[i].databp;
			ppqtype(xildb2(tdv),myatom);
			for toss:=dmpatom(dfile,myatom) to 8
			do write(dfile,' ');
			ppqclass(xildb2(tdv),myatom);
			for toss:=dmpatom(dfile,myatom) to 8
			do write(dfile,' ');
			writeln(dfile)
		    end
	       else if i=1
		    then (* first RR in section *)
			 d_rdv(dfile,rdv[i])
		    else (* not first RR in section *)
			 if dnscomp(rdv[i].namebp,rdv[i-1].namebp)
			 then begin
				write(dfile,'                    ');
				d_databp(dfile,rdv[i].databp)
			      end
		         else d_rdv(dfile,rdv[i])
       end
end; { d_sect }
procedure d_domsg(var dfile:file;
		    var mydomsg:domsg);

{ D_DOMSG dumps a parsed DOMSG assuming it has correct format }

var	toss:integer;
	sect:sectcode;
	myatom:atom;
begin
with mydomsg.dhead
do   begin
	 write(dfile,'ID ',domain_id:4:h,' ');
	 if response then write(dfile,'Response ');
	 ppopcode(opcode,myatom);
	 toss:=dmpatom(dfile,myatom);

	 if aa then write(dfile,' authoritative');
	 if tc then write(dfile,' truncated');
	 if rd then write(dfile,' recursion-requested');
	 if ra then writeln(dfile,' recursion-available')
	       else writeln(dfile);

	 write(dfile,'RCODE=');
	 pprcode(rcode,myatom);
	 toss:=dmpatom(dfile,myatom);
	 writeln(dfile,qdcount:4,ancount:4,nscount:4,arcount:4);

	 d_sect(dfile,mydomsg,question);
	 d_sect(dfile,mydomsg,answer);
	 d_sect(dfile,mydomsg,authority);
	 d_sect(dfile,mydomsg,additional);
     end
end; { d_domsg }
procedure d_sa(var dfile:file;
		 var server:server_type;
		     detail:boolean);

{ Dump the server addresses in Internet format }

var    i,toss:integer;

begin
for i:=1 to server.address_count
do with server.server_addresses[i]
   do begin
	   write(dfile,' ');
	   toss:=dmpina(dfile,ipaddress);
	   if detail
	   then write(dfile,'(',eta:3,'/',rank:1,')')
    end
end. { d_sa }
{$M-,X+}
program eutil;

include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:addrr.hdr';
include {NOLIST} 'domain:msub.hdr';
include {NOLIST} 'domain:iomsg.hdr';

{	**********************************************************

	This file contains procedures for manipulating expanded
	domain data structures and other general utility functions.

	********************************************************** }

function rrsquash(var x:exp_rr):boolean;

{ By convention, consecutive lit_chunks are combined
  this routine does it.  Return false if there wasn't
  enough room for everything. }

var	i, j, tobyte, frombyte:integer;
	overflow:boolean;

begin
with x
do	begin
	overflow:=false;
	i:=chunk_count;
	while (i>=2) and not overflow
	do	begin	
		if (chunks[i].ckind=lit_chunk) and
	    	    (chunks[i-1].ckind=lit_chunk)
		then	if (chunks[i-1].lit_data_count+
				chunks[i].lit_data_count) >
				max_binary_octets
	     		then overflow:=true
	     		else	begin  {combine chunks}
		      		tobyte:=chunks[i-1].lit_data_count;
		      		for frombyte:=1 to chunks[i].lit_data_count do
			  	       chunks[i-1].lit_data[tobyte+frombyte]:=
					chunks[i].lit_data[frombyte];
		      		chunks[i-1].lit_data_count:=
					chunks[i-1].lit_data_count+
					chunks[i].lit_data_count;
		      		chunk_count:=chunk_count-1;
		      		for j:=i to chunk_count do
			  	chunks[j]:=chunks[j+1]
		  		end;
	     	i:=i-1;
    		end;
	rrsquash:=not overflow;
	end;  {with}
end; { rrsquash }
function chcomp(var echunk:exp_chunk;
		cchunk:rdchunk_pointer;
		exact:boolean
		):boolean;

{	CHCOMP compares an expanded and compressed chunk for equality
	EXACT controls whether case is important.

}

var	i:integer;
	result:boolean;
	spoint:dname_pointer;
	myfbp:file_blk_ptr;

begin
if echunk.ckind<>cchunk^.ckind
then	chcomp:=false	{ if not of the same type, they are not equal }
else	case echunk.ckind of

	lit_chunk:	if echunk.lit_data_count<>cchunk^.litdata^.lcount
			then	chcomp:=false	{ not the same size }
			else	begin	{ compare the data }
				i:=0;
				result:=true;
				while	result and (i<echunk.lit_data_count)
				do	begin
					i:=i+1;
					result:=echunk.lit_data[i]=
						cchunk^.litdata^.ldata[i]
					end;
				chcomp:=result
				end;

	name_chunk:	begin	{ compare a domain name }
			i:=1;
			result:=true;
			spoint:=cchunk^.rrname;
			while result and (i<=echunk.rrname.count)
			do	{ compare labels }
				begin
				if exact
				then	result:=elcomp(echunk.rrname.dlabels[i],
							spoint)
				else	result:=lcomp(echunk.rrname.dlabels[i].labinfo,
							spoint^.dlabel.labptr^.text)=0;
				spoint:=spoint^.more;
				i:=i+1
				end;
			chcomp:=result
			end;

	others: begin
		    myfbp:=ofile(fatl);
		    writeln(myfbp^.fident, 'ADDRR internal error');
		    cfile(myfbp);
		end;
	
	end {case}
end; { chcomp }


procedure dlcase(var x:exp_label);

{	DLCASE sets up the modifier bits in its argument label, assuming
	the input contains a mixture of upper and lower case  }

var	i,j:integer;

begin
with x
do	for j:=1 to labinfo[0]
	do	if (chr(labinfo[j])>='a')
			 and
		   (chr(labinfo[j])<='z')
		then	begin
			case_mod[j]:=true;
			labinfo[j]:=labinfo[j]-ord('a')+ord('A')
			end
		else	case_mod[j]:=false

end;	{ DNCASE }


function casechar( ch:char ):char;

begin
if (ch<'a') or (ch>'z')
then	casechar:=ch
else	casechar:=chr(ord(ch)+ord('A')-ord('a'))
end; { casechar }

function compchar( x,y:char ):boolean;

begin
if x=y
then	compchar:=true
else	compchar:= casechar(x)=casechar(y)
end; { compchar }

procedure caseatom( var inarg:atom;
		    var outarg:atom );

var	i:integer;
	chr:char;

begin
for i:=1 to max_atom_chars
do	outarg[i]:=casechar(inarg[i])

end; { caseatom }

function compatom( var arg1:atom;
		       arg2:atom):boolean;

var	i:integer;
	ch1,ch2:char;
	flag:boolean;
begin
flag:=true;
i:=1;
repeat	if arg1[i]<>arg2[i]
	then	begin
		ch1:=casechar(arg1[i]);
		ch2:=casechar(arg2[i]);
		if ch1<>ch2
		then	flag:=false
		end;

	i:=i+1

until	(i=(max_atom_chars+1)) or not(flag);

compatom:=flag;

end. { compatom }
{$M-,X+}
program fproc;

include {NOLIST} '<pascal>extern.pas';
include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:eutil.hdr';
include {NOLIST} 'domain:pp.hdr';
include {NOLIST} 'domain:irdata.hdr';
include {NOLIST} 'domain:addrr.hdr';
include {NOLIST} 'domain:msub.hdr';
include {NOLIST} 'domain:lparse.def';
include {NOLIST} 'domain:lparse.hdr';
include {NOLIST} 'domain:mdep.hdr';

procedure scan_error(var mypib:pib;
		     str:string40);

var	idex:integer;
begin
with mypib
do	begin
	writeln('error in line ',line_number,' of file ',dfilename);
	idex:=1;
	repeat	if line[idex]<>chr(cr)
		then	write(line[idex]);
		idex:=idex+1
	until	(idex>max_line_char) or (line[idex-1]=chr(cr));
	writeln(' ');
	writeln(str);
	writeln(' ');
	ok:=false
	end
end;

procedure parse_error(var mypib:pib;
			str:string11);

var	estr:string40;
	i:integer;

begin
estr:='Unable to parse                         ';
for i:=17 to 27
do	estr[i]:=str[i-16];

scan_error(mypib,estr);
end; { parse_error }
function fload(	var myzone:zone_entry;
		    origin:exp_dname;
		var fn:filename):boolean;

var	sticky_set,	{is the sticky location valid}
	any_ttl,any_class,	{is last_class set}
	insert_rc,file_ok:boolean;

	i:integer;
	sticky_place:node_pointer;
	last_class:dclass;	{sticky class}
	last_ttl:integer;	{sticky ttl}
	call_filename:filename;
	new_rr:exp_rr;
	fload_origin,call_origin,place:exp_dname;
	mypib:pib;

procedure gethdr;

{	This procedure processes the class, TTL, and type fields from
	a RR.  The Type filed is required and is last.  I.E. a type
	terminates a specification.  The class and TTL fileds are
	optional, and preceed the type if they are present.

}

var	saw_TTL,saw_class,saw_type:boolean;
	test_time:itime;
	test_class:dclass;
	test_type:dtype;
	myatom:atom;

begin
with mypib
do begin
saw_ttl:=false;
saw_class:=false;
saw_type:=false;

while ok and not(saw_type)
do	if getatom(mypib,myatom)
	then	{ see if it is a TTL }
		if not(saw_ttl) and cvtime(myatom,test_time)
		then	begin
			new_rr.ttl:=test_time;
			saw_ttl:=true;
			any_ttl:=true;
			last_ttl:=test_time
			end
		else	{ if not TTL, see if it is a class }
			if not(saw_class) and cvclass(myatom,test_class)
			then	begin
				new_rr.rrclass:=test_class;
				saw_class:=true;
				any_class:=true;
				last_class:=test_class
				end
			else	{ if not TTL or class, its a type or error }
				if cvtype(myatom,test_type)
				then	begin
					new_rr.rrtype:=test_type;
					saw_type:=true
					end
				else	scan_error(mypib,'Invalid RR header                       ')
	else	scan_error(mypib,'Unable to type header                   ');

if ok
then	begin
	if not(saw_ttl)
	then	if any_ttl
	        then new_rr.ttl:=last_ttl
		else new_rr.ttl:=0;
	if not(saw_class)
	then	if myzone.zone_is_cache
		then	if any_class
			then	new_rr.rrclass:=last_class
			else	scan_error(mypib,'Class cannot default here               ')
		else	if myzone.zsoa<>NIL
			then	new_rr.rrclass:=myzone.zone_class
			else	scan_error(mypib,'Zone class not available for default    ')
	end

end {with}
end; { gethdr}

procedure getrdata;

{ getrdata reads the class and type dependent parts of the RR
  using the irdata routines to determine the order.}

var	done:boolean;
	i, j, temp, index, rdindex:integer;
	myatom:atom;
	table:rdata_table_pointer;

	procedure binn(     n:integer;
			    x:integer;
			var tochunk:exp_chunk );

	{ The binN procedure copies the rightmost N octets
	  of an integer into the first N octets of a chunk }

	var	i:integer;

	begin  {binN}
	    with tochunk do
	    begin	
		ckind:=lit_chunk;
		lit_data_count:=N;
		for i:=N downto 1 do
		    lit_data[i]:=band( bshift(x, 8*(i-N)), 377b );
	    end;
	end; { binN }

begin  {getrdata}
with mypib
do begin

    done:=false;
    table:=irdata(new_rr.rrclass);
    rdindex:=1;
    with table^[new_rr.rrtype] do  {use rdata description}
	while ok and not done do  { as long as its reasonable }
	begin
	    toss_blanks(mypib);
	    with new_rr.chunks[rdindex] do
		case rdata_item[rdindex] of
		    dname_field:  if getdname(mypib,origin,rrname)
				  then ckind:=name_chunk
				  else parse_error(mypib,'domain name');

		    cstring_field:  if ismore(mypib)
				    then	begin
					     	i:=2;
					     	while ismore(mypib) and 
						   	not issep(mypib) and
						   	(i<=max_binary_octets)
						do    	begin
						 	lit_data[i]:=gpibch(mypib);
						 	i:=i+1
					     		end;
					     	if ismore(mypib) and not issep(mypib)
					     	then parse_error(mypib,'characters ')
					     	else	 begin
							 lit_data_count:=i-1;
							 lit_data[1]:=i-2;
							 ckind:=lit_chunk
						       	end
					 	end
				    else	scan_error(mypib,'Missing character string                ');
				    
		    time_field:	begin
				    if getatom(mypib,myatom)
				    then if cvtime(myatom, temp)
					 then binn(4,temp, 
						   new_rr.chunks[rdindex])
					 else ok:=false
				    else ok:=false;
				    if not ok
				    then parse_error(mypib,'time       ');
				end;
		    
		    int16_field: begin
				     if getatom(mypib,myatom)
				     then if cvint(myatom, temp)
					  then binn(2,temp,
						    new_rr.chunks[rdindex])
					  else ok:=false
				     else ok:=false;
				     if not ok
				     then parse_error(mypib,'integer    ')
				 end;

		    int32_field: begin
				     if getatom(mypib,myatom)
				     then if cvint(myatom, temp)
					  then binn(4,temp,
						    new_rr.chunks[rdindex])
					  else ok:=false
				     else ok:=false;
				     if not ok
				     then parse_error(mypib,'integer    ')
				 end;
		    
		    inet_a_field: begin
				      if getatom(mypib,myatom)
				      then if cvina(myatom, temp)
					   then	binn(4,temp,
						     new_rr.chunks[rdindex])
					   else ok:=false
				      else ok:=false;
				      if not ok
				      then parse_error(mypib,'Internet A ')
				  end;
		    
		    inet_p_field: 
				  if getatom(mypib,myatom)
				  then if cvptcl(myatom, temp)
				       then with new_rr.chunks[rdindex] do
				       begin  {store 8-bit protocol number}
					   ckind:=lit_chunk;	   
					   lit_data_count:=1;
					   lit_data[1]:=temp;
				       end
				       else begin
						ok:=false;
						parse_error(mypib,'protocol   ');
					    end
			          else begin
					   ok:=false;
					   parse_error(mypib,'protocol   ');
				       end;
				  
		    inet_s_field:
			 with new_rr.chunks[rdindex] do
			 begin
			     ckind:=lit_chunk;
			     for i:=1 to 32 do  {clean the slate}
				 lit_data[i]:=0;
			     {get all ports for this protocol}
			     while getatom(mypib,myatom) and ok do
			     begin
				 if cvport(myatom, 0, temp)
				 then begin {add to bitmap}
					  index:=(temp div 8)+1; {which octet}
					  lit_data[index]:=lit_data[index]+
						   bshift(128,-(temp mod 8));
				      end
				 else begin
					  ok:=false;
					  parse_error(mypib,'port       ');
				      end
			     end;
			     i:=32;	{ chop off zeroes }
			     while (i>1) and (lit_data[i]=0)
				do i:=i-1;
			     lit_data_count:=i
			end;
			 
		     vbinary_field:	;
			 
		     no_more_field: if not done
				    then begin  {first time only}
					     done:=true;
					     new_rr.chunk_count:=rdindex-1
					 end;
				    
		     others: scan_error(mypib,
				   'Internal getrdata case error            ')
		end; {case}
	    rdindex:=rdindex+1;
	    done:=done or (rdindex>max_rdata_items);
        end;
    if ok
    then 	if not rrsquash(new_rr)  {compress rdchunks}
		then	scan_error(mypib,'Overflow error during binary compress   ')
end {with}
end; {getrdata}
procedure mxfix;

{ This procedure turns the RR in new_rr into an MX if it is a MD or MF
  MDs get preferences of 10 and MFs get 20 }

begin
if (new_rr.rrtype=MD) or (new_rr.rrtype=MF)
then with new_rr
     do begin
	     chunk_count:=2;
	     chunks[2]:=chunks[1];
	     with chunks[1]
	     do begin
		    ckind:=lit_chunk;
		    lit_data_count:=2;
		    lit_data[1]:=0;
		    if new_rr.rrtype=md
		    then lit_data[2]:=10
		    else lit_data[2]:=20;
		    new_rr.rrtype:=mx
		end
	end
end; { MXFIX }
begin { fload main code }
fload_origin:=origin;
with mypib
do begin

sticky_set:=false;
file_ok:=true;
any_class:=false;
any_ttl:=false;

{ open file and go }
if not pib_init(mypib,fn)
then	file_ok:=false
else	{ load the file }
	while not eof(mypib.dfile)
	do	begin
		ok:=true;
		gline(mypib);
		if smatch(mypib.line,1,'$include       ')
		then	{ process an include line }
			begin
			mypib.line_index:=mypib.line_index+8;	{ bump past include }
			toss_blanks(mypib);

			{ get a file name }
			if ismore(mypib)
			then	getfn(mypib,call_filename)
			else	scan_error(mypib,'Include without filename                ');
			toss_blanks(mypib);

			{ get an optional offset }
			if ismore(mypib)
			then	if getdname(mypib,origin,call_origin)
				then
				else scan_error(mypib,'origin error                            ')
			else	call_origin:=origin;

			check_end(mypib);

			{ call self recursively }
			if ok
			then	if not fload(myzone,call_origin,call_filename)
				then	scan_error(mypib,'file loading error                      ')
			end { process an include line }
		else if smatch(mypib.line,1,'$origin        ')
		then	{ process an origin line }
			begin
			mypib.line_index:=mypib.line_index+8;	{ bump past origin }
			toss_blanks(mypib);

			{ get an optional offset }
			if ismore(mypib)
			then	if getdname(mypib,origin,call_origin)
				then origin:=call_origin
				else scan_error(mypib,'origin error                            ')
			else	origin:=fload_origin;
			check_end(mypib);
			end { process an origin line }
		else	begin
			toss_blanks(mypib);
			if ismore(mypib)
			then	begin	{ process a RR }
				rescan(mypib);
				if issep(mypib)
				then	{ line starts with a blank }
					if not sticky_set
					then	scan_error(mypib,'owner default not set                   ')
					else
				else	begin
					if not getdname(mypib,origin,place)
					then	scan_error(mypib,'RR owner error                          ');
					sticky_set:=false
					end;
					
				if ok
				then	begin
					toss_blanks(mypib);
					if ismore(mypib)
					then	begin
						gethdr; { get type, class, ttl }
						if ok
						then getrdata;
						if ok then mxfix; { hack MD and MF }
						toss_blanks(mypib);
						if ok
						then	check_end(mypib);
						if ok
						then	begin
							if sticky_set
							then	ok:=concrr(myzone,sticky_place,new_rr)
							else	begin
								ok:=addrr(myzone,place,sticky_place,new_rr);
								sticky_set:=true
								end;
							if not ok
							then	scan_error(mypib,'RR addition failed                      ')
							end;
						if ok
						then	if (new_rr.rrtype=soa)
								and
						   	(not(myzone.zone_is_cache))
							then	if	myzone.zsoa<>NIL
								then	scan_error(mypib,'Duplicate SOA                           ')
								else	begin
									myzone.zsoa:=sticky_place;
									myzone.zone_class:=new_rr.rrclass
									end
						end
					end;
			
				end { process a RR }
			end;
		if not ok
		then	file_ok:=false
		end;

close(mypib.dfile);
fload:=file_ok;
end {with}
end; {fload}

function fzload(var myzone:zone_entry;
		    origin:exp_dname;
		var fn:filename):boolean;

begin
if fload(myzone,origin,fn)
then	begin
	makelt(myzone);	{ make the label chains }
	if not(myzone.zone_is_cache)
	then	soa_setup(myzone);	{ check authoritative TTLs }
	fzload:=true;
	end
else	fzload:=false;
end {fzload}.
{$M-,X+}
program hash;

include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:msub.hdr';
include {NOLIST} 'domain:eutil.hdr';

{	This file contains the hash functions used by the domain server
}
function hashlabel(var x:exp_label):integer;

begin
with x
do	if labinfo[0]=0
	then	hashlabel:=0
	else	hashlabel:=band(0377b,bshift(labinfo[0],6)+
				      labinfo[1]+
				      labinfo[labinfo[0]])
end;

function hashchunk(var x:exp_chunk):integer;

var	i,sum:integer;

begin
with x
do	if ckind=name_chunk
	then	hashchunk:=hashlabel(rrname.dlabels[1])
	else	begin
		sum:=0;
		for i:=1 to min(3,lit_data_count)
		do	sum:=bshift(sum,2)+lit_data[i];
		hashchunk:=band(0377b,sum)
		end
end. { hashchunk }
{$M-}
program iomsg;

include {NOLIST} 'domain:jsys.def';
include {NOLIST} 'pascal:extern.pas';
include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:udp.def';
include {NOLIST} 'domain:lparse.def';
include {NOLIST} 'domain:mdep.hdr';
include {NOLIST} 'domain:msub.hdr';

{ **********************************************************

 This program contains procedures for managing the three
 types of messages generated by the server.

     FATAL - terminal illness
     ERROR - recoverable errors
     LOG   - logging information

 An array of file_blks which contain lock and actual
 file ident are kept in the master block.

 There are three procedures associated with file operations.
 The O procedure prepares the file for output (open and/or
 locking.)  The H procedure outputs a date time, etc header.
 The C procedure closes the file.  NOTE:  locking mechanisms
 are not in place!     

 Also included here is the procedure jsys_err which handles
 printing of jsys error messages and termination of program
 execution if dictated by the calling party.

********************************************************** }

var	master:master_block_pointer;
	myblk:file_blk;



procedure pheader(    ftype:file_type;
		  var fp:file_blk_ptr );

{ Print timestamp and Domain leader to identify
  subsequent message. }

begin  { pheader }
    tstamp(fp^.fident);
    case ftype of
	fatl:  write(fp^.fident, ' DOMAIN:F: ');
	err:   write(fp^.fident, ' DOMAIN:E: ');
	log:   write(fp^.fident, ' DOMAIN:L: ');
    end;
end; { pheader }


function ofile( ftype:file_type ):file_blk_ptr;

{ Based on the file type, either enable writing to the tty,
  create a new file, or allow appending to an existing one.
  If create or append fails, default to the tty.  It also is
  the case that calling procedures without access to the master
  block will always write to the tty also. }

var	fbp:file_blk_ptr;

begin  { ofile }
    master:=getmaster;
    if master = NIL
    then begin  {calling procedure has no access to master block}
	     rewrite(myblk.fident, 'TTY:' );
	     {obtain file_blk ptr value}
	     fbp:=fbptr(myblk);
	 end
    else begin
	     while not locke(master^.msg_files[ftype].flock,200,30000)
	     do;
	     case ftype of
		 fatl: rewrite(master^.msg_files[ftype].fident, 'TTY:');
		 err:  append(master^.msg_files[ftype].fident,
			      'domain:domain.error', '/O');
		 log:  append(master^.msg_files[ftype].fident,
			      'domain:domain.log', '/O');
	     end;

	     if erstat(master^.msg_files[ftype].fident) <> 0
	     then begin  {file didn't exist}
		      clreof(master^.msg_files[ftype].fident);
		      case ftype of 
			  fatl: quit;  {in trouble here}
			  err:  rewrite(master^.msg_files[ftype].fident,
					'domain:domain.error', '/O');
			  log:  rewrite(master^.msg_files[ftype].fident,
					'domain:domain.log', '/O');
		      end;
		      if erstat(master^.msg_files[ftype].fident) <> 0
		      then rewrite(master^.msg_files[ftype].fident, 'TTY:');
		  end;
	     {obtain file_blk ptr value}
	     fbp:=fbptr(master^.msg_files[ftype]);
	 end;
    
    pheader(ftype, fbp);  {print leading information}
    ofile:=fbp;

end; { ofile }


procedure cfile( var fp:file_blk_ptr );

begin  { cfile }
    close(fp^.fident);
    if getmaster<>NIL then ulocke(fp^.flock)
end; { cfile }


procedure jsys_err( halt:boolean;
		    error_code:integer;
		    myfbp:file_blk_ptr );

{ Output the error message for the given error code which
  resulted from a jsys call.  If the error code is -1,
  then the most recent error message is printed. }

var   	i:integer;
	error_str:packed array [1..80] of char;

begin  { jsys_err }
    
    {convert code to text string}
    jsys(erstr, 2; error_str, fhslf:error_code, 0); 

    {Output error message--terminate on null.
     Assume that file to write to is already open.}
    i:=1;
    while (error_str[i]<>chr(0)) and (i<81) do
    begin
	write(myfbp^.fident, error_str[i]);
	i:=i+1;
    end; 
    writeln(myfbp^.fident);

    if halt 
    then begin
	     cfile(myfbp);
	     quit;
	 end;

end. { jsys_err }

{$M-,X+}
program iopkt;

include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:udp.def';
include {NOLIST} 'domain:udp.hdr';
include {NOLIST} 'domain:dsconv.hdr';


{ ************************************************************

  These routines provide an interface to the packet transmit
  facility(ies) offered.  This includes parsing, formatting,
  and currently UDP datagram invocation routines.
  TODO:  TCP interface.

  *********************************************************** }

procedure init_query(server:boolean);
begin  {init_query}
    udp_initialize(server);
end; {init_query}


procedure quit_query(xmit:xmit_type);
begin  {quit_query}
    if xmit=dgm
    then udp_exit;
end;  {quit_query}


function parse_pkt(var pkt:message_template;
		   var qry:query_template):boolean;

{ Place the information contained in pkt into qry.
  etoi_xxxx routines do all the work. }

var	posn, qcnt:integer;
	ok, ovfl, done:boolean;
	loopvar:sectcode;

begin { parse_pkt }

with pkt.raw_pkt do
begin
    posn:=1;
    ok:=true;  {innocent until proven guilty}

    {copy header}
    qry.header:=header;

    if pkt.octet_cnt<=0
    then ok:=false  {no data}
    else begin	
	     {check validity of header section counts}
	     if (header.qdcount<0) or
		 (header.ancount<0) or
		 (header.nscount<0) or
		 (header.arcount<0)
	     then ok:=false
	     else begin  {parse sections}

		      if header.qdcount>0
		      then begin
			       qcnt:=header.qdcount;
			       ok:=etoi_qsctn(pkt, posn, qry.q_section, 
					      qcnt, ovfl);
			       if qcnt<>header.qdcount
			       then  {reflect truncation}
				   qry.header.qdcount:=qcnt;
			   end;
		      
		      done:=false;
		      loopvar:=answer;
		      while (not done) and (not ovfl) and ok do
		      with qry.sdata[loopvar] do	  
		      begin	 
			  int_count:=0;
			  case loopvar of
			      answer:  exp_count:=header.ancount;
			      authority:  exp_count:=header.nscount;
			      additional:  exp_count:=header.arcount;
			  end;
			  if exp_count > 0
			  then ok:=etoi_sctn(pkt, posn, 
				     qry.sdata[loopvar], ovfl);
			  if loopvar = additional
			  then done:=true
			  else loopvar:=succ(loopvar);
		      end;
		  end;
	 end;
    parse_pkt:=ok;

end; {with}
end; {parse_pkt}


function format_pkt(var qry:query_template;
		    var pkt:message_template):boolean;

{ Place the information contained in qry into pkt.
  pkt is used as input to udp_send. }

var	posn, cnt:integer;
	ovfl, done:boolean;
	loopvar:sectcode;
	
begin {format_pkt}

with pkt.raw_pkt do
begin
    posn:=1;
    ovfl:=false;

    {copy header}
    header:=qry.header;

    {copy each section in turn}
    if header.qdcount>0
    then begin
	     cnt:=header.qdcount;
	     ovfl:=itoe_qsctn(qry.q_section, pkt, posn, cnt);
	     if ovfl
	     then qry.header.qdcount:=cnt;
	 end; 
    
    done:=false;
    loopvar:=answer;
    while (not done) and (not ovfl) do
    with qry.sdata[loopvar] do
    begin
	if exp_count>0
	then ovfl:=itoe_esctn(qry.sdata[loopvar], pkt, posn);

	if (not ovfl) and (int_count>0)
	then ovfl:=itoe_isctn(qry.sdata[loopvar], pkt, posn);

	if ovfl
	then {need to update header}
	    case loopvar of
		answer:  header.ancount:=exp_count+int_count;
		authority:  header.nscount:=exp_count+int_count;
		additional:  header.arcount:=exp_count+int_count;
	    end;

	if loopvar=additional
	then done:=true
	else loopvar:=succ(loopvar);
    end;

    pkt.octet_cnt:=posn-1;
    format_pkt:=true;  {always send}
end;  {with}
end; { format_pkt }


function put_query(var qry:query_template):boolean;

var	got_one, ok:boolean;
	temp:integer;

begin  {put_query}
    ok:=true;

    { reverse the addresses in the packet}
    with qry.rawmsg do
	begin
	    temp:=from_address;
	    from_address:=to_address;
	    to_address:=temp;
	    temp:=from_port;
	    from_port:=to_port;
	    to_port:=temp
	    end;
    if qry.header.rcode=format_error  {parse error}
    then qry.rawmsg.raw_pkt.header:=qry.header  {use the same data field}
    else ok:=format_pkt(qry, qry.rawmsg);

    if ok
    then begin {go ahead and return pkt}
	     udp_send(qry.rawmsg);
	     put_query:=true;
	 end
    else put_query:=false;
end;  {put_query}
    

function get_query(var qry:query_template;
		       wait:boolean;
		   var got_one:boolean):boolean;

{ Check for a udp datagram.  If one is retrieved,
  set got_one.   Parse the input packet and place
  correct results in qry.  Return true if the
  packet parse was successful. }

begin {get_query}

got_one:=udp_receive(qry.rawmsg, wait);

if got_one
then	get_query:=parse_pkt(qry.rawmsg, qry)
else	get_query:=false

end. {get_query}
{$M-,X+}
program iotty;

include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:pp.hdr';
include {NOLIST} 'domain:dump.hdr';

const	owner_indent=30;

var	input,output:file of char;

procedure init_query(toss:boolean);

begin
reset(input,'TTY:','/I');
rewrite(output,'TTY:');
end;

procedure ttyatom(var x:atom);

begin
readln(input);read(input,x);
end; { ttyatom }
procedure ttybatom(var bx:big_atom);

begin
readln(input);read(input,bx);
end; { ttybatom }

function get_query(var msg:query_template;
			wait:boolean;
		   var got_one:boolean):boolean;

var	xqtype:qtype;
	xqclass:qclass;
	xqname:exp_dname;
	x:atom;
	bx:big_atom;
	sect_index:sectcode;

begin
get_query:=true;
got_one:=true;
repeat	write(output,'Enter QTYPE  : ');
	break(output);
	ttyatom(x);
until	cvqtype(x,xqtype);

repeat	write(output,'Enter QCLASS : ');
	break(output);
	ttyatom(x);
until	cvqclass(x,xqclass);

repeat	write(output,'Enter QNAME  : ');
	break(output);
	ttybatom(bx);
until	cvdname(bx,xqname);

with msg
do	begin

	{ setup header }
	with header
	do	begin
		id:=5;
		response:=false;
		opcode:=std_query;
		aa:=false;
		tc:=false;
		rd:=false;
		ra:=false;
		rcode:=0;
		qdcount:=1;	{ one entry in quetion section }
		ancount:=0;
		nscount:=0;
		arcount:=0
		end;

	{ setup question section }

	q_section.qnames[1]:=xqname;
	q_section.qtypes[1]:=xqtype;
	q_section.qclasses[1]:=xqclass;

	{ initialize other sections }
	for sect_index:=answer to additional
	do	with sdata[sect_index]
		do	begin
			exp_count:=0;
			int_count:=0
			end
	end;

end; { get_query }

procedure pint(var iblok:int_ref);

var	i,cols:integer;

begin
with iblok
do	begin
	if owner_used
	then	cols:=dmpedn(output,owner)
	else	cols:=dmpnn(output,rr_ptr^.node);

	for i:=cols to owner_indent
	do	write(output,' ');

	dmprr(output,rr_ptr)
	end;

writeln(output)

end; { pint }

function put_query(var msg:query_template):boolean;

var	sect_index:sectcode;
	i:integer;
	myatom:atom;

begin
put_query:=true;
with msg
do	begin
	with header
	do	begin
		writeln(output);

		if response
		then	write(output,'Response ')
		else	write(output,'****QUERY**** ');

		if aa
		then	write(output,'authoritative ');

		if tc
		then	write(output,'truncated ');

		if ra
		then	write(output,' recursion-available');

		pprcode(rcode,myatom);
		writeln(output,'RCODE=',myatom)
		end;

	for sect_index:=answer to additional
	do	with sdata[sect_index]
		do	if (int_count<>0)
				or
			   (exp_count<>0)
			then	begin
				case sect_index of
				answer:write(output,'Answer');
				authority:write(output,'Authority');
				additional:write(output,'Additional')
				end; {case}
				writeln(output,' section, exp=',exp_count:2,
					' int=',int_count:2);

				for i:=1 to exp_count
				do	{ print exp_records };

				for i:=1 to int_count
				do	pint(int[i]); { print int records };

				writeln(output)
				end;
				
	writeln(output)
	end
end. { put_query }
{$M-,X+}
program rdata_info;

{	The IRDATA routines are designed to include the description of
	the RDATA fields for RRs of various types and classes.

	IRINIT should be called to initialize internal tables.

	IRDATA(class) returns a pointer to a table describing all
	RRs for the particular class

}

include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';

var	rptr:array[dclass] of rdata_table_pointer;

procedure irinit;

var	myclass:dclass;

begin
for myclass:=internet to csnet
do	rptr[myclass]:=nil
end;

function new_table:rdata_table_pointer;

var	rptr:rdata_table_pointer;
	i:integer;
	mytype:dtype;

begin
new(rptr);
for mytype:=dtype_l_bound to dtype_h_bound
do	for i:=1 to 8
	do	begin
		rptr^[mytype].rdata_item[i]:=no_more_field;
		rptr^[mytype].rdata_asp[i]:=ord(dtype_l_bound)
		end;

new_table:=rptr;

end; { new table }

procedure classinsensitive(rptr:rdata_table_pointer);

begin
with rptr^[cname]
do	begin
	rdata_item[1]:=dname_field
	end;

with rptr^[hinfo]
do	begin
	rdata_item[1]:=cstring_field;
	rdata_item[2]:=cstring_field
	end;

with rptr^[mb]
do	begin
	rdata_item[1]:=dname_field;
	rdata_asp[1]:=ord(A)
	end;

with rptr^[md]
do	begin
	rdata_item[1]:=dname_field;
	rdata_asp[1]:=ord(A)
	end;

with rptr^[mf]
do	begin
	rdata_item[1]:=dname_field;
	rdata_asp[1]:=ord(A)
	end;

with rptr^[mx]
do	begin
	rdata_item[1]:=int16_field;
	rdata_item[2]:=dname_field;
	rdata_asp[2]:=ord(A)
        end;

with rptr^[mg]
do	begin
	rdata_item[1]:=dname_field
	end;

with rptr^[minfo]
do	begin
	rdata_item[1]:=dname_field;
	rdata_item[2]:=dname_field
	end;

with rptr^[mr]
do	begin
	rdata_item[1]:=dname_field
	end;

with rptr^[null]
do	begin
	rdata_item[1]:=vbinary_field
	end;

with rptr^[ns]
do	begin
	rdata_item[1]:=dname_field;
	rdata_asp[1]:=ord(A)
	end;

with rptr^[ptr]
do	begin
	rdata_item[1]:=dname_field
	end;

with rptr^[soa]
do	begin
	rdata_item[1]:=dname_field; 	{ MNAME }
	rdata_item[2]:=dname_field;	{ RNAME }
	rdata_item[3]:=int32_field;	{ SERIAL }
	rdata_item[4]:=time_field;	{ REFRESH }
	rdata_item[5]:=time_field;	{ RETRY }
	rdata_item[6]:=time_field;	{ EXPIRE }
	rdata_item[7]:=time_field	{ MINIMUM }
	end;

end; { classinsensitive }

procedure classunknown(rptr:rdata_table_pointer);

var	mytype:dtype;

begin
for mytype:=succ(dtype_l_bound) to pred(dtype_h_bound)
do	with rptr^[mytype]
	do 	rdata_item[1]:=vbinary_field
end;

function IRDATA(myclass:dclass):rdata_table_pointer;

begin
if rptr[myclass]=nil
then	{ set up table }
	case myclass of

	internet:	begin
			rptr[myclass]:=new_table;
			classinsensitive(rptr[myclass]); { class insensitive }
			with rptr[myclass]^[a]
			do	rdata_item[1]:=inet_a_field;

			with rptr[myclass]^[wks]
			do	begin
				    rdata_item[1]:=inet_a_field;
				    rdata_item[2]:=inet_p_field;
				    rdata_item[3]:=inet_s_field
				end
			end;

	others:		begin
			    rptr[myclass]:=new_table;
			    classunknown(rptr[myclass]);
			end
	
	end; { set up table }

irdata:=rptr[myclass]

end { IRDATA }
.
{$X+}
program jeeves;

include {NOLIST} 'domain:jsys.def';
include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:lparse.def';
include {NOLIST} 'domain:irdata.hdr';
include {NOLIST} 'domain:dump.hdr';
include {NOLIST} 'domain:pp.hdr';
include {NOLIST} 'domain:mdep.hdr';
include {NOLIST} 'domain:rsolve.hdr';
include {NOLIST} 'domain:iomsg.hdr';

type	string5=packed array[1..5] of char;

var	master,slave:master_block_pointer;
	i:integer;
	myfbp:file_blk_ptr;
procedure cproc(    loadfile:filename; (* filename containing process *)
		  var handle:integer); (* handle of created process *)

{ CPROC creates a subfork from the specified file, mapps the database into
  it, and starts the process.  Note that no capabilities are enabled,
  though all are passed to the subfork }

var	ac1,rval,jfn:integer;
	myfbp:file_blk_ptr;

	procedure cpjerr(str:string5);

        begin
	    myfbp:=ofile(fatl);
	    write(myfbp^.fident,str,' failure during fork creation for ');
	    d_file(myfbp^.fident,loadfile);
	    writeln(myfbp^.fident);
	    pheader(fatl,myfbp);
	    jsys_err(noabort,-1,myfbp);
	    cfile(myfbp);

	    myfbp:=ofile(err); (* repeat with error log instead *)
	    write(myfbp^.fident,str,' failure during fork creation for ');
	    d_file(myfbp^.fident,loadfile);
	    writeln(myfbp^.fident);
	    pheader(err,myfbp);
	    jsys_err(noabort,-1,myfbp);
	    cfile(myfbp);
	end; (* cpjerr *)
begin
jsys(cfork,-2,rval; (* create subfork *)
     [1],0;
     ac1);
if rval=3
then cpjerr('CFORK')
else begin (* normal return from cfork *)
	 handle:=ac1;
	 jsys(gtjfn,-2,rval; (* get JFN for EXE file *)
	      [gjold],loadfile;
	      ac1);
	 if rval=3
	 then cpjerr('GTJFN')
	 else begin (* normal return from GTJFN *)
		  jfn:=ac1;
		  jsys(xget,-2,rval; (* load the fork *)
		       handle:jfn);
		  if rval=3
		  then cpjerr('GET  ')
		  else begin (* normal return from GET *)
			   jsys(pmap,-2,rval; (* map database into fork *)
				fhslf:db_first_page, (* from this fork *)
				handle:db_first_page, (* to slave fork *)
				[pmcnt+18,pmrd+18,pmwr+18]:
					  db_last_page-db_first_page+1);
			   if rval=3
			   then cpjerr('PMAP ')
			   else begin (* normal PMAP, database mapped *)
				    jsys(sfrkv,-2,rval;	(* start process *)
					 handle,0);
				    if rval=3
				    then cpjerr('SFRKV')
				    else begin (* normal return *)
					 end
				end
		       end
	      end
     end
	 
end; (* cproc *)

begin { main }

{ low-level initialization }
irinit;	(* initialize encoded value and format descriptors *)
pp_init;

{ initialize database }
initmaster; (* set master and slave pointers to NIL *)
mapmaster(true,true,true,not test_version);
gcmaster;
logmaster;
mapslave;

master:=getmaster;
slave:=getslave;

{ remove comment characters to force cache dump on initialization }

{if master^.cache_pointer<>NIL
then begin
	 myfbp:=ofile(log);
	 dmpzone(myfbp^.fident,master^.cache_pointer^);
	 cfile(myfbp)
     end;}

if (slave^.dirty<>0)
    OR
   (master^.cupdate>slave^.cupdate)
then cpymaster;

{ start up the procedures }

{ the name server }
cproc(nuforkfile,i);

{ the resolver }

rsolve;
end.
{$M-}
program lparse;

{	LPARSE is a package of routines for reading the text files
	which define master files and config files in the domain system
}

include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:lparse.def';
include {NOLIST} 'domain:eutil.hdr';
include {NOLIST} 'domain:msub.hdr';

var	dot_end:boolean;

procedure scan_error(var mypib:pib;
			str:string40);
extern;
procedure parse_error(var mypib:pib;
			str:string11);
extern;

function smatch(var l:line_buffer
		;pos:integer
		;str:atom):boolean;

{	SMATCH checks to see if the string in STR occurs at position
	POS in L
}
var	i:integer;

begin
i:=1;
while compchar(str[i],l[pos+i-1]) and (str[i]<>' ')
do	i:=i+1;

if str[i]=' '
then	smatch:=true
else	smatch:=false
end;
procedure gline(var mypib:pib);

{	GLINE reads an input line.  If at EOF, it inserts a ) and CR }

begin
with mypib
do 
begin

if eof(dfile)
then	begin
	line[1]:=')';
	line[2]:=chr(CR)
	end
else	begin
	line_index:=1;
	repeat	if eof(dfile)
		then	line[line_index]:=chr(CR)
		else	if (line_index=1) and (dfile^=chr(lf))
			then	begin
				get(dfile);
				if eof(dfile)
				then	line[line_index]:=chr(cr)
				else	line[line_index]:=dfile^
				end
			else	line[line_index]:=dfile^;
		line_index:=line_index+1;
		get(dfile)
	until	(line_index=(max_line_char-2)) or
		(line[line_index-1]=chr(CR));
	line[line_index]:=chr(CR);
	line_index:=1;
	line_number:=line_number+1
	end;

csaved:=false;

if false      { if true echo input }
then	begin
	write('GLINE gets:');
	line_index:=1;
	while line[line_index]<>chr(cr)
	do	begin
		write(line[line_index]);
		line_index:=line_index+1
		end;
	writeln(' ')
	end;

line_index:=1

end { with }
end;	{ gline }
procedure rescan(var mypib:pib);

{ rescan allows the current line to be rescanned }

begin
with mypib
do	begin
	line_index:=1;
	csaved:=false
	end
end; {rescan }
function have(var mypib:pib;
		needed:integer):boolean;

{ This procedure checks that the specified number of
  characters are available and that they are not CRs }

var	result:boolean;
	idex:integer;

begin
with mypib
do	begin
	result:=true;
	for idex:=line_index+1 to line_index+needed-1
	do	if idex>max_line_char
		then	result:=false
		else	if	ord(line[idex])=CR
			then	result:=false;

	if not result
	then	begin
		old_char:=-1;
		parse_error(mypib,'escape     ')
		end;

	have:=result
	end

end; { have }
function gpibch(var mypib:pib):integer;

{ gpibch returns an integer with the next octet or -1 if EOL }

var	done:boolean;

begin
with mypib
do begin
if csaved
then	gpibch:=old_char
else	begin
	repeat	done:=false;
		old_char:=ord(line[line_index]);

		{ start of parentheses group }
		if old_char=ord('(')
		then	pflag:=true

		{ end of parentheses group }
		else if old_char=ord(')')
		then	pflag:=false

		{ end of line within parentheses group }
		else if pflag and ((old_char=ord(';')) or (old_char=CR))
		then	begin
			gline(mypib);
			line_index:=line_index-1
			end

		{ backslash quoted char }
		else if old_char=ord('\')
		then	if line[line_index+1] in ['0'..'9']
			then	{ quoted decimal string }
				if have(mypib,3)
				then	begin
					old_char:=(ord(line[line_index+3])-ord('0'))
					+(ord(line[line_index+2])-ord('0'))*10
					+(ord(line[line_index+1])-ord('0'))*100;
					if (line[line_index+2] in ['0'..'9'])
						and
					   (line[line_index+3] in ['0'..'9'])
						and
					   (old_char>0)
						and
					   (old_char<256)
					then
					else	parse_error(mypib,'number     ');
					done:=true;
					line_index:=line_index+3
					end
				else	done:=true
			else	{ quoted special character }
				if have(mypib,1)
				then	begin
					old_char:=ord(line[line_index+1]);
					line_index:=line_index+1;
					done:=true
					end
				else	done:=true
		else 	begin
			done:=true;
			if (old_char=ord(';')) or (old_char=CR)
			then	old_char:=-1
			end;
			
		{ bump pointer }
		line_index:=line_index+1
	until	done;

	gpibch:=old_char
	end;

csaved:=false

end { with }

end; { gpibch }
function issep(var mypib:pib):boolean;

var	tmp:integer;

begin
with mypib
do	begin
	tmp:=gpibch(mypib);
	csaved:=true;
	issep:=(tmp=ord(' ')) or (tmp=ord('	'))
	end

end;	{ issep }

function isdot(var mypib:pib):boolean;

var	tmp:integer;

begin
with mypib
do	begin
	tmp:=gpibch(mypib);
	csaved:=true;
	isdot:=(tmp=ord('.'))
	end

end;	{ isdot }

function ismore(var mypib:pib):boolean;

begin
with mypib
do	begin
	ismore:=gpibch(mypib)<>-1;
	csaved:=true
	end

end;	{ ismore }

procedure toss_blanks(var mypib:pib);

begin
with mypib
do	while issep(mypib)
	do	csaved:=false
end; { toss_blanks }
function getatom(var mypib:pib;
			var myatom:atom):boolean;

{	Getatom returns a blank delimited thing of up
	to max_atom_chars in length.
}

var	i:integer;

begin
with mypib
do	begin
	for i:=1 to max_atom_chars
	do	myatom[i]:=' ';
	toss_blanks(mypib);
	if ismore(mypib)
	then	begin
		i:=1;
		repeat	if ismore(mypib) and (not issep(mypib))
			then begin
				 myatom[i]:=chr(gpibch(mypib));
				 i:=i+1
				 end
		until	(i=(max_atom_chars+1))
			or
			issep(mypib)
			or
			not(ismore(mypib));
		if i<>(max_atom_chars+1)
		then getatom:=true
		else getatom:=issep(mypib) or (not ismore(mypib))
		end
	else	getatom:=false
	end

end; { getatom }
function getlabel(var mypib:pib;
		    var dest:g1bpt;
		    var chars_left:integer):boolean;
var	count,char_limit:integer;
	ccptr:g1bpt;
begin
dot_end:=false;
if chars_left>0
then with mypib
     do	 begin
	 char_limit:=min(chars_left,max_lab_chars+1);
	 count:=0;
	 ccptr:=dest;
	 xidpb(dest,0);
	 char_limit:=char_limit-1;
	 chars_left:=chars_left-1;
	 if isdot(mypib)
	 then begin
		  dot_end:=true;
		  csaved:=false (* a root label by itself *)
	      end
	 else if ismore(mypib) and not(issep(mypib)) and ok
	      then begin
		   while ok and ismore(mypib) and not(isdot(mypib)) and not(issep(mypib))
		   do if char_limit>0
		      then begin
			       chars_left:=chars_left-1;
			       char_limit:=char_limit-1;
			       xidpb(dest,gpibch(mypib));
			       count:=count+1
			   end
		      else scan_error(mypib,'Name too long                           ');
		   xidpb(ccptr,count);
		   if isdot(mypib)
		   then begin
			    dot_end:=true;
			    csaved:=false
			end
		   end
	      else parse_error(mypib,'label      ')
	 
	 end
else scan_error(mypib,'Name too long                           ');
getlabel:=mypib.ok
end; { getlabel }
function getdns(var mypib:pib;
		  var origin:dname_string;
		  var dn:dname_string):boolean;
var	name_ptr,label_ptr:g1bpt;
	name_left:integer;
	toss:boolean;
begin
with mypib
do   begin
	 toss_blanks(mypib);
	 if ismore(mypib)
	 then begin
		  name_left:=max_dname_chars;
		  name_ptr:=xseto(dn);
		  label_ptr:=name_ptr;
		  if getlabel(mypib,name_ptr,name_left)	(* let at least one *)
		  then begin
		       while ok and ismore(mypib) and not(issep(mypib))
		       do begin
			  label_ptr:=name_ptr;
			  toss:=getlabel(mypib,name_ptr,name_left) (* maybe more *)
			  end;
		       if dot_end
		       then if name_left>0
			    then xidpb(name_ptr,0)
		            else scan_error(mypib,'Name too long                           ')
		       else { relative name }
			    if origin[1]=0
			    then scan_error(mypib,' zero origin added to relative name     ')
			    else if lendns(xseto(origin))>name_left
				 then scan_error(mypib,'Name too long                           ')
				 else copydns(xseto(origin),name_ptr)
		       end
		  else parse_error(mypib,'domain name')
	      end
	 else scan_error(mypib,'domain name missing                     ');
	 getdns:=ok
     end;
end; { getdns }
function getdname(var mypib:pib;
			var origin:exp_dname;
			var dn:exp_dname):boolean;

var	i:integer;

begin
with mypib
do begin
dn.count:=0;
toss_blanks(mypib);
if ismore(mypib)
then	begin
	while not(issep(mypib)) and ismore(mypib)
	do	begin
		dn.count:=dn.count+1;
		with dn.dlabels[dn.count]
		do	begin
			labinfo[0]:=0;	{ initialize label }
			while ismore(mypib) and ok and not(issep(mypib)) and not(isdot(mypib))
			do	if labinfo[0]<63
				then	begin
					labinfo[0]:=labinfo[0]+1;
					labinfo[labinfo[0]]:=gpibch(mypib);
					end
				else	scan_error(mypib,'Label length                            ');
			end;
		dlcase(dn.dlabels[dn.count]);	{ set up modifier bits }
		if issep(mypib) or not(ismore(mypib))
		then	{ add origin to domain name }
			if origin.count=0
			then	scan_error(mypib,' relative name requires active origin   ')
			else	begin
				    if (dn.count=1) and { test for naked @ }
				       (dn.dlabels[1].labinfo[0]=1) and
				       (dn.dlabels[1].labinfo[1]=ord('@'))
				    then dn.count:=0;
				    for i:=1 to origin.count
				    do	begin
					dn.count:=dn.count+1;
					dn.dlabels[dn.count]:=origin.dlabels[i]
					end
				end
		else	if isdot(mypib)
			then	begin
				csaved:=false;
				if not(ismore(mypib)) or issep(mypib)	{ add implied root }
				then	if (dn.count<>1)
						or
					   (dn.dlabels[1].labinfo[0]<>0)
					then	begin
						dn.count:=dn.count+1;
						dn.dlabels[dn.count].labinfo[0]:=0
						end
				end
			else	scan_error(mypib,'Label termination error                 ')
		end
	end
else	scan_error(mypib,' error                                  ');

getdname:=ok;

end { with }
end; {getdname}
procedure getfn(var mypib:pib;
		var fn:filename);

var	i:integer;
begin
with mypib
do	begin
	for i:=1 to max_fn_chars
	do	fn[i]:=' ';
	toss_blanks(mypib);
	if ismore(mypib)
	then	begin
		i:=1;
		repeat	fn[i]:=chr(gpibch(mypib));
			i:=i+1
		until	(i=(max_fn_chars+1))
			or
			issep(mypib)
			or
			not(ismore(mypib));
		if (i=1) or (i=(max_fn_chars+1))
		then	parse_error(mypib,'filename   ')
		end
	end

end; {getfn}
procedure check_end(var mypib:pib);

{	check_end makes sure that there is not anything left over
	on the line
}

var	foo:integer;

begin
toss_blanks(mypib);
if ismore(mypib)
then	begin
	scan_error(mypib,'Extraneous data on line                 ');
	while ismore(mypib)
	do	foo:=gpibch(mypib)
	end

end. { check_end }
program makedb;

include {NOLIST} 'domain:jsys.def';
include {NOLIST} 'pascal:extern.pas';		
include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:lparse.def';
include {NOLIST} 'domain:msub.hdr';
include {NOLIST} 'domain:fload.hdr';
include {NOLIST} 'domain:irdata.hdr';
include {NOLIST} 'domain:dump.hdr';
include {NOLIST} 'domain:addrr.hdr';
include {NOLIST} 'domain:mdep.hdr';
include {NOLIST} 'domain:pp.hdr';
include {NOLIST} 'domain:alloc.hdr';
include {NOLIST} 'domain:lparse.hdr';
include {NOLIST} 'domain:tport.hdr';
var	idex,ret,ac1,ac2,ac3,my_address,i,j,toss:integer;
	null_origin:exp_dname;
	master:master_block_pointer;
	infile:filename;
	logfile:file of char;
	logfn:filename;
	cpib:pib;
	cdata:zone_cdata;
	inatom:atom;
	zp:zone_entry_pointer;
	search_node:node_pointer;
	ncd:boolean;
	dumpflag:boolean;
	statflag:boolean;
	delflag:boolean;
	totstg:stgmap;stg_idex:satype;
	null_dns:dname_string;

{ scan_error and parse_errors come from fload in this version }

procedure scan_error(var mypib:pib;
			str:string40);
extern;
procedure parse_error(var mypib:pib;
			str:string11);
extern;

procedure toss_atom;

begin
if not getatom(cpib,inatom)	{ eat keyword }
then cpib.ok:=false;
end;
procedure anyload;

begin
with cpib,cdata,master^
do
begin { with }
if smatch(line,1,'zloadf         ')
then	loadtype:=zloadf
else	if smatch(line,1,'zloadfd        ')
	then	loadtype:=zloadfd
	else	if smatch(line,1,'cloadf         ')
		then	loadtype:=cloadf
		else	if smatch(line,1,'zloadn         ')
			then	loadtype:=zloadn
			else	ok:=false;

toss_atom;

{ Parse off zone name, class, and default interval unless
  a cache load }

if not ok
then	scan_error(cpib,'Unable to understand load type          ')
else	begin
	toss_blanks(cpib);
	case loadtype of

	zloadf,
	zloadfd,
	zloadn:	begin	{ get zone name, class, and default
			  timeout }
		ncd:=false;	{ assume failure }
		if getdname(cpib,null_origin,zone_to_load)
		then if getatom(cpib,inatom)
		then if cvclass(inatom,loadclass)
		then if getatom(cpib,inatom)
		then if cvtime(inatom,default_rinterval)
		then ncd:=true;
		ok:=ok and ncd
		end;

	cloadf:	zone_to_load.count:=0	{ set root }

	end { case }
	end;

{ Parse off filename for file loads, list of hosts if a
  network load }

if ok
then	begin
	case  loadtype of

	zloadf,
	zloadfd,
	cloadf:	getfn(cpib,refresh_file);

	zloadn:	begin
		hostcount:=0;
		repeat	if getdname(cpib,null_origin,
					hosts[hostcount+1])
			then	hostcount:=hostcount+1
		until	not(ismore(cpib))
			 or
			(hostcount=max_zlhosts);
		end
	end {case}
	end;

if ok
then	check_end(cpib);

if ok
then	{ get a zone to set up }
	if loadtype <> cloadf
	then	begin
		search_node:=gonode(search_zone,zone_to_load);
		if search_node^.zone_ptr=NIL
		then	begin
			a_zone(search_node^.zone_ptr);
			zp:=search_node^.zone_ptr
			end
		else	scan_error(cpib,'Already loaded                          ');
		zp:=search_node^.zone_ptr
		end
	else	{ cache load }
		if cache_pointer=NIL
		then	begin
			a_zone(cache_pointer);
			zp:=cache_pointer
			end
		else	scan_error(cpib,'Already loaded                          ');

if ok
then	{ setup parameters in zone block }
	case loadtype of

	zloadf,
	zloadfd,
	zloadn:	zp^.zone_config:=cdata;

	cloadf: zp^.zone_is_cache:=true
	end;

if ok
then	{ load files if file load }
	case loadtype of

	zloadf,
	zloadfd,
	cloadf:	if fzload(zp^,zone_to_load,refresh_file)
		then	begin
			zp^.loaded:=true;
			for stg_idex:=sd_slt to sd_litstring (* Total stats *)
			do begin
			   totstg[stg_idex,sa_units]:=totstg[stg_idex,sa_units]+zp^.sadata[stg_idex,sa_units];
			   totstg[stg_idex,sa_aus]:=totstg[stg_idex,sa_aus]+zp^.sadata[stg_idex,sa_aus]
			   end;
			if statflag or dumpflag
			then begin
				 writeln(logfile);
				 write(logfile,'Data Structure Stats for file ');
				 d_file(logfile,refresh_file);
				 writeln(logfile);
				 dmp_zstg(logfile, zp^);
				 if dumpflag then dmpzone(logfile,zp^)
			     end;
			if statflag or dumpflag or delflag
			then begin
				 writeln(logfile);
				 writeln(logfile,del_count(zp^):3,
					 ' delegations found');
				 writeln(logfile)
			     end;
			if delflag
			then begin (* write out delegations *)
				 writeln(logfile);
				 write(logfile,'Delegations for file ');
				 d_file(logfile,refresh_file);
				 writeln(logfile);
				 dmp_dels(logfile,zp^)
			     end
			end
		else	scan_error(cpib,'File load failed                        ');

	zloadn:

	end;

end; { with }
end; { anyload }
procedure getads(var myst:server_type);

{ parse a server name and an optional sequence of addresses }

begin
with cpib,myst
do   begin
	 addresses_ready:=false;
	 address_count:=0;
	 toss_blanks(cpib);
	 if ismore(cpib)
	 then if getdns(cpib,null_dns,server_name)
	      then begin
		       while ismore(cpib) and ok
		       do begin
			      toss_blanks(cpib);
			      if ismore(cpib)
			      then if getatom(cpib,inatom)
				   then if address_count<max_server_addresses
				        then begin
						 address_count:=address_count+1;
						 if cvina(inatom,server_addresses[address_count].ipaddress)
						 then begin
							  addresses_ready:=true;
							  toss_blanks(cpib)
						      end
					     end
					else scan_error(cpib,'Too many addresses                      ')
				   else parse_error(cpib,'address    ')
			  end;
		       check_end(cpib)
		   end
	      else parse_error(cpib,'name       ')
	 else parse_error(cpib,'name       ');
	 if ok and not(addresses_ready)	(* setup addresses if possible *)
	 then if getadr(myst,true,false,false,0) then
     end;
end; { getads }
procedure getpref;

(* GETPREF scans a line which must be of the form

   APREF mask value eta

   mask must be a IP address expressed in dotted decimal form

   value must be a IP address expressed in dotted decimal form

   eta must be an integer>0 and is the ETA in MS *)

var success:boolean;
    maskatom,valatom,etaatom:atom;
    mask,val,eta,idex:integer;
begin
success:=false;	(* assume failure *)
with cpib,master^.measure
do if ismore(cpib)
   then if getatom(cpib,maskatom)
        then begin
		 toss_blanks(cpib);
		 if ismore(cpib)
		 then if getatom(cpib,valatom)
		      then begin
			   toss_blanks(cpib);
			   if ismore(cpib)
			   then if getatom(cpib,etaatom)
				then if cvina(maskatom,mask) and
				        cvina(valatom,val) and
					cvint(etaatom,eta)
			              then if eta>0
					   then begin
					        idex:=1;
						while (idex<prfmax) and	(* NOT <= *)
						       (prefm[idex]<>0)
						do idex:=idex+1;
						if idex=prfmax
						then scan_error(cpib,'Preference table overflow               ')
						else begin
							prefm[idex]:=mask;
							prefv[idex]:=val;
							prefe[idex]:=eta;
							success:=true
						     end;
						check_end(cpib)
						end
			   end			    
	     end
end;
begin { main }
null_dns[1]:=0;

for stg_idex:=sd_slt to sd_litstring (* Clear total storage stats *)
do begin
       totstg[stg_idex,sa_units]:=0;
       totstg[stg_idex,sa_aus]:=0
   end;

reset(input,'TTY:');
rewrite(output,'TTY:');

imaster;
master:=getmaster;

{ initialize default server and resolver addresses }
master^.resolve_addrs.address_count:=0;
master^.resolve_dserve.server_count:=0;

{ Set version number }
master^.dbvers:=dbvern;
master^.measure.dupver:=dbvern;

{ initialize measurement parameters }
with master^.measure
do begin
	infttl:=10;		{ limit for JSYS looping }
	plttl:=20;		{ primitive lock disms time in MS }
	lckttl:=200;		{ MS wait for exclusive to clear }
	rwaiti:=20;		{ initial MS wait for resolver }
	rwait:=20;		{ subsequent MS wait for resolver }
	ripoll:=20;		{ resolver idle poll interval }
	rbpoll:=20;		{ resolver busy poll interval }
	qtoi:=1500;		{ query initial timeout }
	qtor:=1000;		{ query retransmission timeout }
	qtoq:=2000;		{ query timeout for quiet interval }
	
	dynsw:=1;		{ use dynamic timeouts }
	dynnum:=3;		{ ETA to timeout ratio of 3/2 }
	dynden:=2;

	udphl:=10*60*1000;      { halflife of ten minutes }

	rmttl:=20;		{ resolver max TTL }
	maxit:=3;		{ max tries per address per request }
	maxst:=6;		{ max tries per server per request }
	prefe[0]:=5000;		{ pref zero eta = 5000 }
	
	dfgra.tquanta:=20;
	udpgra.tquanta:=20;
	nsugra.tquanta:=5;
   end;

{ initialize for zone loading }
irinit;
pp_init;
zinit(master^.search_zone);

null_origin.count:=0;

{ ask for the name of the configuration file }

repeat	write(output, 'Enter configuration file name: ');
        break(output);
        readln(input, infile);
until	pib_init(cpib, infile);

{ ask for the name of the log file }

write(output, 'Enter log file name: ');
break(output);
readln(input, logfn);
rewrite(logfile,logfn);

logfile^:=chr(12);
tstamp(logfile);
writeln(logfile,'Configuration file is: ',infile);
writeln(logfile);

statflag:=false;
delflag:=false;
dumpflag:=false;

with cpib,cdata,master^
do	while not eof(dfile)
	do  begin
	    ok:=true;
	    gline(cpib);

	    idex:=1;
	    repeat	if line[idex]<>chr(cr)
			then	write(logfile,line[idex]);
			idex:=idex+1
	    until	(idex>max_line_char) or (line[idex-1]=chr(cr));
	    writeln(logfile);
	    
	    { check for comment line }
	    toss_blanks(cpib);
	    if ismore(cpib)
	    then if smatch(line,1,'dump           ')
		        then dumpflag:=true
		 else if smatch(line,1,'nodump         ')
			then dumpflag:=false
		 else if smatch(line,1,'stat           ')
		        then statflag:=true
		 else if smatch(line,1,'nostat         ')
			then statflag:=false
		 else if smatch(line,1,'del            ')
		        then delflag:=true
		 else if smatch(line,1,'nodel          ')
			then delflag:=false
		 else if smatch(line,1,'apref          ')
		         then begin
				  toss_atom;
				  toss_blanks(cpib);
				  getpref
			      end
		 else if smatch(line,1,'raddr          ')
		 	then { set resolver addresses }
			     begin
				 toss_atom;
				 getads(resolve_addrs)
				 end
		 else if smatch(line,1,'dserve         ')
		      then { set default server address }
			    begin
				toss_atom;
				{ Set absurd length so ancestor test fails }
				resolve_dserve.server_at_len:=260;
				if resolve_dserve.server_count<max_search_servers
				then begin
				     resolve_dserve.server_count:=resolve_dserve.server_count+1;
				     getads(resolve_dserve.servers[resolve_dserve.server_count])
				     end
			        else scan_error(cpib,'Too many default servers                ')
			    end
                 else anyload { assume its a file load }
		
	    end;

close(cpib.dfile);

{ Write out summary information }

if statflag or dumpflag
then begin
	 Writeln(logfile,'***** Total zone usage *****');
	 Writeln(logfile);
	 dmp_stg(logfile,totstg,0);
	 Writeln(logfile)
	 end;

{set source host address}

jsys(gthst, -2, ret;0;ac1,    {get host address} 
     ac2, ac3, my_address); 
if ret=3
then writeln(logfile, 'jsys GTHST failed');

jsys(gthst,-2,ret;2,master^.measure.mname,my_address);

with master^.resolve_addrs
do begin
       if address_count=0
       then begin
		 address_count:=1;
		 server_addresses[1].ipaddress:=my_address;
		 addresses_ready:=true;
		 server_name[1]:=1;
		 server_name[2]:=ord('*');
		 server_name[3]:=0 (* so print routine doesn't die *)
	    end;
       writeln(logfile);
       write(logfile,'Resolver addresses for ');
       toss:=dmpdns(logfile,xseto(server_name));
       write(logfile,' are: ');
       d_sa(logfile,master^.resolve_addrs,false);
       writeln(logfile);
       writeln(logfile)
   end;


with master^.resolve_dserve
do if server_count=0
   then writeln(logfile,'***** No default servers were specified *****')
   else begin
	     sort_sa(master^.resolve_dserve);
	     writeln(logfile,'Default servers are: ');
	     for i:=1 to server_count
	     do begin
		     toss:=dmpdns(logfile,xseto(servers[i].server_name));
		     d_sa(logfile,servers[i],false);
		     writeln(logfile)
		end;
	     writeln(logfile)
	end;
writeln(logfile);


i:=cntpage(master^.used_pages);
j:=db_last_page-db_first_page+1;
write(logfile,i:3,' pages used out of ',j:3);
i:=(i*100) div j;
writeln(logfile,' (',i:2,'%)');
close(logfile);
wmaster

end. { main }
{$X+}
program makedf;

include {NOLIST} 'domain:jsys.def';
include {NOLIST} 'pascal:extern.pas';		
include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:lparse.def';
include {NOLIST} 'domain:msub.hdr';
include {NOLIST} 'domain:fload.hdr';
include {NOLIST} 'domain:irdata.hdr';
include {NOLIST} 'domain:dump.hdr';
include {NOLIST} 'domain:addrr.hdr';
include {NOLIST} 'domain:mdep.hdr';
include {NOLIST} 'domain:pp.hdr';
include {NOLIST} 'domain:alloc.hdr';
include {NOLIST} 'domain:lparse.hdr';

type	char6=packed array[1..6] of char;
	char30=packed array[1..30] of char;
	pool_table=array[sapool] of free_block_pointer;

var	out:file of char;
	cpyfil:file of char;
	p_filename:^filename;
	p_pagemap:^pagemap;
	p_label_string:^label_string;
	p_ulabel:^ulabel;
	p_lab_use:^lab_use;
	p_dname:^dname;
	p_dname_string:^dname_string;
	p_dname_string_table:^dname_string_table;
	p_dname_table:^dname_table;
	p_primary_label_table:^primary_label_table;
	p_rr_table:^rr_table;
	p_rd_table:^rd_table;
	p_stgmap:^stgmap;
	p_zone_pools:^pool_table;
	p_node:^node;
	p_lock:^lock;
	p_zone_entry:^zone_entry;
	p_search_block:^search_block;
	p_master_block:^master_block;
	p_msure_type:^msure_type;
	p_rr:^rr;
	p_file_blk:^file_blk;
	p_zone_cdata:^zone_cdata;
	p_server_type:^server_type;
	p_servers_dv:^servers_dv;
	afile:filename;

procedure dd(lab:char6;val:integer;com:char30);

{	define a symbol	}

begin
writeln(out,lab,'==',val:5:o,'	; ',com);
end; {dd}

procedure dc(lab:char6;val:integer);

{	check a symbol	}
begin
writeln(out,'ifn ',lab,'-',val:5:o,',<printx ',lab,
	' consistency failure, should be ',val:5:o,'>');
end; {dc}

procedure dumpfn;

var	  i:integer;
begin
i:=1;
while afile[i]<>' '
do begin
       write(out,afile[i]);
       i:=i+1
   end
end;
{	This program makes the file DOMSYM.MAC which in turn is
	assembled to produce DOMSYM.unv

	DOMSYM.UNV is used to insure consistency of definitions
	for master file data structures between the pascal world
	and the MACRO world

}
begin { main }

rewrite(out,'domsym.mac');
writeln(out,'	universal domsym	Domain block sizes and offsets');
writeln(out,'	search	  monsym,macsym');
writeln(out);

{	Test or real version            }
if test_version
then dd('dtestv',1,'This is the test version      ')
else dd('dtestv',0,'This is the real thing        ');
writeln(out);

{	Database section definition     }
dd('domsec',db_first_page div 512,'Domain section number         ');
dd('dbvern',dbvern,'Database version number       ');

{	Class related definitions	}

dd('  dclb',ord(dclass_l_bound),'Class lower bound             ');
dd('  dchb',ord(dclass_h_bound),'Class upper bound             ');

{	Type related definitions	}

dd('  dtlb',ord(dtype_l_bound),'Type lower bound              ');
dd('  dthb',ord(dtype_h_bound),'Type upper bound              ');

dd(' fname',sizeof(p_filename),'                              ');
dd('pagema',sizeof(p_pagemap),'                              ');
dd('filebk',sizeof(p_file_blk),'                              ');
dd('zcdata',sizeof(p_zone_cdata),'                              ');
dd(' dntbl',sizeof(p_dname_table),'                              ');
dd('   plt',sizeof(p_primary_label_table),'                              ');
dd(' rrtbl',sizeof(p_rr_table),'                              ');
dd(' rdtbl',sizeof(p_rd_table),'                              ');
dd('stgmap',sizeof(p_stgmap),'                              ');
dd('poltbl',sizeof(p_zone_pools),'                              ');
dd('srvrty',sizeof(p_server_type),'single server definition      ');
dd('srvrdv',sizeof(p_servers_dv),'multiple servers definition   ');

dd(' maxdc',max_dname_chars,'Max chars in a dname          ');
dd(' maxdl',max_dname_labels,'Max labels in a dname         ');
dd(' maxlc',max_lab_chars,'Max chars in a label          ');
dd('labelh',label_hashmod,'Hashing modulo                ');
dd(' maxsb',max_sb,'Number of search blocks       ');
dd('gtdfmx',gtdfmx,'Max GTDOM function            ');

dd('hslots',hslots,'Host slots in tgraph          ');
dd('tslots',tslots,'Time slots in tgraph          ');
dd('qslots',qslots,'QTYPE slots in qgraph         ');
dd('cslots',cslots,'QCLASS slots in cgraph        ');
dd(' dimax',dimax ,'maximum day interval          ');
dd(' sgmax',sgmax ,'maximum segment size graph    ');
dd('prfmax',prfmax,'high index of preference db   ');

{	     copy file of structure definitions}
reset(cpyfil,'master.mac','/E');
while not(eof(cpyfil))
do    begin
	  out^:=cpyfil^;
	  get(cpyfil);
	  put(out)
      end;
close(cpyfil);

{ define the file names }

if test_version
then afile:=tst_flipfile
else afile:=flipfile;
write(out,'define flipfn < asciz /');
dumpfn;
writeln(out,'/>');

if test_version
then afile:=tst_flopfile
else afile:=flopfile;
write(out,'define flopfn < asciz /');
dumpfn;
writeln(out,'/>');

{ now define the dcheck macro which checks for definition consistency	}

writeln(out,'define	dcheck <');

if test_version
then dc('dtestv',1)
else dc('dtestv',0);

dc('  dclb',ord(dclass_l_bound));
dc('   din',ord(internet));
dc('   dcs',ord(csnet));
dc('  dchb',ord(dclass_h_bound));

{	Type related definitions	}

dc('  dtlb',ord(dtype_l_bound));
dc('    da',ord(a));
dc('   dns',ord(ns));
dc('   dmd',ord(md));
dc('   dmf',ord(mf));
dc('dcname',ord(cname));
dc('  dsoa',ord(soa));
dc('   dmb',ord(mb));
dc('   dmg',ord(mg));
dc('   dmr',ord(mr));
dc(' dnull',ord(null));
dc('  dwks',ord(wks));
dc('  dptr',ord(ptr));
dc('dhinfo',ord(hinfo));
dc('dminfo',ord(minfo));
dc('dmx   ',ord(mx));
dc('  dthb',ord(dtype_h_bound));

dc('daxfer',axfr);
dc('dmailb',mailb);
dc('dmaila',maila);
dc(' dstar',star);

dc(' fname',sizeof(p_filename));
dc('pagema',sizeof(p_pagemap));
dc('filebk',sizeof(p_file_blk));
dc('zcdata',sizeof(p_zone_cdata));
dc(' dntbl',sizeof(p_dname_table));
dc('   plt',sizeof(p_primary_label_table));
dc(' rrtbl',sizeof(p_rr_table));
dc(' rdtbl',sizeof(p_rd_table));
dc('stgmap',sizeof(p_stgmap));
dc('poltbl',sizeof(p_zone_pools));
dc('srvrty',sizeof(p_server_type));
dc('srvrdv',sizeof(p_servers_dv));

dc(' maxdc',max_dname_chars);
dc(' maxdl',max_dname_labels);
dc(' maxlc',max_lab_chars);
dc('labelh',label_hashmod);
dc(' maxsb',max_sb);
dc('gtdfmx',gtdfmx);

dc('hslots',hslots);
dc('tslots',tslots);
dc('qslots',qslots);
dc('cslots',cslots);
dc(' dimax',dimax );
dc(' sgmax',sgmax );
dc('prfmax',prfmax);

dc('labels',sizeof(p_label_string));
dc('ulabel',sizeof(p_ulabel));
dc('labuse',sizeof(p_lab_use));
dc(' dname',sizeof(p_dname));
dc('dnames',sizeof(p_dname_string));
dc(' dstbl',sizeof(p_dname_string_table));
dc('  node',sizeof(p_node));
dc('    rr',sizeof(p_rr));
dc('  lock',sizeof(p_lock));
dc('zoneen',sizeof(p_zone_entry));
dc(' serch',sizeof(p_search_block));
dc('master',sizeof(p_master_block));
dc(' msure',sizeof(p_msure_type));

writeln(out,'	>');

writeln(out,'	end');

close(out)

end. { main }
{$M-}
program mdep;

{	*************************************************************

	This file consists of all of the machine dependent routines

	************************************************************* }

include {NOLIST} 'domain:jsys.def';
include {NOLIST} 'pascal:extern.pas';		
include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:addrr.hdr';
include {NOLIST} 'domain:msub.hdr';
include {NOLIST} 'domain:lparse.def';
include {NOLIST} 'domain:iomsg.hdr';
include {NOLIST} 'domain:dump.hdr';

type	flagword=set of 0..35;

var	secfile:file of octet;
	section_number:integer;
	section_pointer:secptr;
	i:integer;
	iptr:^integer;
	jval:integer;
	master:master_block_pointer;
	slave:master_block_pointer;
	flipname,flopname:filename;
	master_jfn,slave_jfn:integer;
	m_ptr,s_ptr:master_block_pointer;
	open_flags,pmap_flags:flagword;
procedure tstamp(var x:file);

{	*************************************************************

	TSTAMP writes a date/time string to the specified file

	************************************************************* }

var	crs:packed array[1..18] of char;

begin
jsys(odtim;crs,-1,0);
write(x,crs)

end; { tstamp }

function getversion(jfn:integer):integer;

{	*************************************************************

	GETVERSION gets the version number of the specified file

	************************************************************* }

var	string:packed array[1..20] of char;
	rval,ac1,ac2:integer;

begin
jsys(jfns;string,jfn,000010b:0,0);
jsys(nin,1;string,0,10;ac1,ac2);
getversion:=ac2
end; { getversion }

function cntpage(var mymap:pagemap):integer;

{ CNTPAGE returns a count of the number of marked pages in the pagemap }

var i,sum:integer;

begin
sum:=0;
for i:=db_first_page to db_last_page
do if mymap[i] then sum:=sum+1;
cntpage:=sum
end;
procedure initmaster;

{ Set the master block pointer to NIL.
  Should be used by all programs sharing
  any portion of this software. }

begin
    master:=NIL;
    slave:=NIL;
end;
procedure up_pages(first_file_page:integer; (* file page number *)
		     count:integer);          (* count of pages to write *)

{ UP_PAGES UPDATES the specified pages of the master file }

var	rval:integer;
	myfbp:file_blk_ptr;

begin
jsys(ufpgs,-2,rval;
     master^.prijfn:first_file_page,count);
if rval<>2
then begin
	 myfbp:=ofile(fatl);
	 writeln(myfbp^.fident,'Cannot update master pages');
	 jsys_err(abort,-1,myfbp)
     end
end; { up_pages }

procedure up_all;

begin
up_pages(0,db_last_page-db_first_page+1);
end; { up_all }
function getmaster:master_block_pointer;

{	*************************************************************

	GETMASTER returns a pointer to the master block at the start
	of the database.  Note that the database must have been set
	up, either by a call to IMASTER to initialize a new copy, or
	by a call to MAPMASTER to get an old one.

	************************************************************* }

begin
getmaster:=master
end; { getmaster }

procedure imaster;

{	*************************************************************

	IMASTER sets up a file and memory for a new data base

	************************************************************* }

var	myfbp:file_blk_ptr;
	total_sections:integer;	(* include space for primary and secondary *)

begin { imaster }

{ setup files }

rewrite(secfile,'flip.dd.-1');

{ create sections }

section_number:=(db_first_page div 512);
total_sections:=((db_last_page div 512)-(db_first_page div 512)+1)*2;
getsections(total_sections,
	    section_number,
	    section_pointer);

section_number:=bshift(quotep(section_pointer),-18);

if section_number<>(db_first_page div 512)
then	begin
	    myfbp:=ofile(err);
	    writeln(myfbp^.fident, 'Section ', (db_first_page div 512):2,
		    ' requested, but section ', section_number:2,
		    ' was obtained');
	    cfile(myfbp);
	end;

modptr(section_pointer,band(db_first_page,511)*512);

{ zero memory to make it real }
cpyptr(section_pointer,iptr);
for i:=db_first_page to db_last_page
do	begin
	iptr^:=0;
	modptr(iptr,512)
	end;

cpyptr(section_pointer,master);

{ mark pages for master block }
for i:=0 to sizeof(master) div au_per_page
do	master^.used_pages[db_first_page+i]:=true;

{ initialize search block chain }
master^.sbloop:=sbptr(master^.sb_array[1]);
for i:=1 to max_sb
do with master^.sb_array[i]
   do begin
	  sbnext:=sbptr(master^.sb_array[(i mod max_sb)+1]);
	  if (i<3) or (i>4) { reserve search blocks 3 & 4 for LDO }
	  then ldores:=0
	  else ldores:=1;
	  rcomp:=intptr(master^.rcom[i])
      end;

{	initialize IAORG and STARK	}

master^.starbp:=xseto(master^.stard);
xidpb(master^.starbp,1);
xidpb(master^.starbp,ord('*'));
master^.starbp:=xseto(master^.stard);

master^.iaorg[1]:=7;
master^.iaorg[2]:=ord('I');
master^.iaorg[3]:=ord('N');
master^.iaorg[4]:=ord('-');
master^.iaorg[5]:=ord('A');
master^.iaorg[6]:=ord('D');
master^.iaorg[7]:=ord('D');
master^.iaorg[8]:=ord('R');
master^.iaorg[9]:=4;
master^.iaorg[10]:=ord('A');
master^.iaorg[11]:=ord('R');
master^.iaorg[12]:=ord('P');
master^.iaorg[13]:=ord('A');

master^.iaorg[14]:=0;

{	set database time }

jsys(gtad;;i);
if i=-1
then   begin
       myfbp:=ofile(err);
       writeln(myfbp^.fident,'System clock not set.. big trouble');
       cfile(myfbp)
       end;
master^.measure.tzero:=i;
master^.measure.mclear:=i;
master^.cupdate:=i;

ilock(master^.update_lock);
ilock(master^.alloc_lock);

ilock(master^.msg_files[fatl].flock);
ilock(master^.msg_files[err].flock);
ilock(master^.msg_files[log].flock);

end; { imaster }

procedure wmaster;

{	*************************************************************

	WMASTER writes out a copy of the new database

	************************************************************* }

begin
{ pmap the file out }
jsys(pmap,-2,jval;
	fhslf:section_number*512,
	secfile:0,
	540000b:((db_last_page div 512)-(db_first_page div 512)+1)*512);

if jval=3
then	analys(secfile);

close(secfile);

{ Set the file length }

jsys(chfdb,-2,jval; (* set file length *)
     12b:secfile,-1,(db_last_page-db_first_page+1)*512);
jsys(chfdb,-2,jval; (* set file bytesize to 36 *)
     11b:secfile,007700b:0,004400b:0);

end; { wmaster }
procedure logmaster;

var	myfbp:file_blk_ptr;

begin
myfbp:=ofile(log);
write(myfbp^.fident, 'Database taken from ');
d_file(myfbp^.fident,flipname);
writeln(myfbp^.fident);
pheader(log,myfbp);
if m_ptr^.cache_pointer=NIL
then writeln(myfbp^.fident,'No cache.')
else begin
     writeln(myfbp^.fident,' Includes a ',
	     cntpage(m_ptr^.cache_pointer^.zone_pages):4,
	     ' page cache');
     if master<>NIL
     then dmp_zstg(myfbp^.fident,m_ptr^.cache_pointer^)
     end;
cfile(myfbp)
end; { logmaster }
procedure jerr;

begin (* This procedure writes the most recent error to the TTY *)
write(tty,' ');
jsys(erstr,2;curjfn(tty),fhslf:-1,0);
writeln(tty)
end; { jerr }

procedure freezl(mynode:node_pointer);

(* This procedure used in mapmaster along with WALKNODE to
   free zone locks *)

var zp:zone_entry_pointer;

begin
zp:=mynode^.zone_ptr;
while zp<>NIL
do begin
       ilock(zp^.zone_lock);
       zp:=zp^.zone_chain
   end
	 
end; { freezl }
procedure fakei(var mjfn:integer; (* return master JFN *)
		  var sjfn:integer);extern; (* return slave JFNgtdom.mac
 *)

procedure fakemaster;

var	rval:integer;

begin
fakei(master_jfn,slave_jfn); (* call userdj to map in database *)
flipname:=m_ptr^.measure.prifn;
flopname:=m_ptr^.measure.secfn;

logmaster; (* goes to console since master=NIL here *)
master:=m_ptr;
end; { fakemaster }
procedure mapmaster(writable:boolean;	(* writable mapin? *)
		      warm_start:boolean; (* warm start lock code *)
		      setup_db:boolean;	(* setup database locks etc *)
		      jsys_file_select:boolean);

{	*************************************************************

	MAPMASTER maps in the best version of the database.
	The database can be selected either by asking the JSYS context
	which files to use (JSYS_FILE_SELECT=true) or else by calling the
	user level JSYS code to emulate the selection process.

	Warm start performs special synchronization with JSYS requests,
        nad is appropriate for restarting a resolver, etc.

        If setup_db is true, then the master block gets its locks set,
	and the jfns in PRIJFN and SECJFN, etc.

        ************************************************************* }

var	i,loopct,unlocked:integer;
	block:free_block_pointer;
	rval:integer;
	myfbp:file_blk_ptr;
	slots_locked:array[1..max_sb] of boolean;

begin

if writable (* setup open and PMAP flags *)
then	 begin
	     open_flags:=[ofrd,ofwr,ofthw];
	     pmap_flags:=[pmrd+18,pmwr+18,pmcnt+18]
	 end
else	 begin
	     open_flags:=[ofrd,ofthw];
	     pmap_flags:=[pmrd+18,pmcnt+18]
	 end;

block:=aofpage(db_first_page); cpyptr(block,m_ptr); cpyptr(block,s_ptr);
modptr(s_ptr,512);

if not jsys_file_select
then fakemaster	(* execute fake mapmaster *)
else begin (* the real thing *)
	 (* Use TTY since file locks may be set *)
	 writeln(tty,' Domain initialization begun');

	 jsys(gtdom,-2,rval; (* get primary file name *)
	      gtdfus,flipname);	(* get name of primary file *)
	 if rval=3
	 then (* error in GTDOM file name query *)
	      begin
		  write(tty,'GTDOM error asking for DB file, ');
		  jerr;quit
	      end
	 else writeln(tty,'GTDOM database is ',flipname);

	 jsys(gtjfn,-2,rval;[gjsht,gjold],flipname;master_jfn);
	 if rval=3
	 then begin (* error in GTJFN *)
		  write(tty,'GTJFN error on primary, ');
		  jerr;quit
	      end;

	 jsys(openf,-2,rval;master_jfn,open_flags);
	 if rval=3
	 then begin (* error in OPENF *)
		  write(tty,'OPENF error on primary, ');
		  jerr;quit
	      end;

	 jsys(pmap,-2,rval; (* map in database *)
	      master_jfn:0,
	      fhslf:db_first_page,
	      pmap_flags:db_last_page-db_first_page+1);
	 if rval=3
	 then begin (* error in PMAP *)
		  write(tty,'PMAP error on primary, ');
		  jerr;quit
	      end;
	 master:=m_ptr;
	 flopname:=master^.measure.secfn;

	 jsys(gtjfn,-2,rval;[gjsht,gjold],flopname;slave_jfn);
	 if rval=3
	 then begin (* error in GTJFN *)
		  write(tty,'GTJFN error on secondary, ');
		  jerr;quit
	      end;

	 jsys(openf,-2,rval;slave_jfn,open_flags);
	 if rval=3
	 then begin (* error in OPENF *)
		  write(tty,'OPENF error on secondary, ');
		  jerr;quit
	      end;
	 
     end; (* the real thing *)

if setup_db
then with master^
     do begin
	     prijfn:=master_jfn;
	     secjfn:=slave_jfn;
	     resolve_job:=-1; (* signal no resolver *)
	     if warm_start (* special initialization if possible restart *)
	     then begin
		      (* This code is intended to flush all pending JSYS
		         requests and lock up all search blocks to prevent
		         any more from starting.  The assumption is that
			 setting resolve_job to -1 will make this happen *)
		      dflush:=1; (* signal flush *)
		      for i:=1 to max_sb (* mark all as unlocked *)
		      do slots_locked[i]:=false;
		      unlocked:=max_sb; (* set unlocked to max *)

		      loopct:=0; (* wait till we get all of them *)
		      while unlocked>0
		      do begin
			     loopct:=loopct+1;
			     for i:=1 to max_sb (* try to lock this one *)
			     do if not slots_locked[i]
				then if (rcom[i]<>0)
				        and tbit(sb_array[i].fcode,gtdrbk)
				     then begin
					      slots_locked[i]:=true;
					      unlocked:=unlocked-1;
					  end
				     else begin
					      slots_locked[i]:=prlock(sb_array[i].slock);
					      if slots_locked[i] then unlocked:=unlocked-1
					  end;
			     if (unlocked<>0) and (loopct>20)
         		     then writeln(tty,'Domain locks stuck after ',
					  loopct:5,' iterations');
			     mswait(1000)
			 end;
		  end; { End of warm start initialization }

	    { Continue Normal initialization }
	    dflush:=0;
	    ilock(search_zone.zone_lock);
	    if cache_pointer<>NIL
	    then if cache_pointer^.zone_lock.exclusive<>0
		 then cache_pointer:=NIL (* if write locked, toss it *)
		 else ilock(cache_pointer^.zone_lock); (* else free it *)
	    walknode(search_zone.zone_node,freezl,-1,1); (* free zone locks *)
	    for i:=1 to max_sb (* unlock and idle all search blocks *)
	    do begin
		    pulock(sb_array[i].slock);
		    rcom[i]:=0
	       end;
	    ilock(master^.update_lock);
	    ilock(master^.alloc_lock);

	    ilock(master^.msg_files[fatl].flock);
	    ilock(master^.msg_files[err].flock);
	    ilock(master^.msg_files[log].flock);

	end;

end; { mapmaster }
procedure forkmaster;

{ FORKMASTER is called when the database is mapped in by a superior
  to a subfork }

var	block:free_block_pointer;

begin
block:=aofpage(db_first_page);
cpyptr(block,master);
end; { forkmaster }
procedure gcmaster;

{ This procedure garbage collects a master file's page map,
  and initializes its locks, etc. }

var     newmap:pagemap;
	i:integer;
	same:boolean;
	oldused,newused:integer;
	myfbp:file_blk_ptr;

	procedure gczone(var myzone:zone_entry);

	{ This procedure adds all of the pages allocated to this zone to the
	  new map being calculated }

	var	  i:integer;

	begin (* gczone *)
	for i:=db_first_page to db_last_page
	do  if myzone.zone_pages[i]
	    then       if newmap[i]
		       then	   { page is used twice }
			   begin
			       myfbp:=ofile(fatl);
			       writeln(myfbp^.fident,'Page ',i:5,' multiple allocation');
			       cfile(myfbp)
			   end
		       else   newmap[i]:=true;
   
	end; (* gczone *)

	procedure gczonelist(mynode:node_pointer);


	{ This procedure marks all of the pages used by zones at the same
	  name }

	var myzone:zone_entry_pointer;

	begin { gczonelist }
	myzone:=mynode^.zone_ptr;
	while myzone<>NIL
	do    begin
		  gczone(myzone^);
		  myzone:=myzone^.zone_chain
	      end
	end; { gczonelist }
	
begin { gcmaster }

ilock(master^.update_lock);
ilock(master^.alloc_lock);

ilock(master^.msg_files[fatl].flock);
ilock(master^.msg_files[err].flock);
ilock(master^.msg_files[log].flock);

for i:=db_first_page to db_last_page (* start out with a blank map *)
do  newmap[i]:=false;

for i:=0 to sizeof(master) div au_per_page
do  newmap[db_first_page+i]:=true; (* mark master block pages *)

gczone(master^.search_zone);
if master^.cache_pointer<>NIL
then	   gczone(master^.cache_pointer^);

walknode(master^.search_zone.zone_node,gczonelist,-1,1);

same:=true; (* get ready for comparison *)
oldused:=0;
newused:=0;

for i:=db_first_page to db_last_page (* compare the old and new maps *)
do  begin
	if master^.used_pages[i]<>newmap[i]
	    then same:=false;
	if master^.used_pages[i]
	    then oldused:=oldused+1;
	if newmap[i]
	    then newused:=newused+1
    end;

myfbp:=ofile(log);
if same
then   writeln(myfbp^.fident,'Database pagemap constant at',oldused:5,
	       ' pages')
else   writeln(myfbp^.fident,'Database pagemap reduced from',oldused:5,
	       ' to new size of ',newused:5);
cfile(myfbp);

master^.used_pages:=newmap;

up_all;

end; { gcmaster }
procedure mapslave;

var  block:free_block_pointer;
     rval:integer;
     myfbp:file_blk_ptr;

begin
jsys(pmap,-2,rval;
     master^.secjfn:0,
     fhslf:backup_first_page,
     [pmcnt+18,pmrd+18,pmwr+18]:db_last_page-db_first_page+1);
if rval=3
then	 begin (* error in PMAP *)
	     myfbp:=ofile(fatl);
	     writeln(myfbp^.fident,'Cannot map backup file');
	     jsys_err(abort,-1,myfbp)
	 end;

block:=aofpage(backup_first_page);
cpyptr(block,slave); (* set up pointer to slave *)
end; { mapslave }

function getslave:master_block_pointer;

begin
getslave:=slave
end;
procedure cpymaster;

(* Cpymaster copies the primary file to the secondary file.

   WARNING: This operation must be protected by the appropriate locking
	    discipline (except as part of process initialization).

	    The caller must guarantee that the primary will never be
            DIRTY during the copy *)

var     i,rval:integer;
	myfbp:file_blk_ptr;
	block:free_block_pointer;
	from_ptr,to_ptr:free_block_pointer; (* copy pointers *)

	procedure usp;

	(* USP makes sure the slave pages are written to disk *)
        begin
	    jsys(ufpgs,-2,rval;
		 master^.secjfn:0,db_last_page-db_first_page+1);
	    if rval<>2
		then begin
			 myfbp:=ofile(fatl);
			 writeln(myfbp^.fident,'Cannot update slave copy');
			 jsys_err(abort,-1,myfbp)
		     end
        end;

	procedure pdbstat(mblock:master_block_pointer;
			 var fn:filename);

	var    i:integer;

	begin
	    write(myfbp^.fident,' last updated ');
	    d_gtad(myfbp^.fident,mblock^.cupdate);
	    write(myfbp^.fident,',dirty=',mblock^.dirty:2);
	    if mblock^.cache_pointer=NIL
	    then write(myfbp^.fident,', no cache')
	    else begin
		     i:=cntpage(mblock^.cache_pointer^.zone_pages);
		     write(myfbp^.fident,', ',i:4,' cache pages')
		 end;
	    write(myfbp^.fident,', file is ');
	    d_file(myfbp^.fident,fn);
	    writeln(myfbp^.fident)
	end;

begin (* cpymaster *)

(* Map the secondary file in *)
if slave=NIL then mapslave;

{ Log status }

myfbp:=ofile(log);
writeln(myfbp^.fident,'Backup begun to slave database');
pheader(log,myfbp);
write(myfbp^.fident,'Master');
pdbstat(master,flipname);
pheader(log,myfbp);
write(myfbp^.fident,'Slave');
pdbstat(slave,flopname);
cfile(myfbp);

{ Now mark slave as dirty }
slave^.dirty:=1;
usp; (* make sure dirty is written to disk *)

(* Copy the database *)
block:=aofpage(db_first_page);
cpyptr(block,from_ptr);
modptr(from_ptr,1); (* dont copy dirty word *)
block:=aofpage(backup_first_page);
cpyptr(block,to_ptr);
modptr(to_ptr,1);
xxblt(from_ptr,to_ptr,au_per_page-1); (* copy rest of first page *)
modptr(from_ptr,au_per_page-1);
modptr(to_ptr,au_per_page-1);

for i:=db_first_page+1 to db_last_page
do begin (* copy other pages only if marked *)
	if master^.used_pages[i]
	then xxblt(from_ptr,to_ptr,au_per_page);
	modptr(from_ptr,au_per_page);
	modptr(to_ptr,au_per_page)
   end;

(* Update file pages *)
usp;

(* Mark the secondary as not-dirty *)
slave^.dirty:=0;

(* Update file pages one more time to finish the process *)
usp;

myfbp:=ofile(log);
writeln(myfbp^.fident,'Backup completed for slave database');
cfile(myfbp)

end; (* cpymaster *)
function pib_init(var mypib:pib;
		      fn:filename):boolean;

{	PIB_INIT initializes a pib for input
}

begin
with mypib
do	begin
	reset(dfile,fn,'/O/E');
	dfilename:=fn;
	line_number:=0;
	pflag:=false;
	pib_init:=erstat(dfile)=0
	end
end. {pib_init}
{$M-,X+}
program msure;

{ Measurement subroutines for JEEVES }

include {NOLIST} 'domain:jsys.def';
include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:eutil.hdr';
include {NOLIST} 'domain:msub.hdr';

var	sticky:integer;

procedure ruse(var data:fruse; (* cumulative data *)
	       var base:fruse);	(* base data for start of this session *)

{ This routine is used to keep cumulative resource information for a fork }

var ac1,ac2,ac3:integer;

begin
jsys(gtrpi;fhslf;ac1,ac2,ac3); (* record pager information *)
data.elpgt:=base.elpgt+ac1; (* page traps *)
data.elpgf:=base.elpgf+ac2; (* page faults *)
data.elpgrt:=base.elpgrt+ac3; (* time spent in pager routines *)

jsys(runtm;fhslf;ac1,ac2,ac3);
data.elrun:=base.elrun+ac1;

data.elwall:=base.elwall+ac3-data.elwb;
end; { ruse }
function hlook(     thost:integer;
		 var  myhgraph:hgraph):hgraph_index;

{ The purpose of this function is to find the hgraph entry for
the specified host, or a open entry, or default to the last
table entry if all else fails }

var done:boolean;
    search:hgraph_index;

begin
search:=1;
done:=false;
if (sticky>0) and (sticky<=hslots)
then if myhgraph[sticky].host=thost
     then begin done:=true; search:=sticky; end;
while not done
do with myhgraph[search]
   do if host=thost
      then done:=true
      else if host=0
	   then begin
		    done:=true;
		    host:=thost;
		    touts:=0;
		    tbacks:=0;
		    ttotal:=0
		end
	   else	begin
		    if search=hslots
		    then begin
			     done:=true;
			     host:=thost
			 end
		    else search:=search+1
		end;
hlook:=search;
sticky:=search;
end; { HLOOK }
procedure hhisto(var myhgraph:hgraph;
		     tvalue:integer;
		     thost:integer);
begin
with myhgraph[hlook(thost,myhgraph)]
do begin
       tbacks:=tbacks+1;
       ttotal:=ttotal+tvalue
   end
end; { HHISTO }
procedure thisto(var mytgraph:tgraph;
		     tvalue:integer);

var	    i:integer;
begin
with mytgraph
do begin
       tbacks:=tbacks+1;
       ttotal:=ttotal+tvalue;
       if tquanta<>0
       then begin
		i:=min(tvalue div tquanta,tslots);
		tdelay[i]:=tdelay[i]+1
	    end;
   end;

end. { THISTO }
{$M-,X+}
program naddr;

include {NOLIST} 'pascal:extern.pas';
include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:msub.hdr';
include {NOLIST} 'domain:hash.hdr';
include {NOLIST} 'domain:alloc.hdr';
include {NOLIST} 'domain:iomsg.hdr';
include {NOLIST} 'domain:tport.hdr';
include {NOLIST} 'domain:irdata.hdr';
include {NOLIST} 'domain:pp.hdr';

var	toss:integer;
function h_label(lptr:g1bpt):integer;

{ The hash of a label is the length of the label shifted left by six plus
  the sum of the first and last characters in the label }

var	length:integer;
	hval:integer;

begin
length:=xildb(lptr);
if length=0
then	h_label:=0
else	begin
	hval:=xildb(lptr);
	if length=1
	then 	hval:=hval+hval
	else	begin
		xadjbp(lptr,length-2);
		hval:=hval+xildb(lptr)
		end;
	h_label:=band(255,hval+bshift(length,6))
	end
end; { h_label }

function h_chunk(var x:chunke_type):integer;

var	i,sum:integer;
	scanptr:g1bpt;

begin
if x.kind=name_chunk
then	h_chunk:=h_label(x.bp)
else	begin
	sum:=0;
	scanptr:=x.bp;
	for i:=1 to min(x.length,3)
	do sum:=sum+bshift(sum,2)+xildb(scanptr);
	h_chunk:=band(255,sum)
	end

end; { h_chunk }
procedure m_dst(name:g1bpt;
		var table:dname_string_table);

{      M_DST makes a dname_string_table for a domain name given
       a byte pointer.  The table is a count of the number of labels and
       byte pointers to each label
}

var     len:integer;

begin
table.count:=0;
repeat  table.count:=table.count+1;
        table.bp[table.count]:=name;
	len:=xildb(name);
	xadjbp(name,len)
until	len=0
end;

procedure cvect(var bits:mod_bits;
		    label_in:g1bpt);

{	CVECT sets a capitalization vector, but leaves the input
	alone }

var     i,count:integer;
	char:octet;
begin
count:=xildb(label_in);
for i:=1 to count
do  begin
	char:=xildb(label_in);
	bits[i]:=(char>=ord('a')) and (char<=ord('z'))
    end
end; { cvect }
procedure walklabel(var myzone:zone_entry;
			procedure callee);

{	WALKULABEL walks the label table of a zone and
	calls its target procedure with an argument of
	a ulabel_pointer
}

var	i,j:integer;
	pscan:^secondary_label_table;
	sscan:ulabel_pointer;

begin
with myzone.ltable
do	begin
	if direct<>NIL	{ do the root entry }
	then	callee(direct);
	for i:=0 to 255
	do	begin
		pscan:=stable[i];	{ scan all of the secondary tables }
		if pscan<>NIL
		then	begin
			if pscan^.direct<>NIL
			then	callee(pscan^.direct);
			for j:=0 to 255
			do	begin
				sscan:=pscan^.lchain[j];
				while sscan<>NIL
				do	begin
					callee(sscan);
					sscan:=sscan^.next
					end
				end
			end
		end
	end
end; { walklabel }
procedure m_ulabel(	var myzone:zone_entry;
			    mylabel:g1bpt;
			var point:ulabel_pointer);

{	M_ULABEL creates a new ulabel, and is used after a 
	failure of f_ulabel
}

var	i,j:integer;
	leroy:ulabel_pointer;
	temp:^secondary_label_table;
	lsize:integer;
begin
lsize:=peekb(mylabel);
a_ulabel(myzone,leroy,max_lab_chars-lsize); { get a new one }
copyls(mylabel,xseto(leroy^.text));
leroy^.nodeptr:=NIL;
leroy^.next:=NIL;
if point<>NIL	{ if POINT is non-NIL, do list insertion }
then	begin
	leroy^.next:=point^.next;
	point^.next:=leroy
	end
else	begin	{ otherwise insert in the primary or secondary table }
	if lsize=0
	then	{ zero length goes into the primary direct entry }
		myzone.ltable.direct:=leroy
	else	begin	{ off secondary table }
		temp:=myzone.ltable.stable[leroy^.text[1]];
		if temp=NIL
		then	{ construct the secondary }
			begin
			a_slt(myzone,temp);
			temp^.direct:=NIL;
			for j:=0 to 255
			do	temp^.lchain[j]:=NIL;
			myzone.ltable.stable[leroy^.text[1]]:=temp
			end;
		if lsize=1
		then	{ direct entry of secondary table }
			temp^.direct:=leroy
		else	begin
			leroy^.next:=temp^.lchain[leroy^.text[2]];
			temp^.lchain[leroy^.text[2]]:=leroy
			end
		end
	end;
point:=leroy
end; { m_ulabel }

function f_ulabel(	var myzone:zone_entry;
			    mylabel:g1bpt;
			var point:ulabel_pointer):boolean;

{	F_ULABEL looks for a unique label in the specified zone.

	If it finds the label, it returns true and sets the
	POINT argument to the ulable's index in the zone's
	label_table.

	If it cannot find the label, it returns false, and sets
	POINT to be either NIL if the label is the first on its
	chain or to point to the existing label it should follow
}

var	lablen,cresult:integer;
	lc1,lc2:octet;
	temp:^secondary_label_table;
	spoint:ulabel_pointer;
	scan:g1bpt;
begin
scan:=mylabel;
lablen:=xildb(scan);
if lablen<>0 then lc1:=xildb(scan);
if lablen>1 then lc2:=xildb(scan);
f_ulabel:=false;

if lablen>1
then	begin	{ normal case, search chain }
	temp:=myzone.ltable.stable[lc1];
	if temp=NIL
	then	point:=NIL
	else	begin	{ search for label down chain }
		point:=NIL;
		spoint:=temp^.lchain[lc2];
		while spoint<>NIL
		do	begin
			cresult:=blcomp(mylabel,spoint^.text);
			if cresult=0
			then	begin
				point:=spoint;
				f_ulabel:=true;
				spoint:=NIL	{ kick out of loop }
				end
			else	if cresult>0
				then	begin   { after this one }
					point:=spoint;
					spoint:=spoint^.next
					end
				else	spoint:=NIL	{ before here }
			end
		end
	end
else	begin
	if lablen=0
	then	{ special case for root }
		point:=myzone.ltable.direct
	else	{ length is one, direct from secondary }
		begin
		temp:=myzone.ltable.stable[lc1];
		if temp=NIL
		then	point:=NIL
		else	point:=temp^.direct
		end;
	f_ulabel:=point<>NIL
	end

end; { f_ulabel }

function g_ulabel(var myzone:zone_entry;
		      mylabel:g1bpt):ulabel_pointer;

{	G_ULABEL returns a ulabel pointer for the label specified
	by mylabel, creating it if necessary

	Note that new ulabel must be caseless
}

var	point:ulabel_pointer;

begin
if not f_ulabel(myzone,mylabel,point)
then m_ulabel(myzone,mylabel,point);

g_ulabel:=point

end; { g_ulabel }

function f_dname(var myzone:zone_entry;
		     myname:g1bpt;
		 var missing:integer;
		 var point:dname_pointer):boolean;

var	found:boolean;
	current_level:integer;
	ltpoint:label_hashtable_pointer;
	spoint,last_match:dname_pointer;
	lcheck:ulabel_pointer;
	org_table,copy_table:dname_string_table;
	caseless:dname_string;
	clessbp:g1bpt;
begin
current_level:=1;
last_match:=NIL;
m_dst(myname,org_table);
clessbp:=xseto(caseless);
ccdns(myname,clessbp);
m_dst(clessbp,copy_table);

repeat	found:=false;
	if f_ulabel(myzone,
		    copy_table.bp[copy_table.count-current_level+1],
		    lcheck)
	then	{ if the label exists, it is worth doing a search }
		begin
		ltpoint:=myzone.dtable[current_level];
		if ltpoint=NIL
		then	spoint:=NIL
		else	spoint:=ltpoint^.dname_hash[bhash(
				copy_table.bp[copy_table.count-current_level+1])];
		while (spoint<>NIL) and not(found)
		do	if spoint^.more<>last_match
			then	spoint:=spoint^.dname_chain
			else	if lcheck=spoint^.dlabel.labptr
				then	if belcomp(org_table.bp[org_table.count-current_level+1],
							spoint)
					then	begin	{ labels are the same }
						found:=true;
						last_match:=spoint
						end
					else	spoint:=spoint^.dname_chain
				else	spoint:=spoint^.dname_chain;
		if spoint<>nil
		then	current_level:=current_level+1
		end
until	not(found) or (current_level>org_table.count);

point:=last_match;
f_dname:=found;
if found
then	missing:=0
else	missing:=org_table.count-current_level+1

end; { f_dname }

function m_dname(var myzone:zone_entry;
		       myname:g1bpt;
		       level:integer;
		       point:dname_pointer):dname_pointer;

{	M_DNAME makes a new dname with LEVEL labels using the
	LEVEL-1 labels pointed to by POINT.
}

var	j:integer;
	child:dname_pointer;
	caseless:dname_string;
	clessbp:g1bpt;
begin
clessbp:=xseto(caseless);
ccls(myname,clessbp);
a_dname(myzone,child);
with child^
do	begin
	dlabel.labptr:=g_ulabel(myzone,clessbp);
	cvect(dlabel.case_mod,myname);
	more:=point;
	j:=bhash(clessbp);
	if myzone.dtable[level]=NIL
	then	a_lht(myzone,myzone.dtable[level]);
	dname_chain:=myzone.dtable[level]^.dname_hash[j];
	myzone.dtable[level]^.dname_hash[j]:=child
	end;

m_dname:=child

end; { m_dname }

function g_dname(var myzone:zone_entry;
		     myname:g1bpt):dname_pointer;

{	GODNAME returns a pointer to the specified domain name,
	creating one if necessary
}

var	i,missing:integer;
	point:dname_pointer;
	table:dname_string_table;

begin
m_dst(myname,table);
if not f_dname(myzone,myname,missing,point)
then	for i:=missing downto 1
	do	point:=m_dname(myzone,
				table.bp[i],
				table.count-i+1,
				point);

g_dname:=point;

end; { g_dname }

function newnode(var myzone:zone_entry):node_pointer;

{	NEWNODE gets a new node from free storage and initializes
	all of its pointers to NIL
}
var	foo:node_pointer;

begin
a_node(myzone,foo);
with foo^
do	begin
	node_lchain:=NIL;
	up_ptr:=NIL;
	side_ptr:=NIL;
	down_ptr:=NIL;
	down_tbl:=NIL;
	rr_ptr:=NIL
	end;

newnode:=foo

end; { newnode }

procedure hashson(var myzone:zone_entry;
		      mynode:node_pointer);

{	HASHSON creates a has table for the specified node	}

var	chain:node_pointer;
	break:node_pointer;
	insert:node_pointer;
	done:boolean;
	index:label_hashrange;
begin
if mynode^.down_tbl=NIL
then	begin
	a_lht(myzone,mynode^.down_tbl);
	for index:=0 to label_hashmod-1
	do	mynode^.down_tbl^.node_hash[index]:=NIL;
	chain:=mynode^.down_ptr;
	mynode^.down_ptr:=NIL;
	while	chain<>NIL
	do	begin
		break:=chain^.side_ptr;
		chain^.side_ptr:=NIL;
		index:=hashls(chain^.node_label.labptr^.text);
		insert:=mynode^.down_tbl^.node_hash[index];
		if insert=NIL
		then	mynode^.down_tbl^.node_hash[index]:=chain
		else	if lcomp(chain^.node_label.labptr^.text,
				insert^.node_label.labptr^.text)
			> 0
			then	begin (* add after the leader *)
				done:=false;
				while not(done)
				do if insert^.side_ptr=NIL
					then	done:=true
					else	if lcomp(chain^.node_label.labptr^.text,
							insert^.side_ptr^.node_label.labptr^.text)
						<0
						then	done:=true
						else	insert:=insert^.side_ptr;
				chain^.side_ptr:=insert^.side_ptr;
				insert^.side_ptr:=chain
				end
			else	begin (* add at the start *)
				chain^.side_ptr:=insert;
				mynode^.down_tbl^.node_hash[index]:=chain
				end;
		chain:=break
		end
	end
end; { hashson }

function m_son(  var myzone:zone_entry;
		     father:node_pointer;	{ new father }
		     leroy:g1bpt;		{ name of child }
		     brother:node_pointer	{ prior brother, if any }
		):node_pointer;

{	M_SON creates a new child node using an insertion pointer
	supplied in brother.  In general, this function will be called
	after a call to F_SON fails, and uses the insertion data supplied
	by a losing findson call.
}
var	child:node_pointer;
	temp:label_hashrange;
	cased_label:dname_string;
	cased_pointer:g1bpt;
begin
child:=newnode(myzone);
cased_pointer:=xseto(cased_label);
ccls(leroy,cased_pointer);
with child^
do	begin
	up_ptr:=father;
	if brother=NIL	{ insert child }
	then	{ first child of this father }
		begin
		if father^.down_tbl=NIL
		then	begin
			side_ptr:=father^.down_ptr;
			father^.down_ptr:=child
			end
		else	begin
			temp:=bhash(cased_pointer);
			side_ptr:=father^.down_tbl^.node_hash[temp];
			father^.down_tbl^.node_hash[temp]:=child
			end
		end
	else	begin	{ just another kid }
		side_ptr:=brother^.side_ptr;
		brother^.side_ptr:=child
		end;
	{ set up the child's node label }
	cvect(node_label.case_mod,leroy);
	node_label.labptr:=g_ulabel(myzone,cased_pointer)
	end;

m_son:=child;

end; { m_son }

function f_son( var mynode:node_pointer;
		    mylabel:g1bpt; (* byte pointer to label *)
		var return_ptr:node_pointer;
		var n_searched:integer):boolean;

{	F_SON looks for the node labeled MYLABEL at the father node
	specified by MYNODE.  If the son is found , the function returns
	true, and returns a pointer to the specified node via return_ptr

	If the function returns false, return_ptr is set to indicate where
	such a son should be inserted.  If at the start of the list,
	NIL is returned, otherwise a pointer to a node to which the new
	son should be appended

	In any case, n_searched is set to be the number of label
	comparisons which were necessary to determine the result.  This
	information is used to guide the use of hashson.}

var	anchor,comp_ptr:node_pointer;
	cresult:integer;
begin
n_searched:=0;	{ have not searched any yet }
anchor:=nil;	{ remember insert value in anchor }
{ can we use fast pointer table ? }
if (mynode^.down_tbl<>NIL) { table exists }
then	comp_ptr:=mynode^.down_tbl^.node_hash[bhash(mylabel)]
else	comp_ptr:=mynode^.down_ptr;

if comp_ptr=NIL
then	{ easy case, nothing to search }
	begin
	return_ptr:=anchor;
	f_son:=false
	end
else	begin
	repeat	cresult:=blcomp(mylabel,comp_ptr^.node_label.labptr^.text);
		n_searched:=n_searched+1;
		if cresult>0
		then	{ move on to next comparison }
			begin
			anchor:=comp_ptr;
			comp_ptr:=anchor^.side_ptr
			end
	until	(cresult<=0) or (comp_ptr=NIL);
	f_son:=cresult=0;
	if cresult=0
	then	return_ptr:=comp_ptr
	else	return_ptr:=anchor
	end;
end; { f_son }

function f_node(var myzone:zone_entry;
		    myplace:g1bpt; (* byte pointer to domain name string *)
		var return_ptr:node_pointer)
		:integer;

{	F_NODE looks for the specified node.  The value of the F_NODE
	function is the number of labels that could not be matched.

	Note that this code assumes canonical case

	return_ptr is set to point to the last node that matched.
}

var	i:integer;
	now_at:node_pointer;
	table:dname_string_table;
	found_son:boolean;

begin
m_dst(myplace,table);
return_ptr:=myzone.zone_node;	{ match root without thought }
i:=table.count-1;

repeat	if i>0
	then begin
		 found_son:=f_son(return_ptr,table.bp[i],now_at,toss);
		 if found_son
		 then	begin
			i:=i-1;
			return_ptr:=now_at
			end
	     end
	
until	(i=0) or not(found_son);

f_node:=i

end; { f_node }

function g_node(var myzone:zone_entry;
		    myplace:g1bpt):node_pointer;

{	GONODE finds the node in the specified zone and returns a pointer
	to it, creating it if it must.

	Note that the input string can have arbitrary capitalization
}

const	search_thresh=50;	{ how bad findson can get before hash table
				  is created }

var	son_ptr,now_at:node_pointer;
	search_count,i:integer;
	copy:dname_string;
	org_table,copy_table:dname_string_table;
	copybp:g1bpt;

begin
now_at:=myzone.zone_node;	{ match root without thought }
m_dst(myplace,org_table);	{ label table with case }
copybp:=xseto(copy);		{ make copy without case for lookups }
ccdns(myplace,copybp);
m_dst(copybp,copy_table);

for i:=copy_table.count-1 downto 1
do	begin
	if f_son(now_at,copy_table.bp[i],son_ptr,search_count)
	then	now_at:=son_ptr
	else	now_at:=m_son(myzone,now_at,org_table.bp[i],son_ptr);

	if (search_count>search_thresh)	{ create hash table if required }
		AND
	   (now_at^.up_ptr^.down_tbl=NIL)
	then	hashson(myzone,now_at^.up_ptr)
	end;

g_node:=now_at

end; { g_node }

procedure walknode(mynode:node_pointer;
		   procedure callee;
		   table_index:integer;
		   sequence:integer);

{	WALKNODE walks the node tree below the specified node,
	calling the specified procedure with an argument of a
	node pointer.

	Tbale index refers to the hash index of this node or -1
	if parent's down pointer isn't hashed.

	Sequence is the position of this label on its hash chain or whatever
}

var	callnode:node_pointer;
	hashed:boolean;
	child_slot,child_sequence:integer;

begin
callee(mynode,table_index,sequence);
hashed:=mynode^.down_tbl<>NIL;
child_slot:=-1;	{ assume not hashed }

repeat	if hashed
	then	begin
		child_slot:=child_slot+1;
		callnode:=mynode^.down_tbl^.node_hash[child_slot];
		end
	else	callnode:=mynode^.down_ptr;
	child_sequence:=1;

	while callnode<>NIL
	do	begin
		walknode(callnode,callee,child_slot,child_sequence);
		callnode:=callnode^.side_ptr;
		child_sequence:=child_sequence+1
		end;

until	(child_slot=(label_hashmax)) or not(hashed)
end; { walknode }
procedure m_rt(    inrr:g1bpt;
		 var table:rdchunk_table);

{ M_RT builds a RDCUNK table for later use in g_rdata }

var	info_table:rdata_table_pointer;
	rdindex:integer;
	inrr_length:integer;
	inrr_type:dtype;

	procedure ofield(x:integer);

	var combine:boolean;

	begin
	if table.count=0
	then	combine:=false
	else	if table.chunke[table.count].kind=name_chunk
		then	combine:=false
		else	combine:=true;

	if combine
	then	with table.chunke[table.count] do length:=length+x
	else	begin
		table.count:=table.count+1;
		with table.chunke[table.count]
		do	begin
			length:=x;
			bp:=inrr;
			kind:=lit_chunk
			end
		end;

	xadjbp(inrr,x);
	inrr_length:=inrr_length-x;

	end; { ofield }

begin
table.count:=0;
rdindex:=1;
info_table:=irdata(f_class(inrr));
inrr_type:=f_type(inrr);
inrr_length:=f_length(inrr);
xadjbp(inrr,10); { skip past header }
with info_table^[inrr_type]
do while rdata_item[rdindex]<>no_more_field
   do begin
      case rdata_item[rdindex] of
	 
         dname_field:begin
      		     table.count:=table.count+1;
		     with table.chunke[table.count]
		     do	begin
		  	bp:=inrr;
			kind:=name_chunk;
			length:=lendns(inrr);
			xadjbp(inrr,length);
			inrr_length:=inrr_length-length
			end
		     end; { dname_field }

	cstring_field:ofield(peekb(inrr)+1);
      

	int16_field:ofield(2);

	time_field,
	int32_field,
	inet_a_field:ofield(4);

	inet_p_field:ofield(1);

	inet_s_field,
	vbinary_field:ofield(inrr_length);

	others:quit
	end; { case }
	rdindex:=rdindex+1
	end

end; { m_rt }
function m_chunk(var	myzone:zone_entry;
		   var	newchunk:chunke_type;
			level:integer;
			splice:rdchunk_pointer)
		:rdchunk_pointer;

var	created:rdchunk_pointer;
	i:integer;
	fromdv,todv:g1bpt;
begin
a_rdchunk(myzone,created);	{ allocate a new chunk }
with created^
do	begin
	more:=splice;	{ splice on tail of other chunks }

	i:=h_chunk(newchunk);
	rdchain:=myzone.rdtable[level,i];	{ add to zone chunk list }
	myzone.rdtable[level,i]:=created;

	ckind:=newchunk.kind;	{ make the chunk }
	case ckind of

	lit_chunk:	begin
			a_litstring(myzone,litdata,
				   max_binary_octets-newchunk.length);
			litdata^.lcount:=newchunk.length;
			fromdv:=newchunk.bp;
			todv:=xseto(litdata^.ldata);
			xadjbp(todv,2);
			ccopy(fromdv,todv,newchunk.length)
			end;	

	name_chunk:	rrname:=g_dname(myzone,newchunk.bp);

	end { case }
	end;

m_chunk:=created

end; { m_chunk }

function f_rdata(var myzone:zone_entry;	{ zone for chunks }
		var table:rdchunk_table;	{ rr with imbedded chunks }
		var missing:integer;	{ number of chunks	  }
		var point:rdchunk_pointer
		):boolean;

{	f_rdata looks for encoded version of the chunk chain specified
	in NEWRR.  It does so by first looking for a chunk that matches
	the last chunk, then a chunk chain that matches the last 2 chunks
	etc.

	f_rdata can obviously find 0 or more of the required chunks.
	If it finds them all it returns true.

	In any case, it returns with missing set to the number of
	chunks which must be added to the chain, and POINT set to the
	chain it did find.  
}

var	current_level:integer;
	spoint:rdchunk_pointer;		{ chunk being examined for match }
	last_match:rdchunk_pointer;	{ match so far }
	found:boolean;
	sdpoint:dname_pointer;
	cp:g1bpt;
begin
if table.count=0
then	begin
	missing:=0;
	point:=NIL;
	f_rdata:=true
	end
else	begin
	current_level:=0;
	last_match:=NIL;
	repeat  current_level:=current_level+1;
	       with table.chunke[table.count-current_level+1]
	       do begin
 		  spoint:=myzone.rdtable[current_level,
			  h_chunk(table.chunke[table.count-current_level+1])];
		  if kind=name_chunk { abort search if dname doesn't exist }
 		  then	if not f_dname(myzone,bp,toss,sdpoint)
			then	spoint:=nil;
 		  found:=false;
		  repeat if spoint<>NIL
			 then	begin
			 	if spoint^.more=last_match { same ancestor }
				then	if kind=spoint^.ckind
					then if kind=name_chunk
					     then found:=sdpoint=spoint^.rrname
					     else begin { lit chunks }
					     	  found:=length=spoint^.litdata^.lcount;
						  cp:=xseto(spoint^.litdata^.ldata);
						  xadjbp(cp,2);
						  if found
						  then found:=ccomp(bp,cp,length)
						  end;
				if found
				then	last_match:=spoint
				else	spoint:=spoint^.rdchain;
					
				end
		   until	(spoint=NIL) or (found=true)
		   end { with }
	until	(found=false) or (current_level=table.count);
	if found
	then	missing:=0
	else	missing:=table.count-current_level+1;
	f_rdata:=found;
	point:=last_match
	end

end; { f_rdata }

function g_rdata(var myzone:zone_entry;	{ zone for chunks }
		     newrr:G1bpt	{ rr with imbedded chunks }
		):rdchunk_pointer;

{	G_RDATA looks for a preexisting set of rdchunks that match
	a set of rdchunks in the new RR, if not found, they are
	created.  Note that this matching must be exact, i.e. case
	sensitive.

}

var	point:rdchunk_pointer;
	table:rdchunk_table;
	missing,i:integer;

begin
m_rt(newrr,table);
if table.count=0
then	g_rdata:=NIL
else	begin
	if not f_rdata(myzone,table,missing,point)
	then	for i:=missing downto 1
		do	point:=m_chunk(myzone,
				 	table.chunke[i],
					table.count-i+1,
					point);
	g_rdata:=point
	end

end; { g_rdata }

procedure zinit(var myzone:zone_entry);

{	ZINIT initializes a zone entry to be empty.  Note that
	the loaded switch may require locking to ensure synchronization
	with other processes
}

var	i,j:integer;
	myclass:dclass;
	mytype:dtype;
	rnode:dname_string;

begin
with myzone
do	begin
	zsoa:=NIL;	{ initialize SOA information }
	zsoa_rr:=NIL;

	loaded:=false;

{	for myclass:=dclass_l_bound to dclass_h_bound
	do	for mytype:=dtype_l_bound to dtype_h_bound
		do	rrtable[mytype,myclass]:=NIL;	  }

	for i:=1 to 255
	do	dtable[i]:=NIL;

	for i:=1 to max_chunk
	do	for j:=0 to 255
		do	rdtable[i,j]:=NIL;

	{ initialize the label table }
	ltable.direct:=NIL;
	for i:=0 to 255
	do	ltable.stable[i]:=NIL;

	{ make a null label }
	zone_node:=newnode(myzone);

	{ make the root node }
	rnode[1]:=0;
	zone_node^.node_label.labptr:=g_ulabel(myzone,xseto(rnode));

	end

end; { zinit }

function m_rr(var myzone:zone_entry;
		  mynode:node_pointer;
		  myrr:g1bpt):rr_pointer;

{	M_RR creates a new RR block at the end of the RRs which
	already exist at a specific node, but does not create the chunk
	chains.
}

var	child:rr_pointer;
	rr_anchor:rr_pointer;

begin
{	create the block	}
a_rr(myzone,child);
with child^
do	begin
	next:=NIL;	{ always insert at end }
{	node:=mynode;	}
	ttl:=f_ttl(myrr);
	rrtype:=f_type(myrr);
	rrclass:=f_class(myrr);
	rdata:=NIL;
{	rrchain:=NIL    }
	end;

if mynode^.rr_ptr=NIL	{ add to node's RR chain }
then	mynode^.rr_ptr:=child
else	begin
	rr_anchor:=mynode^.rr_ptr;
	while rr_anchor^.next<>NIL
	do	rr_anchor:=rr_anchor^.next;
	rr_anchor^.next:=child
	end;

{	add it to the zone list by type and class	
if myzone.rrtable[child^.rrtype,child^.rrclass]=NIL
then	myzone.rrtable[child^.rrtype,child^.rrclass]:=child
else	begin
	rr_anchor:=myzone.rrtable[child^.rrtype,child^.rrclass];
	while rr_anchor^.rrchain<>NIL
	do	rr_anchor:=rr_anchor^.rrchain;
	rr_anchor^.rrchain:=child
	end;	   }

m_rr:=child;

end; { m_rr }
procedure makelt(var myzone:zone_entry);

{	MAKELT makes a label table for the specified zone
}

var	now_at:node_pointer;
	myfbp:file_blk_ptr;

	procedure ltindex(input_node:node_pointer);

	{	LTINDEX adds the specified node to the label table
		specified in the call to makelt.  Note the use of
		circular chains.
	}

	
	begin
	with input_node^.node_label.labptr^
	do	if nodeptr=NIL
		then	begin	{ first addition }
			nodeptr:=input_node;
			input_node^.node_lchain:=input_node
			end
		else	begin	{ add to circular list }
			input_node^.node_lchain:=nodeptr^.node_lchain;
			nodeptr^.node_lchain:=input_node
			end
	end; { ltindex }

	procedure lttry(input_node:node_pointer);

	{	This procedure tests a node to see if it should be added to
		its zone's label table.

		If the zone is the cache zone, then all nodes are so
		added.

		If the zone is an authoritative one, then the test is
		whether the father is authoritative, and no NS records
		are present.  Note that the top node of a zone is indexed
		by force in the main code of makelt
	}

	var	found_ns:boolean;
		scan:rr_pointer;

	begin
	if myzone.zone_is_cache
	then	ltindex(input_node)	{ always index cache nodes }
	else	{ nodes in authoritative zones must have a father }
		if input_node^.up_ptr<>NIL
		then	{ and the father must be authoritative }
			if input_node^.up_ptr^.node_lchain<>NIL
			then	{ and must be free of NS delegations }
				begin	{ look for NS records }
				found_ns:=false;
				scan:=input_node^.rr_ptr;
				while not(found_ns)
					AND
				      (scan<>NIL)
				do	if scan^.rrtype=NS
					then	found_ns:=true
					else	scan:=scan^.next;
				if not(found_ns)
				then	ltindex(input_node)
				end
	end; { lttry }

begin

if myzone.zone_is_cache
then	now_at:=myzone.zone_node
else	begin
	now_at:=myzone.zsoa;
	if now_at<>NIL
	then	ltindex(now_at)
	else	begin
		myfbp:=ofile(fatl);
		writeln(myfbp^.fident, 'ADDRR internal error during makelt');
		cfile(myfbp);
		end
	end;

if now_at<>NIL
then	walknode(now_at,lttry,-1,1)
end; { makelt }
function rrbin(myrr:rr_pointer;
		 first:integer;
		 last:integer):integer;

{	RRBIN returns an right shifted integer equal to the concatenation
	of the FIRST through last bytes of binary data in a RR
}

var	sum,index,length:integer;
	scan:rdchunk_pointer;
	myfbp:file_blk_ptr;

begin
sum:=0;
scan:=myrr^.rdata;

repeat	if scan=NIL
	then	begin
		    myfbp:=ofile(fatl);
		    writeln(myfbp^.fident, 'ADDRR internal error');
		    cfile(myfbp);
		end
	else	if scan^.ckind=name_chunk
		then	scan:=scan^.more
		else	begin
			length:=scan^.litdata^.lcount;
			if first<=length
			then	for index:=first to min(last,length)
				do	sum:=bshift(sum,8)+scan^.litdata^.ldata[index];
			first:=first-length;
			last:=last-length
			end
until	first<=0;

rrbin:=sum;

end; { rrbin }
procedure soa_setup(var myzone:zone_entry);

{	SOA_setup copies data from the zone SOA RR to the zone entry
	and checks to see that all authoritative TTLs are
	at least equal to the zone minimum
}

var	mynode:node_pointer;
	scanrr,myrr:rr_pointer;
	myfbp:file_blk_ptr;

	procedure ttl_check(mynode:node_pointer);

	var	scanrr:rr_pointer;

	begin
	if mynode^.node_lchain<>NIL
	then	begin
		scanrr:=mynode^.rr_ptr;
		while scanrr<>NIL
		do	begin
			if scanrr^.ttl<myzone.zone_config.zone_minimum
			then	scanrr^.ttl:=myzone.zone_config.zone_minimum;
			scanrr:=scanrr^.next
			end
		end
	end; { ttl check }

begin
if myzone.zsoa=NIL
then	begin
	myfbp:=ofile(fatl);
	writeln(myfbp^.fident, 'No SOA for SOA setup');
	cfile(myfbp);
	end
else	begin
	scanrr:=myzone.zsoa^.rr_ptr;	{ set myrr to point to the SOA RR }
	myrr:=NIL;
	while myrr=NIL
	do	if scanrr=NIL
		then begin	
			 myfbp:=ofile(fatl);
			 writeln(myfbp^.fident, 'ADDRR internal error');
			 cfile(myfbp);
		     end
		else	if scanrr^.rrtype=SOA
			then	myrr:=scanrr
			else	scanrr:=scanrr^.next
	end;

{ setup fields in the zone entry }
with myzone
do	begin
	zsoa_rr:=myrr;
	with zone_config
	do	begin
		zone_serial:=rrbin(myrr,1,4);
		zone_refresh:=rrbin(myrr,5,8);
		zone_retry:=rrbin(myrr,9,12);
		zone_expire:=rrbin(myrr,13,16);
		zone_minimum:=rrbin(myrr,17,20)
		end
	end;

walknode(mynode,ttl_check,-1,1);

end; { soa_setup }
procedure con_rr(var myzone:zone_entry;
		     mynode:node_pointer;
		     myrr:G1bpt);

{	Con_rr concatenates the specified RR to the specified node	}

var	mychunk:rdchunk_pointer;
	child:rr_pointer;
	scan:rr_pointer;
	found:boolean;

begin
mychunk:=g_rdata(myzone,myrr); (* get data pointer *)

scan:=mynode^.rr_ptr; (* check for duplicate or refresh of old RR *)
found:=false;
while (scan<>NIL) and not found
do if scan^.rdata=mychunk
   then if (scan^.rrtype=f_type(myrr)) and (scan^.rrclass=f_class(myrr))
        then { RR already exists, consider updating TTL }
	     begin
		 found:=true;
		 if scan^.ttl>0
		 then { authoritative record, ignore for now }
		 else if f_ttl(myrr)<scan^.ttl
		      then scan^.ttl:=f_ttl(myrr) (* use longer lasting *)
		      else		       
	     end
	else scan:=scan^.next
   else scan:=scan^.next;

if not found (* if not found, create it *)
then   begin
	   child:=m_rr(myzone,mynode,myrr);	{ create new rr block on end }
	   child^.rdata:=mychunk
       end

end; { con_rr }

procedure add_rr(var myzone:zone_entry;
 		     myplace:g1bpt;
		 var mynode:node_pointer;	{ set on return }
		     myrr:G1bpt);

{	ADD_RR adds the specified RR to the specified zone,
	creating the node if necessary, 
}

begin
mynode:=g_node(myzone,myplace);	{ find the node to begin work at }
con_rr(myzone,mynode,myrr)

end; { add_rr }
procedure del_rr(var myzone:zone_entry;	(* zone to change *)
		     myplace:g1bpt; (* node in zone *)
		     myqtype:qtype; (* qtype of RRs to zap *)
		     myqclass:qclass); (* qclass of RRs to zap *)

{	DEL_RR sets the timeout of the matching RRs to -1, which times
	them out.  This is used to flush RRs from the cache in the
	case of an authoritative response.
}
var mynode:node_pointer;
    myrr:rr_pointer;
begin
mynode:=g_node(myzone,myplace);	(* find node to begin work *)
myrr:=mynode^.rr_ptr;
while myrr<>NIL
do begin
       if ((ord(myrr^.rrclass)=myqclass) or (myqclass=star))
	   and
	  tmatch(myrr^.rrclass,myqtype,myrr^.rrtype)
       then myrr^.ttl:=-1;
       myrr:=myrr^.next
   end
end. { del_rr }
{$X+}

program nufork;

include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:lparse.def';
include {NOLIST} 'domain:irdata.hdr';
include {NOLIST} 'domain:mdep.hdr';
include {NOLIST} 'domain:pp.hdr';

procedure serve;extern;

begin

{ low-level initialization }
irinit;
pp_init;

{ initialize database }
forkmaster;

serve
end.{$X+}

program numain;

include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:lparse.def';
include {NOLIST} 'domain:irdata.hdr';
include {NOLIST} 'domain:mdep.hdr';
include {NOLIST} 'domain:pp.hdr';

procedure serve;extern;

begin

{ low-level initialization }
irinit;
pp_init;

{ initialize database }
mapmaster(true,false,true,false);
gcmaster;
logmaster;

serve
end.{$M-,X+}
program pp;

include {NOLIST} 'pascal:extern.pas';
include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:pp.def';
include {NOLIST} 'domain:msub.hdr';
include {NOLIST} 'domain:eutil.hdr';
include {NOLIST} 'domain:iomsg.hdr';

{	**********************************************************

	This file contains procedures for converting between
	character strings and encoded representations for domain
	types, classes, times etc.

	All of these procedures use PASCAL type atom for their
	character strings; all procedures to convert from character
	strings are functions that return true if the conversion
	was without error

	********************************************************** }

			      
var	port_tbl,              {assigned port keywords/decimals}
	ptcl_tbl,	       {assigned protocol keywords/decimals}
        general:pptbl_ptr;     {dtype, qtype, dclass, qclass, rcodes}

function cvint( var inarg:atom;
		var outarg:integer ):boolean;

var	i,sum:integer;

begin
i:=1;
sum:=0;
while (i<=max_atom_chars) and (inarg[i] in ['0'..'9'])
do	begin
	sum:=sum*10+ord(inarg[i])-ord('0');
	i:=i+1
	end;
if (i=16) or (inarg[i]=' ')
then	begin
	cvint:=true;
	outarg:=sum
	end
else	cvint:=false

end; { cvint }


procedure ppint(     number:integer;
		 var myatom:atom );

var	i:integer;

	procedure outdig(x:integer);
	    var j:integer;
	begin
	if (x div 10)>0
	then	outdig(x div 10);
	if i>max_atom_chars
	then for j:=1 to max_atom_chars
	     do myatom[j]:='*'
	else myatom[i]:=chr(ord('0')+x mod 10);
	i:=i+1
	end; { outdig }

begin	
for i:=1 to max_atom_chars
do 	myatom[i]:=' ';

if number<0
then begin
	 myatom[i]:='-';
	 number:=-number;
	 i:=2
	 end
else i:=1;
outdig(number)

end; { ppint }


function cvtime( var inarg:atom;
		 var outarg:itime):boolean;

begin
cvtime:=cvint(inarg,outarg)
end; { cvtime }
procedure cvnnp(    dnp:node_pointer;
		  var bp:g1bpt);

{	CVDNP converts a node pointer to a string

	it increments the byte pointer as it goes }

var	ll,i,byte:integer;

begin { cvnnp }
while dnp<>NIL
do	begin
	    with dnp^.node_label
	    do	begin
		    ll:=labptr^.text[0];
		    xidpb(bp,ll);
		    for i:=1 to ll
		    do begin
		       byte:=labptr^.text[i];
		       if case_mod[i]
		       then byte:=byte+40b;
		       xidpb(bp,byte)
		       end
		end;
	    dnp:=dnp^.up_ptr
	end
end; { cvnnp }
procedure cvdnp(    dnp:dname_pointer;
		  var bp:g1bpt);

{	CVDNP converts a dname pointer to a string

	it increments the byte pointer as it goes }

var	i,ll,byte:integer;

begin { cvdnp }
while dnp<>NIL
do	begin
	    with dnp^.dlabel
	    do	begin
		    ll:=labptr^.text[0];
		    xidpb(bp,ll);
		    for i:=1 to ll
		    do begin
		       byte:=labptr^.text[i];
		       if case_mod[i]
		       then byte:=byte+40b;
		       xidpb(bp,byte)
		       end
		end;
	    dnp:=dnp^.more
	end
end; { cvdnp }
procedure ccvdnp(    dnp:dname_pointer;
		  var bp:g1bpt);

{	CCVDNP converts a dname pointer to a string
	without case i.e. upper case

	it increments the byte pointer as it goes }

var	i:integer;

begin { ccvdnp }
while dnp<>NIL
do	begin
	    with dnp^.dlabel.labptr^
	    do	for i:=0 to text[0]
		do xidpb(bp,text[i]);
 	    dnp:=dnp^.more
	end
end; { ccvdnp }
function cvdname( var iname:big_atom; 
		  var dn:exp_dname ):boolean;

type	string40=packed array[1..40] of char;

var	i:integer;
	index:integer;
	ok:boolean;
	origin:exp_dname;

	procedure error(x:string40);

	begin
	ok:=false
	end;

	function ismore:boolean;

	begin
	ismore:=index<=max_big_atom_chars
	end;

	function issep:boolean;

	begin
	issep:=(iname[index]=' ') or (iname[index]=chr(tab))
	end;

	function isdot:boolean;

	begin
	isdot:=iname[index]='.'
	end;

	function getch:integer;

	begin
	getch:=ord(iname[index]);
	index:=index+1
	end;

	procedure toss_blanks;

	var	toss:integer;

	begin
	while issep
	do	toss:=getch
	end;

begin
index:=1;
ok:=not issep;
origin.count:=1;
origin.dlabels[1].labinfo[0]:=0;

{ ***** reprinted from fload.pas ***** }
dn.count:=0;
toss_blanks;

if ismore and ok
then	begin
	while not(issep) and ismore
	do	begin
		dn.count:=dn.count+1;
		with dn.dlabels[dn.count]
		do	begin
			labinfo[0]:=0;	{ initialize label }
			while ismore and ok and not(issep) and not(isdot)
			do	if labinfo[0]<63
				then	begin
					labinfo[0]:=labinfo[0]+1;
					labinfo[labinfo[0]]:=getch;
					end
				else	error('Label length                            ');
			end;
		dlcase(dn.dlabels[dn.count]);	{ set up modifier bits }
		if issep or not(ismore)
		then	{ add origin to domain name }
			if origin.count=0
			then	error(' zero origin added to relative label    ')
			else	for i:=1 to origin.count
				do	begin
					dn.count:=dn.count+1;
					dn.dlabels[dn.count]:=origin.dlabels[i]
					end
		else	if isdot
			then	begin
				index:=index+1;	{ old csaved:=false }
				if not(ismore) or issep	{ add implied root }
				then	if (dn.count<>1)
						or
					   (dn.dlabels[1].labinfo[0]<>0)
					then	begin
						dn.count:=dn.count+1;
						dn.dlabels[dn.count].labinfo[0]:=0
						end
				end
			else	error('Label termination error                 ')
		end
	end
else	error(' error                                  ');

cvdname:=ok;

end; {cvdname}

procedure ppina(     inarg:integer;
		 var outarg:atom);

{	PPINA pretty prints an internet address
}

var	i:integer;
	outptr:integer;
	temp:integer;

	procedure outnum(x:integer);

	var	digit:integer;

	begin
	if x<>0
	then	begin
		digit:=x mod 10;
		outnum(x div 10);
		outarg[outptr]:=chr(digit+ord('0'));
		outptr:=outptr+1
		end
	end; { outnum }

begin
outptr:=1;
for i:=3 downto 0
do	begin
	temp:=band(bshift(inarg,-(i*8)),377b);
	if temp=0
	then	begin
		outarg[outptr]:='0';
		outptr:=outptr+1
		end
	else	outnum(temp);
	if i<>0
	then	begin
		outarg[outptr]:='.';
		outptr:=outptr+1
		end
	end;

if outptr<=max_atom_chars
then	for i:=outptr to max_atom_chars
	do	outarg[i]:=' '

end; { ppina }

function cvina( var inarg:atom;
		var outarg:integer):boolean;

var	inptr:integer;
	ok:boolean;
	oct:array[1..4] of integer;

	procedure getdot;

	begin
	if inptr>max_atom_chars
	then	ok:=false
	else	if inarg[inptr]='.'
		then	inptr:=inptr+1
		else	ok:=false
	end; { getdot }

	procedure getoct(which_oct:integer);

	var	sum:integer;
		more:boolean;
	begin
	if inptr>max_atom_chars
	then	ok:=false
	else	if inarg[inptr] in ['0'..'9']
		then	begin
			sum:=0;
			{accumulate number }
			repeat	more:=inptr<=max_atom_chars;
				if more
				then	more:=inarg[inptr] in ['0'..'9'];
				if more
				then	begin
					sum:=sum*10
						+ord(inarg[inptr])-ord('0');
					inptr:=inptr+1
					end
			until	not more;
			if (sum>=0) and (sum<=255)
			then	oct[which_oct]:=sum
			else	oct[which_oct]:=0
			end;
	end; { getoct }

begin
inptr:=1;	{ scan from beginning }
ok:=true;	{ presume it works }
getoct(1);
getdot;
getoct(2);
getdot;
getoct(3);
getdot;
getoct(4);
if ok
then	if inptr<=max_atom_chars
	then	ok:=inarg[inptr]=' ';
if	ok
then	outarg:=bshift(oct[1],24)+
		bshift(oct[2],16)+
		bshift(oct[3],8)+
		oct[4];
cvina:=ok

end; { cvina }

{ TABLE ACCESS ROUTINES }


function mtch_atom( inarg:atom;
		    attr:pp_types ):pp_ptr;

{ Match inarg/attr to a key/attribute entry.  Determine
  the table in which to search by the value of attr.
  Return a pointer to the table entry, or NIL if not found. }
  
var	index:integer;
	found, done:boolean;
	myatom:atom;
	ptr:pp_ptr;
	keytbl:pptbl_ptr;
	
begin  {mtch_atom}
    found:=false;

    {determine table to use}
    case attr of
	port: keytbl:=port_tbl;
	ptcl: keytbl:=ptcl_tbl;
	others: keytbl:=general;
    end;

    caseatom(inarg, myatom);  {to upper case}
    index:= ord(myatom[1]) - ord('A');
    if (index<0) or (index>25)
    then ptr:=keytbl^.table[26]  {first char not a letter}
    else ptr:=keytbl^.table[index];

    done:=(ptr=NIL);
    while not done do
    begin
	if (myatom=ptr^.key) and
	    (attr=ptr^.attribute)
	then begin
		 found:=true;
		 done:=true;
	     end
	else if ptr^.key>myatom  
	     then done:=true  {stop if successor reached}
	     else ptr:=ptr^.key_next;
        done:=done or (ptr=NIL);
    end;
 
    if found
    then mtch_atom:=ptr	
    else mtch_atom:=NIL;
end;  {mtch_atom}


function mtch_int( inarg:integer;
		   attr:pp_types ):pp_ptr;


{ Match the integer/attr given to a num/attribute.
  Determine the table in which to search by the
  type of the attribute.  Return a pointer to
  the pp_rec containing the match, or NIL if not
  found. }

var	done, found:boolean;
	ptr:pp_ptr;
	keytbl:pptbl_ptr;

begin {mtch_int}
    {determine table to use}
    case attr of
	port: keytbl:=port_tbl;
	ptcl: keytbl:=ptcl_tbl;
	others: keytbl:=general;
    end;
	
    ptr:=keytbl^.num_head;
    done:=(ptr=NIL);
    found:=false;

    while not done do
    begin	
	if attr<>ptr^.attribute  {attribute doesn't match}
	then ptr:=ptr^.num_next
	else  {now check for integer match}
	    if inarg=ptr^.num
	    then found:=true    
	    else if ptr^.num>inarg  {passed possible match already}
		 then done:=true
		 else ptr:=ptr^.num_next;
	done:=done or found or (ptr=NIL);
    end; 

    if found
    then mtch_int:=ptr
    else mtch_int:=NIL;
end;  {mtch_int}
function v_type(raw_value:integer;
		   var out_value:dtype):boolean;
begin
if (raw_value>ord(dtype_l_bound)) and (raw_value<ord(dtype_h_bound))
then begin
	 out_value:=chrtype(raw_value);
	 v_type:=true
     end
else v_type:=false
end; { v_type }

function tmatch(	mydclass:dclass;
			myqtype:qtype;
			mydtype:dtype):boolean;

{	TMATCH decides whether the type is responsive to the particular
	qtype
}
begin
if ord(mydtype)=myqtype
then	tmatch:=true
else	case myqtype of

	star:	tmatch:=true;

	maila:	tmatch:=mydtype in [md,mf];

	mailb:	tmatch:=mydtype in [mb,mg,mr];

	others:	tmatch:=false

	end { case }

end; { tmatch }
function cvtype( var inarg:atom;
		 var outarg:dtype ):boolean;

var	ptr:pp_ptr;  

begin  {cvtype}
    outarg:=dtype_h_bound;  {default return}
    ptr:=mtch_atom(inarg, dty);
    if ptr<>NIL
    then outarg:=ptr^.pp_dty;
    cvtype:=(outarg>dtype_l_bound) and (outarg<dtype_h_bound);
end; {cvtype}


procedure pptype(     inarg:dtype;
		  var outarg:atom );

var	ptr:pp_ptr;  

begin  {pptype}
    if (inarg<=dtype_l_bound) or
	(inarg>=dtype_h_bound)
    then outarg:=illegal
    else begin    
	     ptr:=mtch_int(ord(inarg), dty);
	     if ptr<>NIL
	     then outarg:=ptr^.key;
	 end;
end;  {pptype}

function cvqtype( var inarg:atom;
		  var outarg:qtype ):boolean;

var	ptr:pp_ptr;  

begin  {cvqtype}
    outarg:=0;  {default return}
    ptr:=mtch_atom(inarg, qty);
    if ptr<>NIL
    then outarg:=ptr^.pp_qty
    else begin
	     ptr:=mtch_atom(inarg, dty);
	     if ptr<>NIL
	     then outarg:=ord(ptr^.pp_dty);	 
	 end;
    cvqtype:=(outarg<>0);
end; {cvqtype}


procedure ppqtype(     inarg:qtype;
		   var outarg:atom );

var	ptr:pp_ptr;  

begin  {ppqtype}
    outarg:=illegal;  {default return}
    if (inarg <= ord(dtype_l_bound)) or
	(inarg>star) or
	( (inarg >= ord(dtype_h_bound)) and
	  (inarg<axfr) ) 
    then outarg:=illegal
    else begin	
	     if inarg>=axfr
	     then ptr:=mtch_int(inarg, qty)
	     else ptr:=mtch_int(inarg, dty);
	     if ptr<>NIL
	     then outarg:=ptr^.key;
	 end;
end; { ppqtype }
function v_class(raw_value:integer;
		   var out_value:dclass):boolean;
begin
if (raw_value>ord(dclass_l_bound)) and (raw_value<ord(dclass_h_bound))
then begin
	 out_value:=chrclass(raw_value);
	 v_class:=true
     end
else v_class:=false
end; { v_class }

function cvclass( var inarg:atom;
		  var outarg:dclass ):boolean;

var	ptr:pp_ptr;  

begin  {cvclass}
    outarg:=dclass_h_bound;  {default return}
    ptr:=mtch_atom(inarg, dcl);
    if ptr<>NIL
    then outarg:=ptr^.pp_dcl;	
    cvclass:=(outarg>dclass_l_bound) and (outarg<dclass_h_bound)
end;  {cvclass}


procedure ppclass(     inarg:dclass;
		   var outarg:atom );

var	ptr:pp_ptr;  

begin  {ppclass}
    if (inarg<=dclass_l_bound) or
	(inarg>=dclass_h_bound)
    then outarg:=illegal
    else begin	
	     ptr:=mtch_int(ord(inarg), dcl);
	     if ptr<>NIL
	     then outarg:=ptr^.key;
	 end;
end; {ppclass}

function cvqclass( var inarg:atom;
		   var outarg:qclass ):boolean;

var	ptr:pp_ptr;  

begin
    outarg:=0;  {default return}
    ptr:=mtch_atom(inarg, qcl);
    if ptr<>NIL
    then outarg:=ptr^.pp_qcl	
    else begin
	     ptr:=mtch_atom(inarg, dcl);
	     if ptr<>NIL
	     then outarg:=ord(ptr^.pp_dcl);
	 end;
    cvqclass:=(outarg<>0);
end; {cvqclass}


procedure ppqclass(     inarg:qclass;
		    var outarg:atom );

var	ptr:pp_ptr;  

begin
    if (inarg <= ord(dclass_l_bound)) or
	(inarg>star) or
	( (inarg >= ord(dclass_h_bound)) and
	  (inarg<star) )
    then outarg:=illegal
    else begin	
	     if inarg < ord(dclass_h_bound)
	     then ptr:=mtch_int(inarg, dcl)
	     else ptr:=mtch_int(inarg, qcl);
	     if ptr<>NIL
	     then outarg:=ptr^.key;
	 end;
end;  {ppqclass}
procedure pprcode(     inarg:integer;
		   var outarg:atom );

var	ptr:pp_ptr;  

begin  {pprcode}
    outarg:='bad rcode      ';  {default return}
    ptr:=mtch_int(inarg, rc);
    if ptr<>NIL
    then outarg:=ptr^.key;	
end;  {pprcode}

procedure ppopcode(    opcode:integer;
		   var outarg:atom);
begin
case opcode of
std_query:  outarg:='standard query ';
inv_query:  outarg:='inverse query  ';
cm_query:   outarg:='multi complete ';
cu_query:   outarg:='unique complete';

others:	    outarg:='Illegal opcode ';
end {case}
end; { ppopcode }

procedure ppsect(    sect:sectcode;
		 var outarg:atom);

begin
case sect of
question:   outarg:='question       ';
answer:	    outarg:='answer         ';
authority:  outarg:='authority      ';
additional: outarg:='additional     ';
others:	    outarg:='Unknown section'
end { case }
end; { ppsect }
function cvptcl( var inarg:atom;
		 var outarg:integer ):boolean;

var	ptr:pp_ptr;  

begin  {cvptcl}
    outarg:=-1;  {default return}
    ptr:=mtch_atom(inarg, ptcl);
    if ptr<>NIL
    then outarg:=ptr^.num;
    cvptcl:=(outarg<>-1);
end; {cvptcl}


procedure ppptcl(     inarg:integer;
	          var outarg:atom );

var	ptr:pp_ptr;  

begin
    if (inarg<0) or (inarg>255)
    then outarg:=illegal
    else begin	
	     ptr:=mtch_int(inarg, ptcl);
	     if ptr<>NIL
	     then outarg:=ptr^.key
	     else outarg:='UNDEFINED      ';	 
	 end;
end;  {ppptcl}

function cvport(     inarg:atom;
		     protocol:integer;  {for later use}
		 var outarg:integer ):boolean;

{ Find the corresponding decimal for the given port keyword. 
  If duplicates exist, return the lowest matching value. }

var	ptr:pp_ptr;

begin
    outarg:=-1;  {default return}
    ptr:=mtch_atom(inarg, port);  {match the string}
    if ptr<>NIL
    then begin
	     outarg:=ptr^.num;
	     cvport:=true;
	 end
    else cvport:=false;
	 
end; {cvport}


procedure ppport(     inarg:integer;
		      protocol:integer;  {for later use}
	          var outarg:atom );

var	ptr:pp_ptr;

begin  {ppport}
    if (inarg<0) or (inarg>255)
    then outarg:=illegal
    else begin	
	     ptr:=mtch_int(inarg, port);
	     if ptr<>NIL
	     then outarg:=ptr^.key
	     else outarg:='UNDEFINED      ';	 
	 end;

end;  {ppport}
	

{ FILE INPUT UTILITY ROUTINES }

procedure skip_whsp( var infile:charfile );

{ Skip white space which is identified as a
  blank, tab, or newline. }

begin  {skip_whsp}
    while ( not eof(infile) and
	    ( (infile^ = ' ') or 
	      (infile^ = '	') or
	      eoln(infile) ) ) do
	get(infile);
end;  {skip_whsp}


function pp_read( var infile:charfile;
		  var decimal:integer;
		  var buf:atom;
		  var attr:pp_types ):boolean;

{ From the file specified, retrieve a decimal number/keyword 
  pair.  Return false if a complete pair is not obtained.
  Comments are initiated by ';' and terminated by eoln.
  Lines beginning with '*' designate a change in attribute. }

var	ok, done:boolean;
	howmany:integer;

begin  {pp_read}
    decimal:=-1;
    buf[1]:=' ';

    howmany:=0;
    ok:=true;
    done:=false;

    { Ignore lead comment lines while noting attribute
      change lines. }
    while not eof(infile) and
	 ( (infile^ = ';') or
	  (infile^ = '*') ) do
    begin      
	if infile^='*'
	then attr:=succ(attr);    
	readln(infile);
    end;
	  
    { Get decimal number }
    if not eof(infile)
    then begin
	     skip_whsp(infile);
	     if not eof(infile)
	     then begin
		      read( infile, buf:howmany:[' ', '	', ';'] );
		      if infile^ = ';'  {comment precludes set completion}
		      then ok:=false	
		      else {convert string to decimal}
			  ok:=cvint(buf, decimal);
		  end;
	 end;
    
    if ok and not eof(infile)
    then begin  {get keyword}
	     skip_whsp(infile);
	     if not eof(infile)
	     then begin
		      read( infile, buf:howmany:['	', ';'] );
		      readln(infile);
		  end
	     else ok:=false;
	 end;
    pp_read:=ok and (decimal>=0) and (buf[1]<>' ');
end;  {pp_read}


function to_dtype(     inarg:integer;
		   var outarg:dtype ):boolean;

{ Convert the given integer to a valid dtype type.
  Return false if a defined value is not found. }

begin  {to_dtype}
    outarg:=dtype_l_bound;
    while (ord(outarg)<>inarg) and
	  (outarg<dtype_h_bound) do
	      outarg:=succ(outarg);
    to_dtype:=(outarg>dtype_l_bound) and (outarg<dtype_h_bound);
end;  {to_dtype}


function to_dclass(     inarg:integer;
		    var	outarg:dclass ):boolean;

{ Convert the given integer to a valid dclass type.
  Return false if a defined value is not found. }

begin  {to_dclass}
    outarg:=dclass_l_bound;
    while (ord(outarg)<>inarg) and
	  (outarg<dclass_h_bound) do
	      outarg:=succ(outarg);
    to_dclass:=(outarg>dclass_l_bound) and (outarg<dclass_h_bound);
end;  {to_dclass}


procedure pp_insert( decimal:integer;
		     string:atom;
		     attr:pp_types );

{ intbl in indexed by the ordinal value of A-Z. 
  Exceptions are place at the bottom, index=26.
  Insert a pp_rec based on the first character
  of the string.  If collision at the hash bucket,
  place in alphabetic order.  Link this entry into
  the num_head chain.  Duplicates are not supressed.
  If a problem exists with one of the entry values,
  don't insert the pp_rec. }

var	index:integer;
	ok, done:boolean;
	mydtype:dtype;
	mydclass:dclass;
	ptr, scratch:pp_ptr;
	tblptr:pptbl_ptr;

begin  {pp_insert}
    
    ok:=true;
    index:=ord(string[1]) - ord('A');    {where does the new entry belong?}
    if (index<0) or (index>25)
    then index:=26;

    { Create a new entry }
    new(ptr);
    ptr^.key:=string;
    ptr^.key_next:=NIL;
    ptr^.num:=decimal;
    ptr^.num_next:=NIL;
    ptr^.attribute:=attr;
    case attr of
	dty:  begin
		  ok:=to_dtype(decimal, mydtype);
		  if ok
		  then ptr^.pp_dty:=mydtype;    
	      end;
	
	qty:  if (decimal>=0) and (decimal<=177777b)
	      then ptr^.pp_qty:=decimal
	      else ok:=false;	 

	dcl:  begin
		  ok:=to_dclass(decimal, mydclass);
		  if ok
		  then ptr^.pp_dcl:=mydclass;
	      end;

	qcl:  if (decimal>=0) and (decimal<=177777b)
	      then ptr^.pp_qcl:=decimal
	      else ok:=false;	 
    end;

    if not ok
    then dispose(ptr)
    else begin	
	     { Choose a table to put it in }
	     case attr of
		 port:  tblptr:=port_tbl;
		 ptcl:  tblptr:=ptcl_tbl;
		 others: tblptr:=general;
	     end;

	     { Put it in the table }
	     if tblptr^.table[index] = NIL
	     then  {table empty at this index}
		 tblptr^.table[index]:=ptr	
	     else begin   {alphabetical order}
		      scratch:=tblptr^.table[index];
		      if scratch^.key>string
		      then begin  {place new entry at front of table}
			       ptr^.key_next:=scratch;
			       tblptr^.table[index]:=ptr;	 
			   end
		      else begin 
			       done:=false;
			       while not done and 
				     (scratch^.key_next<>NIL) do
			       begin	  
				   if scratch^.key_next^.key>string
				   then begin
					    ptr^.key_next:=scratch^.key_next;
					    done:=true;
					end
				   else scratch:=scratch^.key_next;
			       end;
			       scratch^.key_next:=ptr;
			   end;
		  end;
	     
	     { Link into decimal representation chain }
	     if tblptr^.num_head=NIL
	     then  {first addition}
		 tblptr^.num_head:=ptr
	     else begin
		      scratch:=tblptr^.num_head;
		      if scratch^.num>decimal
		      then begin   {new one should be first in list}
			       ptr^.num_next:=scratch;
			       tblptr^.num_head:=ptr;
			   end
		      else begin  {find where it goes}
			       done:=false;
			       while not done and
				     (scratch^.num_next<>NIL) do
			       begin	    
				   if scratch^.num_next^.num>decimal
				   then begin 	  
					    ptr^.num_next:=scratch^.num_next;
					    done:=true;
					end
				   else scratch:=scratch^.num_next;
			       end;
			       scratch^.num_next:=ptr;
			   end;
		      end;
	 end;
end;  {pp_insert}


procedure pp_init;

{ Read all decimal/string pairs from pplegals.txt
  and store in the approproate tables. }

var	decimal:integer;
	string:atom;
	attr:pp_types;
	pfile:charfile;
	myfbp:file_blk_ptr;

begin  {pp_init}
    reset(pfile,ppfile1, '/U/O/E');  
    if erstat(pfile) <> 0
    then begin
	     clreof(pfile);
	     reset(pfile,ppfile2, '/U/O/E');  
	     if erstat(pfile) <> 0
	     then begin
		      myfbp:=ofile(fatl);
		      writeln(myfbp^.fident, 'Couldn''t open pplegals.txt');
		      jsys_err(abort, -1, myfbp);  {print error msg and quit}
		  end;
	 end;
	     
    { Allocate tables }
    new(port_tbl);
    new(ptcl_tbl);
    new(general);
    attr:=dty;  {use knowlwdge of file layout to initialize}

    while not eof(pfile) do
    begin	
	if ( pp_read(pfile, decimal, string, attr) )
	then pp_insert(decimal, string, attr);
    end;
end.  {pp_init}
{$X+}
program query;

include {NOLIST}'domain:jsys.def';
include {NOLIST}'pascal:pascmd.pas';
include {NOLIST}'domain:mdep.def';
include {NOLIST}'domain:master.def';
include {NOLIST}'domain:lparse.def';
include {NOLIST}'domain:udp.def';
include {NOLIST}'domain:udp.hdr';
include {NOLIST}'domain:msub.hdr';
include {NOLIST}'domain:dsconv.hdr';
include {NOLIST}'domain:tface.hdr';
include {NOLIST}'domain:iopkt.hdr';
include {NOLIST}'domain:pp.hdr';
include {NOLIST}'domain:iomsg.hdr';
include {NOLIST}'domain:mdep.hdr';

var	ac1, ac2,i, j, len, ret, qid:integer;
	retran_interval:integer;{ seconds of wait for a response }
	retran_count:integer;	{ number of times to send a request }
	forever, dg_dump:boolean;
	server_atom:atom;
	server_name:big_atom;
	keytbl:table;
	port:field16;
	address:field32;
	req:query_template;
	myfbp:file_blk_ptr;


procedure qry_reset(var query:query_template);

{ Reset header and count of query_template }

var	loopvar:sectcode;

begin
    with query.header do
    begin
	id:=0;
	response:=false;
	opcode:=0;
	aa:=false;
	tc:=false;
	rd:=false;
	ra:=false;
	rcode:=0;
	qdcount:=0;
	ancount:=0;
	nscount:=0;
	arcount:=0;
    end;
    
    for loopvar:=answer to additional do
    with query.sdata[loopvar] do
    begin
	exp_count:=0;
	int_count:=0;
    end;
end; {qry_reset}



procedure find_address(var qry:query_template);
		
{ Format the request and send it to the name server. Check
  for a response every 0.5 seconds and accept the response	  
  having an id which matches the id of the request sent.
  Retransmit the request if a response has not been received
  after every 5 seconds for up to 3 retransmits.  The query
  attempt is aborted if a response is not received after a
  further 5 seconds (20 seconds in all).  Validate and
  output the correct response. }

var	i, j, timeout, diff:integer;
	ok, valid_response:boolean;
	resp:query_template;

begin  {find_address}
    valid_response:=false;
    qry.rawmsg.xmit_using:=dgm;
    timeout:=retran_interval*2*retran_count;

    ok:=format_pkt(qry,qry.rawmsg);
    if not ok
    then  {couldn't correctly format pkt}
	writeln('Query completion aborted')
    else begin
	     udp_send(qry.rawmsg);  {send the query}

	     { If response with correct name not received after
               5 seconds retransmit; after 20 elapsed seconds,
	       return control to user. }
	     repeat
		 jsys(disms, -2, ret; 500);     { wait 500 ms. }
		 if udp_receive(resp.rawmsg, false)
		 then begin  {accept datagram} 
			  if dg_dump  {print received pkt if desired}
			  then dump_pkt(resp.rawmsg);

			  {make superficial checks on pkt header}
			  with resp.rawmsg.raw_pkt.header do
			  begin    
			      if band(id, "fff0)<>band(qry.header.id, "fff0)
			      then begin  {old pkt}
				       writeln('Stale pkt:', id:4:h,
					       ' expecting:',qry.header.id);
				       dump_pkt(resp.rawmsg);
				   end
			      else begin
				       if id<>qry.header.id
				       then writeln('Previous pkt:',id:4:h)
				       else writeln( 'Matching pkt:', id:4:h);
				       if response
						and (opcode=qry.header.opcode)
				       then valid_response:=true
				       else valid_response:=false;
				   end;
			  end;
		      end {accept datagram}
		 else begin
			  timeout:=timeout-1;
			  {retransmit request every 5 seconds if no resonse }
			  if ((timeout mod (retran_interval*2))=0) and (timeout<>0)
			      then begin {retransmit request}
				       {bump id to reflect rexmit}
				       qry.rawmsg.raw_pkt.header.id:=
				       qry.rawmsg.raw_pkt.header.id+1;
				       udp_send(qry.rawmsg);
				       writeln('Request retransmitted');
				   end;  {retransmit request}
		      end
		 until valid_response or (timeout=0);
	     
	     if timeout=0
	     then begin {failure message}
		      writeln('Valid response not received.');
		      writeln('Query completion aborted.');
		  end   {failure message}
	     else begin
		  if resp.rawmsg.raw_pkt.header.rcode<>no_error
		  then with resp.rawmsg.raw_pkt.header
		       do begin
			      {report header information}
			      if aa or tc
			      then begin
				       write('Response:  ');
				       if aa
				       then write('Authoritative  ');
				       if tc
				       then write('Truncated');
				       writeln;
				   end;
			      pr_error(rcode)
			  end;
		  if (parse_pkt(resp.rawmsg, resp))
		  then pr_response(resp)
		  else writeln('Faulty packet received')
		  end;
	 end;
end; {find_address}

procedure lset_server(addr:field32;
		      port:field16);

var     myatom:atom;

begin
ppina(addr,myatom);
writeln('Using address ',myatom,' and port ',port:5,'(decimal)');
set_server(addr,port)
end; {lset_server}
{----------------------------------------

-----------------------------------------}

begin  {query}

    {**Initialization*}
    pp_init;
    initmaster;

    reset(input,'tty:', '/i');  {interactive file}
    rewrite(output,'tty:');

    forever:=true;
    dg_dump:=false;   {don't print datagrams}
    qid:=0;  {query id for domain header}	
    init_query(false);  {"false" means not the server}

    retran_interval:=10;
    retran_count:=3;

    writeln('Domain-style Query Program--');
    writeln;
    writeln('Use QUIT or EXIT to terminate.');
    writeln('    DUMP/NODUMP to enable/disable UDP data');
    writeln('                printing (octal) upon receipt.');
    writeln('    SERVER to change target nameserver locations.');
    writeln('	        Initial nameserver-- A.ISI.EDU port 53.');
    writeln('    QUERY OPERATIONS: std, inv, cm, cu');
    writeln;

    { set up keyword command table }
    keytbl:=tbmak(9);	   {make a table for keywords}
    tbadd(keytbl, 0, 'Exit', 0);
    tbadd(keytbl, 1, 'Quit', 0);
    tbadd(keytbl, 2, 'Dump', 0);
    tbadd(keytbl, 3, 'Nodump', 0);
    tbadd(keytbl, 4, 'Server', 0);
    tbadd(keytbl, 5, 'std', 0);
    tbadd(keytbl, 6, 'inv', 0);
    tbadd(keytbl, 7, 'cm', 0);
    tbadd(keytbl, 8, 'cu', 0);

    while forever do
	begin  {get user request}
	    with req.rawmsg
	    do	 begin
		     to_address:=0;
		     from_address:=0
		     end;
	writeln;
	cminir('QUERY OPERATION:  ');  {prompt to user}
	j:=cmkey(keytbl);		 {keyword expected}
	case j of
	    0,1: begin   {'exit or quit'--release queue}
		     quit_query(dgm);
		     forever:=false;
		 end;  {'exit or quit'}
	    
	    2: dg_dump:=true;  {enable datagram printing}
	    
	    3: dg_dump:=false; {disable datagram printing}

	    4: begin {'server'--assign name server}
		     write('host(string or address)  port(optional):  ');
		     readln;  {clear eoln}
		     read(server_name:len:[' ']);
		     if not eoln
		     then read(port)
		     else port:=53;
		     jsys(gthst_, -2, ret; gthsn_, 
			   server_name; ac1, ac2, address);
		     if ret=3 
		     then begin {jsys error}
			      {try to convert as if dotted decimal notation}
			      for i:=1 to max_atom_chars
		              do if i<=len
			         then server_atom[i]:=server_name[i]
				 else server_atom[i]:=' ';
			      if (len<=max_atom_chars) and not (cvina(server_atom, address))
			      then begin
				       {use server file open to init
					myfbp in order to conform to
					jsys_err calling requirements}
				       myfbp:=ofile(err);
				       writeln(myfbp^.fident,
					       'jsys GTHST failed' );
				       {print error messag}
				       jsys_err(noabort, -1, myfbp);
				       writeln(myfbp^.fident,
					       'Try another name server.');
				       writeln(myfbp^.fident);
				   end
			      else lset_server(address, port);
			  end  {jsys error}
		     else lset_server(address, port);
	       end;  {'server'--assign name server}
	    
	    5,6,7,8: begin  {query operation}
			 with req.header do
			 begin
			     {reset req internals}
			     qry_reset(req);

			     {consider id 12 bits request +
			      4 bits rexmit}
			     qid:=qid+"10;
			     if qid>"10000
			     then qid:=0;	 
			     id:=qid;
			     opcode:=j-5;

			     {prompt for query input}
			     case opcode of
				 std_query: begin
						qdcount:=1;
						writeln('question section');
						get_qsctn(req.q_section, 
							 qdcount);
					    end;
				 inv_query: begin
						ancount:=1;
						req.sdata[answer].exp_count:=
							       ancount;
						writeln('answer section');
						get_exp_sctn(
						     req.sdata[answer], 
						     opcode);
					    end;
				 cm_query,
				 cu_query: begin
					       qdcount:=1;
					       arcount:=1;
					       req.sdata[additional].
						   exp_count:=arcount;
					       writeln('question section');
					       get_qsctn(req.q_section, 
							 qdcount);
					       writeln('additional section');
					       get_exp_sctn(
						    req.sdata[additional],
						    opcode);
					   end;
			     end; {case}
			     find_address(req);
			 end; {with}
		     end; {query operation}
	     end; { case j }
     end; {while loop}
end. {query}
{$M-,X+}
program rsolve;

include {NOLIST} 'domain:jsys.def';
include {NOLIST} 'pascal:extern.pas';
include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:lparse.def';
include {NOLIST} 'domain:hash.hdr';
include {NOLIST} 'domain:msub.hdr';
include {NOLIST} 'domain:alloc.hdr';
include {NOLIST} 'domain:iomsg.hdr';
include {NOLIST} 'domain:eutil.hdr';
include {NOLIST} 'domain:mdep.hdr';
include {NOLIST} 'domain:dump.hdr';
include {NOLIST} 'domain:irdata.hdr';
include {NOLIST} 'domain:pp.hdr';
include {NOLIST} 'domain:tport.hdr';
include {NOLIST} 'domain:msure.hdr';
include {NOLIST} 'domain:naddrr.hdr';
const   sb_state_idle=0; (* resolver is not active for this block *)
	sb_state_new=1;	(* JSYS asked for resolve which has not started *)
	sb_state_waiting=2; (* Waiting for reply or retrasmission *)
	sb_state_quiet=3; (* Waiting after transmissions done *)


	did_slot_mask="f00; (* mask to extract slot number from domain_id *)
	did_gas=1;	     (* number of unused bits here *)
	did_slot_shift=8;    (* shift count for slot number *)
	did_seq_mask="70;    (* mask to extract request number *)
	did_seq_bit="10;
	did_xmit_mask="0f;   (* mask to extract  *)

	max_xmit_time="7ff;	     (* array dimension for timing array *)

	paranoid=false;	     (* should the resolver be paranoid? *)
type

string30=packed array[1..30] of char;

search_block_index=1..max_sb;

var     search_scan:search_block_index;	(* index of current search block *)
	newgram:rawmsg;	(* raw received datagram *)
	rval,toss:integer;
	master:master_block_pointer;
	index:integer;
	select_index:hgraph_index;
	select_eta:integer;

        { process scan blocks and parallel domain and raw message buffers }
	psb:array[1..max_sb] of servers_dv;
	pdmsg:array[1..max_sb] of domsg;
	ptport:array[1..max_sb] of transport;
	prmsg:array[1..max_sb] of rawmsg;

	logging:boolean;
	myfbp:file_blk_ptr;
	xmit_time:array[0..max_xmit_time] of integer; (* time query sent *)
	xmit_to:array[0..max_xmit_time] of integer; (* address slot number *)

procedure r_search;forward;

function tocheck(myrr:rr_pointer):boolean;

{	 TOCHECK returns true if this RR has not timed out}

begin
if myrr^.ttl>=0
then	 tocheck:=true	(* always OK if from authoritative *)
else	 tocheck:=myrr^.ttl<=master^.sb_array[search_scan].tquery
end; { tocheck }

function loghdr:boolean;

{	 This function returns a value equal to the logging variable

	 if the logging condition is true, it opens the log file and
	 outputs the start of a slot message }

begin
loghdr:=logging;
if logging
then with master^.sb_array[search_scan]
     do begin
	 myfbp:=ofile(log);
	 write(myfbp^.fident,'Slot ',search_scan:1,' TTL ',resttl:1,' ');
	 if tbit(rflags,gtdmba)
	 then write(myfbp^.fident,'MBA ')
     end
end; { LOGHDR }
{ All exits come through these routines }

procedure set_state(newstate:integer;
		      time_delta:integer);

{ SET_STATE is called to transition a search block to a new state }

begin
master^.rcom[search_scan]:=newstate; (* set search block state *)
master^.sb_array[search_scan].rtimeo:=msclock+time_delta; (* and timeout *)
end; { set_state }

procedure clear_sblocks;

begin
with master^.sb_array[search_scan]
do begin
       if lock1<>NIL
       then begin
		ulocks(lock1^);
		lock1:=NIL
	    end;
       if lock2<>NIL
       then begin
		ulocks(lock2^);
		lock2:=NIL
	    end;
       azone:=NIL;
       adeln:=NIL;
       cdeln:=NIL;
       adell:=0;
       cdell:=0;
   end
end;

procedure res_ret(code:integer);

{ return specified error code, or zero if no error.  Note that we must be
   very careful with the order of things to avoid synchronization problems }

var release:boolean;
begin
with master^.sb_array[search_scan]
do   begin
	 derc:=code;
	 if loghdr
	 then begin
		  if code=0
		  then writeln(myfbp^.fident,'terminated normally')
		  else writeln(myfbp^.fident,'terminated error ',code:6:o);
		  cfile(myfbp)
	      end;
	 release:=tbit(fcode,gtdrbk); { background request release resources }
	 master^.rcom[search_scan]:=sb_state_idle;
	 if release then begin
			     clear_sblocks;
			     pulock(slock)
			 end;
     end
end;

procedure create_query;

{	CREATE_QUERY builds a new query }

var	len:integer;

begin
i_domsg(pdmsg[search_scan]); (* initialize query record *)
with master^.sb_array[search_scan],pdmsg[search_scan]
do   begin
	 dhead.domain_id:=bshift(search_scan,did_slot_shift)+
			  band(dhead.domain_id+did_seq_bit,did_seq_mask);
	 dhead.opcode:=std_query;
	 with parse[question]
	 do   begin
		  count:=1;
		  with rdv[1]
		  do   begin
			   namebp:=free_ptr;
			   copydns(xseto(sname),free_ptr);
			   len:=lendns(free_ptr);
			   free_cnt:=free_cnt-len;
			   xadjbp(free_ptr,len);
			   databp:=free_ptr;
			   xidpb2(free_ptr,stype);
			   xidpb2(free_ptr,sclass);
			   free_cnt:=free_cnt-4
		       end
	      end
     end
end; { create_query }

procedure bump_did;

begin
with prmsg[search_scan]
do   dhead.domain_id:=band(dhead.domain_id+1,did_xmit_mask)+
		      band(dhead.domain_id,did_slot_mask+did_seq_mask)
end; { bump_did }

function idscode(id:integer):integer;

{	 Fold the ID field into the xmit_time data base }
begin
idscode:=min(max_xmit_time,
	     bshift(band(id,did_slot_mask),-did_gas)+
	     band(id,did_seq_mask+did_xmit_mask))
end; { idscode }
procedure log_xmit;

{ log_xmit logs a transmission }

var id,idex:integer;
    idptr:g1bpt;
begin
with prmsg[search_scan]
do begin
       idptr:=xseto(unspec);
       xadjbp(idptr,(ihl*4)+udp_hdr_sz);
       id:=xildb2(idptr);
       idex:=idscode(id);
       xmit_time[idex]:=msclock;
       xmit_to[idex]:=select_index;

       with master^.measure
       do   begin
		xaos(udpgra.touts);
		xaos(udphst[select_index].touts);
		xaos(newudp[select_index].touts);
		newudp[select_index].host:=dest_adr
	    end;

       if loghdr
       then  begin
		 write(myfbp^.fident,' ID ',id:4:h,' query sent to ');
		 toss:=dmpina(myfbp^.fident,dest_adr);
		 writeln(myfbp^.fident,' ETA ',select_eta:3);
		 cfile(myfbp)
	     end
   end
end; { log_xmit }
procedure log_wait;

begin
if loghdr
then begin
	 Writeln(myfbp^.fident,'recursive wait');
	 cfile(myfbp)
     end
end; { log_wait }

procedure log_recv;

begin
if loghdr
then begin
	write(myfbp^.fident,'ID ',pdmsg[search_scan].dhead.domain_id:4:h,
	       ' message from ');
	 toss:=dmpina(myfbp^.fident,newgram.sorc_adr);
	 writeln(myfbp^.fident);
	 if master^.logri<>0 then d_domsg(myfbp^.fident,pdmsg[search_scan]);
	 cfile(myfbp)
     end
end; { log_rcv }
procedure age_newudp;

(* This procedure throws away half of the data in NEWUDP to try and keep
   only reasonably recent data for making routing decisions.  Note that
   queries and replies in flight when this happens may create incorrectly
   high batting averages, and roundoff error can be exciting but
   c'est la vie *)

var i:integer;

begin
for i:=1 to hslots
do with master^.measure.newudp[i]
   do if touts<=1
      then begin (* clear slot *)
	       host:=0;
	       touts:=0;
	       tbacks:=0;
	       ttotal:=0
	   end
      else begin (* half *)
	       touts:=touts div 2;
	       tbacks:=tbacks div 2;
	       ttotal:=ttotal div 2
	   end
end; (* age_newudp *)
function server_goodness(myname:g1bpt):integer;

{ SERVER_GOODNESS is a function which returns a measure of how
  close a name is to the target name.  The larger this value is,
  the better.  The function is the number of labels in the server
  name if the name is an ancestor of the target, and negative the
  number of labels if the server is not an ancestor of the target }

var	myname_table:dname_string_table;
        target_table:dname_string_table;
	extra:integer;

begin
m_dst(myname,myname_table);
m_dst(xseto(master^.sb_array[search_scan].sname),target_table);
extra:=target_table.count-myname_table.count;
server_goodness:=-myname_table.count; (* assume the worst *)
if extra>=0
then if dnscomp(myname,target_table.bp[extra+1])
     then server_goodness:=myname_table.count;
end; { server_goodness}
procedure glue_set_sa(var server:server_type);

{	GLUE_SET_SA attempts to set up server addresses via a glue search }

var	mynode:node_pointer;
	myrr:rr_pointer;
	adv:g1bpt;

begin { glue_set_sa }

with master^.sb_array[search_scan],server
do   begin
	 address_count:=0;
	 addresses_ready:=false;
	 if f_node(azone^,xseto(server_name),mynode)=0
	 then begin (* found a node where glue entries could be expected *)
		  myrr:=mynode^.rr_ptr;
		  while (myrr<>NIL) and (address_count<max_server_addresses)
		  do begin
			 if (myrr^.rrtype=a) and (myrr^.rrclass=internet)
			 then begin
			       address_count:=address_count+1;
			       addresses_ready:=true;
			       with server_addresses[address_count]
			       do begin
				    adv:=xseto(myrr^.rdata^.litdata^.ldata);
				    xadjbp(adv,2); (* skip past length *)
				    ipaddress:=xildb4(adv)
				  end
			      end;
			 myrr:=myrr^.next
		     end
	      end;
     end
end; { glue_set_sa }
function need_mba(s_index:integer):boolean;

{ This function decides whether the recursive search for a server's
  address should be done using MBA.  The basic idea here is that it should
  if the domain of interest is an ancestor of the server's name }

var server_bp,domain_bp:g1bpt;
    server_len,domain_len,ll:integer;
begin
with psb[search_scan]
do begin
       server_bp:=xseto(servers[s_index].server_name);
       server_len:=lendns(server_bp);
       domain_bp:=xseto(server_at);
       domain_len:=server_at_len;

        (* while server name is longer, peel off labels *)
       while server_len>domain_len
       do begin
	      ll:=xildb(server_bp);
	      xadjbp(server_bp,ll);
	      server_len:=server_len-ll-1;
	  end;

       if server_len<>domain_len
       then need_mba:=false
       else need_mba:=dnscomp(server_bp,domain_bp)
   end
end; { need_mba }
procedure set_sptrs(var mst:server_type);

(* This procedure initializes the stat_ptrs for a server to point
to the appropriate entry in udpgra and newudp *)

var i:integer;
begin
if mst.addresses_ready
then for i:=1 to mst.address_count
     do with mst.server_addresses[i]
        do stat_ptr:=hlook(ipaddress,master^.measure.udphst);
end;
procedure bind_sa(use_glue:boolean);

{ Given the list of name servers to use, try to get their host addresses
  via GTDOM% calls.  These calls are restricted to
  avoid recursive disaster.  If the name server data came from an
  authoritative zone, look for address bindings via a glue search as well 

  WARNING: this procedure assumes that the log file is ready and uses it
           without initialization }

var	i:integer;
	mba:boolean;
begin
with psb[search_scan],master^.sb_array[search_scan]
do begin
   for i:=1 to server_count
   do begin
       if logging
	   then begin
		   if (i>1) and ((i mod 2)=1) (* print two servers per line *)
		   then begin
			    writeln(myfbp^.fident);
			    pheader(log,myfbp)
			end
		   else write(myfbp^.fident,' ');
		   toss:=dmpdns(myfbp^.fident,xseto(servers[i].server_name));
		end;

       (* Note that in the following code, we see if we can start up a
          background request by testing that RESTTL exceeds some value and
          then start a background request with some amount less than the
          current RESTTL.

          IT IS ESSENTIAL that a zero value not be used since that implies
          that the default value will be used and could result in infinite
          looping. *)

       if getadr(servers[i],false,false,false,resttl-5) (* LDO try *)
       then (* name resolved *)
       else begin
		if use_glue (*  use glue *)
                then begin
			  if logging then write(myfbp^.fident,' (glue)');
			  glue_set_sa(servers[i])
		     end;
		if (not servers[i].addresses_ready) and (resttl>5)
		then if getadr(servers[i],true,true,need_mba(i),resttl-5)then;
	    end;

       if servers[i].addresses_ready
       then begin
		if logging then d_sa(myfbp^.fident,servers[i],false);
		set_sptrs(servers[i]) (* setup stat_ptrs *)
	    end;
       end;

   if logging then writeln(myfbp^.fident);

   { Reorder the list if desired to pick closer servers, addresses etc }
   sort_sa(psb[search_scan]);

   if logging and (server_count>0)
   then begin (* print out reordered list *)
	    pheader(log,myfbp);
	    write(myfbp^.fident,'Reorder to:');
	    for i:=1 to server_count
	    do begin
		   if (i>1) and ((i mod 2)=1) (* print two servers per line *)
		   then begin
			    writeln(myfbp^.fident);
			    pheader(log,myfbp)
			end
		   else write(myfbp^.fident,' ');
		   toss:=dmpdns(myfbp^.fident,xseto(servers[i].server_name));
		   d_sa(myfbp^.fident,servers[i],true)
	       end;
	    writeln(myfbp^.fident)
        end
   end { with }
end; { bind_sa }
procedure get_cl;

{ GET_CL gets the primitive cache lock }

const	  cache_wait_delta=500;	(* how long between cache lock tries *)

var	  started_waiting,interval:integer;
begin
with master^.cache_pointer^
do if not prlock(zone_lock.lockwd) (* primative lock *)
	   then   begin
		       started_waiting:=msclock;
		       repeat mswait(cache_wait_delta);
			      interval:=started_waiting-msclock;
		       until  prlock(zone_lock.lockwd);
		  end

end; { GET_CL }
procedure s_caching;

{ S_caching is called to obtain write access to the cache.  It
  also creates the cache if necessary.  Like E_caching, a call to
  s_caching is a NOP if the cache is already held in write mode.
  This all assumes that the resolver is the only code to ever get
  a write lock on the cache. }

const	  write_wait=500; (* wait inteval for JSYSes to clear *)

var	  acquired:boolean;
	  new_cache:zone_entry_pointer;
	  index,locks_needed:integer;
	  cache_lock_address,this_lock:lock_pointer;
begin
if master^.cache_pointer=NIL
then	   begin (* must create cache zone *)
	       a_zone(new_cache);
	       new_cache^.zone_is_cache:=true;
	       new_cache^.loaded:=true;
	       ilock(new_cache^.zone_lock);
	       { give a lock to the requester }
	       while not locks(new_cache^.zone_lock,100,1000)
	       do; { should never wait }
	       this_lock:=lckptr(new_cache^.zone_lock);
	       with master^.sb_array[search_scan]
	       do if lock1=NIL
		  then lock1:=this_lock
		  else lock2:=this_lock;
	       up_all;
	       master^.cache_pointer:=new_cache;
	       up_all
	   end;

{ The strategy for obtaining the write lock is to get a primative lock on
  the cache zone, and then to check to see if all of the read locks
  (if any) belong to search blocks which are owned by the resolver. }

with master^.cache_pointer^
do repeat  get_cl;  
	   if zone_lock.exclusive>0
	   then { Already write locked, assume we have it }
	        acquired:=true
	   else	if zone_lock.share=0
	        then acquired:=true
		else begin (* see if the read locks belong to the resolver *)
		     locks_needed:=zone_lock.share;
		     index:=1;
		     cache_lock_address:=lckptr(zone_lock);
		     while (locks_needed>0) and (index<=max_sb)
		     do with master^.sb_array[index]
			do begin
			       if master^.rcom[index]<>0 (* belongs to resolver *)
			       then if (lock1=cache_lock_address) or
				       (lock2=cache_lock_address)
				    then locks_needed:=locks_needed-1;
			       index:=index+1
			   end;
		     acquired:=locks_needed=0
		     end;
	   if acquired
	   then begin
		    zone_lock.exclusive:=1;
		    master^.cupdate:=0;	(* signal cache at risk *)
		    up_pages(quotep(master^.cache_pointer) div 512,
			    (sizeof(master^.cache_pointer)+511) div 512)
		end;
	   pulock(master^.cache_pointer^.zone_lock.lockwd);
	   if not acquired then mswait(write_wait)
   until acquired

end; { S_caching }

procedure e_caching;

{ E_caching is called to release the cache if it is held in write
  mode. This procedure is designed so that calling it doesn't hurt
  anything, even if a matching S_CACHING call didn't happen. }

var	i:integer;
begin
get_cl;
if master^.cache_pointer^.zone_lock.exclusive<>0
then begin
	 up_all;
	 { set database update time }
	 
	 jsys(gtad;;i);
	 if i=-1
	 then begin
		   myfbp:=ofile(err);
		   writeln(myfbp^.fident,'System clock not set.. big trouble');
		   cfile(myfbp)
	      end;

	 master^.cupdate:=i;
	 up_pages(quotep(master) div 512,
		  (sizeof(master)+511) div 512)
     end;
master^.cache_pointer^.zone_lock.exclusive:=0;
up_pages(quotep(master^.cache_pointer) div 512,
	 (sizeof(master^.cache_pointer)+511) div 512);
pulock(master^.cache_pointer^.zone_lock.lockwd)
end;
procedure rr_cache(     scode:sectcode;
			  first:integer;
			  last:integer;
		      var mynode:node_pointer);

{ This procedure caches the specified RRs in a section. }

var	index:integer;

begin
if last>=first (* if there is anything to cache *)
then begin
	 S_caching;
	 if loghdr
	 then begin
	      write(myfbp^.fident,'Caching RRs ',first:1,' through ',last:1,
			     ' from section:');
	      d_sect(myfbp^.fident,pdmsg[search_scan],scode);
	      cfile(myfbp)
	      end;
	 with pdmsg[search_scan].parse[scode]
	 do for index:=first to last
	     do with rdv[index]
		 do if index=1
		    then add_rr(master^.cache_pointer^,namebp,mynode,databp)
		    else if dnscomp(namebp,rdv[index-1].namebp)
			 then con_rr(master^.cache_pointer^,mynode,databp)
			 else add_rr(master^.cache_pointer^,namebp,mynode,databp);
	 e_caching { free up the cache }
     end
end; { rr_cache }

procedure sct_cache(    scode:sectcode;
		    var mynode:node_pointer);

begin
rr_cache(scode,1,pdmsg[search_scan].parse[scode].count,mynode)
end; { sct_cache }
function select_server(var resolve_wait:boolean):integer;

{	   Select_server selects the next IP address of a server to be
	   queried and returns either it or zero if there are no addresses
	   to try.  RESOLVE_WAIT is set if an unresolved server might be
	   available in the future.

	   The selection algorithm tries servers in the order in which they
	   appear in the table, using all first addresses, then all second
	   addresses, etc.  All addresses for all servers are tried before
           any addresses are repeated. }

var i,j,server_number,server_address,best_tries_so_far:integer;

begin
resolve_wait:=false;
best_tries_so_far:=master^.measure.maxit+1; (* initialize match data *)
server_number:=0;
server_address:=2; (* random value to avoid uninitialized value error *)
with psb[search_scan]
do for i:=1 to server_count (* loop over all servers *)
   do  begin
       if not servers[i].addresses_ready (* if server address not known *)
       then begin
	    resolve_wait:=true;
	    if getadr(servers[i],false,false,false,gtdrcm) (* try to get it with ldo *)
	    then begin
		     set_sptrs(servers[i]);
		     sort_a(servers[i]) (* if got it, sort the addresses *)
		 end
	    end;
       if servers[i].addresses_ready
       then for j:=1 to servers[i].address_count (* and all addresses *)
	    do	with servers[i].server_addresses[j]
		do   if (tries<limit)
			and (tries<=best_tries_so_far)
                     then if (tries<best_tries_so_far) (* best so far *)
			     or (j<server_address) (* equal, but new server *)
                          then	begin (* best candidate so far *)
				     best_tries_so_far:=tries;
				     server_number:=i;
				     server_address:=j
				end;
       end;
if server_number=0
then select_server:=0 (* signal failure *)
else with psb[search_scan].servers[server_number].server_addresses[server_address]
     do begin
	    select_server:=ipaddress; (* signal address to query *)
	    tries:=tries+1;
	    select_index:=stat_ptr;
	    select_eta:=eta
	end

end; { select_server }
procedure forget_server;

{ Stop asking the server which just responded }

var    loser:integer;
       server_index,mark_index,address_index:integer;
begin
loser:=newgram.sorc_adr;
with psb[search_scan]
do for server_index:=1 to server_count
   do with servers[server_index]
      do for address_index:=1 to address_count
	 do with server_addresses[address_index]
	    do if ipaddress=loser
	       then (* mark all addresses of this server as losers *)
		for mark_index:=1 to address_count
		do server_addresses[mark_index].tries:=master^.measure.maxit
end; { forget_server }
procedure ask_another;

{ Send the query out to the next choice }

var next_server,expected:integer;
    waiting:boolean;
begin
with master^.sb_array[search_scan]
do begin
       resttl:=resttl-1; (* decrement resolver time to live *)
       next_server:=select_server(waiting); (* select next target *)
       if master^.rcom[search_scan]<>sb_state_quiet
       then if next_server=0
	    then if waiting
		 then begin
			  set_state(sb_state_waiting,master^.measure.qtor);
			  log_wait
		      end
		 else set_state(sb_state_quiet,master^.measure.qtoq)
	    else begin
		     ptport[search_scan].foreign_address:=next_server;
		     bump_did;
		     s_rawmsg(master^.resolve_handle,
			      ptport[search_scan],prmsg[search_scan]);
		     log_xmit;
		     if master^.measure.dynsw=0
		     then expected:=master^.measure.qtor
		     else expected:=(select_eta * master^.measure.dynnum) div
			                 master^.measure.dynden;
		     set_state(sb_state_waiting,expected)
	    end
   end

end; { ask_another }
procedure peculiar_response(msg:string30);

{ Log this domain message as peculiar, along with the message,
  and don't ask this server again }

begin
if (master^.logrp<>0) or logging
then begin
	 myfbp:=ofile(log);
	 Writeln(myfbp^.fident,'Slot ',search_scan:1,' ',msg);
	 d_domsg(myfbp^.fident,pdmsg[search_scan]);
	 cfile(myfbp)
     end;
forget_server;
ask_another;
end; { peculiar_response }
procedure delegation;

{ DELEGATION is called to use the information in a response
  to locate a better server }

var	new_server:boolean;
	new_goodness,referral_rr,i:integer;
	sbp:g1bpt;
	toss_node:node_pointer;

	procedure get_server(servebp:g1bpt);

	{ GET_SERVER adds a server to the current process scan block }

	begin
	with psb[search_scan]
	do if server_count<max_search_servers
	   then begin
		    server_count:=server_count+1;
		    with servers[server_count]
		    do begin
			   addresses_ready:=false;
			   copydns(servebp,xseto(server_name))
		       end
		end
	end; (* get_server *)

begin
with psb[search_scan],pdmsg[search_scan].parse[authority]
do	if count=0
	then peculiar_response('No answers, no delegation     ')
	else begin
		new_server:=false;
		for i:=1 to count
		do begin (* make sure the referral makes progress *)
			sbp:=rdv[i].databp;
			xadjbp(sbp,10); (* point to server name *)
		        new_goodness:=server_goodness(rdv[i].namebp);
			if new_goodness>server_quality
			then	{ better than ever before }
				begin
				referral_rr:=i;
				if new_server
				then if logging
				     then write(myfbp^.fident,' redelegation ')
				     else
				else begin { cache only once }
					sct_cache(authority,toss_node);
					sct_cache(additional,toss_node);
					if loghdr
					then write(myfbp^.fident,'delegate ');
				     end;
				if logging then toss:=dmpdns(myfbp^.fident,rdv[referral_rr].namebp);
				server_count:=0;
			        copydns(rdv[i].namebp,xseto(server_at));
				server_at_len:=lendns(xseto(server_at));
				server_quality:=new_goodness;
				get_server(sbp);
				new_server:=true
				end
			else	if new_server and
				(new_goodness=server_quality) and 
				(server_count<max_search_servers)
				then get_server(sbp); { add a new co-equal }
		   end;
		(* bind the server addresses without glue *)
		if new_server
		then begin
			 if logging
			 then begin
				  writeln(myfbp^.fident);
				  pheader(log,myfbp)
			      end;
			 bind_sa(false)
		     end
		else if loghdr
		     then writeln(myfbp^.fident,' ***** DELEGATION FAILED *****');
		if logging then cfile(myfbp)
	     end
end; { delegation }
procedure use_cname;

{ This routine is called by use_mcname and use_dcname to set up a CNAME
  from either a message or the database.  It standardizes the case of SNAME,
  set up string descriptor, logs it, etc. }

var     toss:integer;

begin
with master^.sb_array[search_scan]
do begin
       if loghdr
       then begin
		 Write(myfbp^.fident,'CNAME taken: ');
		 toss:=dmpdns(myfbp^.fident,xseto(sname));
		 writeln(myfbp^.fident);
		 cfile(myfbp)
	    end;
       m_dst(xseto(sname),stable);
       sbit(rflags,gtdaka); (* set alias *)
   end;
end;

procedure use_mcname(scode:sectcode;
		      id:integer);

var cname_bp:g1bpt;

begin (* found a CNAME to use *)
with master^.sb_array[search_scan],pdmsg[search_scan].parse[answer].rdv[id]
do begin
       rr_cache(scode,id,id,rsolvn);
       ccdns(f_data(databp),xseto(sname));
       use_cname
   end;
end; {use_mcname}

procedure use_dcname(myrr:rr_pointer);

var ptr:g1bpt;

begin
ptr:=xseto(master^.sb_array[search_scan].sname);
cvdnp(myrr^.rdata^.rrname,ptr);
use_cname
end;
procedure sb_lock(var mylock:lock);

begin
with master^.sb_array[search_scan]
do begin
       while not locks(mylock,100,2000) do;
       if lock1=NIL
       then lock1:=lckptr(mylock)
       else lock2:=lckptr(mylock)
   end
end;
function azfind:boolean;

{ AZFIND looks for the best authoritative zone to search, if any.
  Points ANONE at it, returns true if node in authoritative region
  otherwise returns false with ADELN pointing to a delegation and
  ADELL set to the number of labels that matched in the delegation }

var now_at:node_pointer;
    scanptr:zone_entry_pointer;
    i,toss:integer;
    s_result:boolean;

begin
with master^.sb_array[search_scan]
do begin
       while not locks(master^.search_zone.zone_lock,100,2000) do;
       now_at:=master^.search_zone.zone_node;

       i:=stable.count; (* start at root *)
       repeat if now_at^.zone_ptr<>NIL
	      then begin (* find zone with matching class *)
		      scanptr:=now_at^.zone_ptr;
		      while scanptr<>NIL
		      do if (ord(scanptr^.zone_class)=sclass)
				AND
			     scanptr^.loaded
		         then	begin
				     azone:=scanptr;
				     adell:=stable.count-i+1;
				     scanptr:=NIL
				end
			 else	scanptr:=scanptr^.zone_chain
		   end;
	      i:=i-1;	(* move down one label *)
	      if i<>0 then s_result:=f_son(now_at,stable.bp[i],now_at,toss)
       until  (i=0) or (not(s_result));

       if azone=NIL
       then azfind:=false
       else begin
	       sb_lock(azone^.zone_lock);
	       azfind:=true
	    end;
   end;

ulocks(master^.search_zone.zone_lock); {release search zone lock}
end; { azfind }
function azlook:boolean;

{ AZLOOK tries to find data for the query in the current search block in
  a local authoritative zone.

  If the name doesn't exist (authoritatively) then derc gets set

  If the name is present in the authoritative part of the zone, then the
  function returns TRUE.  AZONE points to the zone, RSOLVN points to the
  node, and a lock is set for the authoritative zone and recorded in the
  search block.

  If the name isn't present in authoritative data, then the function
  returns false.  If an authoritative delegation is present, ADELN, ADELL,
  AZONE and some lock variable will be set. }

var star_label:packed array[0..63] of octet;
    spoint,next_spoint:node_pointer;
    toss:integer;
    search_cond:boolean;
begin
with master^.sb_array[search_scan]
do if azfind { look for and authoritative zone to search }
   then begin
   	spoint:=azone^.zsoa;	{ set search pointer to top of authority }
	search_cond:=true;
	if stable.count>adell  (* are there more labels to match *)
	then repeat search_cond:=f_son(spoint,stable.bp[stable.count-adell],
					next_spoint,toss);
	            if search_cond
		    then begin
			 adell:=adell+1;
			 spoint:=next_spoint;
			 if spoint^.node_lchain=NIL (* dropped off bottom? *)
			 then search_cond:=false
			 end
	      until  (search_cond=false) or (adell=stable.count);

	if (adell=stable.count) and (spoint^.node_lchain=NIL)
	then begin
		rsolvn:=spoint;
		azlook:=true 
	     end
	else if spoint^.node_lchain=NIL
	     then begin
		       adeln:=spoint; (* found delegation *)
		       azlook:=false
		   end
	     else begin
		       star_label[0]:=1;
		       star_label[1]:=ord('*');
		       if f_son(spoint,xseto(star_label),spoint,toss)
		       then begin
				rsolvn:=spoint;
				azlook:=true
			    end
		       else begin
				derc:=gtddne;
				azlook:=false
			    end
		   end
	end
   else azlook:=false (* signal failure, no authoritative zone to find *)
end; (* azlook *)
function czlook:boolean;

{ set RSOLVN to point to the node in the cache which matches the most
  labels of the search name.  Return true if all labels matched }

var toss,matched:integer;
    search_cond:boolean;
    new_ptr:node_pointer;
begin
with master^.sb_array[search_scan]
do if master^.cache_pointer<>NIL
   then begin
   	sb_lock(master^.cache_pointer^.zone_lock);
	rsolvn:=master^.cache_pointer^.zone_node;
	matched:=1;
	search_cond:=true; { root node matched automatically }
	while search_cond and (matched<>stable.count)
	do if f_son(rsolvn,stable.bp[stable.count-matched],new_ptr,toss)
	   then begin
	   	matched:=matched+1;
		rsolvn:=new_ptr;
		end
	   else search_cond:=false;
	czlook:=search_cond
	end
   else czlook:=false
end; { CZLOOK }
procedure czdel;

{ Setup CDELN and CDELL using node pointer in RSOLVN }

var spoint:rr_pointer;
    s_node:node_pointer;

begin
with master^.sb_array[search_scan]
do begin
   while rsolvn<>NIL { work up to the best delegation }
   do begin
      spoint:=rsolvn^.rr_ptr;
      while (spoint<>NIL)
      do if (spoint^.rrtype=NS) and tocheck(spoint)
         then begin
	      spoint:=NIL; { signal end of search }
	      cdeln:=rsolvn; { remember place with delegation }
	      rsolvn:=NIL
	      end
	 else spoint:=spoint^.next;
      if rsolvn<>NIL then rsolvn:=rsolvn^.up_ptr
      end;
   if cdeln<>NIL { if delegation found, find its level }
   then begin
        cdell:=1;
	s_node:=cdeln;
	while s_node^.up_ptr<>NIL
	do begin
	   s_node:=s_node^.up_ptr;
	   cdell:=cdell+1
	   end
	end;
   end
end; { CZDEL }
function answers_there:boolean;

{ return TRUE if there answers at the node spefied by RSOLVN }

var spoint:rr_pointer;

begin
with master^.sb_array[search_scan]
do begin
   answers_there:=false; { assume failure }
   spoint:=master^.sb_array[search_scan].rsolvn^.rr_ptr;
   repeat if spoint<>NIL
          then if tmatch(internet,stype,spoint^.rrtype) and tocheck(spoint)
               then begin
		    answers_there:=true;
		    spoint:=NIL
		    end
	       else spoint:=spoint^.next
    until  spoint=NIL
end { with }
end; { answers_there }
function cname_effective:boolean;

{ Check the RRs at RSOLVN and take a CNAME if appropriate }

var done:boolean;
    scan:rr_pointer;

begin
with master^.sb_array[search_scan]
do if tmatch(internet,stype,cname)
   then cname_effective:=false (* if CNAME could be in answer don't follow *)
   else begin
	    scan:=rsolvn^.rr_ptr;
	    done:=false; (* assume failure *)
	    while not done
	    do if scan=NIL
	       then done:=true
	       else if (scan^.rrtype=CNAME) and tocheck(scan)
		    then done:=true
		    else scan:=scan^.next;
	    if scan=NIL
	    then cname_effective:=false
	    else begin (* take the CNAME *)
		     use_dcname(scan);
		     r_search
		 end;
	end;
end; (* cname_effective *)
procedure dasd(server_data:servers_dv);

{ print all data for this servers block }

var i,toss:integer;

begin 
for i:=1 to server_data.server_count
do with server_data.servers[i]
   do begin
	  toss:=dmpdns(myfbp^.fident,xseto(server_name));
	  d_sa(myfbp^.fident,server_data.servers[i],true);
	  write(myfbp^.fident,' ');
      end;
writeln(myfbp^.fident)
end; { dasd }

procedure get_nserve(np:node_pointer);

{ copy name server references into psb }

var	  scan:rr_pointer;
	  bp,temp_ptr:g1bpt;
	  i:integer;
begin
scan:=np^.rr_ptr;
with psb[search_scan]
do  begin
    temp_ptr:=xseto(server_at);
    cvnnp(np,temp_ptr);
    server_at_len:=lendns(xseto(server_at));
    while (scan<>NIL) and (server_count<max_search_servers)
    do	  begin
	      if (scan^.rrtype=ns) and (scan^.rrclass=internet)
		  and tocheck(scan)
	      then    begin (* A server to use *)
		      server_count:=server_count+1;
		      with servers[server_count]
		      do   begin
			      bp:=xseto(server_name);
			      cvdnp(scan^.rdata^.rrname,bp);
			      addresses_ready:=false
			   end
		      end;
	      scan:=scan^.next
	  end;
    if server_count>0 (* calculate goodness if servers found *)
    then begin (* quality is number of labels in this case *)
	     i:=0;
	     while np<>NIL
	     do begin
		    np:=np^.up_ptr;
		    i:=i+1
		end;
	     server_quality:=i
	 end
    end
end; { get_nserve }
procedure r_delegation;

var next_server,timeout:integer;
    waiting:boolean;
begin
with master^.sb_array[search_scan],psb[search_scan] do
begin
server_count:=0;
if (adeln<>NIL) and (cdeln<>NIL)
then if cdell>adell
then adeln:=NIL;
if logging then myfbp:=ofile(log);
if cdeln<>NIL
then	begin (* Use the cache delegation *)
	    if logging then write(myfbp^.fident,'cache');
	    get_nserve(cdeln);
	    bind_sa(false) (* bind without glue *)
	end
else	if adeln<>NIL
	then begin (* Use the authoritative delegation *)
	     if logging then write(myfbp^.fident,'auth');
	     get_nserve(adeln);
	     bind_sa(true) (* bind with glue *)
	     end
	else begin (* Didn't get any delegation, try default server *)
	     if logging
	     then begin
		       write(myfbp^.fident,'default ');
		       dasd(master^.resolve_dserve);	(* dump server data *)
		  end;
	     psb[search_scan]:=master^.resolve_dserve
	     end;

if server_count=0
then begin
	 if logging
	 then begin
		  Writeln(myfbp^.fident,' No servers found, request terminated *****');
		  cfile(myfbp)
	      end;
	 res_ret(gtddna) (* signal data not available *)
     end
else
begin {servers to work with }

{ Format up the query datagram, and send it off to the best choice.  Set
  the alarm to go off after initial query timeout. }

next_server:=select_server(waiting);

if (next_server<>0) or waiting
then if tbit(fcode,gtdrtc)
     then (* Resolution with TCP was requested, return error *)
	  begin
	       if logging
	       then begin
			pheader(log,myfbp);
			Writeln(myfbp^.fident,' TCP requested, request terminated *****');
			cfile(myfbp)
		    end;
	       res_ret(gtddna)
	  end
     else begin
	  if logging then cfile(myfbp);
	  create_query;
	  with ptport[search_scan] (* setup the transport information *)
	  do   begin
		   xmit_using:=dgm;
		   foreign_address:=next_server;
		   foreign_port:=dns_socket;
		   local_port:=master^.resolve_port;
		   (* Note local address selected by s_rawmsg *)
	       end;
	  f_rawmsg(pdmsg[search_scan],ptport[search_scan],prmsg[search_scan]);
	  if next_server<>0
	  then begin
		   bump_did;
		   s_rawmsg(master^.resolve_handle,
			    ptport[search_scan],prmsg[search_scan]);
		   log_xmit;
		   if master^.measure.dynsw=0
		   then timeout:=master^.measure.qtoi
		   else timeout:=(select_eta * master^.measure.dynnum) div
			                 master^.measure.dynden;
	       end
	  else begin
		   log_wait;
		   timeout:=master^.measure.qtoi
	       end;
	  set_state(sb_state_waiting,master^.measure.qtoi)
	  end
else begin (* Couldn't find the address of any server *)
     if logging
     then begin
	      pheader(log,myfbp);
	      Writeln(myfbp^.fident,' No addresses, request terminated *****');
	      cfile(myfbp)
	  end;
     res_ret(gtddna)
     end
		
end {servers to work with}
end { with }
end; { r_delegation }
procedure r_search;

{ RESTART search restarts the search assuming that the name is set up, but
  that the delgation variables need to be restarted.

  This procedure is typically used after a CNAME. }

begin
with master^.sb_array[search_scan]
do if resttl<=0	(* kill infinite loops *)
   then res_ret(gtddna)
   else begin
	    resttl:=resttl-1;
	    clear_sblocks; (* clear zone locks held by search block *)	    
	    if azlook (* look up node in authoritative data *)
	    then (* found authoritative data *)
		 if cname_effective
		 then (* take cname from database *)
		 else res_ret(0) (* done, whatever the result *)
	    else if derc<>0
		 then res_ret(derc) { Name does not exist }
		 else if tbit(rflags,gtdmba)
   		      then r_delegation (* if MBA, don't check cache *)
		      else if czlook
		           then if cname_effective
			        then (* off on another CNAME *)
			        else if answers_there
			             then res_ret(0)
				     else begin
				     	      czdel;
					      r_delegation
					  end
			   else begin
			   	czdel;
			   	r_delegation (* go hit default server *)
				end
	end
end; { restart saerch }
procedure eat_answers(first:integer);

{ EAT_ANSWERS is called when the remainder of the answer section is the
  answer, whether it is empty or not }

var i:integer;
    ok:boolean;
    toss_node:node_pointer;

begin
with pdmsg[search_scan].parse[answer],master^.sb_array[search_scan]
do begin
       ok:=true;
       for i:=first to count (* make sure all RRs are for the same place *)
       do if ok
	  then if not dnscomp(xseto(sname),rdv[i].namebp)
	       then ok:=false;
       if not ok
       then peculiar_response('Answers for different names   ')
       else { Cache and return }
	    begin
		if first>count
		then { Return an empty answer }
		else { Cache and return answers }
		     rr_cache(answer,first,count,rsolvn);
		sct_cache(authority,toss_node);
		sct_cache(additional,toss_node);
		res_ret(0) { exit without error }
	    end
   end { with }
end; { eat_answers }
procedure chk_answer;

{ CHK_ANSWER is called when a response contains an answer section.
  It goes through the answer section.  There are three main cases:

  1. If the answer may contain CNAME, then assume that all of the answer
     section is in fact the answer.

  2. The answer may start with one or more CNAMES which are followed by
     the answer.

  3. The answer may have one or more CNAMEs but not be followed by the 
     answer.

  Note that the special case of a MBA request with a leading CNAME is
   dealt with in the caller of chk_answer
}

var now_scanning:integer;
    any_cnames:boolean;
    cname_bp:g1bpt;
    cnames_complete:boolean;
    errors_found:boolean;
    toss_node:node_pointer;
begin
with pdmsg[search_scan],master^.sb_array[search_scan]
do begin (* with *)
       now_scanning:=1;	(* setup to eat CNAMEs off the front of the message *)
       errors_found:=false;
       cnames_complete:=false;
       any_cnames:=false;

       while (now_scanning<=parse[answer].count) and not cnames_complete
       do with parse[answer].rdv[now_scanning]
	  do if dnscomp(xseto(sname),namebp) (* name match *)
	     then if (f_type(databp)=cname) and not tmatch(internet,stype,cname)
		  then begin
			   any_cnames:=true;
			   use_mcname(answer,now_scanning);
			   now_scanning:=now_scanning+1
		       end
		  else cnames_complete:=true
	     else begin
		      errors_found:=true;
		      peculiar_response('Irrelevant RR in CNAME check  ');
		      errors_found:=true;
		      cnames_complete:=true
		  end;

       if errors_found (* if CNAME error happened, try to get going again *)
       then if any_cnames
	    then r_search	(* since one CNAME took, try restarting *)
	    else forget_server
       else with parse[answer]
	    do if truncated
	       then { Trucated answer section }
		    if any_cnames
		    then r_search	(* restart past CNAMEs *)
		    else res_ret(gtdtru)
	       else { Non-truncated answer section }
		    if any_cnames
		    then if now_scanning>count
			 then begin (* CNAMEs without follow-up *)
			      sct_cache(authority,toss_node);
			      sct_cache(additional,toss_node);
			      r_search
			      end
			 else (* CNAMEs with follow-up *)
			      eat_answers(now_scanning)
		    else { No CNAMEs, no truncation, so answer is complete
			   even if it is empty }
			 begin
			     if dhead.aa (* if authoritative, delete old *)
			     then begin
				      S_caching;
				      del_rr(master^.cache_pointer^,
					 xseto(sname),stype,sclass);
				      E_caching
				  end;
			     eat_answers(now_scanning)
			 end
   end; (* with *)

end; { chk_answer }
procedure new_dg;

{ NEW_DG starts with a response which parses, and now must
  decide whether the response has the answer we need, points to a
  better delegation, or is a distraction of one sort or another }

var myrr_type:dtype;

begin
with pdmsg[search_scan],master^.sb_array[search_scan]
do case dhead.rcode of

no_error:	    if dhead.ancount=0
		    then if dhead.aa (* name exists, but no matching RRs *)
			 then begin
				  rsolvn:=NIL;
				  res_ret(0)
			      end
			 else { not an empty answer, look for delegation }
			      begin
				  forget_server;
				  delegation;
				  ask_another
			      end
		    else { answers present, check for CNAME }
			if not dnscomp(xseto(sname),
				       parse[answer].rdv[1].namebp) 
			then peculiar_response('Answer name does not match    ')
			else begin
				 myrr_type:=f_type(parse[answer].rdv[1].databp);
				 if tbit(fcode,gtdmba) and
				    (myrr_type=cname) and
				    not tmatch(internet,stype,cname)
				 then (* eat just one CNAME if mba *)
				      if dhead.aa
				      then begin
					       use_mcname(answer,1);
					       r_search
					   end
				      else begin
					       forget_server;
					       delegation;
					       ask_another
					   end
				 else (* MBA answer *)
				      chk_answer
			     end;

format_error:	    peculiar_response('Format error in response      ');

server_failure:	    peculiar_response('Server failure                ');

name_error:	    if dhead.aa
		    then { If an authoritative server says name does not
			   exist, pass message on to user }
			 res_ret(gtddne)
		    else { If a non-authoritative server says name doesn't
			   exist, treat it as peculiar }
		         peculiar_response('Non-authoritative name error  ');

not_implemented:    peculiar_response('Query type not implemented    ');

refused:	    peculiar_response('Request refused               ');

others:		    peculiar_response('Unknown response code         ')
   end { case }

end; { new_dg }
function validate_domsg(var mydomsg:domsg;
			  var myrawmsg:rawmsg):boolean;

{ VALIDATE_DOMSG iterates through all of the data in a message, checking
  to see if it makes sense }

var  ok,new_error:boolean;
     sect_idx:sectcode;
     rdindex,i,wanted,last_label,dname_size:integer;
     check_type:dtype;
     check_class:dclass;
     check_ttl,check_left:integer;
     check_bp:g1bpt;
     table:rdata_table_pointer;

     procedure log_err;

     var stext:packed array[1..10] of char;

     begin
     ok:=false;
     myfbp:=ofile(log);

     case sect_idx of
     question:	   stext:='question  ';
     answer:	   stext:='answer    ';
     authority:	   stext:='authority ';
     additional:   stext:='additional'
     end;

     writeln(myfbp^.fident,'Bad format for RR ',i:1,
	     ' in section ',stext);
     if new_error
     then dumpbuffer(myrawmsg,(myrawmsg.rec_count-1)*4,log,myfbp);
     new_error:=false;
     cfile(myfbp)
     end; { log_err }

     procedure validate_rr;

     begin
     rdindex:=1; (* index of items in RDATA *)
     with table^[check_type]
     do while ok and (rdata_item[rdindex]<>no_more_field)
	do begin
	   case rdata_item[rdindex] of

		dname_field:  begin
				   last_label:=1;
				   dname_size:=0;
				   while ok and (last_label<>0)
				   do	if check_left>0
				        then begin
						 last_label:=xildb(check_bp);
						 if check_left>last_label
						 then begin
							   check_left:=check_left-last_label-1;
							   xadjbp(check_bp,last_label);
							   dname_size:=dname_size+last_label+1;
							   if dname_size>max_dname_chars
							   then log_err
						      end
						 else log_err
					     end
					else log_err
			      end; { dname_field }
						    
		cstring_field: if check_left>0
			       then begin
					wanted:=xildb(check_bp);
					if check_left>=wanted
					then begin    
						 check_left:=check_left-wanted-1;
						 xadjbp(check_bp,wanted)
					     end
					else log_err
				    end;

		int16_field:  if check_left<2
			      then log_err
				   else begin
					     check_left:=check_left-2;
					     xadjbp(check_bp,2)
					end;

		time_field,
		int32_field,
		inet_a_field: if check_left<4
			      then log_err
				   else begin
					     check_left:=check_left-4;
					     xadjbp(check_bp,4)
					end;
							
		inet_p_field:  if check_left>0
			       then begin
					 check_left:=check_left-1;
					 xadjbp(check_bp,1)
				    end
			       else log_err;

	        inet_s_field,
		vbinary_field: check_left:=0;
	   end; { case }
	   rdindex:=rdindex+1;
		  end;
      if check_left>0 then log_err
      end; { validate_rr }
begin { validate_domsg }
new_error:=true;
ok:=true; (* assume innocence *)

{ Validate the question section }


{ Validate the other sections }
for sect_idx:=answer to additional
do with mydomsg.parse[sect_idx]
   do for i:=1 to count
      do begin
	     check_bp:=rdv[i].databp;
	     if not v_type(xildb2(check_bp),check_type)
	     then log_err
	     else if not v_class(xildb2(check_bp),check_class)
		  then log_err
		  else begin
			   check_ttl:=xildb4(check_bp);
			   check_left:=xildb2(check_bp);
			   table:=irdata(check_class);
			   validate_rr
		       end
	 end;

validate_domsg:=ok

end; { validate_domsg }
procedure fix_ttls;

{ FIX_TTLs adjusts the TTL fields of the response }

var	sect:sectcode;
	qtime,index:integer;

begin
qtime:=master^.sb_array[search_scan].tquery;
for sect:=answer to additional
do with pdmsg[search_scan].parse[sect]
   do if truncated
      then for index:=1 to count
	   do (* for truncated sections set cache ttl to zero *)
	      s_ttl(rdv[index].databp,qtime)
      else for index:=1 to count
	   do { if not truncated, convert offset to internal time }
	      s_ttl(rdv[index].databp,qtime-f_ttl(rdv[index].databp))

end; { FIX_TTLS }
function matches_question:boolean;

{ MATCHES_QUESTION checks to see that the response received is to the
  question which was asked }

var result:boolean;
    scandv:g1bpt;

begin
result:=false;
with pdmsg[search_scan].parse[question].rdv[1],
     master^.sb_array[search_scan]
do   begin
	 scandv:=databp;
	 if xildb2(scandv)=stype (* check that the types are the same *)
	 then if xildb2(scandv)=sclass (* class check *)
	      then if dnscomp(namebp,xseto(sname)) (* domain names *)
		   then result:=true
     end;
matches_question:=result
end; { matches_question }
procedure t_new_dg;

{ t_new_dg checks to see if a new datagram is available and if so,
   processes it }

var	push_search_scan:search_block_index;
	i,udptime,raw_delay,new_id,slot_hash:integer;
	newgbp:g1bpt;

	procedure old_reply;

	{ OLD_REPLY is called in response to an arriving datagram which
	  refers to a search block which isn't active or which doesn't
	  match the currently active question }

        begin
	if logging
	then begin
		 myfbp:=ofile(log);
		 Writeln(myfbp^.fident,'Old datagram for slot ',i:1,
			 ' ID ',new_id:4:h,' in state ',master^.rcom[i]:1);
		 if master^.logri<>0
		 then dumpbuffer(newgram,(newgram.rec_count-1)*4,log,myfbp);
		 cfile(myfbp)
	     end
	end; { old_reply }

begin { t_new_dg }

{ Get a newly arrived datagram, log it if debugging is armed, and then
  attempt to associate it with a search block.  The association assumes
  that the ID in the domain protocol header will yield a search block index,
  but also checks to see that the query name matches that in the search
  block. }

while u_receive(master^.resolve_handle,newgram,false)
do    begin
	  { Get slot ID from domain packet ID }
	  newgbp:=xseto(newgram.unspec);
	  xadjbp(newgbp,(newgram.ihl*4)+udp_hdr_sz);
	  new_id:=xildb2(newgbp);
	  i:=bshift(new_id,-did_slot_shift);
	  slot_hash:=idscode(new_id);
	  if xmit_time[slot_hash]=0 (* see if we remember sending it *)
	  then if logging or (master^.logue<>0) or (master^.logrp<>0)
	       then begin (* no record, log if enabled *)
			myfbp:=ofile(log);
			Write(myfbp^.fident,
			      'Ancient datagram ID ',new_id:4:h,' from ');
			toss:=dmpina(myfbp^.fident,newgram.sorc_adr);
			writeln(myfbp^.fident);
			if master^.logri<>0
			then dumpbuffer(newgram,(newgram.rec_count-1)*4,log,myfbp);
			cfile(myfbp)
		    end
	       else
	  else begin (* found record of sending it *)
		   udptime:=msclock-xmit_time[slot_hash];
		   thisto(master^.measure.udpgra,udptime);
		   if master^.measure.udphst[xmit_to[slot_hash]].host<>
		      newgram.sorc_adr
		   then if logging
		        then begin
				 myfbp:=ofile(log);
				 write(myfbp^.fident,
				       'Datagram ID ',new_id:4:h,' from ');
				 toss:=dmpina(myfbp^.fident,newgram.sorc_adr);
				 write(myfbp^.fident,' was sent to ');
				 toss:=dmpina(myfbp^.fident,
				 master^.measure.udphst[xmit_to[slot_hash]].host);
				 writeln(myfbp^.fident);
				 cfile(myfbp)
			     end;
		   with master^.measure.udphst[xmit_to[slot_hash]]
		   do begin
			  tbacks:=tbacks+1;
			  ttotal:=ttotal+udptime
		      end;
		   with master^.measure.newudp[xmit_to[slot_hash]]
		   do begin
			  tbacks:=tbacks+1;
			  ttotal:=ttotal+udptime
		      end;
		   xmit_time[slot_hash]:=0;
	       end;
	  if (i>0) and (i<=max_sb)
	  then	   { The response maps to a search block }
	       if master^.rcom[i]=sb_state_idle
	       then old_reply
	       else begin
			push_search_scan:=search_scan; (* push search_scan *)
			search_scan:=i; (* match to block *)
			if p_rawmsg(pdmsg[i],ptport[i],newgram)
			then if validate_domsg(pdmsg[i],newgram)
			     then (* now check for answer to question we are currently asking *)
				  with pdmsg[search_scan]
				  do if (dhead.qdcount=1) and
					dhead.response and
					(dhead.opcode=std_query)
				     then if matches_question
				          then begin
						   log_recv;
						   fix_ttls;
						   new_dg (* process it *)
					       end
				          else old_reply
				     else begin
					       myfbp:=ofile(err);
					       Writeln(myfbp^.fident,' Irrelevant response received');
					       dumpbuffer(newgram,(newgram.rec_count-1)*4,err,myfbp);
					       cfile(myfbp)
					  end
			     else (* validate failed *)
		        else (* p_rawmsg failed *)
			    begin
				myfbp:=ofile(err);
				Writeln(myfbp^.fident,'P_RAWMSG failed for');
				dumpbuffer(newgram,(newgram.rec_count-1)*4,err,myfbp);
				cfile(myfbp)
			    end;
			search_scan:=push_search_scan (* pop search scan *)
		    end
	       else { The response doesn't seem relevant }
		    begin
			myfbp:=ofile(err);
			Writeln(myfbp^.fident,'reply to non-existent block');
			dumpbuffer(newgram,(newgram.rec_count-1)*4,err,myfbp);
			cfile(myfbp)
		    end { not_relevant }
      end
end; { t_new_dg }
procedure new_service;

{ new_service handles newly arrived requests for resolution }

var	myatom:atom;

begin { new_service }
with master^.sb_array[search_scan],psb[search_scan] do
begin {with}

(* initialize TTL *)
resttl:=band(gtdrcm,bshift(fcode,-gtdrsc));
if (resttl<=0) or (resttl>gtdrcm)
then resttl:=master^.measure.rmttl;

if loghdr
then	  begin
	      Write(myfbp^.fident,'resolving begun for ');
	      ppqtype(stype,myatom);
	      toss:=dmpatom(myfbp^.fident,myatom);
	      write(myfbp^.fident,' ');
	      ppqclass(sclass,myatom);
	      toss:=dmpatom(myfbp^.fident,myatom);
	      write(myfbp^.fident,' ');
	      toss:=dmpdns(myfbp^.fident,xseto(sname));
	      writeln(myfbp^.fident);
	      cfile(myfbp)
	  end;

end; {with}
r_delegation { go start it up }
end; { new_service }
function t_wakeup:boolean;

{ t_wakeup tests to see if the search block needs a wakeup_call }

begin { t_wakeup }
if (master^.rcom[search_scan]=sb_state_waiting) or
   (master^.rcom[search_scan]=sb_state_quiet)
then t_wakeup:=msclock>=master^.sb_array[search_scan].rtimeo
else t_wakeup:=false
end; { t_wakeup }

procedure wakeup;

begin

{ We sent out a query and haven't heard an answer.  Assuming that we aren't
  ready to give up due to the quiet timeout,
  send out another query, possibly to a different name server or name
  server address, and set the alarm clock depending on how far we
  are into the retry process }

if master^.rcom[search_scan]=sb_state_quiet
then res_ret(gtddna) (* this request loses *)
else if master^.sb_array[search_scan].resttl<=0
     then set_state(sb_state_quiet,master^.measure.qtoq) (* quiet wait *)
     else ask_another

end; {wakeup}
procedure rsolve;

var ac1,ac2,ac3,ac4,next_time,hold_time:integer;
    busy:boolean;
    base_elapsed:fruse;

begin { resolver main code }

{ initialization }
master:=getmaster;
u_initialize(false,666,master^.resolve_port,master^.resolve_handle);

for index:=1 to hslots (* clear recent UDP statistics *)
do with master^.measure.newudp[index]
   do begin
	  host:=0;
	  touts:=0;
	  tbacks:=0;
	  ttotal:=0
      end;
master^.measure.udpdcy:=msclock+master^.measure.udphl; (* schedule decay *)

for index:=1 to master^.resolve_dserve.server_count (* setup stat_ptrs *)
do begin
       set_sptrs(master^.resolve_dserve.servers[index]);
       sort_a(master^.resolve_dserve.servers[index])
   end;

for index:=0 to max_xmit_time (* reset outstanding datagram timers *)
do xmit_time[index]:=0;

for search_scan:=1 to max_sb (* initialize UDP ID fields *)
do pdmsg[search_scan].dhead.domain_id:=bshift(search_scan,did_slot_shift);

jsys(gjinf;;ac1,ac2,ac3,ac4); (* setup job number used by blocking test *)
master^.resolve_job:=ac3;
base_elapsed:=master^.measure.rusage;
jsys(runtm;fhslf;ac1,ac2,ac3);
master^.measure.rusage.elwb:=ac3;

{ forever loop }
while true
do with master^
   do begin
	  measure.resolve_loops:=measure.resolve_loops+1;
	  logging:=logrn<>0;

	  { get an update lock on the cache }
	  while not locks(update_lock,1000,60000)
	  do begin
		 myfbp:=ofile(fatl);
		 writeln(myfbp^.fident,'***** Resolver cannot get update lock *****');
		 cfile(myfbp);
		 myfbp:=ofile(err);
		 writeln(myfbp^.fident,'***** Resolver cannot get update lock *****');
		 cfile(myfbp);
	     end;

	  { Set default time for next action.  This time may be changed
	    by the scan of search blocks. }
	  next_time:=msclock;
	  if test_version
	  then next_time:=next_time+measure.ripoll
	  else next_time:=next_time+600000; (* 10 minutes *)

	  busy:=false;
	  for search_scan:=1 to max_sb { all search blocks }
	  do  with sb_array[search_scan]
	      do   begin
		   t_new_dg; (* test for new datagrams *)

		   if rcom[search_scan]=sb_state_new
		   then new_service;

		   if t_wakeup
		   then wakeup;

		   if rcom[search_scan]<>sb_state_idle
		   then begin
			next_time:=min(next_time,rtimeo);
			busy:=true
			end
		   end;

	  ulocks(update_lock); (* release update lock *)

	  if msclock>=measure.udpdcy (* see if its time to decay newudp *)
	  then begin
		   age_newudp;
		   measure.udpdcy:=msclock+measure.udphl; (* schedule next decay *)
	       end;

	  ruse(measure.rusage,base_elapsed); (* update resource usage *)

	  next_time:=min(measure.udpdcy,next_time)-msclock;

	  if next_time>0
	  then if test_version
	       then mswait(next_time)
	       else begin (* special JSYS blocking *)
		    if busy
		    then hold_time:=2000 (* long hold time if busy *)
		    else hold_time:=500; (* shorter if not *)
		    jsys(gtdom,-2,rval;gtdrwt,hold_time,next_time);
		    if rval <>2
		    then begin
			     myfbp:=ofile(fatl);
			     writeln(myfbp^.fident,'Resolver block failed');
			     jsys_err(abort,-1,myfbp)
			 end
		    end;
      end
end. { resolver main } 
{$M-,X+}
program serve;

include {NOLIST} 'jsys.def';
include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:lparse.def';
include {NOLIST} 'domain:naddrr.hdr';
include {NOLIST} 'domain:irdata.hdr';
include {NOLIST} 'domain:tport.hdr';
include {NOLIST} 'domain:msub.hdr';
include {NOLIST} 'domain:pp.hdr';
include {NOLIST} 'domain:mdep.hdr';
include {NOLIST} 'domain:msure.hdr';
include {NOLIST} 'domain:iomsg.hdr';
include {NOLIST} 'domain:dump.hdr';

const	recursion_limit=10;	{ This value is used to define the maximum
				  number of times the search algorithm will
				  follow CNAME chains, etc.; the limit
				  prevents infinite loops during searches.

				  The actual value is stored in the variable
				  recursion_left, and must be decremented and
				  checked every time a potential for loop
				  occurs
				}

var	master:master_block_pointer;	{ base of all tables }
	gmtoff:integer;
	scratch:packed array[1..20] of char;
	i,ns_handle:integer;
	bp:g1bpt;
	message:domsg;
	m_tport:transport;
	raw_message:rawmsg;
	class_index:dclass;
	low_class,high_class:dclass;
	time_value:integer;
	recursion_left:integer;		{ used to prevent infinite loops }
	discard, ok:boolean;

	query_qclass,query_qtype:integer;
	original_query_name:dname_string;
	search_name:dname_string;
	search_cased_name:dname_string;
	search_dst:dname_string_table;
	asp_done:packed array[sectcode] of array [0..max_rrs] of boolean;
procedure sq_one_class(		search_qtype:qtype;
				search_class:dclass;
				dest_section:sectcode;
				ezone:zone_entry_pointer { NS glue zone }
			);forward;

function rrcomp(rrbp:g1bpt;
		myrr:rr_pointer):boolean;

{ This function checks to see that the data in a RR is the same
  as in a string }

var  myttl,mylen,tlen:integer;
     mychunk:rdchunk_pointer;
     bp:g1bpt;
     test_name:dname_string;
     result:boolean;
begin
if xildb2(rrbp)<>ord(myrr^.rrtype) { check the type }
then rrcomp:=false
else if xildb2(rrbp)<>ord(myrr^.rrclass) { check the class }
     then rrcomp:=false
     else begin
     		myttl:=xildb4(rrbp);
		mylen:=xildb2(rrbp);
		mychunk:=myrr^.rdata;
		result:=true;
		while result and (mychunk<>NIL)
		do begin
		       if mychunk^.ckind=lit_chunk
		       then with mychunk^.litdata^ (* binary data compare *)
			    do if lcount>mylen
			       then result:=false
			       else begin
					 bp:=xseto(ldata);
					 xadjbp(bp,2);
					 if ccomp(bp,rrbp,lcount)
					 then begin
						  xadjbp(rrbp,lcount);
						  mylen:=mylen-lcount
					      end
					 else result:=false
				    end
		       else begin { domain name }
			    bp:=xseto(test_name);
			    cvdnp(mychunk^.rrname,bp);
			    bp:=xseto(test_name);
			    tlen:=lendns(bp);
			    if tlen<>lendns(rrbp)
			    then result:=false
			    else if ccomp(bp,rrbp,tlen)
				 then begin
					  xadjbp(rrbp,tlen);
					  mylen:=mylen-tlen
				      end
				 else result:=false
			    end;
			 mychunk:=mychunk^.more
		   end;
		rrcomp:=result and (mychunk=NIL) and (mylen=0)
	  end
end; { RRCOMP }
function lenrdata(myrr:rr_pointer):integer;

{ This function returns the length of the rdata section of an RR,
  not including the fixed 10 byte header }

var	ptr:rdchunk_pointer;
	dnp:dname_pointer;
	count:integer;
begin
count:=0;
ptr:=myrr^.rdata;
while ptr<>NIL
do begin
  	if ptr^.ckind=lit_chunk
	then { binary } 
		count:=count+ptr^.litdata^.lcount
	else { dname }
		begin
		dnp:=ptr^.rrname;
		while dnp<>NIL
		do begin
			count:=count+dnp^.dlabel.labptr^.text[0]+1;
			dnp:=dnp^.more
		   end
		end;
	ptr:=ptr^.more
   end;
lenrdata:=count;
end; { lenrdata }
procedure cpyrr(    myrr:rr_pointer;
 	 	 var bp:g1bpt);

{ This routine outputs a RR in linear format, including its fixed header.
  The byte pointer gets updated }

var	count,sum:integer;
	temp_bp,frombp,sumptr:g1bpt;
	ptr:rdchunk_pointer;
	dnp:dname_pointer;
begin
{ Output the fixed header }
xidpb2(bp,ord(myrr^.rrtype));
xidpb2(bp,ord(myrr^.rrclass));
xidpb4(bp,myrr^.ttl);
sumptr:=bp;
xidpb2(bp,0); (* reserve space *)
sum:=0;

ptr:=myrr^.rdata;
while ptr<>NIL
do begin
  	if ptr^.ckind=lit_chunk
	then { binary } 
	     begin
		 frombp:=xseto(ptr^.litdata^.ldata);
		 count:=xildb2(frombp);
		 sum:=sum+count;
		 ccopy(frombp,bp,count)
	     end
	else { dname }
		begin
		dnp:=ptr^.rrname;
		temp_bp:=bp;
		cvdnp(dnp,bp); { copy with case adjustment }
		sum:=sum+lendns(temp_bp);
		end;
	ptr:=ptr^.more
   end;
xidpb2(sumptr,sum)
end; (* cpyrr *)
function copy_hits(	search_qtype:qtype;
			use_nodename:boolean;
			from_node:node_pointer;
			dest_section:sectcode):integer;

{	COPY_HITS copies all RRs that match search_qtype into
	the specified section.  SCAN points to a RR chain.

	The value of copy_hits is equal to the number of RRs copied
	or duplictes tossed }

var	i,len_name,len_new_rr,copied:integer;
	scan:rr_pointer;
	name_stored,found:boolean;
	node_name_bp,bp,equal_name:g1bpt;
	scan_sect:sectcode;
	node_name:dname_string;
begin
scan:=from_node^.rr_ptr;
copied:=0;
name_stored:=false; (* name not already stored in domsg *)
if use_nodename
then begin
	 node_name_bp:=xseto(node_name);
	 bp:=node_name_bp;
	 cvnnp(from_node,bp);
     end
else node_name_bp:=xseto(search_cased_name);
while scan<>NIL
do begin
       if tmatch(internet,search_qtype,scan^.rrtype)
       then begin
	    found:=false; (* look for a duplicate RR *)
	    for scan_sect:=answer to dest_section
	    do if not found
	       then with message.parse[scan_sect]
		    do begin (* check all RRs in a section *)
			   i:=1;
			   while not(found) and (i<=count)
			   do if dnscomp(node_name_bp,rdv[i].namebp)
			      then begin { names match }
				   equal_name:=rdv[i].namebp;
				   repeat if rdv[i].namebp=equal_name
				          then if rrcomp(rdv[i].databp,scan)
					       then found:=true
					       else begin
							i:=i+1;
							if i<=count
							then if rdv[i].namebp<>equal_name
							     then equal_name:=nil
							     else
						   end
				   until found or (i>count) or (equal_name=NIL)
				   end
			      else i:=i+1 { names don't match }
		       end;
	    if not found
	    then with message.parse[dest_section]
		 do begin (* not a duplicate, add it *)
			len_name:=lendns(node_name_bp);
			len_new_rr:=lenrdata(scan)+10;
			if not name_stored
			then len_new_rr:=len_new_rr+len_name;
			if (count=max_rrs) or (message.free_cnt<len_new_rr)
			then truncated:=true
			else begin (* create the RR *)
				message.free_cnt:=message.free_cnt-len_new_rr;
				count:=count+1;
				asp_done[dest_section][count]:=false;
				if name_stored
				then rdv[count].namebp:=rdv[count-1].namebp
				else begin
					  rdv[count].namebp:=message.free_ptr;
					  copydns(node_name_bp,message.free_ptr);
					  xadjbp(message.free_ptr,len_name);
					  name_stored:=true
				      end;
				 rdv[count].databp:=message.free_ptr;
				 cpyrr(scan,message.free_ptr);
			     end;
		    end;
	    copied:=copied+1
	    end;
       scan:=scan^.next
   end;
copy_hits:=copied

end; { copy_hits }

function csearch(	search_qtype:qtype;
			search_class:dclass;
			dest_section:sectcode):boolean;

begin
csearch:=false	{ no cache search for now }
{ Fix output routine to understand TTL }
end; { csearch }

procedure asp(scode:sectcode;	{ section of entry to check }
	      index:integer;	{ entry index }
	      ez:zone_entry_pointer);	{ glue search zone }

{	ASP does the additional section processing for a
	single entry in the message }

var	cdscan,csize:integer;
	chunk:g1bpt;
	table:rdata_table_pointer;
	myclass:dclass;
	icode:rdata_field;
begin
if not asp_done[scode][index]
then begin
	asp_done[scode][index]:=true;
	chunk:=message.parse[scode].rdv[index].databp;
	myclass:=f_class(chunk);
	table:=irdata(myclass);
	with table^[f_type(chunk)]
	do begin
		st_rdata(chunk); (* skip to rdata *)
		cdscan:=1;
		repeat icode:=rdata_item[cdscan];
		       case icode of
		dname_field: begin
			     csize:=lendns(chunk);
			     if rdata_asp[cdscan]<>ord(dtype_l_bound)
			     then begin { asp required }
				  ccdns(chunk,xseto(search_name));
				  copydns(chunk,xseto(search_cased_name));
				  m_dst(xseto(search_name),search_dst);
				  sq_one_class(rdata_asp[cdscan],
					       myclass,additional,ez)
				  end;
			     end;
		cstring_field:     csize:=peekb(chunk)+1;

		time_field,int32_field,inet_a_field: csize:=4;

		int16_field: csize:=2;

		inet_p_field: csize:=1;

		others:	      icode:=no_more_field
		       end; { case }
		       xadjbp(chunk,csize);
		       cdscan:=cdscan+1;
		until  icode=no_more_field
	   end;
   end
end; { asp }

procedure asp_all;

{	ASP_ALL calls ASP to perform additional section processing for
	the message
}

var	scode:sectcode;
	i:integer;

begin
for scode:=answer to authority	{ don't asp the additional section }
do with message.parse[scode]
   do begin
	   i:=1;
	   while i<=count { and records in the section }
	   do begin
		   if not asp_done[scode][i] { if not already done }
		   then	{ and there is space for an answer }
			if (message.parse[additional].count<max_rrs) and
			    not(message.parse[additional].truncated)
			then asp(scode,i,NIL); { do asp }
		   i:=i+1
	      end
      end

end; { asp_all }
function asearch(	search_qtype:qtype;
			search_match:integer;
		 	myzone:zone_entry_pointer;
			dest_section:sectcode;
			glue_search:boolean
		):boolean;

{ ASEARCH searches an authoritative zone for the desired RR
  or RRs.  The search terminates with a referral, name error, or
  answer for a normal search.  If a glue serch is specified, the
  search terminates in an answer or failure, but never a referral

  ASEARCH returns true if the search completed the request, i.e.
  found the answer, or found that the node didn't exist }

type	search_state=(above,inside,below);	{ where is serch in zone with
						respect to region of authority}

var	result:boolean;
	state:search_state;
	spoint,next_spoint:node_pointer;
	aresult,search_cond:boolean;
	scan:rr_pointer;
	toss:integer;
	start_refs,hit_idex:integer;

	procedure include_soa;

	begin { this gets called when the SOA may want to be copied into
	        the authority section if we are putting authoritative stuff
		in the answer section }
        if (dest_section=answer) and (recursion_left=recursion_limit)
        then toss:=copy_hits(ord(soa),true,myzone^.zsoa,authority)
	end; { include_soa }
	
	function star_search:boolean;

	{	STAR_SEARCH looks for a * label match	}
	
	var	star_label:packed array[0..63] of octet;
		toss:integer;

	begin
	star_label[0]:=1;
	star_label[1]:=ord('*');
	if f_son(spoint,xseto(star_label),spoint,toss)
	then begin
		  start_refs:=message.parse[dest_section].count+1;
		  toss:=copy_hits(search_qtype,false,spoint,dest_section);
		  star_search:=true
	     end
	else star_search:=false
	end { star_search };

begin
{ Initialize the search.  For a regular zone it starts where the search
  tree left off.  For a glue search, it must restart at the root }

if glue_search
then begin
	 state:=above; (* start glue search at root *)
	 spoint:=myzone^.zone_node;
	 search_match:=search_dst.count
     end
else begin
	 state:=inside;		{ initialize search state to inside (SOA) }
	 spoint:=myzone^.zsoa;	{ search pointer to top of authority }
     end;

{ Now descend to the named node, name error, or delegation }

if search_match>1 (* are there more labels to match *)
then repeat search_match:=search_match-1;
   	    search_cond:=f_son(spoint,search_dst.bp[search_match],next_spoint,toss);
	    if search_cond
	    then begin
		 spoint:=next_spoint;
		 case state of
    above:	    if spoint^.node_lchain<>NIL then state:=inside;
    inside:	    if spoint^.node_lchain=NIL (* drop off the bottom? *)
		    then begin
			  state:=below;
			  if not glue_search then search_cond:=false
		         end;
    below:	 end { case }
		 end
	    else search_match:=search_match+1;
     until  (search_cond=false) or (search_match=1);

{ search is complete, separate cases }
aresult:=(search_match=1) and ( (state=inside) or glue_search);
start_refs:=message.parse[answer].count+1; { save for glue scan iff top node }
if aresult
then { found the node }
     if copy_hits(search_qtype,true,spoint,dest_section)=0
     then { Nothing copied, go for cname }
	  if not(glue_search) and (dest_section=answer)
	  then if copy_hits(ord(CNAME),true,spoint,answer)<>0
	       then { CNAME there, restart search }
		    if recursion_left>0
		    then begin { restart query }
			 recursion_left:=recursion_left-1;
			 scan:=spoint^.rr_ptr;
			 while scan^.rrtype<>CNAME
			 do scan:=scan^.next;
			 bp:=xseto(search_name);
			 ccvdnp(scan^.rdata^.rrname,bp);
			 bp:=xseto(search_cased_name);
			 cvdnp(scan^.rdata^.rrname,bp);
			 m_dst(xseto(search_name),search_dst);
			 sq_one_class(search_qtype,scan^.rrclass,answer,NIL);
			 recursion_left:=recursion_left+1
		         end
		    else message.dhead.rcode:=server_failure
	       else { No CNAME there }
	  else
     else (* answers copied, all done *)
	  if state=inside
	  then begin
		   include_soa; (* add SOA to AA answer *)
		   if (dest_section=answer) and (spoint=myzone^.zsoa)
		   then for hit_idex:=start_refs to message.parse[answer].count
		        do if (hit_idex<=max_rrs) (* special asp for top ns *)
			   then if f_type(message.parse[answer].rdv[hit_idex].databp)=ns
			        then asp(answer,hit_idex,myzone)
	       end
	  else
else if not glue_search { did not find the node }
     then if state=below { search of authoritative zone}
	  then if dest_section=answer	{ referral }
	       then begin (* pass on referrals for question only *)
		       start_refs:=message.parse[authority].count+1;
		       if copy_hits(ord(ns),true,spoint,authority)>0
		       then { special search for NS referrals }
			    for hit_idex:=start_refs to message.parse[authority].count
			    do asp(authority,hit_idex,myzone)
		    end
	       else
	  else { either name error or * match }
	       begin
		   aresult:=true;
		   if not star_search
		   then if dest_section=answer
			then message.dhead.rcode:=name_error;
		   include_soa
	       end;
	  
asearch:=aresult
end; { asearch }

procedure sq_one_class;

{	sq_one_class processes a standard query for a specific class.

	It returns true if it finds the answer. (Regardless of zone) }

var	auth_zone:zone_entry_pointer;
	result:boolean;
	scanptr:zone_entry_pointer;
	now_at:node_pointer;
	i,search_last,toss:integer;
	s_result:boolean;
begin
auth_zone:=NIL;
{ Find and lock authoritative zone (if any) }
while not locks(master^.search_zone.zone_lock,100,2000) do; {get search lock}
now_at:=master^.search_zone.zone_node;

i:=search_dst.count; (* start at root *)
repeat	if now_at^.zone_ptr<>NIL
	then	begin (* find zone with matching class *)
		scanptr:=now_at^.zone_ptr;
		while scanptr<>NIL
		do	if (scanptr^.zone_class=search_class)
				AND
			   scanptr^.loaded
			then	begin
				auth_zone:=scanptr;
				search_last:=i;
				scanptr:=NIL
				end
			else	scanptr:=scanptr^.zone_chain
		end;
	i:=i-1;	(* move down one label *)
	if i<>0
	then	s_result:=f_son(now_at,search_dst.bp[i],now_at,toss)
until	(i=0) or (not(s_result));
if auth_zone<>NIL (* lock the authoritative zone *)
then while not locks(auth_zone^.zone_lock,100,2000) do;
ulocks(master^.search_zone.zone_lock); {release search zone lock}

if auth_zone<>NIL
then	{ search a zone where authoritative answer or delegation will result }
	begin
	result:=asearch(search_qtype,
			search_last,
			auth_zone,
			dest_section,
			false);
	if (dest_section=answer)
		AND
	   (recursion_left=recursion_limit)
	then message.dhead.aa:=result
	end
else	result:=false;

{ is no authoritative search was performed, or if it didn't get the
  answer, try searching the cache }

if not result
then	result:=csearch(search_qtype,
			search_class,
			dest_section);

{ if we still don't have the answer, but a glue zone was specified,
  try searching it }

if (not(result)) and (ezone<>NIL)
then	result:=asearch(search_qtype,
			search_last,
			ezone,
			dest_section,
			true);

if auth_zone<>NIL (* unlock authoritative zone, if any *)
then ulocks(auth_zone^.zone_lock);
end; { sq_one_class }
procedure dosq;

var	qindex:qgraph_index;
	myatom:atom;
	myfbp:file_blk_ptr;
	toss:integer;

begin {dosq}
if (message.parse[question].count<>1) or message.parse[question].truncated
then message.dhead.rcode:=format_error
else begin
	 message.dhead.rcode:=0; { presume innocence }
	 message.dhead.aa:=false;
	 with message.parse[question].rdv[1] (* setup query *)
	 do begin
		bp:=databp;
		query_qtype:=xildb2(bp);
		query_qclass:=xildb2(bp);
		copydns(namebp,xseto(search_cased_name));
		copydns(namebp,xseto(original_query_name));
		ccdns(namebp,xseto(search_name));
		m_dst(xseto(search_name),search_dst)
	    end;

	 if (query_qtype>0) and (query_qtype<=qslots) (* qgraph *)
	 then qindex:=query_qtype else qindex:=qslots;
	 xaos(master^.measure.nsbyqt[qindex]);

	 if (query_qclass>0) and (query_qclass<=cslots) (* cgraph *)
         then qindex:=query_qclass else qindex:=cslots;
	 xaos(master^.measure.nsbyqc[qindex]);

	 if query_qclass=star	(* setup class loop *)
	 then	begin
		    low_class:=succ(dclass_l_bound);
		    high_class:=pred(dclass_h_bound)
		end
	 else	if query_qclass>=ord(dclass_h_bound)
	        then	message.dhead.rcode:=format_error
		else	begin
			    low_class:=chrclass(query_qclass);
			    high_class:=low_class
			end;
		
	 if message.dhead.rcode=0 { loop over search classes }
	 then for class_index:=low_class to high_class
	      do begin
		     recursion_left:=recursion_limit;
		     sq_one_class(query_qtype,class_index,answer,NIL)
		 end;
	 asp_all;	{ perform asp }
		     
	 if low_class<>high_class then message.dhead.aa:=false;

	 { Update counts }
	 message.dhead.ancount:=message.parse[answer].count;
	 message.dhead.nscount:=message.parse[authority].count;
	 message.dhead.arcount:=message.parse[additional].count;

	 if master^.logns<>0 (* name server summary logging *)
	 then begin
		  myfbp:=ofile(log);
		  dmphst(myfbp^.fident,m_tport.foreign_address);
		  write(myfbp^.fident,' ');
		  write(myfbp^.fident,message.dhead.domain_id:4:h);
		  write(myfbp^.fident,' ');
		  ppqtype(query_qtype,myatom);
		  toss:=dmpatom(myfbp^.fident,myatom);
		  write(myfbp^.fident,' ');
		  ppqclass(query_qclass,myatom);
		  toss:=dmpatom(myfbp^.fident,myatom);
		  write(myfbp^.fident,' ');
		  toss:=dmpdns(myfbp^.fident,xseto(original_query_name));
		  if message.dhead.rcode<>0
		  then write(myfbp^.fident,' RCODE=',message.dhead.rcode:1);
		  writeln(myfbp^.fident);
		  cfile(myfbp)
	      end
	 
    end;
	 
end; {dosq}
procedure serve;

var     ac1,ac2,ac3:integer;
	toss:integer;
	baseline:fruse;
	sect_idex:sectcode;

begin { serve }

jsys(odtim;scratch,-1,0); (* compute ODTIM offset for GMT to local *)
for ac1:=11 to 20
do if (scratch[ac1]>'0') and (scratch[ac1]<='9')
   then scratch[ac1]:='0';
jsys(idtim,1;scratch,0;ac1,gmtoff);

master:=getmaster;

baseline:=master^.measure.nusage; (* setup fork resource measurement *)
jsys(runtm;fhslf;ac1,ac2,ac3);
master^.measure.nusage.elwb:=ac3;

u_initialize(true, (* this is a server *)
	     dns_socket,toss,ns_handle);

while true (* forever *)
do begin
   if u_receive(ns_handle,raw_message,true)
   then	if not p_rawmsg(message,m_tport,raw_message)
        then xaos(master^.measure.pfail)
        else if message.dhead.response (*  ignore bogons *)
	     then begin
		  xaos(master^.measure.bogon);
	          xaos(master^.measure.nsuhst[hlook(m_tport.foreign_address,
				  master^.measure.nsuhst)].touts)
		  end
	     else begin
		     time_value:=msclock;
		     xaos(master^.measure.nsuhst[hlook(m_tport.foreign_address,
				  master^.measure.nsuhst)].touts);
		     xaos(master^.measure.nsugra.touts);
		     message.dhead.response:=true;

		     case message.dhead.opcode of

std_query:	       dosq; { standard query }

inv_query:	       message.dhead.rcode:=not_implemented; { inverse query }
    
cm_query:              message.dhead.rcode:=not_implemented;

cu_query:              message.dhead.rcode:=not_implemented;

others:                message.dhead.rcode:=format_error

		     end; { case by query type}

		     { do statistics for AA, truncation, section sizes }
		     if message.dhead.aa then xaos(master^.measure.nsaa);

		     for sect_idex:=question to additional
		     do with message.parse[sect_idex],master^.measure.nssgra[sect_idex]
			do begin
			       if truncated then xaos(strun);
			       xaos(ssize[min(count,sgmax)])
			   end;

		     { send response in message }
		     f_rawmsg(message,m_tport,raw_message);
		     s_rawmsg(ns_handle,m_tport,raw_message);
		     if raw_message.dhead.tc then xaos(master^.measure.nudptc);
		     time_value:=msclock-time_value;
		     thisto(master^.measure.nsugra,time_value);
		     hhisto(master^.measure.nsuhst,time_value,m_tport.foreign_address);
		     xaos(master^.measure.nsucod[message.dhead.rcode]);
		     end;

   jsys(gtad;;ac1); (* bump time of day graph *)
   ac1:=bshift(band(ac1-gmtoff,rh)*(dimax+1),-18);
   xaos(master^.measure.nsbyds[ac1]);

   ruse(master^.measure.nusage,baseline)	  
   end
end.

{$M-,X+}

include {NOLIST}'pascal:pascmd.pas';
include {NOLIST}'domain:mdep.def';
include {NOLIST}'domain:master.def';
include {NOLIST}'domain:msub.hdr';
include {NOLIST}'domain:dsconv.hdr';
include {NOLIST}'domain:irdata.hdr';
include {NOLIST}'domain:dump.hdr';
include {NOLIST}'domain:eutil.hdr';
include {NOLIST}'domain:pp.hdr';


procedure get_dname(var name:exp_dname);

{ Prompt for a domain name, parse and store in name.
  "." alone signifies the root.  Leading and trailing
  blanks are ignored.  Any sequence of ". " signifies
  end of dname.  Note:  No real syntax checking is
  included so "bad" dnames may be passed along. }

var	i, j, len, cnt:integer;
	last_char:char;
	done:boolean;
	buf:big_atom;

begin
    i:=1;
    j:=1;
    cminir('domain name  ');
    len:=cmtxt(buf);

    {toss leading blanks}
    while (i<=len) and (buf[i]=' ') do
	i:=i+1;
    done:=i>len;

    {set initial counts and toss trailing blanks, if necessary}
    if not done
    then begin
	     name.count:=1;  {assume at lease one segment}
	     name.dlabels[1].labinfo[0]:=0;
	     cnt:=i;
	     while (cnt<=len) and (buf[cnt]<>' ') do	
		 cnt:=cnt+1;
	     cnt:=cnt-1;
	     len:=cnt-i+1;
	 end;
    
    {store dname}
    while not done do
    with name.dlabels[name.count] do
    begin	
	if buf[i]='.' 
	then begin {complete segment}
		 if i=cnt
		 then {end of dname}
		     done:=true;
		 if len<>1
		 then begin  {advance cntrs except if root only}
			  j:=1;
			  name.count:=name.count+1;
			  name.dlabels[name.count].labinfo[0]:=0;
			  if name.count=max_lab_levels
			  then {cut off here regardless of what's left}
			      done:=true;
		      end
	     end
        else begin  {store character}    
		 case_mod[j]:=(buf[i]>='a') and (buf[i]<='z');
		 if case_mod[j]
		 then  {lower->upper case}
		     labinfo[j]:=ord(buf[i])-40b
	         else  {upper case}
		     labinfo[j]:=ord(buf[i]);
		 labinfo[0]:=labinfo[0]+1;
		 j:=j+1;
	     end;
	i:=i+1;
	done:=(i>cnt) or done;
    end;  {i loop}	 

    if buf[cnt]<>'.'
    then begin  {create root segment}
	     name.count:=name.count+1;
	     name.dlabels[name.count].labinfo[0]:=0;
	 end;
end;  {get_dname}



procedure get_qsctn( var qsec:qsection;
			 count:integer);

{ Prompt to terminal to obtain all information needed to
  fill a qsection (for query input). }

var	i, xxx:integer;
	ok:boolean;
	short_buf:atom;
	ty:qtype;
	cl:qclass;

begin {get_qsctn}

with qsec do
begin
    for i:=1 to count do
    begin	
	{get qname}
	get_dname(qnames[i]);

	{fill in remainder of section}
	repeat
	    cminir('type (use qtype)  ');
	    xxx:=cmtxt(short_buf);
	    ok:=cvqtype(short_buf, ty);
	    if not ok
	    then writeln('ERROR--use qtype')
	    else qtypes[i]:=ty;	
	until ok;

	repeat
	    cminir( 'class (use qclass)  ');
	    xxx:=cmtxt(short_buf);
	    ok:=cvqclass(short_buf, cl);
	    if not ok
	    then writeln('ERRROR--use qclass')
	    else qclasses[i]:=cl;	
	until ok;
	
    end; {i loop}
end; {with}
end; {get_qsctn}



procedure get_exp_sctn(var sec:section;
			   op:integer);

{ Prompt to terminal to obtain all information needed to
  fill expanded portions of section (for query input). }

var	i, j, k, l, {loop vars}
	len, factor, limit, ovfl:integer;  {misc temps}
	ok, done:boolean;
	short_buf:atom;
	buf:big_atom;
	tbl:rdata_table_pointer;

begin {get_exp_sctn}

    ok:=true;

    for i:=1 to sec.exp_count do
    with sec.exp[i].rr_data do
    begin

	{get dname for other than inv_query since the
	 dname is the answer for an inverse query}
	if op<>inv_query 
	then get_dname(sec.exp[i].owner)
	else sec.exp[i].owner.count:=0;

	ttl:=0;
	repeat	{rrtype}
	    cminir('type (use dtype)  ');
	    len:=cmtxt(short_buf);
	    ok:=cvtype(short_buf, rrtype);
	    if not ok
	    then writeln('ERROR--use dtype');
	until ok;
	
	repeat	{rrclass}
	    cminir('class (use dclass)  ');
	    len:=cmtxt(short_buf);
	    ok:=cvclass(short_buf, rrclass);
	    if not ok
	    then writeln('ERRROR--use dclass');
	until ok;
	
	if op=inv_query
	then begin  {get rdata for inverse queries}

		 if i=1
		 then  {only create once}
		     tbl:=irdata(rrclass);

		 j:=0;
		 repeat
		     j:=j+1;
		     case tbl^[rrtype].rdata_item[j] of
			 dname_field: begin
					  chunks[j].ckind:=name_chunk;
					  get_dname(chunks[j].rrname);
				      end;
			 cstring_field: with chunks[j] do
					begin
					    ckind:=lit_chunk;
					    {use specific knowledge
					     about hinfo record}
					    if j=1
					    then cminir('cpu string  ')
					    else cminir('os string  ');
					    len:=cmtxt(buf);
					    k:=1;
					    lit_data[k]:=len;
					    for k:=2 to len+1 do
						lit_data[k]:=ord(
							 buf[k-1]);
					    lit_data_count:=k-1;
					end;  {with}

			 int16_field:  with chunks[j] do
				       begin
					   cminir('16 bit integer  ');    
					   len:=cmnum;
					   ckind:=lit_chunk;
					   lit_data_count:=2;
					   l:=1;
					   for k:=3 downto 2 do
					   begin    
					       lit_data[l]:=band(bshift(len,
							-(k*8)), 377b);
					       l:=l+1;
					   end;
				       end;

			 time_field,
			 int32_field:  with chunks[j] do
				       begin
					   if tbl^[sec.exp[i].rr_data.rrtype].
					       rdata_item[j] = time_field
					   then cminir('time in seconds  ')
					   else cminir('32 bit integer  ');    
					   len:=cmnum;
					   ckind:=lit_chunk;
					   lit_data_count:=4;
					   l:=1;
					   for k:=3 downto 0 do
					   begin    
					       lit_data[l]:=band(bshift(len,
							-(k*8)), 377b);
					       l:=l+1;
					   end;
				       end;
			 
			 inet_a_field: with chunks[j] do
				       begin
					   repeat
					       cminir('4-octet IN addr  ');
					       len:=cmtxt(short_buf);
					       ok:=cvina(short_buf, len);
					       if not ok
					       then writeln(
					        'use dotted decimal notation');
					   until ok;
					   l:=1; 
					   for k:=3 downto 0 do
					   begin
					       lit_data[l]:=band(bshift(len,
								-(k*8)), 377b);
					       l:=l+1;
					   end;
					   lit_data_count:=4;
				       end;
			 
			 inet_p_field: with chunks[j] do
				       begin
					   ckind:=lit_chunk;
					   lit_data_count:=1;
					   repeat
					       cminir('protocol string  ');
					       len:=cmtxt(short_buf);
					       ok:=cvptcl(short_buf, len);
					       if not ok
					       then writeln(
						    'not a valid protocol');
					   until ok;
					   lit_data[1]:=len;
				       end;

			 inet_s_field: with chunks[j] do
				       begin
					   ckind:=lit_chunk;
					   for k:=1 to 32 do  {clear bitmap}
					       lit_data[k]:=0;

					   cminir('port string or "done" ');
					   len:=cmtxt(short_buf);
					   done:=compatom(short_buf,
							  'done           ');
					   while not done do
 					   begin
					       ok:=cvport(short_buf, 0, len);
					       if not ok
					       then writeln(
						    'not a valid port')
					       else begin
						    k:= (len div 8)+1;
						    lit_data[k]:=
						    lit_data[k] +
						    bshift(128,
							   -(len mod 8));
						    end;
					       cminir(
					           'port string or "done" ');
					       len:=cmtxt(short_buf);
					       done:=compatom(short_buf,
							  'done           ');
					   end;
					   {set actual size of bitmap}
					   k:=32;
					   while lit_data[k]=0 do
					       k:=k-1;
					   lit_data_count:=k;
				       end;
			 
			 {oh, no...monkey with j in this section}
			 vbinary_field: begin
					    cminir('# octets ');
					    len:=cmnum;
					    if len > ((max_chunk-j+1)*
						      max_binary_octets)
					    then begin
						     len:=((max_chunk-j+1)*
							max_binary_octets);
						     writeln(len:0,
							     ' available');
						 end;
					    {set-up limit, ovfl, and len
					     to control loop for filling
					     vbinary chunks}
					    limit:=len div max_binary_octets;
					    ovfl:=len mod max_binary_octets;
					    if (limit<max_chunk) and
						(ovfl>0)
					    then limit:=limit+1;	
					    len:=max_binary_octets;

					    while j<=limit do
					    with chunks[j] do
					    begin
						{fill partial chunk}
						if (j=limit) and 
						    (ovfl>0)
						then len:=ovfl;   

						for k:=1 to len do
					        begin
						    cminir('octet ');
						    lit_data[k]:=cmnum8;
						end;
						lit_data_count:=len;
						j:=j+1;
					    end;
					end;
		     end; {case}
		 until (tbl^[rrtype].rdata_item[j]
			      =no_more_field) or not ok;
		 chunk_count:=j-1;
		 ok:=rrsquash(sec.exp[i].rr_data);
	     end; {op=inv_query}
    end; {i loop}
end; {get_exp_sctn}



procedure dump_pkt(var pkt:message_template);

{ Print the header (octal), and data in both 
  octal character format.  This routine is
  called when dg_dump=true. }

var	  i:integer;
	  myatom:atom;

begin {dump_pkt}

    with pkt do
	begin
	    ppina(from_address,myatom);
	    write('From: ',myatom,' port ',from_port:5);
	    ppina(to_address,myatom);
	    writeln(' To: ',myatom,' port ',to_port:5)
	    end;

    with pkt.raw_pkt.header do
    begin {print header contents}
	writeln;
	writeln('id:', id:6:O,
		'   qr:', ord(response):1:O,
		'   opcode: ', opcode:1:O,
		'   aa:', ord(aa):1:O,
		'   tc:', ord(tc):1:O);

	writeln('rd:', ord(rd):1:O,
		'        ra:', ord(ra):1:O,
		'   rcode:', rcode:2:O,
		'    qdcount:', qdcount:6:O);

	writeln('ancount:', ancount:6:O,
		'   nscount:', nscount:6:O,
		'   arcount:', arcount:6:O);
	writeln;
    end; {with}
	
    with pkt.raw_pkt do
    begin {print data}
	write('data:  ');
	for i:=1 to pkt.octet_cnt do
	begin
	    write(data_recs[i]:3:O);
	    if (ord(chr(data_recs[i]))<32)
	    then write(' .   ')  {non-printable}
	    else write(' ', chr(data_recs[i]), '   ');
	    if (i mod 8) = 0
	    then begin
		     writeln;
		     write('       ');
		 end;
	end;
    end; {with}
    writeln;
end; {dump_pkt}


procedure pr_error(return:field4);

{ Based on the type of error, print an appropriate
  error message. }

begin {pr_error}
    
    writeln;
    case return of
	format_error: begin
			  writeln('Format Error');
			  writeln('Name server was',
				   ' unable to interpret query');
		      end;
	server_failure: begin
			    writeln('Server Failure');
			    writeln('Name server was unable',
				    ' to process query');
			end;
	name_error: begin
			writeln('Name Error' );
			writeln('Domain name referenced',
				 ' in query does not exist');
		    end;
	not_implemented: begin
			     writeln('Not Implemented');
			     writeln('Name server does not ',
				      'support this type of query');
			 end;
	refused: begin
		     writeln('Refused by Name Server');
		     writeln('Operation refused for ',
			      ' NS policy reasons' );
		 end;
    end;  {case}
end;  {pr_error}



procedure pr_sctn(var sctn:section);

{ Print the contents of the section.
  Remember that literal data has been "squashed",
  dnames in their own rdata chunk. }

var	i, j, k, tmp, void, count, bits, offset:integer;
	str1, str2:atom;
	tbl:rdata_table_pointer;

begin {pr_sctn}

    {create rdata map}
    tbl:=irdata(sctn.exp[1].rr_data.rrclass);

    for i:=1 to sctn.exp_count do
    with sctn.exp[i].rr_data do
    begin
	tmp:=dmpedn(output, sctn.exp[i].owner);
	j:=1;
	repeat  {pad}
	    write(' ');
	    j:=j+1;
	until j>(22-tmp);
	
	{type, class, ttl}
	pptype(rrtype, str1);
	ppclass(rrclass, str2);
	write(str1:7, str2:7, 'ttl:', ttl:4, '  ');

	j:=1; {rdata field indexer}
	count:=1; {rdchunk vars}
	offset:=1;

	while tbl^[rrtype].rdata_item[j]<>no_more_field do
	begin
	    case tbl^[rrtype].rdata_item[j] of
		dname_field:
		    begin
			tmp:=dmpedn(output, chunks[count].rrname);
			write(' ');
			count:=count+1;  {next chunk}
			offset:=1;
		    end;
		
		cstring_field:
		      begin
			  {string endpoint}
			  tmp:=chunks[count].lit_data[offset]+offset+1;
			  offset:=offset+1;

			  while offset<tmp do
			  begin	
			      write(chr(chunks[count].lit_data[offset]));
			      offset:=offset+1;
			  end;
			  write(' ');
		      end;
		
		int16_field:
		    begin
			tmp:=0;
			for k:=1 to 2 do
			begin
			    tmp:= tmp+
				  bshift(chunks[count].lit_data[offset],
						       8*(2-k));
			    offset:=offset+1;
			end;
			ppint(tmp,str1);
			tmp:=dmpatom(output,str1);
			write(' ');
		    end;

		time_field,
		int32_field:
		    begin
			tmp:=0;
			for k:=1 to 4 do
			begin
			    tmp:= tmp+
				  bshift(chunks[count].lit_data[offset],
						       8*(4-k));
			    offset:=offset+1;
			end;
			ppint(tmp,str1);
			tmp:=dmpatom(output,str1);
			write(' ');
		    end;
		
		inet_a_field:
		     for k:=1 to 4 do
		     begin    
			 write(chunks[count].lit_data[offset]:0);
			 offset:=offset+1;
			 if k<>4
			 then write('.')
			 else write(' ');
		     end;
		     
		inet_p_field:
		     begin
			 ppptcl(chunks[count].lit_data[offset], str1);
			 offset:=offset+1;
			 tmp:=dmpatom(output, str1);
			 write(' ');
		     end;
		
		inet_s_field:
		     begin
			 {print the bitmap}
			 for k:=1 to chunks[count].lit_data_count-5 do
			 begin  
			     if chunks[count].lit_data[offset]>0
			     then begin   {convert the bits}
				      bits:=chunks[count].lit_data[offset];
				      for tmp:=0 to 7 do
				      begin
					  if (bits div bshift(128, -tmp)) > 0
					  then begin
						   ppport((k-1)*8+tmp,
							  0, str1);
						   void:=dmpatom(output, str1);
						   write(' ');
					       end;
					  bits:=bits mod bshift(128, -tmp);
				      end;
				  end;
			     offset:=offset+1;
			 end;
		     end;
		
		vbinary_field:
		      begin
			  writeln;
			  while count<=chunk_count do
			  begin
			      for k:=1 to chunks[count].lit_data_count do
			      begin
				  write(chunks[count].lit_data[k]);
				  if (k mod 8)=0
				  then writeln;
			      end;
			      count:=count+1;
			  end;
		      end;
		
	    end; {case}
	    j:=j+1;
	    if chunks[count].ckind=lit_chunk
	    then if offset>=chunks[count].lit_data_count
		 then begin
			  count:=count+1;
			  offset:=1;
		      end;
        end;
	writeln;
    end;
end;  {pr_sctn}




procedure pr_response(var resp:query_template);

{ Print sections relevant for reply }

var	i, j, cnt:integer;
	void:boolean;
	str1, str2:atom;

begin {pr_response}

with resp.header do
begin
    {report header information}
    if aa or tc
    then begin
	     write('Response:  ');
	     if aa
	     then write('Authoritative  ');
	     if tc
	     then write('Truncated');
	     writeln;
	 end;
    
    if opcode=inv_query
    then with resp.q_section do
	 begin  {print question section(s)}
	     if qdcount=0
	     then writeln('No inverse match found')
	     else begin
		      writeln('<question>');
		      for i:=1 to qdcount do
		      begin
			  cnt:=dmpedn(output, qnames[i]);
			  j:=1;
			  repeat
			      write(' ');
			      j:=j+1;
			  until j>(22-cnt);
			  pptype(chrtype(qtypes[i]), str1);
			  ppclass(chrclass(qclasses[i]), str2);
			  writeln(str1:7, str2:7);
		      end;
		  end;
	 end
    else if (ancount+nscount+arcount) = 0
	 then writeln('No matching records found')
	 else begin
		  if ancount>0
		  then begin
			   writeln('<answer>');
			   pr_sctn(resp.sdata[answer]);
		       end;
		  if nscount>0
		  then begin
			   writeln('<authority>');
			   pr_sctn(resp.sdata[authority]);
		       end;
		  if (arcount>0) and (opcode=std_query)
		      then begin
			       writeln('<additional>');
			       pr_sctn(resp.sdata[additional]);
			   end;
	      end;
end;
end.

{$M-,X+}
program tport;

include {NOLIST} 'pascal:extern.pas';
include {NOLIST} 'domain:jsys.def';
include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:lparse.def';
include {NOLIST} 'domain:iomsg.hdr';
include {NOLIST} 'domain:irdata.hdr';
include {NOLIST} 'domain:msub.hdr';
include {NOLIST} 'domain:dump.hdr';
include {NOLIST} 'domain:mdep.hdr';
include {NOLIST} 'domain:eutil.hdr';
include {NOLIST} 'domain:userdj.hdr';

const	log_all_udp_default=false; (* if true log all packets in and out *)
	log_uerr_default=false;	(* log checksum errors *)
	
	{ JSYS flags }
	riqnw_ = "20000; {no wait flag for rcvin_}

type    {queue descriptor block}
        iqprv_type=packed record
			      dummy:field24;
			      ptcl:octet;
			  end;

	iqptv_type=packed record
			      src_port:field16;
			      dst_port:field16;
			  end;

	iqprm_type=packed record    
			      dummy:field24;
			      ptcl:octet;
			  end;

	iqptm_type=packed record
			      src_port:field16;
			      dst_port:field16;
			  end;
	
	qdb_type=packed record
			    iqprv:iqprv_type;  { protocol }
			    iqfhv:field32;     { destination host }
			    iqshv:field32;     { source host }
			    iqptv:iqptv_type;  { source, destination port }
			    iqprm:iqprm_type;  { protocol mask }
			    iqfhm:field32;     { destination host mask }
			    iqshm:field32;     { source host mask }
			    iqptm:iqptm_type;  { source,destination port mask }
			end;

var	master:master_block_pointer;
	ip_identification:field16;
	my_address:integer; (* local host IP address *)
	myfbp:file_blk_ptr;
	low_buffer:rawmsg_pointer;

function gdom(    flags:integer;
	          source_bp:g1bpt;
	      var dest_bp:g1bpt):boolean;extern;


function f_net(x:integer):integer;

{ F_NET returns the net number of an IP addresses }

begin
if band(x,"80000000)=0
then f_net:=band(bshift(x,-24),"7f) (* Class A address *)
else if band(x,"40000000)=0
     then f_net:=band(bshift(x,-16),"3fff) (* Class B *)
     else f_net:=band(bshift(x,-8),"1fffff) (* Class C *)
end; { F_NET }

function f_imp(x:integer):integer;

{ F_IMP returns the IMP number of an IP address, but doesn't
  check to see that it is in fact from a suitable net }

begin
f_imp:=band(x,"ff)
end; { F_IMP }
procedure stat_rank(var myserver:search_address_type);

(* This code assigns the rank of a particular address and its ETA
   based on the preference data in the database *)

var i:integer;

begin
with myserver
do for i:=1 to master^.resolve_addrs.address_count (* try all ours *)
       do begin
	      eta:=master^.measure.prefe[hpref(ipaddress)];
	      rank:=hpref(ipaddress);
	  end
end; { STAT_RANK }
procedure dyn_rank(var myserver:search_address_type);

(* This procedure assigns the ETA and RANK of an address based on
   previous results for this address.  

   The results in NEWUDP are tried first, followed by those in UDPHST.
   If neither has results, then static ranking is used.

   The dynamic ETA is TTOTAL/TBACKS

   The dynamic RANK is 10000*Psuccess
                       --------------
                           ETA

   where Psuccess is the probability that a query comes back or TBACKS/TOUTS

   *)

    procedure dyn(var myhd:hgraph_type);

    begin
    if myhd.tbacks=0
    then myserver.eta:=master^.measure.prefe[hpref(myhd.host)] (* nothing back from host *)
    else myserver.eta:=myhd.ttotal div myhd.tbacks;
    myserver.rank:=((10000*myhd.tbacks) div myhd.touts) div myserver.eta
    end;

begin
with myserver,master^.measure
do if stat_ptr=hslots (* points to others bucket? *)
   then stat_rank(myserver)
   else if stat_ptr=0 (* Dont want dynamic rank *)
        then stat_rank(myserver)
	else if newudp[stat_ptr].touts<>0 (* if recent data *)
	     then dyn(newudp[stat_ptr])	(* use recent data *)
             else if udphst[stat_ptr].touts<>0 (* if old data *)
		  then dyn(udphst[stat_ptr])
		  else stat_rank(myserver)
end; (* DYN_RANK *)
procedure sort_a(var server:server_type);

{ SORT_A ranks and sorts the addresses for a single server }

var	temp_sat:search_address_type;
	quo,rem,j,k:integer;
begin
with server
do begin
       for j:=1 to address_count
       do if master^.measure.dynsw<>0
	  then dyn_rank(server_addresses[j])
	  else stat_rank(server_addresses[j]);
       if address_count>1
	   then for j:=1 to address_count-1 (* sort one server *)
		do for k:=j downto 1
		   do if server_addresses[k+1].rank>server_addresses[k].rank
		      then begin	(* swap entries *)
			       temp_sat:=server_addresses[k];
			       server_addresses[k]:=server_addresses[k+1];
			       server_addresses[k+1]:=temp_sat
			   end;

       quo:=min(master^.measure.maxit,
		master^.measure.maxst div address_count); (* assign limits *)
       rem:=master^.measure.maxst mod address_count;
       for j:=1 to rem
       do server_addresses[j].limit:=min(master^.measure.maxit,quo+1);
       for j:=rem+1 to address_count
       do server_addresses[j].limit:=quo
   end
end; { sort_a }
procedure sort_sa(var sdv:servers_dv);

{ SORT_SA takes the list of servers and prioritizes the addresses for
  a server and the servers in general }

var	temp_st:server_type;
	i,j,k:integer;
begin
master:=getmaster;
with sdv
do begin { with }
       for i:=1 to server_count
       do with servers[i]
	  do if addresses_ready
	     then sort_a(servers[i]); (* sort multiple addresses *)
       for i:=1 to server_count-1 (* sort servers *)
       do for j:=i downto 1
	  do if (servers[j+1].addresses_ready and not(servers[j].addresses_ready))
		 or
		(servers[j+1].server_addresses[1].rank>servers[j].server_addresses[1].rank)
	     then (* swap server types *)
		 begin
		     temp_st:=servers[j];
		     servers[j]:=servers[j+1];
		     servers[j+1]:=temp_st
		 end;
       for i:=1 to server_count	(* set tries to zero *)
       do if servers[i].addresses_ready
	  then for j:=1 to servers[i].address_count
	       do servers[i].server_addresses[j].tries:=0;
   end { with }
end; { sort_sa }
function getadr(var server:server_type; (* server type block to fill in *)
		      foreign:boolean; (* should foreign data be used? *)
		      background:boolean; (* background search? *)
		      mba:boolean; (* MBA GTDOM? *)
		      ttl:integer (* TTL for resolver *)
		  ):boolean;

{	GETADR attempts to find the addresses of a host
	if FOREIGN is false, then only local data is considered

	Note that uses of GETADR from within the resolver should always
	specify a non-zero ttl value to insure that the request will
        be discarded if a search block isn't available.  This is necessary
	so that the resolver won't block waiting for the resolver.
}

var	ansbuf:packed array[1..1000] of octet;
	indv,startdv,enddv:g1bpt;
	switches,ac1,ac2,ac3,rval:integer;
begin { getadr }
with server
do	begin
	address_count:=0;

	indv:=xseto(server.server_name);	{ search name }
	startdv:=xseto(ansbuf);			{ answer area }
	enddv:=startdv;

	if ttl>0 (* validate TTL *)
	then ttl:=min(gtdrcm,ttl)
	else ttl:=0;

	switches:=bshift(topbit,-gtddnf)+bshift(ttl,gtdrsc)+gtdgen;
	if not foreign then switches:=switches+bshift(topbit,-gtdldo);
	if background then switches:=switches+bshift(topbit,-gtdrbk);
	if mba then switches:=switches+bshift(topbit,-gtdmba);

	if gdom(switches,indv,enddv)
	then	{ normal return }
		begin
		addresses_ready:=true;
		if startdv<>enddv
		then	{ found answers }
			while (startdv<>enddv) and
			      (address_count<max_server_addresses)
			do	begin
				address_count:=address_count+1;
				xadjbp(startdv,10);{ skip type,class,ttl,len }
				with server_addresses[address_count]
				do begin
				       ipaddress:=xildb4(startdv);
				       stat_ptr:=0
				   end
				end
		else    addresses_ready:=false { no such addresses }
		end
	else	addresses_ready:=false;{ name needs resolution }

	getadr:=addresses_ready;	{ success if got address }
	end { with }
end; { getadr }
procedure u_initialize(server:boolean;
		       wanted_port:integer;
		       var got_port:integer;
		       var got_handle:integer);

{ Initialize UDP for use by either the nameserver or resolver.
  The value of server specifies whether the port SERVER_PORT
  is required or whether any port will do.
  Enables Arpanet Wizard capability, 
  and sets up network queue for the Internet Protocol, 
  identified by the got_handle.

  Notes:  The source host address is set here because it is 
  required to compute the udp checksum.  Identification is 
  initialized here and incremented in u_send. }

var	ac1, ac2, ac3, jobnum, runtime, max_count, ret:integer;
	enable_cap:set of 0..35;	{bits of 36-bit word}
	qdb:^qdb_type;

begin {u_initialize}

    master:=getmaster;

    { Compensate for brain damage in monitor }
    newl(low_buffer);

    {enable Arpanet Wizard capability}
    jsys( rpcap, -2, ret;fhslf;ac1,
	  ac2, enable_cap );   {get current user capabilities}
    if ret=3
    then begin
	     myfbp:=ofile(err);
	     writeln(myfbp^.fident, 'jsys RPCAP failed ');
	     jsys_err(noabort, -1, myfbp);
	     cfile(myfbp);
	 end;
    enable_cap:=enable_cap+[24];     {set arpanet-wizard (bit 24)}
    jsys(epcap, -2, ret;fhslf,
	 ac2, enable_cap);      {enable arpanet wizard capability}
    if ret=3
    then begin	
	     myfbp:=ofile(err);
	     writeln(myfbp^.fident, 'jsys EPCAP failed');
	     jsys_err(noabort, -1, myfbp);
	     cfile(myfbp);
	 end;
    
    {set source host address}
    jsys(gthst, -2, ret;0;ac1,    {get host address} 
	 ac2, ac3, my_address); 
    if ret=3
    then begin
	     myfbp:=ofile(err);
	     writeln(myfbp^.fident, 'jsys GTHST failed');
	     jsys_err(noabort, -1, myfbp);
	     cfile(myfbp);
	 end;

    if server
    then if test_version
	 then wanted_port:=wanted_port+100
	 else
    else begin	{resolver}
	     {make up a source port number--use job number plus
	      randomly select lower 8 bits so different source 
	      each time run so no duplicates from last run}

	     jsys(gjinf, -1, ret;; ac1, ac2, jobnum);    {get job number}
	     jsys(time, -1, ret;; runtime);	          {get runtime}
	     wanted_port:=((jobnum mod 256)*256)+
			   (runtime mod 256);
	     if (wanted_port<256) or (wanted_port="ffff) then wanted_port:=256
	 end;

    ip_identification:=0;   {initialize}

    {set up network queue}
    {queue descriptor block}
    newl(qdb);
    with qdb^ do
    begin
	iqprv.ptcl:=17;                 {UDP}
	iqfhv:=0;		
	iqshv:=0;
	iqptv.src_port:=wanted_port;
	iqptv.dst_port:=0;		{arbitary-receive from all ports}
	iqprm.ptcl:=377b;
	iqfhm:=0;			{receive from all hosts}
	iqshm:=0;
	iqptm.src_port:=177777b;
	iqptm.dst_port:=0;		{receive from all ports}
    end;

    {assign network queue for Internet protocol}
    repeat
	jsys(asniq, -2, ret;0:qdb^, 0, 0;got_handle, max_count);
	if ret=3 
	then if not server
	     then begin  {try next port}
		      wanted_port:=wanted_port+1;
		      if wanted_port="ffff
		      then begin
			       myfbp:=ofile(fatl);
			       writeln(myfbp^.fident, 'jsys ASNIQ failed');
			       jsys_err(abort, -1, myfbp);
			   end
		      else qdb^.iqptv.src_port:=wanted_port;
		  end
	     else begin
		      myfbp:=ofile(fatl);
		      writeln(myfbp^.fident, 'jsys ASNIQ failed');
		      jsys_err(abort, -1, myfbp);
		  end;
    until ret<>3;
    
    got_port:=wanted_port;

    {if insufficient buffer allocation terminate program}
    if max_count<144
    then begin   {buffer too small}
	     myfbp:=ofile(fatl);
	     writeln(myfbp^.fident, 'maximum buffer size insufficient (',
		     max_count:3, ' words), try again later');
	     jsys_err(abort, -1, myfbp);
	 end; {buffer too small}
end; {u_initialize}
procedure u_exit(handle:integer);

var	ret:integer;

begin  {u_exit}
    {release the queue}
    jsys(reliq, -2, ret; handle, 0, 0);
    if ret=3
    then begin
	     myfbp:=ofile(err);
	     writeln(myfbp^.fident, 'jsys RELIQ failed');
	     jsys_err(noabort, -1, myfbp);
	     cfile(myfbp);
	 end
end;  {u_exit}
function u_checksum(var pkt:rawmsg):integer;

{ U_CHECKSUM calculates the UDP checksum for a raw buffer }

var sum,sum_count:integer;
    sum_bp:g1bpt;

begin
{ Initialize checksum to pseudoheader }
sum:=pkt.sorc_adr+pkt.dest_adr+pkt.protocol+pkt.iplength-(pkt.ihl*4);
sum_bp:=xseto(pkt.unspec);
xadjbp(sum_bp,pkt.ihl*4);
sum_count:=pkt.iplength-(pkt.ihl*4);

while sum_count>1
do    begin
	  sum:=sum+xildb2(sum_bp);
	  sum_count:=sum_count-2
      end;
if sum_count=1
then sum:=sum+(xildb(sum_bp)*256);

{ End around carry adjustment }
sum:=(sum mod "10000)+(sum div "10000);
sum:=(sum mod "10000)+(sum div "10000);

u_checksum:="ffff-sum
end; { U_checksum }
function u_receive(    handle:integer;
		     var toget:rawmsg;
			 wait:boolean):boolean;

{ Receive UDP messages from 0 to  MAX_DGM_OCTETS octets. 
  If wait is true then wait until a message is received,
  else check for messages, and return.  If a message
  was received, return true as the value of the function.
  Messages longer than MAX_DGM_OCTETS octets or with invalid
  checksums are discarded. }

var	i, ret, wait_flag,
	checksum, datalength, error_code:integer;
	log_udp,log_uerr,message_received:boolean;

begin {u_receive}
    if wait 
    then wait_flag:=0
    else wait_flag:=RIQNW_; 

    {receive internet datagram}
    
    repeat  {until message received or not wait}
	low_buffer^.count:=max_dgm_octets div 4;{maximum buffer size in words}

	{receive Internet datagram}
	jsys(rcvin, -2, ret;wait_flag:handle, 
	     low_buffer^, 0;error_code);
	if ret=3
	then begin  {error}
		 message_received:=false;
		 if (error_code <> 777777b) and
		     (error_code <> -1)
		 then begin
			  myfbp:=ofile(err);
			  writeln(myfbp^.fident, 'jsys RCVIN failed');
			  jsys_err(noabort, error_code, myfbp);
			  cfile(myfbp);
		      end;
	     end  {error}
	else begin {message received}
		 xxblt(low_buffer,rmptr(toget),low_buffer^.rec_count);
		 if master=NIL
		 then log_udp:=log_all_udp_default
		 else log_udp:=master^.logua<>0;
		 if log_udp
		     then      begin
				   myfbp:=ofile(log);
				   writeln(myfbp^.fident,' UDP message received');
				   dumpbuffer(toget,
					      (toget.rec_count-1)*4,
					      log,myfbp);
				   cfile(myfbp);
			       end;
		 {check bounds on datalength}
		 datalength:=toget.iplength;	 {datalength in octets}

		 if (datalength>max_dgm_octets) or (datalength<0)
		 then {datalength out of bounds}
		      begin
			  message_received:=false;
			  myfbp:=ofile(err);
			  writeln(myfbp^.fident,' UDP message discarded due to length');
			  dumpbuffer(toget,
				     (toget.rec_count-1)*4,
				     err,myfbp);
				     cfile(myfbp);
				     end
		 else begin {datalength ok}
			  {check UDP checksum}	
			  if toget.udpchecksum=0
			  then 	{no checksum--assume data valid}
			      checksum:=0
			  else	{compute checksum}
			      checksum:=u_checksum(toget);

			  if checksum<>0
			  then  {checksum error}
			      begin
				  message_received:=false;
				  if master=NIL
				  then log_uerr:=log_uerr_default
				  else log_uerr:=master^.logue<>0;
				  if log_uerr
				  then begin
					   myfbp:=ofile(err);
					   writeln(myfbp^.fident,' UDP checksum errror');
					   dumpbuffer(toget,
				             toget.iplength,
					     err,myfbp);
					   cfile(myfbp)
				       end
				  end
			  else    message_received:=true;
		      end;  {datalength ok}
	     end; {message received}
    until message_received or (not wait);
    u_receive:=message_received;	
end; {u_receive}
procedure u_send(handle:integer;
		 var togo:rawmsg);

var	i, j, error_code, ret:integer;
	log_udp:boolean;

begin {u_send}

with togo
do   begin

    {prepare output buffer}
	 {buffer length in words, rounded up }
    rec_count:=0;
    count:=1 {count word} +
	     ((iplength+3) div 4);

    if master=NIL
    then log_udp:=log_all_udp_default
    else log_udp:=master^.logua<>0;
    if log_udp
    then      begin
		   myfbp:=ofile(log);
		   writeln(myfbp^.fident,' UDP message sent');
		   dumpbuffer(togo,
		              togo.iplength,
			      log,myfbp);
		   cfile(myfbp);
	      end;
    
    {send internet datagram}
    xxblt(rmptr(togo),low_buffer,togo.count); (* fix monitor trouble *)
    jsys(sndin, -2, ret;handle,low_buffer^,0;error_code);

    if ret=3 
    then begin {error message}
	     if master<>NIL
	     then begin
		      xaos(master^.measure.uoerrs);
		      log_udp:=(master^.logua<>0) or (master^.logue<>0)
		  end
	     else log_udp:=true;
	     if log_udp
	     then begin
		      myfbp:=ofile(err);
		      write(myfbp^.fident, 'jsys SNDIN failed ');
		      jsys_err(noabort, error_code, myfbp);
		      dumpbuffer(togo,
	                (togo.count-1)*4,
			err,myfbp);
		      cfile(myfbp)
		  end;
	 end;  {error message}
    
end; {with}    
end; {u_send}

{ The following procedures are used to extract type, class, and
  ttl information from RR strings }

function f_type(bp:g1bpt):dtype;

begin
f_type:=chrtype(xildb2(bp))
end;

function f_class(bp:g1bpt):dclass;

begin
xadjbp(bp,2);
f_class:=chrclass(xildb2(bp));
end;

function f_ttl(bp:g1bpt):integer;

begin
xadjbp(bp,4);
f_ttl:=sildb4(bp)
end;

procedure s_ttl(bp:g1bpt;value:integer);

begin
xadjbp(bp,4);
xidpb4(bp,value)
end;

function f_length(bp:g1bpt):integer;

begin
xadjbp(bp,8);
f_length:=xildb2(bp)
end;

function f_data(bp:g1bpt):g1bpt;

(* bump a byte pointer to RRDATA past the header *)
begin
xadjbp(bp,10);
f_data:=bp
end;

procedure st_rdata(var bp:g1bpt);

{ Skip to start of RDATA }
begin
xadjbp(bp,10)
end;

procedure i_domsg(var mydomsg:domsg);

{	Initialize the text of a domsg }

var code:sectcode;

begin
with mydomsg.dhead
do   begin
	 response:=false;
	 aa:=false;
	 tc:=false;
	 rd:=false;
	 ra:=false;
	 unused:=0;
	 rcode:=0;
	 qdcount:=0;
	 ancount:=0;
	 nscount:=0;
	 arcount:=0
     end;
with mydomsg
do   begin
	 free_cnt:=max_msg_octet-dmn_hdr_sz;
	 free_ptr:=xseto(data);
	 xadjbp(free_ptr,dmn_hdr_sz);

	 for code:= question to additional
	 do with parse[code]
	    do	 begin
		     truncated:=false;
		     count:=0
		 end
     end
end; { i_domsg }
procedure f_rawmsg(var mydomsg:domsg;
		     var mytport:transport;
		     var myrawmsg:rawmsg);

{       F_RAWMSG formats up a message for transmission.  Note
	that it doesn't fill in the checksums or addresses.
        These last minute changes are performed in S_RAWMSG so that we
        don't have to reformat queries every time we want to send
	the same message to a different host }

var	header_octets,rr_index,octets_left,i:integer;
	out_ptr:G1bpt;
	sect_scan:sectcode;
	datalen:integer;
	datalenbp:G1bpt;

	procedure out_byt(o_bytes:g1bpt;
			  count:integer);

	(* OUT_BYT outputs the specified number of bytes, truncating
	 if required *)
        
	begin
	if count>octets_left
	    then begin
		      myrawmsg.dhead.tc:=true;
		      count:=octets_left
		 end;
	for i:=1 to count
	do  xidpb(out_ptr,xildb(o_bytes));
	octets_left:=octets_left-count;
	end; { out_byt }

	function fename(var o_name:g1bpt):boolean;

	(* FENAME attempts to find a complete copy of the specified
	 domain name and output a reference to it.  Assumes that it will
	 never be called for a root. Returns true if successful. *)

	var tstidx,i,tstbytes,look_start,look_last,last_len,last_used:integer;
	    len_octet:octet;
	    found:boolean;
	    keyptr,tstptr:g1bpt;

	begin
	    found:=false; (* assume failure *)
	    len_octet:=peekb(o_name); (* get first byte we are looking for *)
	    
	    look_start:=header_octets+1; (* array index of first possible *)
	    last_used:=ip_hdr_sz+udp_hdr_sz+512	(* last array index used *)
		       -octets_left;
	    look_last:=last_used-len_octet-1; (* last hope for search *)

	    while (look_start<=look_last) and not found
	    do if myrawmsg.unspec[look_start]=len_octet
	       then begin (* worth a try because lengths match *)
		    keyptr:=o_name;
		    tstptr:=xseto(myrawmsg.unspec);
		    xadjbp(tstptr,look_start-1);
		    tstidx:=look_start;
		    repeat if bbelcomp(keyptr,tstptr)
			   then begin
				found:=true;
				last_len:=peekb(keyptr);
				xadjbp(keyptr,last_len+1);
				xadjbp(tstptr,last_len+1);
				tstidx:=tstidx+last_len+1;
				tstbytes:=last_used-tstidx+1;
				if last_len<>0
				then	(* check out new keyptr *)
				    if tstbytes<=0
				    then found:=false (* fall off end *)
				    else if band(peekb(tstptr),"C0)="C0
					 then (* validate compression ptr *)
					      if tstbytes<2
					      then found:=false
					      else begin
						   i:=xildb2(tstptr)-"C000+ip_hdr_sz+udp_hdr_sz+1;
						   if i>=tstidx
						   then found:=false (* must point backward *)
						   else	begin (* follow pointer *)
							tstidx:=i;
							tstbytes:=last_used-tstidx+1;
							tstptr:=xseto(myrawmsg.unspec);
							xadjbp(tstptr,tstidx-1);
							if (peekb(tstptr)>63) or (peekb(tstptr)>=tstbytes)
							then found:=false
							end;
						   if peekb(keyptr)>=tstbytes
						   then found:=false
						   end
					 else if (peekb(tstptr)>63) or (peekb(tstptr)>=tstbytes)
					      then found:=false
				end
			   else	found:=false
		    until not found or (last_len=0);
		    if not found then look_start:=look_start+1
		    end
	       else look_start:=look_start+1;
       
	    fename:=found;
	    i:=look_start+dmn_hdr_sz-header_octets-1+"C000;
	    if found
	    then (* output compression pointer *)
		if octets_left>=2
		then begin
			octets_left:=octets_left-2;
			xidpb2(out_ptr,i)
		     end
		else begin
			 myrawmsg.dhead.tc:=true;
			 if octets_left=1
			 then begin
				  octets_left:=octets_left-1;
				  xidpb(out_ptr,bshift(i,-8))
			      end
		     end

	end; { fename }
	    
	procedure out_dns(o_name:g1bpt);

	(* OUT_DNS outputs a domain name which is eligible for compression,
	 incrementing the byte pointer as it goes *)

        var label_length:integer;

	begin
	repeat label_length:=peekb(o_name); (* get length of first label *)
	       if label_length=0 (* if root don't try for compression *)
	       then out_byt(o_name,1)
	       else if fename(o_name) (* try to find encoded version *)
		    then label_length:=0 (* signal done *)
		    else (* if no compressed reference possible *)
			 begin
			     out_byt(o_name,label_length+1);
			     xadjbp(o_name,label_length+1)
			 end
	until label_length=0
	end; { out_dns }

begin
with myrawmsg
do  begin

    {prepare ip datagram header}
    version:=4;
    ihl:= 5;                       {header length in 32-bit words} 
    tos:=0;			   {normal type of service}
    flagrsvd:=0;	           {reserved}
    flagdf:=0;			   {may fragment}
    flagmf:=0;			   {last fragment}
    fragment:=0;		   {fragment offset}
    ttl:=100;			   {time to live = 100 gateway hops} 
    protocol:=17;		   {udp}
    sorc_port:=mytport.local_port;
    dest_port:=mytport.foreign_port;

    dhead:=mydomsg.dhead;
    dhead.qdcount:=mydomsg.parse[question].count;
    dhead.ancount:=mydomsg.parse[answer].count;
    dhead.nscount:=mydomsg.parse[authority].count;
    dhead.arcount:=mydomsg.parse[additional].count;

    end;

(* set up count of bytes left and byte pointer *)
header_octets:=ip_hdr_sz+udp_hdr_sz+dmn_hdr_sz;	(* offset to QNAME *)
octets_left:=512-dmn_hdr_sz;

out_ptr:=xseto(myrawmsg.unspec);
xadjbp(out_ptr,header_octets); (* get pointer to data area *)

with mydomsg.parse[question] (* output question section *)
do for rr_index:=1 to count
   do if octets_left>0
      then begin
	       out_dns(rdv[rr_index].namebp);
	       out_byt(rdv[rr_index].databp,4);	(* type and class *)
	   end
      else myrawmsg.dhead.tc:=true;

for sect_scan:=answer to additional (* output other sections *)
do with mydomsg.parse[sect_scan]
    do for rr_index:= 1 to count
	do if octets_left>0
	    then begin
		     out_dns(rdv[rr_index].namebp);
		     datalenbp:=rdv[rr_index].databp;
		     xadjbp(datalenbp,8); (* past type, class, TTL *)
		     datalen:=xildb2(datalenbp)+10;
		     out_byt(rdv[rr_index].databp,datalen)
		 end
	    else myrawmsg.dhead.tc:=true;

myrawmsg.iplength:=ip_hdr_sz+udp_hdr_sz+512-octets_left;
myrawmsg.udplength:=myrawmsg.iplength-ip_hdr_sz;
	    
end; (* f_rawmsg *)
function bestfrom(dest:integer):integer;

{ BESTFROM selects the address which will be used as a source of an
  outgoing datagram if there are multiple choices. The current algorithm
  selects the same address, then addresses on the same network, or
  last the first choice. }

var	i,mynet:integer;
	found:boolean;
begin
if master=NIL
then bestfrom:=my_address (* if no master block use GTHST address *)
else with master^.resolve_addrs
     do if address_count=0
	then bestfrom:=my_address
	else if address_count=1
	     then bestfrom:=server_addresses[1].ipaddress
	     else begin
		       found:=false;
		       for i:=1 to address_count
		       do if dest=server_addresses[i].ipaddress
			  then begin
				   found:=true;
				   bestfrom:=server_addresses[i].ipaddress
			       end;
		       if not found
		       then begin
				 mynet:=f_net(dest);
				 for i:=1 to address_count
				 do if f_net(server_addresses[i].ipaddress)=mynet
				    then begin
					     found:=true;
					     bestfrom:=server_addresses[i].ipaddress
					 end;
				 if not found
				 then bestfrom:=server_addresses[1].ipaddress
			    end
		  end

end; { bestfrom }

procedure s_rawmsg(    myhandle:integer;
		   var mytport:transport;
		   var myrawmsg:rawmsg);

{ Perform the last steps of formatting the datagram and then send it }
begin
case mytport.xmit_using of

dgm: begin
	 {increment internet identification}
	 if ip_identification<"ffff
	 then ip_identification:=ip_identification+1
	 else ip_identification:=0;
	 myrawmsg.ident:=ip_identification;

	 { fill in to address }
	 myrawmsg.dest_adr:=mytport.foreign_address;

	 { if from address was specified, use it, otherwise pick the
	   from address that best matches the to address }
	 if mytport.local_address=0
	 then myrawmsg.sorc_adr:=bestfrom(mytport.foreign_address)
	 else myrawmsg.sorc_adr:=mytport.local_address;

	 { Now calculate the UDP header checksum }
	 myrawmsg.udpchecksum:=0;
	 myrawmsg.udpchecksum:=u_checksum(myrawmsg);
	 if myrawmsg.udpchecksum=0 then myrawmsg.udpchecksum:="ffff;
	 
	 { Ok, now send the packet }
	 u_send(myhandle,myrawmsg)
	 end;

tcp:	 quit
end; {case}

end; (* s_rawmsg *)
function p_rawmsg(var mydomsg:domsg;
		    var mytport:transport;
		    var myrawmsg:rawmsg):boolean;

{ P_RAWMSG parses a raw message into domain format in as paranoid a manner
  as possible, and returns true if the parse worked }

type str30=packed array[1..30] of char;

var  dmsg_base:G1bpt; (* pointer to origin of domain message *)
     dmsg_length:integer; (* size of original domain message *)
     scan_bp:g1bpt; (* pointer used to scan message *)
     scan_left:integer;	(* bytes left to be processed *)
     scan_sect:sectcode; (* section currently being processed *)
     scan_indirect:boolean;
     c_scan_bp,rdata_len_bp:g1bpt;
     c_scan_left:integer;
     i,hdr_size,compression_amount,remaining_rdata,this_rdata_len:integer;
     parse_ok:boolean;

       procedure parse_abort(str:str30);

       var i,j:integer;
	   log_cond:boolean;
       begin
	   parse_ok:=false;
	   i:=30;
	   while str[i]=' '
	   do i:=i-1;
	   if master=NIL
	   then log_cond:=true
	   else begin
		    xaos(master^.measure.uierrs);
		    log_cond:=(master^.logue<>0) or (master^.logua<>0)
		    end;
	   if log_cond
	   then begin
		    myfbp:=ofile(log);		    
		    for j:=1 to i
		    do write(myfbp^.fident,str[j]);
		    i:=dmsg_length-scan_left;
		    write(myfbp^.fident,' offset=',i:4);
		    if scan_indirect
		    then begin
			 i:=dmsg_length-c_scan_left;
			 writeln(myfbp^.fident,' compress offset=',i:4)
			 end
		    else writeln(myfbp^.fident);
		    dumpbuffer(myrawmsg,myrawmsg.iplength,log,myfbp);
		    cfile(myfbp)
		end
       end; { parse_abort }

       function get_dn(var byte_ptr:g1bpt; (* parsed name pointer return *)
		       var truncated:boolean) (* before/after trucate state *)
		       :boolean;
	var scanned,last_ll:integer;
	    this_length:integer;

	begin { get_dn }
	byte_ptr:=mydomsg.free_ptr;
	scanned:=0; (* zero count of characters eaten *)
	scan_indirect:=false; (* start scanning in uncompressed mode *)
	last_ll:=1; (* last label was not the root *)
	while parse_ok and (last_ll<>0) and not(truncated)
	do if scan_indirect
	   then	if c_scan_left>0 (* compression pointer moved us back *)
		then begin
		     this_length:=peekb(c_scan_bp);	(* get length byte *)
		     if this_length>63
		     then if c_scan_left>=2 (* compression reference *)
			  then begin { validate compression pointer }
			       this_length:=xildb2(c_scan_bp);
			       if band(this_length,"C000)<>"C000
			       then parse_abort('Bad compression pointer       ')
			       else begin
				    this_length:=this_length-"C000;
				    if this_length+c_scan_left<dmsg_length
				    then { pointer does go backward }
					 begin (* setup compression mode processing *)
					     c_scan_bp:=dmsg_base;
					     xadjbp(c_scan_bp,this_length);
					     c_scan_left:=dmsg_length-this_length;
					 end
				    else parse_abort('Forward compression pointer   ')
					end
			       end
			  else truncated:=true
		     else { parse off a vanilla label }
			  if c_scan_left>this_length
			  then if mydomsg.free_cnt>this_length
			       then if scanned+this_length<max_dname_chars
				    then begin	(* copy label *)
					 copyls(c_scan_bp,mydomsg.free_ptr);
					 last_ll:=this_length;
					 this_length:=this_length+1;
					 xadjbp(c_scan_bp,this_length);
					 xadjbp(mydomsg.free_ptr,this_length);
					 mydomsg.free_cnt:=mydomsg.free_cnt-this_length;
					 c_scan_left:=c_scan_left-this_length;
				         scanned:=scanned+this_length
					 end
				    else parse_abort('Name too long                 ')
			       else parse_abort('DOMSG space exhausted         ')
			  else truncated:=true
		     end
		else truncated:=true
	   else if scan_left>0 (* scanning new input *)
		then begin
		     this_length:=peekb(scan_bp);	(* get length byte *)
		     if this_length>63
		     then if scan_left>=2 { switch to compressed mode }
			  then begin { validate compression pointer }
			       this_length:=xildb2(scan_bp);
			       if band(this_length,"C000)<>"C000
			       then parse_abort('Bad compression pointer       ')
			       else begin
				    this_length:=this_length-"C000;
				    if this_length+scan_left<dmsg_length
				    then begin (* setup compression mode *)
					 scan_left:=scan_left-2;
					 c_scan_bp:=dmsg_base;
					 xadjbp(c_scan_bp,this_length);
					 c_scan_left:=dmsg_length-this_length;
					 scan_indirect:=true;
					 end
				    else parse_abort('Forward compression pointer   ')
				    end
			       end
			  else truncated:=true
		     else if scan_left>this_length
			  then if mydomsg.free_cnt>this_length
			       then if scanned+this_length<max_dname_chars
				    then begin	(* copy label *)
					 copyls(scan_bp,mydomsg.free_ptr);
					 last_ll:=this_length;
					 this_length:=this_length+1;
					 xadjbp(scan_bp,this_length);
					 xadjbp(mydomsg.free_ptr,this_length);
					 mydomsg.free_cnt:=mydomsg.free_cnt-this_length;
					 scan_left:=scan_left-this_length;
					 scanned:=scanned+this_length
					 end
				    else parse_abort('DNAME too long                ')
			       else parse_abort('DOMSG space exhausted         ')
			   else truncated:=true
			   end
		      else truncated:=true;
	get_dn:=parse_ok
	end; { get_dn }

       procedure eat(howmuch:integer);

       (* Eat consumes the specified number of bytes of binary data *)
       begin
       if howmuch>scan_left
       then mydomsg.parse[scan_sect].truncated:=true
       else if howmuch>mydomsg.free_cnt
	    then parse_abort('RDATA item storage exhausted  ')
	    else if howmuch>remaining_rdata
		 then parse_abort('Premature RDATA end           ')
		 else begin
			  ccopy(scan_bp,mydomsg.free_ptr,howmuch);
			  scan_left:=scan_left-howmuch;
			  mydomsg.free_cnt:=mydomsg.free_cnt-howmuch;
			  remaining_rdata:=remaining_rdata-howmuch;
		      end
       end; { eat }
	    
       function get_rdata:boolean;

       var rdindex,save_left:integer;
	   save_bp:g1bpt;
	   table:rdata_table_pointer;
       begin
       with mydomsg.parse[scan_sect]
       do begin
	  rdv[count+1].databp:=mydomsg.free_ptr;
	  if scan_left>=10 { space for type, class, ttl, length }
	  then if mydomsg.free_cnt>=10
	       then begin
		    ccopy(scan_bp,mydomsg.free_ptr,8);
		    rdata_len_bp:=mydomsg.free_ptr;
                    remaining_rdata:=xildb2(scan_bp);
		    this_rdata_len:=remaining_rdata;
		    xidpb2(mydomsg.free_ptr,remaining_rdata);
		    scan_left:=scan_left-10;
		    mydomsg.free_cnt:=mydomsg.free_cnt-10;
		    table:=irdata(f_class(rdv[count+1].databp));
		    rdindex:=1;
		    with table^[f_type(rdv[count+1].databp)] do while not truncated and parse_ok and (rdata_item[rdindex]<>no_more_field)
		    do begin
		       case rdata_item[rdindex] of
		       dname_field:   begin
				      save_left:=scan_left;
				      if get_dn(save_bp,truncated)
				      then begin
					   compression_amount:=lendns(save_bp)-(save_left-scan_left);
					   remaining_rdata:=remaining_rdata-(save_left-scan_left);
					   this_rdata_len:=this_rdata_len+compression_amount;
					   if remaining_rdata<0
					   then parse_abort('Name parse error              ')
					   end;
				      end;
		       cstring_field: if scan_left>1
				      then eat(peekb(scan_bp)+1)
				      else truncated:=true;
		       int16_field:   eat(2);
		       time_field,
		       int32_field,
		       inet_a_field:  eat(4);
		       inet_p_field:  eat(1);
		       inet_s_field,
		       vbinary_field: eat(remaining_rdata);
		       no_more_field:
		       end; { case }
		       rdindex:=rdindex+1;
		       end;
		    if parse_ok and not truncated 
		    then if remaining_rdata<>0
			 then parse_abort('Extra RDATA detected          ')
		         else (* correct for compression *)
			      xidpb2(rdata_len_bp,this_rdata_len);
		    end
	       else parse_abort('RRDATA storage exhausted      ')
	  else truncated:=true
	  end;
       get_rdata:=parse_ok
       end; { get_rdata }

       function p_sect(code:sectcode;count:integer):boolean;

       var counter:integer;

       begin
       scan_sect:=code;
       for counter:=1 to count do with mydomsg.parse[code]
       do if parse_ok
	  then if count>=max_rrs
	       then parse_abort('Section space exhausted       ')
	       else if get_dn(rdv[count+1].namebp,truncated) (* get owner name *)
	            then if code=question (* special case question section *)
			 then if scan_left>=4 (* QTYPE, QCLASS *)
			      then begin
					rdv[count+1].databp:=mydomsg.free_ptr;
					ccopy(scan_bp,mydomsg.free_ptr,4);
					scan_left:=scan_left-4;
					count:=count+1
				      end
			      else parse_abort('QTYPE, QCLASS missing         ')
			 else if get_rdata
			      then if not truncated then count:=count+1;
       p_sect:=parse_ok						    
       end; { p_sect }

begin { p_rawmsg }
parse_ok:=true;	(* parse successful so far *)
i_domsg(mydomsg); (* initialize the output structure *)
case mytport.xmit_using of

dgm: begin
	 hdr_size:=(myrawmsg.ihl*4)+udp_hdr_sz;
	 dmsg_length:=myrawmsg.iplength-hdr_size; (* including domain hdr *)
	 dmsg_base:=xseto(myrawmsg.unspec);
	 xadjbp(dmsg_base,hdr_size); (* points to start of domain header *)

	 mytport.foreign_address:=myrawmsg.sorc_adr;
	 mytport.foreign_port:=myrawmsg.sorc_port;
	 mytport.local_address:=myrawmsg.dest_adr;
	 mytport.local_port:=myrawmsg.dest_port
     end;
tcp: quit
end; { case }

scan_bp:=dmsg_base;
scan_left:=dmsg_length;
if scan_left<dmn_hdr_sz
then parse_abort('Domain header missing         ')
else begin
	 xadjbp(mydomsg.free_ptr,-dmn_hdr_sz);
	 for i:=1 to dmn_hdr_sz	(* copy header into domsg *)
	 do xidpb(mydomsg.free_ptr,xildb(scan_bp));
	 mydomsg.free_cnt:=mydomsg.free_cnt-dmn_hdr_sz;
	 scan_left:=scan_left-dmn_hdr_sz;

	 { Check out header for reasonableness }
	 with mydomsg.dhead
	 do   if opcode>cu_query
	      then parse_abort('Unknown domain opcode         ')
	      else if (rcode>refused) and response
		   then parse_abort('Unknown domain response code  ')
		   else if p_sect(question,qdcount)
		        then if p_sect(answer,ancount)
			     then if p_sect(authority,nscount)
				  then if p_sect(additional,arcount)
				       then;
     end;
p_rawmsg:=parse_ok
end. { p_rawmsg }


{$M-,X+}
program udp;

include {NOLIST} 'domain:jsys.def';
include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:udp.def';
include {NOLIST} 'domain:iomsg.hdr';
include {NOLIST} 'domain:msub.hdr';

const	udp_log_all=false; (* if true log all packets in and out *)

var	iq_handle:integer;
	src_port, dst_port, identification:field16;
	src_address, dst_address:field32;
	the_buffer:buffer_type_pointer;
	myfbp:file_blk_ptr;


procedure set_server(addr:field32;
		     port:field16);

{ Invoked by resolvers when a change in
  nameservers is desired. }

begin  {set_server}
    dst_address:=addr;
    dst_port:=port;
end;  {set_server}

procedure udp_initialize(server:boolean);

{ Initialize UDP for use by either the nameserver or resolver.
  The value of server identifies the calling program and
  therefore which port number to assign to src_port.
  Initial resolver destination address and port are assumed
  to be ISIA, port 53.  Enable Arpanet Wizard capability, 
  and set up network queue for the Internet Protocol, 
  identified by the iq_handle.

  Notes:  The source host address is set here because it is 
  required to compute the udp checksum.  Identification is 
  initialized here and incremented in udp_send. }

var	ac1, ac2, ac3, jobnum, runtime, max_count, ret:integer;
	enable_cap:set of 0..35;	{bits of 36-bit word}
	port_low_bits:field8;
	qdb:^qdb_type;

begin {udp_initialize}
    
    newl(the_buffer);

    {enable Arpanet Wizard capability}
    jsys( rpcap, -2, ret;fhslf;ac1,
	  ac2, enable_cap );   {get current user capabilities}
    if ret=3
    then begin
	     myfbp:=ofile(err);
	     writeln(myfbp^.fident, 'jsys RPCAP failed ');
	     jsys_err(noabort, -1, myfbp);
	     cfile(myfbp);
	 end;
    enable_cap:=enable_cap+[24];     {set arpanet-wizard (bit 24)}
    jsys(epcap, -2, ret;fhslf,
	 ac2, enable_cap);      {enable arpanet wizard capability}
    if ret=3
    then begin	
	     myfbp:=ofile(err);
	     writeln(myfbp^.fident, 'jsys EPCAP failed');
	     jsys_err(noabort, -1, myfbp);
	     cfile(myfbp);
	 end;
    
    {set source host address}
    jsys(gthst_, -2, ret;gthsz_;ac1,    {get host address} 
	 ac2, ac3, src_address); 
    if ret=3
    then begin
	     myfbp:=ofile(err);
	     writeln(myfbp^.fident, 'jsys GTHST failed');
	     jsys_err(noabort, -1, myfbp);
	     cfile(myfbp);
	 end;

    {assign src_port (both), and initial dst_address and dst_port
     (resolver only)}
    if server
    then if test_version
	 then src_port:=test_port
	 else src_port:=dns_port
    else begin	{resolver}
	     {make up a source port number--use job number plus
	      randomly select lower 8 bits so different source 
	      each time run so no duplicates from last run}

	     jsys(gjinf, -1, ret;; ac1, ac2, jobnum);    {get job number}
	     jsys(time, -1, ret;; runtime);	          {get runtime}
	     port_low_bits:=((runtime div "100) mod "100);{bits 21-28}
	     src_port:=jobnum*"100+port_low_bits+"20;  {source port #}
	     dst_address:=dns_dserve;
	     dst_port:=dns_port;
	 end;

    identification := 0;   {initialize}

    {set up network queue}
    {queue descriptor block}
    newl(qdb);
    with qdb^ do
    begin
	iqprv.ptcl:=17;                 {UDP}
	iqfhv:=0;			{arbitrary-receive from 
					 all foreign hosts}
	iqshv:=0;
	iqptv.src_port:=src_port;
	iqptv.dst_port:=0;		{arbitary-receive from all ports}
	iqprm.ptcl:=377b;
	iqfhm:=0;			{receive from all hosts}
	iqshm:=0;
	iqptm.src_port:=177777b;
	iqptm.dst_port:=0;		{receive from all ports}
    end;

    {assign network queue for Internet protocol}
    repeat
	jsys(asniq_, -2, ret;0:qdb^, 0, 0;iq_handle, max_count);
	if ret=3 
	then if not server
	     then begin  {try next port}
		      src_port:=src_port+1;
		      if src_port="ffff
		      then begin
			       myfbp:=ofile(fatl);
			       writeln(myfbp^.fident, 'jsys ASNIQ failed');
			       jsys_err(abort, -1, myfbp);
			   end
		      else qdb^.iqptv.src_port:=src_port;
		  end
	     else begin
		      myfbp:=ofile(fatl);
		      writeln(myfbp^.fident, 'jsys ASNIQ failed');
		      jsys_err(abort, -1, myfbp);
		  end;
    until ret<>3;
    
    {if insufficient buffer allocation terminate program}
    if max_count<144
    then begin   {buffer too small}
	     myfbp:=ofile(fatl);
	     writeln(myfbp^.fident, 'maximum buffer size insufficient (',
		     max_count:3, ' words), try again later');
	     jsys_err(abort, -1, myfbp);
	 end; {buffer too small}
end; {udp_initialize}


procedure udp_exit;

var	ret:integer;

begin  {udp_exit}
    {release the queue}
    jsys(reliq_, -2, ret; iq_handle, 0, 0);
    if ret=3
    then begin
	     myfbp:=ofile(err);
	     writeln(myfbp^.fident, 'jsys RELIQ failed');
	     jsys_err(noabort, -1, myfbp);
	     cfile(myfbp);
	 end
end;  {udp_exit}


function udp_checksum(var buffer:buffer_type):field16;

{ Compute the UDP checksum, which is the 16-bit ones 
  complement of the ones complement sum (add with end
  around carry) of the pseudo header, udp header and
  data taken 16 bits at a time. The checksum field is 
  included in the computation. }

var    checksum, datalength, i, sumhigh, temp:integer;

begin  {udp_checksum}

with buffer do
begin
    {sum of pseudoheader}
    checksum:=(sorc_adr mod "10000)+(sorc_adr div "10000)+
	      (dest_adr mod "10000)+(dest_adr div "10000)+
	      protocol+udplength;

    {sum of udp header}
    checksum:=checksum+sorc_port+dest_port+
	      udplength+udpchecksum;

    with buffer.data.header do
    begin    {sum udp data--header first then remainder
	      in 16 bit groups}
	temp:=ord(response)*"8000 + opcode*"800 +
	      ord(aa)*"400 + ord(tc)*"200 + ord(rd)*"100 + 
	      ord(ra)*"80 + unused*"10 + rcode;
	checksum:=checksum+id+temp+qdcount+ 
		  ancount+nscount+arcount;
    end; {with}	

    datalength:=iplength-ip_hdr_sz-udp_hdr_sz-dmn_hdr_sz; 
       { Note: Use iplength rather than udplength since it
	 has been protected by ipchecksum for received datagrams }
	
    {sum high order octets first}
    i:=1;
    sumhigh:=0;
    while i<=datalength do
    begin
	sumhigh:=sumhigh+data.data_recs[i];
	i:=i+2;
    end; 
    
    checksum:=checksum+sumhigh*256;
    {sum low order octets}
    i:=2;
    while i<=datalength do
    begin {add low order octet}
	checksum:=checksum+data.data_recs[i];
	i:=i+2;
    end; 

    {convert to ones complement sum of 16-bit 
     words by adding 16-bit carry}
    checksum:=(checksum mod "10000)+(checksum div "10000);
    checksum:=(checksum mod "10000)+(checksum div "10000);

    {return ones complement of result}
    udp_checksum:="ffff-checksum;

end; {with}    
end; {udp_checksum}


function udp_receive(var pkt:message_template;
		     wait_pkt:boolean):boolean;

{ Receive UDP messages from 0 to 548 octets. 
  If wait_pkt is true then wait until a message is received,
  else check for messages, and return.  If a message
  was received, return true as the value of the function.
  Messages longer than 548 octets or with invalid
  checksums are discarded. }

var	i, ret, wait_flag,
	checksum, datalength, error_code:integer;
	message_received:boolean;

begin {udp_receive}
    if wait_pkt 
    then wait_flag:=0
    else wait_flag:=RIQNW_; 

    {receive internet datagram}
    
    repeat  {until message received or not wait}
	the_buffer^.count:=145;	{maximum buffer size in words}

	{receive Internet datagram}
	jsys(rcvin_, -2, ret;wait_flag:iq_handle, 
	     the_buffer^, 0;error_code);
	if ret=3
	then begin  {error}
		 message_received:=false;
		 if (error_code <> 777777b) and
		     (error_code <> -1)
		 then begin
			  myfbp:=ofile(err);
			  writeln(myfbp^.fident, 'jsys RCVIN failed');
			  jsys_err(noabort, error_code, myfbp);
			  cfile(myfbp);
		      end;
	     end  {error}
	else begin {message received}
		 {check bounds on datalength}
		 datalength:=the_buffer^.iplength-ip_hdr_sz-udp_hdr_sz;	 {datalength in octets}

		 if (datalength>548) or (datalength<0)
		 then {datalength out of bounds}
		      begin
			  message_received:=false;
			  myfbp:=ofile(err);
			  writeln(myfbp^.fident,' UDP message discarded due to length');
				     end
		 else begin {datalength ok}
			  {check UDP checksum}	
			  if the_buffer^.udpchecksum=0
			  then 	{no checksum--assume data valid}
			      checksum:=0
			  else	{compute checksum}
			      checksum:=udp_checksum(the_buffer^);

			  if checksum<>0
			  then  {checksum error}
			      begin
				  message_received:=false;
				  myfbp:=ofile(err);
				  writeln(myfbp^.fident,' UDP checksum errror');
				  cfile(myfbp);
				  end
			  else begin {copy message}
				   message_received:=true;
				   pkt.xmit_using:=dgm;
				   pkt.octet_cnt:=datalength-dmn_hdr_sz;
				   pkt.raw_pkt:=the_buffer^.data;
				   if datalength > 512
				   then pkt.raw_pkt.header.tc:=true;    
				   with pkt,the_buffer^
				   do	begin
					    to_address:=dest_adr;
					    to_port:=dest_port;
					    from_address:=sorc_adr;
					    from_port:=sorc_port
					    end;
				   dst_address:=the_buffer^.sorc_adr;
				   dst_port:=the_buffer^.sorc_port;
			       end; {copy message}
		      end;  {datalength ok}
	     end; {message received}
    until message_received or (not wait_pkt);
    udp_receive:=message_received;	
end; {udp_receive}


procedure udp_send(var pkt:message_template);

{ Send a user datagram using UDP/IP for
  messages of up to 548 octets in length.
  Increment identification here. }

var	i, j, error_code, ret:integer;

begin {udp_send}

with the_buffer^, pkt.raw_pkt do
begin	
    {prepare output buffer}
	 {buffer length in words, rounded up }
    count:=1 {count word} +
	     ((ip_hdr_sz+udp_hdr_sz+dmn_hdr_sz+pkt.octet_cnt+3) div 4);

    {prepare ip datagram header}
    version:=4;
    ihl:= 5;                       {header length in 32-bit words} 
    tos:=0;			   {normal type of service}
    {ip datagram length in octets}
    iplength:=ip_hdr_sz+udp_hdr_sz+dmn_hdr_sz+pkt.octet_cnt;
    ident:=identification;
    flagrsvd:=0;	           {reserved}
    flagdf:=0;			   {may fragment}
    flagmf:=0;			   {last fragment}
    fragment:=0;		   {fragment offset}
    ttl:=100;			   {time to live = 100 gateway hops} 
    protocol:=17;		   {udp}
    with pkt
    do if from_address<>0
    then begin
	     sorc_adr:=from_address;
	     sorc_port:=from_port
	     end
    else begin
	     sorc_adr:=src_address;
	     sorc_port:=src_port
	     end;		{internet protocol will fill in but
				    it is required for udp checksum}
    with pkt
    do if to_address<>0
    then begin
	     dest_adr:=to_address;
	     dest_port:=to_port
	     end
    else begin
	     dest_adr:=dst_address;
	     dest_port:=dst_port
	     end;

    {udp header}
    udplength:=udp_hdr_sz+dmn_hdr_sz+pkt.octet_cnt;   {in octets}
    udpchecksum:=0;		  {initialize for checksum computation}

    {udp data}
    data:=pkt.raw_pkt;
 
    {udp checksum}
    udpchecksum:=udp_checksum(the_buffer^);
    if udpchecksum=0 
    then udpchecksum:="ffff;

    if udp_log_all
    then      begin
		   myfbp:=ofile(log);
		   writeln(myfbp^.fident,' UDP message sent');
		   cfile(myfbp);
	      end;
    
    {send internet datagram}
    jsys(sndin_, -2, ret;iq_handle, the_buffer^, 0;error_code);

    if ret=3
    then begin {error message}
	     myfbp:=ofile(err);
	     writeln(myfbp^.fident, 'jsys SNDIN failed');
	     jsys_err(noabort, error_code, myfbp);
	     cfile(myfbp);
	 end;  {error message}
    
    {increment internet identification}
    if identification<"ffff
    then identification:=identification+1
    else identification:=0;

end; {with}    
end. {udp_send}