{$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 }