{$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;
		     var csavings:integer);

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

        csavings is bytes saved due to compression,
        not including domain names tossed due to truncation }

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 byteto look 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 { check 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;
	    csavings:=csavings+lendns(o_name)-2;
	    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
csavings:=0; { zero out savings due to compression }
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 }