{$M-,X+}
program fproc;

include {NOLIST} '<pascal>extern.pas';
include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:eutil.hdr';
include {NOLIST} 'domain:pp.hdr';
include {NOLIST} 'domain:irdata.hdr';
include {NOLIST} 'domain:addrr.hdr';
include {NOLIST} 'domain:msub.hdr';
include {NOLIST} 'domain:lparse.def';
include {NOLIST} 'domain:lparse.hdr';
include {NOLIST} 'domain:mdep.hdr';

procedure scan_error(var mypib:pib;
		     str:string40);

var	idex:integer;
begin
with mypib
do	begin
	writeln('error in line ',line_number,' of file ',dfilename);
	idex:=1;
	repeat	if line[idex]<>chr(cr)
		then	write(line[idex]);
		idex:=idex+1
	until	(idex>max_line_char) or (line[idex-1]=chr(cr));
	writeln(' ');
	writeln(str);
	writeln(' ');
	ok:=false
	end
end;

procedure parse_error(var mypib:pib;
			str:string11);

var	estr:string40;
	i:integer;

begin
estr:='Unable to parse                         ';
for i:=17 to 27
do	estr[i]:=str[i-16];

scan_error(mypib,estr);
end; { parse_error }
function fload(	var myzone:zone_entry;
		    origin:exp_dname;
		var fn:filename):boolean;

var	sticky_set,	{is the sticky location valid}
	any_ttl,any_class,	{is last_class set}
	insert_rc,file_ok:boolean;

	i:integer;
	sticky_place:node_pointer;
	last_class:dclass;	{sticky class}
	last_ttl:integer;	{sticky ttl}
	call_filename:filename;
	new_rr:exp_rr;
	fload_origin,call_origin,place:exp_dname;
	mypib:pib;

procedure gethdr;

{	This procedure processes the class, TTL, and type fields from
	a RR.  The Type filed is required and is last.  I.E. a type
	terminates a specification.  The class and TTL fileds are
	optional, and preceed the type if they are present.

}

var	saw_TTL,saw_class,saw_type:boolean;
	test_time:itime;
	test_class:dclass;
	test_type:dtype;
	myatom:atom;

begin
with mypib
do begin
saw_ttl:=false;
saw_class:=false;
saw_type:=false;

while ok and not(saw_type)
do	if getatom(mypib,myatom)
	then	{ see if it is a TTL }
		if not(saw_ttl) and cvtime(myatom,test_time)
		then	begin
			new_rr.ttl:=test_time;
			saw_ttl:=true;
			any_ttl:=true;
			last_ttl:=test_time
			end
		else	{ if not TTL, see if it is a class }
			if not(saw_class) and cvclass(myatom,test_class)
			then	begin
				new_rr.rrclass:=test_class;
				saw_class:=true;
				any_class:=true;
				last_class:=test_class
				end
			else	{ if not TTL or class, its a type or error }
				if cvtype(myatom,test_type)
				then	begin
					new_rr.rrtype:=test_type;
					saw_type:=true
					end
				else	scan_error(mypib,'Invalid RR header                       ')
	else	scan_error(mypib,'Unable to type header                   ');

if ok
then	begin
	if not(saw_ttl)
	then	if any_ttl
	        then new_rr.ttl:=last_ttl
		else new_rr.ttl:=0;
	if not(saw_class)
	then	if myzone.zone_is_cache
		then	if any_class
			then	new_rr.rrclass:=last_class
			else	scan_error(mypib,'Class cannot default here               ')
		else	if myzone.zsoa<>NIL
			then	new_rr.rrclass:=myzone.zone_class
			else	scan_error(mypib,'Zone class not available for default    ')
	end

end {with}
end; { gethdr}

procedure getrdata;

{ getrdata reads the class and type dependent parts of the RR
  using the irdata routines to determine the order.}

var	done:boolean;
	i, j, temp, index, rdindex:integer;
	myatom:atom;
	table:rdata_table_pointer;

	procedure binn(     n:integer;
			    x:integer;
			var tochunk:exp_chunk );

	{ The binN procedure copies the rightmost N octets
	  of an integer into the first N octets of a chunk }

	var	i:integer;

	begin  {binN}
	    with tochunk do
	    begin	
		ckind:=lit_chunk;
		lit_data_count:=N;
		for i:=N downto 1 do
		    lit_data[i]:=band( bshift(x, 8*(i-N)), 377b );
	    end;
	end; { binN }

begin  {getrdata}
with mypib
do begin

    done:=false;
    table:=irdata(new_rr.rrclass);
    rdindex:=1;
    with table^[new_rr.rrtype] do  {use rdata description}
	while ok and not done do  { as long as its reasonable }
	begin
	    toss_blanks(mypib);
	    with new_rr.chunks[rdindex] do
		case rdata_item[rdindex] of
		    dname_field:  if getdname(mypib,origin,rrname)
				  then ckind:=name_chunk
				  else parse_error(mypib,'domain name');

		    cstring_field:  if ismore(mypib)
				    then	begin
					     	i:=2;
					     	while ismore(mypib) and 
						   	not issep(mypib) and
						   	(i<=max_binary_octets)
						do    	begin
						 	lit_data[i]:=gpibch(mypib);
						 	i:=i+1
					     		end;
					     	if ismore(mypib) and not issep(mypib)
					     	then parse_error(mypib,'characters ')
					     	else	 begin
							 lit_data_count:=i-1;
							 lit_data[1]:=i-2;
							 ckind:=lit_chunk
						       	end
					 	end
				    else	scan_error(mypib,'Missing character string                ');
				    
		    time_field:	begin
				    if getatom(mypib,myatom)
				    then if cvtime(myatom, temp)
					 then binn(4,temp, 
						   new_rr.chunks[rdindex])
					 else ok:=false
				    else ok:=false;
				    if not ok
				    then parse_error(mypib,'time       ');
				end;
		    
		    int16_field: begin
				     if getatom(mypib,myatom)
				     then if cvint(myatom, temp)
					  then binn(2,temp,
						    new_rr.chunks[rdindex])
					  else ok:=false
				     else ok:=false;
				     if not ok
				     then parse_error(mypib,'integer    ')
				 end;

		    int32_field: begin
				     if getatom(mypib,myatom)
				     then if cvint(myatom, temp)
					  then binn(4,temp,
						    new_rr.chunks[rdindex])
					  else ok:=false
				     else ok:=false;
				     if not ok
				     then parse_error(mypib,'integer    ')
				 end;
		    
		    inet_a_field: begin
				      if getatom(mypib,myatom)
				      then if cvina(myatom, temp)
					   then	binn(4,temp,
						     new_rr.chunks[rdindex])
					   else ok:=false
				      else ok:=false;
				      if not ok
				      then parse_error(mypib,'Internet A ')
				  end;
		    
		    inet_p_field: 
				  if getatom(mypib,myatom)
				  then if cvptcl(myatom, temp)
				       then with new_rr.chunks[rdindex] do
				       begin  {store 8-bit protocol number}
					   ckind:=lit_chunk;	   
					   lit_data_count:=1;
					   lit_data[1]:=temp;
				       end
				       else begin
						ok:=false;
						parse_error(mypib,'protocol   ');
					    end
			          else begin
					   ok:=false;
					   parse_error(mypib,'protocol   ');
				       end;
				  
		    inet_s_field:
			 with new_rr.chunks[rdindex] do
			 begin
			     ckind:=lit_chunk;
			     for i:=1 to 32 do  {clean the slate}
				 lit_data[i]:=0;
			     {get all ports for this protocol}
			     while getatom(mypib,myatom) and ok do
			     begin
				 if cvport(myatom, 0, temp)
				 then begin {add to bitmap}
					  index:=(temp div 8)+1; {which octet}
					  lit_data[index]:=lit_data[index]+
						   bshift(128,-(temp mod 8));
				      end
				 else begin
					  ok:=false;
					  parse_error(mypib,'port       ');
				      end
			     end;
			     i:=32;	{ chop off zeroes }
			     while (i>1) and (lit_data[i]=0)
				do i:=i-1;
			     lit_data_count:=i
			end;
			 
		     vbinary_field:	;
			 
		     no_more_field: if not done
				    then begin  {first time only}
					     done:=true;
					     new_rr.chunk_count:=rdindex-1
					 end;
				    
		     others: scan_error(mypib,
				   'Internal getrdata case error            ')
		end; {case}
	    rdindex:=rdindex+1;
	    done:=done or (rdindex>max_rdata_items);
        end;
    if ok
    then 	if not rrsquash(new_rr)  {compress rdchunks}
		then	scan_error(mypib,'Overflow error during binary compress   ')
end {with}
end; {getrdata}
procedure mxfix;

{ This procedure turns the RR in new_rr into an MX if it is a MD or MF
  MDs get preferences of 10 and MFs get 20 }

begin
if (new_rr.rrtype=MD) or (new_rr.rrtype=MF)
then with new_rr
     do begin
	     chunk_count:=2;
	     chunks[2]:=chunks[1];
	     with chunks[1]
	     do begin
		    ckind:=lit_chunk;
		    lit_data_count:=2;
		    lit_data[1]:=0;
		    if new_rr.rrtype=md
		    then lit_data[2]:=10
		    else lit_data[2]:=20;
		    new_rr.rrtype:=mx
		end
	end
end; { MXFIX }
begin { fload main code }
fload_origin:=origin;
with mypib
do begin

sticky_set:=false;
file_ok:=true;
any_class:=false;
any_ttl:=false;

{ open file and go }
if not pib_init(mypib,fn)
then	file_ok:=false
else	{ load the file }
	while not eof(mypib.dfile)
	do	begin
		ok:=true;
		gline(mypib);
		if smatch(mypib.line,1,'$include       ')
		then	{ process an include line }
			begin
			mypib.line_index:=mypib.line_index+8;	{ bump past include }
			toss_blanks(mypib);

			{ get a file name }
			if ismore(mypib)
			then	getfn(mypib,call_filename)
			else	scan_error(mypib,'Include without filename                ');
			toss_blanks(mypib);

			{ get an optional offset }
			if ismore(mypib)
			then	if getdname(mypib,origin,call_origin)
				then
				else scan_error(mypib,'origin error                            ')
			else	call_origin:=origin;

			check_end(mypib);

			{ call self recursively }
			if ok
			then	if not fload(myzone,call_origin,call_filename)
				then	scan_error(mypib,'file loading error                      ')
			end { process an include line }
		else if smatch(mypib.line,1,'$origin        ')
		then	{ process an origin line }
			begin
			mypib.line_index:=mypib.line_index+8;	{ bump past origin }
			toss_blanks(mypib);

			{ get an optional offset }
			if ismore(mypib)
			then	if getdname(mypib,origin,call_origin)
				then origin:=call_origin
				else scan_error(mypib,'origin error                            ')
			else	origin:=fload_origin;
			check_end(mypib);
			end { process an origin line }
		else	begin
			toss_blanks(mypib);
			if ismore(mypib)
			then	begin	{ process a RR }
				rescan(mypib);
				if issep(mypib)
				then	{ line starts with a blank }
					if not sticky_set
					then	scan_error(mypib,'owner default not set                   ')
					else
				else	begin
					if not getdname(mypib,origin,place)
					then	scan_error(mypib,'RR owner error                          ');
					sticky_set:=false
					end;
					
				if ok
				then	begin
					toss_blanks(mypib);
					if ismore(mypib)
					then	begin
						gethdr; { get type, class, ttl }
						if ok
						then getrdata;
						if ok then mxfix; { hack MD and MF }
						toss_blanks(mypib);
						if ok
						then	check_end(mypib);
						if ok
						then	begin
							if sticky_set
							then	ok:=concrr(myzone,sticky_place,new_rr)
							else	begin
								ok:=addrr(myzone,place,sticky_place,new_rr);
								sticky_set:=true
								end;
							if not ok
							then	scan_error(mypib,'RR addition failed                      ')
							end;
						if ok
						then	if (new_rr.rrtype=soa)
								and
						   	(not(myzone.zone_is_cache))
							then	if	myzone.zsoa<>NIL
								then	scan_error(mypib,'Duplicate SOA                           ')
								else	begin
									myzone.zsoa:=sticky_place;
									myzone.zone_class:=new_rr.rrclass
									end
						end
					end;
			
				end { process a RR }
			end;
		if not ok
		then	file_ok:=false
		end;

close(mypib.dfile);
fload:=file_ok;
end {with}
end; {fload}

function fzload(var myzone:zone_entry;
		    origin:exp_dname;
		var fn:filename):boolean;

begin
if fload(myzone,origin,fn)
then	begin
	makelt(myzone);	{ make the label chains }
	if not(myzone.zone_is_cache)
	then	soa_setup(myzone);	{ check authoritative TTLs }
	fzload:=true;
	end
else	fzload:=false;
end {fzload}.