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