{$M-,X+}
program rsolve;

include {NOLIST} 'domain:jsys.def';
include {NOLIST} 'pascal:extern.pas';
include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:lparse.def';
include {NOLIST} 'domain:hash.hdr';
include {NOLIST} 'domain:msub.hdr';
include {NOLIST} 'domain:alloc.hdr';
include {NOLIST} 'domain:iomsg.hdr';
include {NOLIST} 'domain:eutil.hdr';
include {NOLIST} 'domain:mdep.hdr';
include {NOLIST} 'domain:dump.hdr';
include {NOLIST} 'domain:irdata.hdr';
include {NOLIST} 'domain:pp.hdr';
include {NOLIST} 'domain:tport.hdr';
include {NOLIST} 'domain:msure.hdr';
include {NOLIST} 'domain:naddrr.hdr';
const   sb_state_idle=0; (* resolver is not active for this block *)
	sb_state_new=1;	(* JSYS asked for resolve which has not started *)
	sb_state_waiting=2; (* Waiting for reply or retrasmission *)
	sb_state_quiet=3; (* Waiting after transmissions done *)


	did_slot_mask="f00; (* mask to extract slot number from domain_id *)
	did_gas=1;	     (* number of unused bits here *)
	did_slot_shift=8;    (* shift count for slot number *)
	did_seq_mask="70;    (* mask to extract request number *)
	did_seq_bit="10;
	did_xmit_mask="0f;   (* mask to extract  *)

	max_xmit_time="7ff;	     (* array dimension for timing array *)

	paranoid=false;	     (* should the resolver be paranoid? *)
type

string30=packed array[1..30] of char;

search_block_index=1..max_sb;

var     search_scan:search_block_index;	(* index of current search block *)
	newgram:rawmsg;	(* raw received datagram *)
	rval,toss:integer;
	master:master_block_pointer;
	index:integer;
	select_index:hgraph_index;
	select_eta:integer;

        { process scan blocks and parallel domain and raw message buffers }
	psb:array[1..max_sb] of servers_dv;
	pdmsg:array[1..max_sb] of domsg;
	ptport:array[1..max_sb] of transport;
	prmsg:array[1..max_sb] of rawmsg;

	logging:boolean;
	myfbp:file_blk_ptr;
	xmit_time:array[0..max_xmit_time] of integer; (* time query sent *)
	xmit_to:array[0..max_xmit_time] of integer; (* address slot number *)

procedure r_search;forward;

function tocheck(myrr:rr_pointer):boolean;

{	 TOCHECK returns true if this RR has not timed out}

begin
if myrr^.ttl>=0
then	 tocheck:=true	(* always OK if from authoritative *)
else	 tocheck:=myrr^.ttl<=master^.sb_array[search_scan].tquery
end; { tocheck }

function loghdr:boolean;

{	 This function returns a value equal to the logging variable

	 if the logging condition is true, it opens the log file and
	 outputs the start of a slot message }

begin
loghdr:=logging;
if logging
then with master^.sb_array[search_scan]
     do begin
	 myfbp:=ofile(log);
	 write(myfbp^.fident,'Slot ',search_scan:1,' TTL ',resttl:1,' ');
	 if tbit(rflags,gtdmba)
	 then write(myfbp^.fident,'MBA ')
     end
end; { LOGHDR }
{ All exits come through these routines }

procedure set_state(newstate:integer;
		      time_delta:integer);

{ SET_STATE is called to transition a search block to a new state }

begin
master^.rcom[search_scan]:=newstate; (* set search block state *)
master^.sb_array[search_scan].rtimeo:=msclock+time_delta; (* and timeout *)
end; { set_state }

procedure clear_sblocks;

begin
with master^.sb_array[search_scan]
do begin
       if lock1<>NIL
       then begin
		ulocks(lock1^);
		lock1:=NIL
	    end;
       if lock2<>NIL
       then begin
		ulocks(lock2^);
		lock2:=NIL
	    end;
       azone:=NIL;
       adeln:=NIL;
       cdeln:=NIL;
       adell:=0;
       cdell:=0;
   end
end;

procedure res_ret(code:integer);

{ return specified error code, or zero if no error.  Note that we must be
   very careful with the order of things to avoid synchronization problems }

var release:boolean;
begin
with master^.sb_array[search_scan]
do   begin
	 derc:=code;
	 if loghdr
	 then begin
		  if code=0
		  then writeln(myfbp^.fident,'terminated normally')
		  else writeln(myfbp^.fident,'terminated error ',code:6:o);
		  cfile(myfbp)
	      end;
	 release:=tbit(fcode,gtdrbk); { background request release resources }
	 master^.rcom[search_scan]:=sb_state_idle;
	 if release then begin
			     clear_sblocks;
			     pulock(slock)
			 end;
     end
end;

procedure create_query;

{	CREATE_QUERY builds a new query }

var	len:integer;

begin
i_domsg(pdmsg[search_scan]); (* initialize query record *)
with master^.sb_array[search_scan],pdmsg[search_scan]
do   begin
	 dhead.domain_id:=bshift(search_scan,did_slot_shift)+
			  band(dhead.domain_id+did_seq_bit,did_seq_mask);
	 dhead.opcode:=std_query;
	 with parse[question]
	 do   begin
		  count:=1;
		  with rdv[1]
		  do   begin
			   namebp:=free_ptr;
			   copydns(xseto(sname),free_ptr);
			   len:=lendns(free_ptr);
			   free_cnt:=free_cnt-len;
			   xadjbp(free_ptr,len);
			   databp:=free_ptr;
			   xidpb2(free_ptr,stype);
			   xidpb2(free_ptr,sclass);
			   free_cnt:=free_cnt-4
		       end
	      end
     end
end; { create_query }

procedure bump_did;

begin
with prmsg[search_scan]
do   dhead.domain_id:=band(dhead.domain_id+1,did_xmit_mask)+
		      band(dhead.domain_id,did_slot_mask+did_seq_mask)
end; { bump_did }

function idscode(id:integer):integer;

{	 Fold the ID field into the xmit_time data base }
begin
idscode:=min(max_xmit_time,
	     bshift(band(id,did_slot_mask),-did_gas)+
	     band(id,did_seq_mask+did_xmit_mask))
end; { idscode }
procedure log_xmit;

{ log_xmit logs a transmission }

var id,idex:integer;
    idptr:g1bpt;
begin
with prmsg[search_scan]
do begin
       idptr:=xseto(unspec);
       xadjbp(idptr,(ihl*4)+udp_hdr_sz);
       id:=xildb2(idptr);
       idex:=idscode(id);
       xmit_time[idex]:=msclock;
       xmit_to[idex]:=select_index;

       with master^.measure
       do   begin
		xaos(udpgra.touts);
		xaos(udphst[select_index].touts);
		xaos(newudp[select_index].touts);
		newudp[select_index].host:=dest_adr
	    end;

       if loghdr
       then  begin
		 write(myfbp^.fident,' ID ',id:4:h,' query sent to ');
		 toss:=dmpina(myfbp^.fident,dest_adr);
		 writeln(myfbp^.fident,' ETA ',select_eta:3);
		 cfile(myfbp)
	     end
   end
end; { log_xmit }
procedure log_wait;

begin
if loghdr
then begin
	 Writeln(myfbp^.fident,'recursive wait');
	 cfile(myfbp)
     end
end; { log_wait }

procedure log_recv;

begin
if loghdr
then begin
	write(myfbp^.fident,'ID ',pdmsg[search_scan].dhead.domain_id:4:h,
	       ' message from ');
	 toss:=dmpina(myfbp^.fident,newgram.sorc_adr);
	 writeln(myfbp^.fident);
	 if master^.logri<>0 then d_domsg(myfbp^.fident,pdmsg[search_scan]);
	 cfile(myfbp)
     end
end; { log_rcv }
procedure age_newudp;

(* This procedure throws away half of the data in NEWUDP to try and keep
   only reasonably recent data for making routing decisions.  Note that
   queries and replies in flight when this happens may create incorrectly
   high batting averages, and roundoff error can be exciting but
   c'est la vie *)

var i:integer;

begin
for i:=1 to hslots
do with master^.measure.newudp[i]
   do if touts<=1
      then begin (* clear slot *)
	       host:=0;
	       touts:=0;
	       tbacks:=0;
	       ttotal:=0
	   end
      else begin (* half *)
	       touts:=touts div 2;
	       tbacks:=tbacks div 2;
	       ttotal:=ttotal div 2
	   end
end; (* age_newudp *)
function server_goodness(myname:g1bpt):integer;

{ SERVER_GOODNESS is a function which returns a measure of how
  close a name is to the target name.  The larger this value is,
  the better.  The function is the number of labels in the server
  name if the name is an ancestor of the target, and negative the
  number of labels if the server is not an ancestor of the target }

var	myname_table:dname_string_table;
        target_table:dname_string_table;
	extra:integer;

begin
m_dst(myname,myname_table);
m_dst(xseto(master^.sb_array[search_scan].sname),target_table);
extra:=target_table.count-myname_table.count;
server_goodness:=-myname_table.count; (* assume the worst *)
if extra>=0
then if dnscomp(myname,target_table.bp[extra+1])
     then server_goodness:=myname_table.count;
end; { server_goodness}
procedure glue_set_sa(var server:server_type);

{	GLUE_SET_SA attempts to set up server addresses via a glue search }

var	mynode:node_pointer;
	myrr:rr_pointer;
	adv:g1bpt;

begin { glue_set_sa }

with master^.sb_array[search_scan],server
do   begin
	 address_count:=0;
	 addresses_ready:=false;
	 if f_node(azone^,xseto(server_name),mynode)=0
	 then begin (* found a node where glue entries could be expected *)
		  myrr:=mynode^.rr_ptr;
		  while (myrr<>NIL) and (address_count<max_server_addresses)
		  do begin
			 if (myrr^.rrtype=a) and (myrr^.rrclass=internet)
			 then begin
			       address_count:=address_count+1;
			       addresses_ready:=true;
			       with server_addresses[address_count]
			       do begin
				    adv:=xseto(myrr^.rdata^.litdata^.ldata);
				    xadjbp(adv,2); (* skip past length *)
				    ipaddress:=xildb4(adv)
				  end
			      end;
			 myrr:=myrr^.next
		     end
	      end;
     end
end; { glue_set_sa }
function need_mba(s_index:integer):boolean;

{ This function decides whether the recursive search for a server's
  address should be done using MBA.  The basic idea here is that it should
  if the domain of interest is an ancestor of the server's name }

var server_bp,domain_bp:g1bpt;
    server_len,domain_len,ll:integer;
begin
with psb[search_scan]
do begin
       server_bp:=xseto(servers[s_index].server_name);
       server_len:=lendns(server_bp);
       domain_bp:=xseto(server_at);
       domain_len:=server_at_len;

        (* while server name is longer, peel off labels *)
       while server_len>domain_len
       do begin
	      ll:=xildb(server_bp);
	      xadjbp(server_bp,ll);
	      server_len:=server_len-ll-1;
	  end;

       if server_len<>domain_len
       then need_mba:=false
       else need_mba:=dnscomp(server_bp,domain_bp)
   end
end; { need_mba }
procedure set_sptrs(var mst:server_type);

(* This procedure initializes the stat_ptrs for a server to point
to the appropriate entry in udpgra and newudp *)

var i:integer;
begin
if mst.addresses_ready
then for i:=1 to mst.address_count
     do with mst.server_addresses[i]
        do stat_ptr:=hlook(ipaddress,master^.measure.udphst);
end;
procedure bind_sa(use_glue:boolean);

{ Given the list of name servers to use, try to get their host addresses
  via GTDOM% calls.  These calls are restricted to
  avoid recursive disaster.  If the name server data came from an
  authoritative zone, look for address bindings via a glue search as well 

  WARNING: this procedure assumes that the log file is ready and uses it
           without initialization }

var	i:integer;
	mba:boolean;
begin
with psb[search_scan],master^.sb_array[search_scan]
do begin
   for i:=1 to server_count
   do begin
       if logging
	   then begin
		   if (i>1) and ((i mod 2)=1) (* print two servers per line *)
		   then begin
			    writeln(myfbp^.fident);
			    pheader(log,myfbp)
			end
		   else write(myfbp^.fident,' ');
		   toss:=dmpdns(myfbp^.fident,xseto(servers[i].server_name));
		end;

       (* Note that in the following code, we see if we can start up a
          background request by testing that RESTTL exceeds some value and
          then start a background request with some amount less than the
          current RESTTL.

          IT IS ESSENTIAL that a zero value not be used since that implies
          that the default value will be used and could result in infinite
          looping. *)

       if getadr(servers[i],false,false,false,resttl-5) (* LDO try *)
       then (* name resolved *)
       else begin
		if use_glue (*  use glue *)
                then begin
			  if logging then write(myfbp^.fident,' (glue)');
			  glue_set_sa(servers[i])
		     end;
		if (not servers[i].addresses_ready) and (resttl>5)
		then if getadr(servers[i],true,true,need_mba(i),resttl-5)then;
	    end;

       if servers[i].addresses_ready
       then begin
		if logging then d_sa(myfbp^.fident,servers[i],false);
		set_sptrs(servers[i]) (* setup stat_ptrs *)
	    end;
       end;

   if logging then writeln(myfbp^.fident);

   { Reorder the list if desired to pick closer servers, addresses etc }
   sort_sa(psb[search_scan]);

   if logging and (server_count>0)
   then begin (* print out reordered list *)
	    pheader(log,myfbp);
	    write(myfbp^.fident,'Reorder to:');
	    for i:=1 to server_count
	    do begin
		   if (i>1) and ((i mod 2)=1) (* print two servers per line *)
		   then begin
			    writeln(myfbp^.fident);
			    pheader(log,myfbp)
			end
		   else write(myfbp^.fident,' ');
		   toss:=dmpdns(myfbp^.fident,xseto(servers[i].server_name));
		   d_sa(myfbp^.fident,servers[i],true)
	       end;
	    writeln(myfbp^.fident)
        end
   end { with }
end; { bind_sa }
procedure get_cl;

{ GET_CL gets the primitive cache lock }

const	  cache_wait_delta=500;	(* how long between cache lock tries *)

var	  started_waiting,interval:integer;
begin
with master^.cache_pointer^
do if not prlock(zone_lock.lockwd) (* primative lock *)
	   then   begin
		       started_waiting:=msclock;
		       repeat mswait(cache_wait_delta);
			      interval:=started_waiting-msclock;
		       until  prlock(zone_lock.lockwd);
		  end

end; { GET_CL }
procedure s_caching;

{ S_caching is called to obtain write access to the cache.  It
  also creates the cache if necessary.  Like E_caching, a call to
  s_caching is a NOP if the cache is already held in write mode.
  This all assumes that the resolver is the only code to ever get
  a write lock on the cache. }

const	  write_wait=500; (* wait inteval for JSYSes to clear *)

var	  acquired:boolean;
	  new_cache:zone_entry_pointer;
	  index,locks_needed:integer;
	  cache_lock_address,this_lock:lock_pointer;
begin
if master^.cache_pointer=NIL
then	   begin (* must create cache zone *)
	       a_zone(new_cache);
	       new_cache^.zone_is_cache:=true;
	       new_cache^.loaded:=true;
	       ilock(new_cache^.zone_lock);
	       { give a lock to the requester }
	       while not locks(new_cache^.zone_lock,100,1000)
	       do; { should never wait }
	       this_lock:=lckptr(new_cache^.zone_lock);
	       with master^.sb_array[search_scan]
	       do if lock1=NIL
		  then lock1:=this_lock
		  else lock2:=this_lock;
	       up_all;
	       master^.cache_pointer:=new_cache;
	       up_all
	   end;

{ The strategy for obtaining the write lock is to get a primative lock on
  the cache zone, and then to check to see if all of the read locks
  (if any) belong to search blocks which are owned by the resolver. }

with master^.cache_pointer^
do repeat  get_cl;  
	   if zone_lock.exclusive>0
	   then { Already write locked, assume we have it }
	        acquired:=true
	   else	if zone_lock.share=0
	        then acquired:=true
		else begin (* see if the read locks belong to the resolver *)
		     locks_needed:=zone_lock.share;
		     index:=1;
		     cache_lock_address:=lckptr(zone_lock);
		     while (locks_needed>0) and (index<=max_sb)
		     do with master^.sb_array[index]
			do begin
			       if master^.rcom[index]<>0 (* belongs to resolver *)
			       then if (lock1=cache_lock_address) or
				       (lock2=cache_lock_address)
				    then locks_needed:=locks_needed-1;
			       index:=index+1
			   end;
		     acquired:=locks_needed=0
		     end;
	   if acquired
	   then begin
		    zone_lock.exclusive:=1;
		    master^.cupdate:=0;	(* signal cache at risk *)
		    up_pages(quotep(master^.cache_pointer) div 512,
			    (sizeof(master^.cache_pointer)+511) div 512)
		end;
	   pulock(master^.cache_pointer^.zone_lock.lockwd);
	   if not acquired then mswait(write_wait)
   until acquired

end; { S_caching }

procedure e_caching;

{ E_caching is called to release the cache if it is held in write
  mode. This procedure is designed so that calling it doesn't hurt
  anything, even if a matching S_CACHING call didn't happen. }

var	i:integer;
begin
get_cl;
if master^.cache_pointer^.zone_lock.exclusive<>0
then begin
	 up_all;
	 { set database update time }
	 
	 jsys(gtad;;i);
	 if i=-1
	 then begin
		   myfbp:=ofile(err);
		   writeln(myfbp^.fident,'System clock not set.. big trouble');
		   cfile(myfbp)
	      end;

	 master^.cupdate:=i;
	 up_pages(quotep(master) div 512,
		  (sizeof(master)+511) div 512)
     end;
master^.cache_pointer^.zone_lock.exclusive:=0;
up_pages(quotep(master^.cache_pointer) div 512,
	 (sizeof(master^.cache_pointer)+511) div 512);
pulock(master^.cache_pointer^.zone_lock.lockwd)
end;
procedure rr_cache(     scode:sectcode;
			  first:integer;
			  last:integer;
		      var mynode:node_pointer);

{ This procedure caches the specified RRs in a section. }

var	index:integer;

begin
if last>=first (* if there is anything to cache *)
then begin
	 S_caching;
	 if loghdr
	 then begin
	      write(myfbp^.fident,'Caching RRs ',first:1,' through ',last:1,
			     ' from section:');
	      d_sect(myfbp^.fident,pdmsg[search_scan],scode);
	      cfile(myfbp)
	      end;
	 with pdmsg[search_scan].parse[scode]
	 do for index:=first to last
	     do with rdv[index]
		 do if index=1
		    then add_rr(master^.cache_pointer^,namebp,mynode,databp)
		    else if dnscomp(namebp,rdv[index-1].namebp)
			 then con_rr(master^.cache_pointer^,mynode,databp)
			 else add_rr(master^.cache_pointer^,namebp,mynode,databp);
	 e_caching { free up the cache }
     end
end; { rr_cache }

procedure sct_cache(    scode:sectcode;
		    var mynode:node_pointer);

begin
rr_cache(scode,1,pdmsg[search_scan].parse[scode].count,mynode)
end; { sct_cache }
function select_server(var resolve_wait:boolean):integer;

{	   Select_server selects the next IP address of a server to be
	   queried and returns either it or zero if there are no addresses
	   to try.  RESOLVE_WAIT is set if an unresolved server might be
	   available in the future.

	   The selection algorithm tries servers in the order in which they
	   appear in the table, using all first addresses, then all second
	   addresses, etc.  All addresses for all servers are tried before
           any addresses are repeated. }

var i,j,server_number,server_address,best_tries_so_far:integer;

begin
resolve_wait:=false;
best_tries_so_far:=master^.measure.maxit+1; (* initialize match data *)
server_number:=0;
server_address:=2; (* random value to avoid uninitialized value error *)
with psb[search_scan]
do for i:=1 to server_count (* loop over all servers *)
   do  begin
       if not servers[i].addresses_ready (* if server address not known *)
       then begin
	    resolve_wait:=true;
	    if getadr(servers[i],false,false,false,gtdrcm) (* try to get it with ldo *)
	    then begin
		     set_sptrs(servers[i]);
		     sort_a(servers[i]) (* if got it, sort the addresses *)
		 end
	    end;
       if servers[i].addresses_ready
       then for j:=1 to servers[i].address_count (* and all addresses *)
	    do	with servers[i].server_addresses[j]
		do   if (tries<limit)
			and (tries<=best_tries_so_far)
                     then if (tries<best_tries_so_far) (* best so far *)
			     or (j<server_address) (* equal, but new server *)
                          then	begin (* best candidate so far *)
				     best_tries_so_far:=tries;
				     server_number:=i;
				     server_address:=j
				end;
       end;
if server_number=0
then select_server:=0 (* signal failure *)
else with psb[search_scan].servers[server_number].server_addresses[server_address]
     do begin
	    select_server:=ipaddress; (* signal address to query *)
	    tries:=tries+1;
	    select_index:=stat_ptr;
	    select_eta:=eta
	end

end; { select_server }
procedure forget_server;

{ Stop asking the server which just responded }

var    loser:integer;
       server_index,mark_index,address_index:integer;
begin
loser:=newgram.sorc_adr;
with psb[search_scan]
do for server_index:=1 to server_count
   do with servers[server_index]
      do for address_index:=1 to address_count
	 do with server_addresses[address_index]
	    do if ipaddress=loser
	       then (* mark all addresses of this server as losers *)
		for mark_index:=1 to address_count
		do server_addresses[mark_index].tries:=master^.measure.maxit
end; { forget_server }
procedure ask_another;

{ Send the query out to the next choice }

var next_server,expected:integer;
    waiting:boolean;
begin
with master^.sb_array[search_scan]
do begin
       resttl:=resttl-1; (* decrement resolver time to live *)
       next_server:=select_server(waiting); (* select next target *)
       if master^.rcom[search_scan]<>sb_state_quiet
       then if next_server=0
	    then if waiting
		 then begin
			  set_state(sb_state_waiting,master^.measure.qtor);
			  log_wait
		      end
		 else set_state(sb_state_quiet,master^.measure.qtoq)
	    else begin
		     ptport[search_scan].foreign_address:=next_server;
		     bump_did;
		     s_rawmsg(master^.resolve_handle,
			      ptport[search_scan],prmsg[search_scan]);
		     log_xmit;
		     if master^.measure.dynsw=0
		     then expected:=master^.measure.qtor
		     else expected:=(select_eta * master^.measure.dynnum) div
			                 master^.measure.dynden;
		     set_state(sb_state_waiting,expected)
	    end
   end

end; { ask_another }
procedure peculiar_response(msg:string30);

{ Log this domain message as peculiar, along with the message,
  and don't ask this server again }

begin
if (master^.logrp<>0) or logging
then begin
	 myfbp:=ofile(log);
	 Writeln(myfbp^.fident,'Slot ',search_scan:1,' ',msg);
	 d_domsg(myfbp^.fident,pdmsg[search_scan]);
	 cfile(myfbp)
     end;
forget_server;
ask_another;
end; { peculiar_response }
procedure delegation;

{ DELEGATION is called to use the information in a response
  to locate a better server }

var	new_server:boolean;
	new_goodness,referral_rr,i:integer;
	sbp:g1bpt;
	toss_node:node_pointer;

	procedure get_server(servebp:g1bpt);

	{ GET_SERVER adds a server to the current process scan block }

	begin
	with psb[search_scan]
	do if server_count<max_search_servers
	   then begin
		    server_count:=server_count+1;
		    with servers[server_count]
		    do begin
			   addresses_ready:=false;
			   copydns(servebp,xseto(server_name))
		       end
		end
	end; (* get_server *)

begin
with psb[search_scan],pdmsg[search_scan].parse[authority]
do	if count=0
	then peculiar_response('No answers, no delegation     ')
	else begin
		new_server:=false;
		for i:=1 to count
		do begin (* make sure the referral makes progress *)
			sbp:=rdv[i].databp;
			xadjbp(sbp,10); (* point to server name *)
		        new_goodness:=server_goodness(rdv[i].namebp);
			if new_goodness>server_quality
			then	{ better than ever before }
				begin
				referral_rr:=i;
				if new_server
				then if logging
				     then write(myfbp^.fident,' redelegation ')
				     else
				else begin { cache only once }
					sct_cache(authority,toss_node);
					sct_cache(additional,toss_node);
					if loghdr
					then write(myfbp^.fident,'delegate ');
				     end;
				if logging then toss:=dmpdns(myfbp^.fident,rdv[referral_rr].namebp);
				server_count:=0;
			        copydns(rdv[i].namebp,xseto(server_at));
				server_at_len:=lendns(xseto(server_at));
				server_quality:=new_goodness;
				get_server(sbp);
				new_server:=true
				end
			else	if new_server and
				(new_goodness=server_quality) and 
				(server_count<max_search_servers)
				then get_server(sbp); { add a new co-equal }
		   end;
		(* bind the server addresses without glue *)
		if new_server
		then begin
			 if logging
			 then begin
				  writeln(myfbp^.fident);
				  pheader(log,myfbp)
			      end;
			 bind_sa(false)
		     end
		else if loghdr
		     then writeln(myfbp^.fident,' ***** DELEGATION FAILED *****');
		if logging then cfile(myfbp)
	     end
end; { delegation }
procedure use_cname;

{ This routine is called by use_mcname and use_dcname to set up a CNAME
  from either a message or the database.  It standardizes the case of SNAME,
  set up string descriptor, logs it, etc. }

var     toss:integer;

begin
with master^.sb_array[search_scan]
do begin
       if loghdr
       then begin
		 Write(myfbp^.fident,'CNAME taken: ');
		 toss:=dmpdns(myfbp^.fident,xseto(sname));
		 writeln(myfbp^.fident);
		 cfile(myfbp)
	    end;
       m_dst(xseto(sname),stable);
       sbit(rflags,gtdaka); (* set alias *)
   end;
end;

procedure use_mcname(scode:sectcode;
		      id:integer);

var cname_bp:g1bpt;

begin (* found a CNAME to use *)
with master^.sb_array[search_scan],pdmsg[search_scan].parse[answer].rdv[id]
do begin
       rr_cache(scode,id,id,rsolvn);
       ccdns(f_data(databp),xseto(sname));
       use_cname
   end;
end; {use_mcname}

procedure use_dcname(myrr:rr_pointer);

var ptr:g1bpt;

begin
ptr:=xseto(master^.sb_array[search_scan].sname);
cvdnp(myrr^.rdata^.rrname,ptr);
use_cname
end;
procedure sb_lock(var mylock:lock);

begin
with master^.sb_array[search_scan]
do begin
       while not locks(mylock,100,2000) do;
       if lock1=NIL
       then lock1:=lckptr(mylock)
       else lock2:=lckptr(mylock)
   end
end;
function azfind:boolean;

{ AZFIND looks for the best authoritative zone to search, if any.
  Points ANONE at it, returns true if node in authoritative region
  otherwise returns false with ADELN pointing to a delegation and
  ADELL set to the number of labels that matched in the delegation }

var now_at:node_pointer;
    scanptr:zone_entry_pointer;
    i,toss:integer;
    s_result:boolean;

begin
with master^.sb_array[search_scan]
do begin
       while not locks(master^.search_zone.zone_lock,100,2000) do;
       now_at:=master^.search_zone.zone_node;

       i:=stable.count; (* start at root *)
       repeat if now_at^.zone_ptr<>NIL
	      then begin (* find zone with matching class *)
		      scanptr:=now_at^.zone_ptr;
		      while scanptr<>NIL
		      do if (ord(scanptr^.zone_class)=sclass)
				AND
			     scanptr^.loaded
		         then	begin
				     azone:=scanptr;
				     adell:=stable.count-i+1;
				     scanptr:=NIL
				end
			 else	scanptr:=scanptr^.zone_chain
		   end;
	      i:=i-1;	(* move down one label *)
	      if i<>0 then s_result:=f_son(now_at,stable.bp[i],now_at,toss)
       until  (i=0) or (not(s_result));

       if azone=NIL
       then azfind:=false
       else begin
	       sb_lock(azone^.zone_lock);
	       azfind:=true
	    end;
   end;

ulocks(master^.search_zone.zone_lock); {release search zone lock}
end; { azfind }
function azlook:boolean;

{ AZLOOK tries to find data for the query in the current search block in
  a local authoritative zone.

  If the name doesn't exist (authoritatively) then derc gets set

  If the name is present in the authoritative part of the zone, then the
  function returns TRUE.  AZONE points to the zone, RSOLVN points to the
  node, and a lock is set for the authoritative zone and recorded in the
  search block.

  If the name isn't present in authoritative data, then the function
  returns false.  If an authoritative delegation is present, ADELN, ADELL,
  AZONE and some lock variable will be set. }

var star_label:packed array[0..63] of octet;
    spoint,next_spoint:node_pointer;
    toss:integer;
    search_cond:boolean;
begin
with master^.sb_array[search_scan]
do if azfind { look for and authoritative zone to search }
   then begin
   	spoint:=azone^.zsoa;	{ set search pointer to top of authority }
	search_cond:=true;
	if stable.count>adell  (* are there more labels to match *)
	then repeat search_cond:=f_son(spoint,stable.bp[stable.count-adell],
					next_spoint,toss);
	            if search_cond
		    then begin
			 adell:=adell+1;
			 spoint:=next_spoint;
			 if spoint^.node_lchain=NIL (* dropped off bottom? *)
			 then search_cond:=false
			 end
	      until  (search_cond=false) or (adell=stable.count);

	if (adell=stable.count) and (spoint^.node_lchain=NIL)
	then begin
		rsolvn:=spoint;
		azlook:=true 
	     end
	else if spoint^.node_lchain=NIL
	     then begin
		       adeln:=spoint; (* found delegation *)
		       azlook:=false
		   end
	     else begin
		       star_label[0]:=1;
		       star_label[1]:=ord('*');
		       if f_son(spoint,xseto(star_label),spoint,toss)
		       then begin
				rsolvn:=spoint;
				azlook:=true
			    end
		       else begin
				derc:=gtddne;
				azlook:=false
			    end
		   end
	end
   else azlook:=false (* signal failure, no authoritative zone to find *)
end; (* azlook *)
function czlook:boolean;

{ set RSOLVN to point to the node in the cache which matches the most
  labels of the search name.  Return true if all labels matched }

var toss,matched:integer;
    search_cond:boolean;
    new_ptr:node_pointer;
begin
with master^.sb_array[search_scan]
do if master^.cache_pointer<>NIL
   then begin
   	sb_lock(master^.cache_pointer^.zone_lock);
	rsolvn:=master^.cache_pointer^.zone_node;
	matched:=1;
	search_cond:=true; { root node matched automatically }
	while search_cond and (matched<>stable.count)
	do if f_son(rsolvn,stable.bp[stable.count-matched],new_ptr,toss)
	   then begin
	   	matched:=matched+1;
		rsolvn:=new_ptr;
		end
	   else search_cond:=false;
	czlook:=search_cond
	end
   else czlook:=false
end; { CZLOOK }
procedure czdel;

{ Setup CDELN and CDELL using node pointer in RSOLVN }

var spoint:rr_pointer;
    s_node:node_pointer;

begin
with master^.sb_array[search_scan]
do begin
   while rsolvn<>NIL { work up to the best delegation }
   do begin
      spoint:=rsolvn^.rr_ptr;
      while (spoint<>NIL)
      do if (spoint^.rrtype=NS) and tocheck(spoint)
         then begin
	      spoint:=NIL; { signal end of search }
	      cdeln:=rsolvn; { remember place with delegation }
	      rsolvn:=NIL
	      end
	 else spoint:=spoint^.next;
      if rsolvn<>NIL then rsolvn:=rsolvn^.up_ptr
      end;
   if cdeln<>NIL { if delegation found, find its level }
   then begin
        cdell:=1;
	s_node:=cdeln;
	while s_node^.up_ptr<>NIL
	do begin
	   s_node:=s_node^.up_ptr;
	   cdell:=cdell+1
	   end
	end;
   end
end; { CZDEL }
function answers_there:boolean;

{ return TRUE if there answers at the node spefied by RSOLVN }

var spoint:rr_pointer;

begin
with master^.sb_array[search_scan]
do begin
   answers_there:=false; { assume failure }
   spoint:=master^.sb_array[search_scan].rsolvn^.rr_ptr;
   repeat if spoint<>NIL
          then if tmatch(internet,stype,spoint^.rrtype) and tocheck(spoint)
               then begin
		    answers_there:=true;
		    spoint:=NIL
		    end
	       else spoint:=spoint^.next
    until  spoint=NIL
end { with }
end; { answers_there }
function cname_effective:boolean;

{ Check the RRs at RSOLVN and take a CNAME if appropriate }

var done:boolean;
    scan:rr_pointer;

begin
with master^.sb_array[search_scan]
do if tmatch(internet,stype,cname)
   then cname_effective:=false (* if CNAME could be in answer don't follow *)
   else begin
	    scan:=rsolvn^.rr_ptr;
	    done:=false; (* assume failure *)
	    while not done
	    do if scan=NIL
	       then done:=true
	       else if (scan^.rrtype=CNAME) and tocheck(scan)
		    then done:=true
		    else scan:=scan^.next;
	    if scan=NIL
	    then cname_effective:=false
	    else begin (* take the CNAME *)
		     use_dcname(scan);
		     r_search
		 end;
	end;
end; (* cname_effective *)
procedure dasd(server_data:servers_dv);

{ print all data for this servers block }

var i,toss:integer;

begin 
for i:=1 to server_data.server_count
do with server_data.servers[i]
   do begin
	  toss:=dmpdns(myfbp^.fident,xseto(server_name));
	  d_sa(myfbp^.fident,server_data.servers[i],true);
	  write(myfbp^.fident,' ');
      end;
writeln(myfbp^.fident)
end; { dasd }

procedure get_nserve(np:node_pointer);

{ copy name server references into psb }

var	  scan:rr_pointer;
	  bp,temp_ptr:g1bpt;
	  i:integer;
begin
scan:=np^.rr_ptr;
with psb[search_scan]
do  begin
    temp_ptr:=xseto(server_at);
    cvnnp(np,temp_ptr);
    server_at_len:=lendns(xseto(server_at));
    while (scan<>NIL) and (server_count<max_search_servers)
    do	  begin
	      if (scan^.rrtype=ns) and (scan^.rrclass=internet)
		  and tocheck(scan)
	      then    begin (* A server to use *)
		      server_count:=server_count+1;
		      with servers[server_count]
		      do   begin
			      bp:=xseto(server_name);
			      cvdnp(scan^.rdata^.rrname,bp);
			      addresses_ready:=false
			   end
		      end;
	      scan:=scan^.next
	  end;
    if server_count>0 (* calculate goodness if servers found *)
    then begin (* quality is number of labels in this case *)
	     i:=0;
	     while np<>NIL
	     do begin
		    np:=np^.up_ptr;
		    i:=i+1
		end;
	     server_quality:=i
	 end
    end
end; { get_nserve }
procedure r_delegation;

var next_server,timeout:integer;
    waiting:boolean;
begin
with master^.sb_array[search_scan],psb[search_scan] do
begin
server_count:=0;
if (adeln<>NIL) and (cdeln<>NIL)
then if cdell>adell
then adeln:=NIL;
if logging then myfbp:=ofile(log);
if cdeln<>NIL
then	begin (* Use the cache delegation *)
	    if logging then write(myfbp^.fident,'cache');
	    get_nserve(cdeln);
	    bind_sa(false) (* bind without glue *)
	end
else	if adeln<>NIL
	then begin (* Use the authoritative delegation *)
	     if logging then write(myfbp^.fident,'auth');
	     get_nserve(adeln);
	     bind_sa(true) (* bind with glue *)
	     end
	else begin (* Didn't get any delegation, try default server *)
	     if logging
	     then begin
		       write(myfbp^.fident,'default ');
		       dasd(master^.resolve_dserve);	(* dump server data *)
		  end;
	     psb[search_scan]:=master^.resolve_dserve
	     end;

if server_count=0
then begin
	 if logging
	 then begin
		  Writeln(myfbp^.fident,' No servers found, request terminated *****');
		  cfile(myfbp)
	      end;
	 res_ret(gtddna) (* signal data not available *)
     end
else
begin {servers to work with }

{ Format up the query datagram, and send it off to the best choice.  Set
  the alarm to go off after initial query timeout. }

next_server:=select_server(waiting);

if (next_server<>0) or waiting
then if tbit(fcode,gtdrtc)
     then (* Resolution with TCP was requested, return error *)
	  begin
	       if logging
	       then begin
			pheader(log,myfbp);
			Writeln(myfbp^.fident,' TCP requested, request terminated *****');
			cfile(myfbp)
		    end;
	       res_ret(gtddna)
	  end
     else begin
	  if logging then cfile(myfbp);
	  create_query;
	  with ptport[search_scan] (* setup the transport information *)
	  do   begin
		   xmit_using:=dgm;
		   foreign_address:=next_server;
		   foreign_port:=dns_socket;
		   local_port:=master^.resolve_port;
		   (* Note local address selected by s_rawmsg *)
	       end;
	  f_rawmsg(pdmsg[search_scan],ptport[search_scan],
		   prmsg[search_scan],toss);
	  if next_server<>0
	  then begin
		   bump_did;
		   s_rawmsg(master^.resolve_handle,
			    ptport[search_scan],prmsg[search_scan]);
		   log_xmit;
		   if master^.measure.dynsw=0
		   then timeout:=master^.measure.qtoi
		   else timeout:=(select_eta * master^.measure.dynnum) div
			                 master^.measure.dynden;
	       end
	  else begin
		   log_wait;
		   timeout:=master^.measure.qtoi
	       end;
	  set_state(sb_state_waiting,master^.measure.qtoi)
	  end
else begin (* Couldn't find the address of any server *)
     if logging
     then begin
	      pheader(log,myfbp);
	      Writeln(myfbp^.fident,' No addresses, request terminated *****');
	      cfile(myfbp)
	  end;
     res_ret(gtddna)
     end
		
end {servers to work with}
end { with }
end; { r_delegation }
procedure r_search;

{ RESTART search restarts the search assuming that the name is set up, but
  that the delgation variables need to be restarted.

  This procedure is typically used after a CNAME. }

begin
with master^.sb_array[search_scan]
do if resttl<=0	(* kill infinite loops *)
   then res_ret(gtddna)
   else begin
	    resttl:=resttl-1;
	    clear_sblocks; (* clear zone locks held by search block *)	    
	    if azlook (* look up node in authoritative data *)
	    then (* found authoritative data *)
		 if cname_effective
		 then (* take cname from database *)
		 else res_ret(0) (* done, whatever the result *)
	    else if derc<>0
		 then res_ret(derc) { Name does not exist }
		 else if tbit(rflags,gtdmba)
   		      then r_delegation (* if MBA, don't check cache *)
		      else if czlook
		           then if cname_effective
			        then (* off on another CNAME *)
			        else if answers_there
			             then res_ret(0)
				     else begin
				     	      czdel;
					      r_delegation
					  end
			   else begin
			   	czdel;
			   	r_delegation (* go hit default server *)
				end
	end
end; { restart saerch }
procedure eat_answers(first:integer);

{ EAT_ANSWERS is called when the remainder of the answer section is the
  answer, whether it is empty or not }

var i:integer;
    ok:boolean;
    toss_node:node_pointer;

begin
with pdmsg[search_scan].parse[answer],master^.sb_array[search_scan]
do begin
       ok:=true;
       for i:=first to count (* make sure all RRs are for the same place *)
       do if ok
	  then if not dnscomp(xseto(sname),rdv[i].namebp)
	       then ok:=false;
       if not ok
       then peculiar_response('Answers for different names   ')
       else { Cache and return }
	    begin
		if first>count
		then { Return an empty answer }
		else { Cache and return answers }
		     rr_cache(answer,first,count,rsolvn);
		sct_cache(authority,toss_node);
		sct_cache(additional,toss_node);
		res_ret(0) { exit without error }
	    end
   end { with }
end; { eat_answers }
procedure chk_answer;

{ CHK_ANSWER is called when a response contains an answer section.
  It goes through the answer section.  There are three main cases:

  1. If the answer may contain CNAME, then assume that all of the answer
     section is in fact the answer.

  2. The answer may start with one or more CNAMES which are followed by
     the answer.

  3. The answer may have one or more CNAMEs but not be followed by the 
     answer.

  Note that the special case of a MBA request with a leading CNAME is
   dealt with in the caller of chk_answer
}

var now_scanning:integer;
    any_cnames:boolean;
    cname_bp:g1bpt;
    cnames_complete:boolean;
    errors_found:boolean;
    toss_node:node_pointer;
begin
with pdmsg[search_scan],master^.sb_array[search_scan]
do begin (* with *)
       now_scanning:=1;	(* setup to eat CNAMEs off the front of the message *)
       errors_found:=false;
       cnames_complete:=false;
       any_cnames:=false;

       while (now_scanning<=parse[answer].count) and not cnames_complete
       do with parse[answer].rdv[now_scanning]
	  do if dnscomp(xseto(sname),namebp) (* name match *)
	     then if (f_type(databp)=cname) and not tmatch(internet,stype,cname)
		  then begin
			   any_cnames:=true;
			   use_mcname(answer,now_scanning);
			   now_scanning:=now_scanning+1
		       end
		  else cnames_complete:=true
	     else begin
		      errors_found:=true;
		      peculiar_response('Irrelevant RR in CNAME check  ');
		      errors_found:=true;
		      cnames_complete:=true
		  end;

       if errors_found (* if CNAME error happened, try to get going again *)
       then if any_cnames
	    then r_search	(* since one CNAME took, try restarting *)
	    else forget_server
       else with parse[answer]
	    do if truncated
	       then { Trucated answer section }
		    if any_cnames
		    then r_search	(* restart past CNAMEs *)
		    else res_ret(gtdtru)
	       else { Non-truncated answer section }
		    if any_cnames
		    then if now_scanning>count
			 then begin (* CNAMEs without follow-up *)
			      sct_cache(authority,toss_node);
			      sct_cache(additional,toss_node);
			      r_search
			      end
			 else (* CNAMEs with follow-up *)
			      eat_answers(now_scanning)
		    else { No CNAMEs, no truncation, so answer is complete
			   even if it is empty }
			 begin
			     if dhead.aa (* if authoritative, delete old *)
			     then begin
				      S_caching;
				      del_rr(master^.cache_pointer^,
					 xseto(sname),stype,sclass);
				      E_caching
				  end;
			     eat_answers(now_scanning)
			 end
   end; (* with *)

end; { chk_answer }
procedure new_dg;

{ NEW_DG starts with a response which parses, and now must
  decide whether the response has the answer we need, points to a
  better delegation, or is a distraction of one sort or another }

var myrr_type:dtype;

begin
with pdmsg[search_scan],master^.sb_array[search_scan]
do case dhead.rcode of

no_error:	    if dhead.ancount=0
		    then if dhead.aa (* name exists, but no matching RRs *)
			 then begin
				  rsolvn:=NIL;
				  res_ret(0)
			      end
			 else { not an empty answer, look for delegation }
			      begin
				  forget_server;
				  delegation;
				  ask_another
			      end
		    else { answers present, check for CNAME }
			if not dnscomp(xseto(sname),
				       parse[answer].rdv[1].namebp) 
			then peculiar_response('Answer name does not match    ')
			else begin
				 myrr_type:=f_type(parse[answer].rdv[1].databp);
				 if tbit(fcode,gtdmba) and
				    (myrr_type=cname) and
				    not tmatch(internet,stype,cname)
				 then (* eat just one CNAME if mba *)
				      if dhead.aa
				      then begin
					       use_mcname(answer,1);
					       r_search
					   end
				      else begin
					       forget_server;
					       delegation;
					       ask_another
					   end
				 else (* MBA answer *)
				      chk_answer
			     end;

format_error:	    peculiar_response('Format error in response      ');

server_failure:	    peculiar_response('Server failure                ');

name_error:	    if dhead.aa
		    then { If an authoritative server says name does not
			   exist, pass message on to user }
			 res_ret(gtddne)
		    else { If a non-authoritative server says name doesn't
			   exist, treat it as peculiar }
		         peculiar_response('Non-authoritative name error  ');

not_implemented:    peculiar_response('Query type not implemented    ');

refused:	    peculiar_response('Request refused               ');

others:		    peculiar_response('Unknown response code         ')
   end { case }

end; { new_dg }
function validate_domsg(var mydomsg:domsg;
			  var myrawmsg:rawmsg):boolean;

{ VALIDATE_DOMSG iterates through all of the data in a message, checking
  to see if it makes sense }

var  ok,new_error:boolean;
     sect_idx:sectcode;
     rdindex,i,wanted,last_label,dname_size:integer;
     check_type:dtype;
     check_class:dclass;
     check_ttl,check_left:integer;
     check_bp:g1bpt;
     table:rdata_table_pointer;

     procedure log_err;

     var stext:packed array[1..10] of char;

     begin
     ok:=false;
     myfbp:=ofile(log);

     case sect_idx of
     question:	   stext:='question  ';
     answer:	   stext:='answer    ';
     authority:	   stext:='authority ';
     additional:   stext:='additional'
     end;

     writeln(myfbp^.fident,'Bad format for RR ',i:1,
	     ' in section ',stext);
     if new_error
     then dumpbuffer(myrawmsg,(myrawmsg.rec_count-1)*4,log,myfbp);
     new_error:=false;
     cfile(myfbp)
     end; { log_err }

     procedure validate_rr;

     begin
     rdindex:=1; (* index of items in RDATA *)
     with table^[check_type]
     do while ok and (rdata_item[rdindex]<>no_more_field)
	do begin
	   case rdata_item[rdindex] of

		dname_field:  begin
				   last_label:=1;
				   dname_size:=0;
				   while ok and (last_label<>0)
				   do	if check_left>0
				        then begin
						 last_label:=xildb(check_bp);
						 if check_left>last_label
						 then begin
							   check_left:=check_left-last_label-1;
							   xadjbp(check_bp,last_label);
							   dname_size:=dname_size+last_label+1;
							   if dname_size>max_dname_chars
							   then log_err
						      end
						 else log_err
					     end
					else log_err
			      end; { dname_field }
						    
		cstring_field: if check_left>0
			       then begin
					wanted:=xildb(check_bp);
					if check_left>=wanted
					then begin    
						 check_left:=check_left-wanted-1;
						 xadjbp(check_bp,wanted)
					     end
					else log_err
				    end;

		int16_field:  if check_left<2
			      then log_err
				   else begin
					     check_left:=check_left-2;
					     xadjbp(check_bp,2)
					end;

		time_field,
		int32_field,
		inet_a_field: if check_left<4
			      then log_err
				   else begin
					     check_left:=check_left-4;
					     xadjbp(check_bp,4)
					end;
							
		inet_p_field:  if check_left>0
			       then begin
					 check_left:=check_left-1;
					 xadjbp(check_bp,1)
				    end
			       else log_err;

	        inet_s_field,
		vbinary_field: check_left:=0;
	   end; { case }
	   rdindex:=rdindex+1;
		  end;
      if check_left>0 then log_err
      end; { validate_rr }
begin { validate_domsg }
new_error:=true;
ok:=true; (* assume innocence *)

{ Validate the question section }


{ Validate the other sections }
for sect_idx:=answer to additional
do with mydomsg.parse[sect_idx]
   do for i:=1 to count
      do begin
	     check_bp:=rdv[i].databp;
	     if not v_type(xildb2(check_bp),check_type)
	     then log_err
	     else if not v_class(xildb2(check_bp),check_class)
		  then log_err
		  else begin
			   check_ttl:=xildb4(check_bp);
			   check_left:=xildb2(check_bp);
			   table:=irdata(check_class);
			   validate_rr
		       end
	 end;

validate_domsg:=ok

end; { validate_domsg }
procedure fix_ttls;

{ FIX_TTLs adjusts the TTL fields of the response }

var	sect:sectcode;
	qtime,index:integer;

begin
qtime:=master^.sb_array[search_scan].tquery;
for sect:=answer to additional
do with pdmsg[search_scan].parse[sect]
   do if truncated
      then for index:=1 to count
	   do (* for truncated sections set cache ttl to zero *)
	      s_ttl(rdv[index].databp,qtime)
      else for index:=1 to count
	   do { if not truncated, convert offset to internal time }
	      s_ttl(rdv[index].databp,qtime-f_ttl(rdv[index].databp))

end; { FIX_TTLS }
function matches_question:boolean;

{ MATCHES_QUESTION checks to see that the response received is to the
  question which was asked }

var result:boolean;
    scandv:g1bpt;

begin
result:=false;
with pdmsg[search_scan].parse[question].rdv[1],
     master^.sb_array[search_scan]
do   begin
	 scandv:=databp;
	 if xildb2(scandv)=stype (* check that the types are the same *)
	 then if xildb2(scandv)=sclass (* class check *)
	      then if dnscomp(namebp,xseto(sname)) (* domain names *)
		   then result:=true
     end;
matches_question:=result
end; { matches_question }
procedure t_new_dg;

{ t_new_dg checks to see if a new datagram is available and if so,
   processes it }

var	push_search_scan:search_block_index;
	i,udptime,raw_delay,new_id,slot_hash:integer;
	newgbp:g1bpt;

	procedure old_reply;

	{ OLD_REPLY is called in response to an arriving datagram which
	  refers to a search block which isn't active or which doesn't
	  match the currently active question }

        begin
	if logging
	then begin
		 myfbp:=ofile(log);
		 Writeln(myfbp^.fident,'Old datagram for slot ',i:1,
			 ' ID ',new_id:4:h,' in state ',master^.rcom[i]:1);
		 if master^.logri<>0
		 then dumpbuffer(newgram,(newgram.rec_count-1)*4,log,myfbp);
		 cfile(myfbp)
	     end
	end; { old_reply }

begin { t_new_dg }

{ Get a newly arrived datagram, log it if debugging is armed, and then
  attempt to associate it with a search block.  The association assumes
  that the ID in the domain protocol header will yield a search block index,
  but also checks to see that the query name matches that in the search
  block. }

while u_receive(master^.resolve_handle,newgram,false)
do    begin
	  { Get slot ID from domain packet ID }
	  newgbp:=xseto(newgram.unspec);
	  xadjbp(newgbp,(newgram.ihl*4)+udp_hdr_sz);
	  new_id:=xildb2(newgbp);
	  i:=bshift(new_id,-did_slot_shift);
	  slot_hash:=idscode(new_id);
	  if xmit_time[slot_hash]=0 (* see if we remember sending it *)
	  then if logging or (master^.logue<>0) or (master^.logrp<>0)
	       then begin (* no record, log if enabled *)
			myfbp:=ofile(log);
			Write(myfbp^.fident,
			      'Ancient datagram ID ',new_id:4:h,' from ');
			toss:=dmpina(myfbp^.fident,newgram.sorc_adr);
			writeln(myfbp^.fident);
			if master^.logri<>0
			then dumpbuffer(newgram,(newgram.rec_count-1)*4,log,myfbp);
			cfile(myfbp)
		    end
	       else
	  else begin (* found record of sending it *)
		   udptime:=msclock-xmit_time[slot_hash];
		   thisto(master^.measure.udpgra,udptime);
		   if master^.measure.udphst[xmit_to[slot_hash]].host<>
		      newgram.sorc_adr
		   then if logging
		        then begin
				 myfbp:=ofile(log);
				 write(myfbp^.fident,
				       'Datagram ID ',new_id:4:h,' from ');
				 toss:=dmpina(myfbp^.fident,newgram.sorc_adr);
				 write(myfbp^.fident,' was sent to ');
				 toss:=dmpina(myfbp^.fident,
				 master^.measure.udphst[xmit_to[slot_hash]].host);
				 writeln(myfbp^.fident);
				 cfile(myfbp)
			     end;
		   with master^.measure.udphst[xmit_to[slot_hash]]
		   do begin
			  tbacks:=tbacks+1;
			  ttotal:=ttotal+udptime
		      end;
		   with master^.measure.newudp[xmit_to[slot_hash]]
		   do begin
			  tbacks:=tbacks+1;
			  ttotal:=ttotal+udptime
		      end;
		   xmit_time[slot_hash]:=0;
	       end;
	  if (i>0) and (i<=max_sb)
	  then	   { The response maps to a search block }
	       if master^.rcom[i]=sb_state_idle
	       then old_reply
	       else begin
			push_search_scan:=search_scan; (* push search_scan *)
			search_scan:=i; (* match to block *)
			if p_rawmsg(pdmsg[i],ptport[i],newgram)
			then if validate_domsg(pdmsg[i],newgram)
			     then (* now check for answer to question we are currently asking *)
				  with pdmsg[search_scan]
				  do if (dhead.qdcount=1) and
					dhead.response and
					(dhead.opcode=std_query)
				     then if matches_question
				          then begin
						   log_recv;
						   fix_ttls;
						   new_dg (* process it *)
					       end
				          else old_reply
				     else begin
					       myfbp:=ofile(err);
					       Writeln(myfbp^.fident,' Irrelevant response received');
					       dumpbuffer(newgram,(newgram.rec_count-1)*4,err,myfbp);
					       cfile(myfbp)
					  end
			     else (* validate failed *)
		        else (* p_rawmsg failed *)
			    begin
				myfbp:=ofile(err);
				Writeln(myfbp^.fident,'P_RAWMSG failed for');
				dumpbuffer(newgram,(newgram.rec_count-1)*4,err,myfbp);
				cfile(myfbp)
			    end;
			search_scan:=push_search_scan (* pop search scan *)
		    end
	       else { The response doesn't seem relevant }
		    begin
			myfbp:=ofile(err);
			Writeln(myfbp^.fident,'reply to non-existent block');
			dumpbuffer(newgram,(newgram.rec_count-1)*4,err,myfbp);
			cfile(myfbp)
		    end { not_relevant }
      end
end; { t_new_dg }
procedure new_service;

{ new_service handles newly arrived requests for resolution }

var	myatom:atom;

begin { new_service }
with master^.sb_array[search_scan],psb[search_scan] do
begin {with}

(* initialize TTL *)
resttl:=band(gtdrcm,bshift(fcode,-gtdrsc));
if (resttl<=0) or (resttl>gtdrcm)
then resttl:=master^.measure.rmttl;

if loghdr
then	  begin
	      Write(myfbp^.fident,'resolving begun for ');
	      ppqtype(stype,myatom);
	      toss:=dmpatom(myfbp^.fident,myatom);
	      write(myfbp^.fident,' ');
	      ppqclass(sclass,myatom);
	      toss:=dmpatom(myfbp^.fident,myatom);
	      write(myfbp^.fident,' ');
	      toss:=dmpdns(myfbp^.fident,xseto(sname));
	      writeln(myfbp^.fident);
	      cfile(myfbp)
	  end;

end; {with}
r_delegation { go start it up }
end; { new_service }
function t_wakeup:boolean;

{ t_wakeup tests to see if the search block needs a wakeup_call }

begin { t_wakeup }
if (master^.rcom[search_scan]=sb_state_waiting) or
   (master^.rcom[search_scan]=sb_state_quiet)
then t_wakeup:=msclock>=master^.sb_array[search_scan].rtimeo
else t_wakeup:=false
end; { t_wakeup }

procedure wakeup;

begin

{ We sent out a query and haven't heard an answer.  Assuming that we aren't
  ready to give up due to the quiet timeout,
  send out another query, possibly to a different name server or name
  server address, and set the alarm clock depending on how far we
  are into the retry process }

if master^.rcom[search_scan]=sb_state_quiet
then res_ret(gtddna) (* this request loses *)
else if master^.sb_array[search_scan].resttl<=0
     then set_state(sb_state_quiet,master^.measure.qtoq) (* quiet wait *)
     else ask_another

end; {wakeup}
procedure rsolve;

var ac1,ac2,ac3,ac4,next_time,hold_time:integer;
    busy:boolean;
    base_elapsed:fruse;

begin { resolver main code }

{ initialization }
master:=getmaster;
u_initialize(false,666,master^.resolve_port,master^.resolve_handle);

for index:=1 to hslots (* clear recent UDP statistics *)
do with master^.measure.newudp[index]
   do begin
	  host:=0;
	  touts:=0;
	  tbacks:=0;
	  ttotal:=0
      end;
master^.measure.udpdcy:=msclock+master^.measure.udphl; (* schedule decay *)

for index:=1 to master^.resolve_dserve.server_count (* setup stat_ptrs *)
do begin
       set_sptrs(master^.resolve_dserve.servers[index]);
       sort_a(master^.resolve_dserve.servers[index])
   end;

for index:=0 to max_xmit_time (* reset outstanding datagram timers *)
do xmit_time[index]:=0;

for search_scan:=1 to max_sb (* initialize UDP ID fields *)
do pdmsg[search_scan].dhead.domain_id:=bshift(search_scan,did_slot_shift);

jsys(gjinf;;ac1,ac2,ac3,ac4); (* setup job number used by blocking test *)
master^.resolve_job:=ac3;
base_elapsed:=master^.measure.rusage;
jsys(runtm;fhslf;ac1,ac2,ac3);
master^.measure.rusage.elwb:=ac3;

{ forever loop }
while true
do with master^
   do begin
	  measure.resolve_loops:=measure.resolve_loops+1;
	  logging:=logrn<>0;

	  { get an update lock on the cache }
	  while not locks(update_lock,1000,60000)
	  do begin
		 myfbp:=ofile(fatl);
		 writeln(myfbp^.fident,'***** Resolver cannot get update lock *****');
		 cfile(myfbp);
		 myfbp:=ofile(err);
		 writeln(myfbp^.fident,'***** Resolver cannot get update lock *****');
		 cfile(myfbp);
	     end;

	  { Set default time for next action.  This time may be changed
	    by the scan of search blocks. }
	  next_time:=msclock;
	  if test_version
	  then next_time:=next_time+measure.ripoll
	  else next_time:=next_time+600000; (* 10 minutes *)

	  busy:=false;
	  for search_scan:=1 to max_sb { all search blocks }
	  do  with sb_array[search_scan]
	      do   begin
		   t_new_dg; (* test for new datagrams *)

		   if rcom[search_scan]=sb_state_new
		   then new_service;

		   if t_wakeup
		   then wakeup;

		   if rcom[search_scan]<>sb_state_idle
		   then begin
			next_time:=min(next_time,rtimeo);
			busy:=true
			end
		   end;

	  ulocks(update_lock); (* release update lock *)

	  if msclock>=measure.udpdcy (* see if its time to decay newudp *)
	  then begin
		   age_newudp;
		   measure.udpdcy:=msclock+measure.udphl; (* schedule next decay *)
	       end;

	  ruse(measure.rusage,base_elapsed); (* update resource usage *)

	  next_time:=min(measure.udpdcy,next_time)-msclock;

	  if next_time>0
	  then if test_version
	       then mswait(next_time)
	       else begin (* special JSYS blocking *)
		    if busy
		    then hold_time:=2000 (* long hold time if busy *)
		    else hold_time:=500; (* shorter if not *)
		    jsys(gtdom,-2,rval;gtdrwt,hold_time,next_time);
		    if rval <>2
		    then begin
			     myfbp:=ofile(fatl);
			     writeln(myfbp^.fident,'Resolver block failed');
			     jsys_err(abort,-1,myfbp)
			 end
		    end;
      end
end. { resolver main }