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