{$M-}
program lparse;

{	LPARSE is a package of routines for reading the text files
	which define master files and config files in the domain system
}

include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:lparse.def';
include {NOLIST} 'domain:eutil.hdr';
include {NOLIST} 'domain:msub.hdr';

var	dot_end:boolean;

procedure scan_error(var mypib:pib;
			str:string40);
extern;
procedure parse_error(var mypib:pib;
			str:string11);
extern;

function smatch(var l:line_buffer
		;pos:integer
		;str:atom):boolean;

{	SMATCH checks to see if the string in STR occurs at position
	POS in L
}
var	i:integer;

begin
i:=1;
while compchar(str[i],l[pos+i-1]) and (str[i]<>' ')
do	i:=i+1;

if str[i]=' '
then	smatch:=true
else	smatch:=false
end;
procedure gline(var mypib:pib);

{	GLINE reads an input line.  If at EOF, it inserts a ) and CR }

begin
with mypib
do 
begin

if eof(dfile)
then	begin
	line[1]:=')';
	line[2]:=chr(CR)
	end
else	begin
	line_index:=1;
	repeat	if eof(dfile)
		then	line[line_index]:=chr(CR)
		else	if (line_index=1) and (dfile^=chr(lf))
			then	begin
				get(dfile);
				if eof(dfile)
				then	line[line_index]:=chr(cr)
				else	line[line_index]:=dfile^
				end
			else	line[line_index]:=dfile^;
		line_index:=line_index+1;
		get(dfile)
	until	(line_index=(max_line_char-2)) or
		(line[line_index-1]=chr(CR));
	line[line_index]:=chr(CR);
	line_index:=1;
	line_number:=line_number+1
	end;

csaved:=false;

if false      { if true echo input }
then	begin
	write('GLINE gets:');
	line_index:=1;
	while line[line_index]<>chr(cr)
	do	begin
		write(line[line_index]);
		line_index:=line_index+1
		end;
	writeln(' ')
	end;

line_index:=1

end { with }
end;	{ gline }
procedure rescan(var mypib:pib);

{ rescan allows the current line to be rescanned }

begin
with mypib
do	begin
	line_index:=1;
	csaved:=false
	end
end; {rescan }
function have(var mypib:pib;
		needed:integer):boolean;

{ This procedure checks that the specified number of
  characters are available and that they are not CRs }

var	result:boolean;
	idex:integer;

begin
with mypib
do	begin
	result:=true;
	for idex:=line_index+1 to line_index+needed-1
	do	if idex>max_line_char
		then	result:=false
		else	if	ord(line[idex])=CR
			then	result:=false;

	if not result
	then	begin
		old_char:=-1;
		parse_error(mypib,'escape     ')
		end;

	have:=result
	end

end; { have }
function gpibch(var mypib:pib):integer;

{ gpibch returns an integer with the next octet or -1 if EOL }

var	done:boolean;

begin
with mypib
do begin
if csaved
then	gpibch:=old_char
else	begin
	repeat	done:=false;
		old_char:=ord(line[line_index]);

		{ start of parentheses group }
		if old_char=ord('(')
		then	pflag:=true

		{ end of parentheses group }
		else if old_char=ord(')')
		then	pflag:=false

		{ end of line within parentheses group }
		else if pflag and ((old_char=ord(';')) or (old_char=CR))
		then	begin
			gline(mypib);
			line_index:=line_index-1
			end

		{ backslash quoted char }
		else if old_char=ord('\')
		then	if line[line_index+1] in ['0'..'9']
			then	{ quoted decimal string }
				if have(mypib,3)
				then	begin
					old_char:=(ord(line[line_index+3])-ord('0'))
					+(ord(line[line_index+2])-ord('0'))*10
					+(ord(line[line_index+1])-ord('0'))*100;
					if (line[line_index+2] in ['0'..'9'])
						and
					   (line[line_index+3] in ['0'..'9'])
						and
					   (old_char>0)
						and
					   (old_char<256)
					then
					else	parse_error(mypib,'number     ');
					done:=true;
					line_index:=line_index+3
					end
				else	done:=true
			else	{ quoted special character }
				if have(mypib,1)
				then	begin
					old_char:=ord(line[line_index+1]);
					line_index:=line_index+1;
					done:=true
					end
				else	done:=true
		else 	begin
			done:=true;
			if (old_char=ord(';')) or (old_char=CR)
			then	old_char:=-1
			end;
			
		{ bump pointer }
		line_index:=line_index+1
	until	done;

	gpibch:=old_char
	end;

csaved:=false

end { with }

end; { gpibch }
function issep(var mypib:pib):boolean;

var	tmp:integer;

begin
with mypib
do	begin
	tmp:=gpibch(mypib);
	csaved:=true;
	issep:=(tmp=ord(' ')) or (tmp=ord('	'))
	end

end;	{ issep }

function isdot(var mypib:pib):boolean;

var	tmp:integer;

begin
with mypib
do	begin
	tmp:=gpibch(mypib);
	csaved:=true;
	isdot:=(tmp=ord('.'))
	end

end;	{ isdot }

function ismore(var mypib:pib):boolean;

begin
with mypib
do	begin
	ismore:=gpibch(mypib)<>-1;
	csaved:=true
	end

end;	{ ismore }

procedure toss_blanks(var mypib:pib);

begin
with mypib
do	while issep(mypib)
	do	csaved:=false
end; { toss_blanks }
function getatom(var mypib:pib;
			var myatom:atom):boolean;

{	Getatom returns a blank delimited thing of up
	to max_atom_chars in length.
}

var	i:integer;

begin
with mypib
do	begin
	for i:=1 to max_atom_chars
	do	myatom[i]:=' ';
	toss_blanks(mypib);
	if ismore(mypib)
	then	begin
		i:=1;
		repeat	if ismore(mypib) and (not issep(mypib))
			then begin
				 myatom[i]:=chr(gpibch(mypib));
				 i:=i+1
				 end
		until	(i=(max_atom_chars+1))
			or
			issep(mypib)
			or
			not(ismore(mypib));
		if i<>(max_atom_chars+1)
		then getatom:=true
		else getatom:=issep(mypib) or (not ismore(mypib))
		end
	else	getatom:=false
	end

end; { getatom }
function getlabel(var mypib:pib;
		    var dest:g1bpt;
		    var chars_left:integer):boolean;
var	count,char_limit:integer;
	ccptr:g1bpt;
begin
dot_end:=false;
if chars_left>0
then with mypib
     do	 begin
	 char_limit:=min(chars_left,max_lab_chars+1);
	 count:=0;
	 ccptr:=dest;
	 xidpb(dest,0);
	 char_limit:=char_limit-1;
	 chars_left:=chars_left-1;
	 if isdot(mypib)
	 then begin
		  dot_end:=true;
		  csaved:=false (* a root label by itself *)
	      end
	 else if ismore(mypib) and not(issep(mypib)) and ok
	      then begin
		   while ok and ismore(mypib) and not(isdot(mypib)) and not(issep(mypib))
		   do if char_limit>0
		      then begin
			       chars_left:=chars_left-1;
			       char_limit:=char_limit-1;
			       xidpb(dest,gpibch(mypib));
			       count:=count+1
			   end
		      else scan_error(mypib,'Name too long                           ');
		   xidpb(ccptr,count);
		   if isdot(mypib)
		   then begin
			    dot_end:=true;
			    csaved:=false
			end
		   end
	      else parse_error(mypib,'label      ')
	 
	 end
else scan_error(mypib,'Name too long                           ');
getlabel:=mypib.ok
end; { getlabel }
function getdns(var mypib:pib;
		  var origin:dname_string;
		  var dn:dname_string):boolean;
var	name_ptr,label_ptr:g1bpt;
	name_left:integer;
	toss:boolean;
begin
with mypib
do   begin
	 toss_blanks(mypib);
	 if ismore(mypib)
	 then begin
		  name_left:=max_dname_chars;
		  name_ptr:=xseto(dn);
		  label_ptr:=name_ptr;
		  if getlabel(mypib,name_ptr,name_left)	(* let at least one *)
		  then begin
		       while ok and ismore(mypib) and not(issep(mypib))
		       do begin
			  label_ptr:=name_ptr;
			  toss:=getlabel(mypib,name_ptr,name_left) (* maybe more *)
			  end;
		       if dot_end
		       then if name_left>0
			    then xidpb(name_ptr,0)
		            else scan_error(mypib,'Name too long                           ')
		       else { relative name }
			    if origin[1]=0
			    then scan_error(mypib,' zero origin added to relative name     ')
			    else if lendns(xseto(origin))>name_left
				 then scan_error(mypib,'Name too long                           ')
				 else copydns(xseto(origin),name_ptr)
		       end
		  else parse_error(mypib,'domain name')
	      end
	 else scan_error(mypib,'domain name missing                     ');
	 getdns:=ok
     end;
end; { getdns }
function getdname(var mypib:pib;
			var origin:exp_dname;
			var dn:exp_dname):boolean;

var	i:integer;

begin
with mypib
do begin
dn.count:=0;
toss_blanks(mypib);
if ismore(mypib)
then	begin
	while not(issep(mypib)) and ismore(mypib)
	do	begin
		dn.count:=dn.count+1;
		with dn.dlabels[dn.count]
		do	begin
			labinfo[0]:=0;	{ initialize label }
			while ismore(mypib) and ok and not(issep(mypib)) and not(isdot(mypib))
			do	if labinfo[0]<63
				then	begin
					labinfo[0]:=labinfo[0]+1;
					labinfo[labinfo[0]]:=gpibch(mypib);
					end
				else	scan_error(mypib,'Label length                            ');
			end;
		dlcase(dn.dlabels[dn.count]);	{ set up modifier bits }
		if issep(mypib) or not(ismore(mypib))
		then	{ add origin to domain name }
			if origin.count=0
			then	scan_error(mypib,' relative name requires active origin   ')
			else	begin
				    if (dn.count=1) and { test for naked @ }
				       (dn.dlabels[1].labinfo[0]=1) and
				       (dn.dlabels[1].labinfo[1]=ord('@'))
				    then dn.count:=0;
				    for i:=1 to origin.count
				    do	begin
					dn.count:=dn.count+1;
					dn.dlabels[dn.count]:=origin.dlabels[i]
					end
				end
		else	if isdot(mypib)
			then	begin
				csaved:=false;
				if not(ismore(mypib)) or issep(mypib)	{ add implied root }
				then	if (dn.count<>1)
						or
					   (dn.dlabels[1].labinfo[0]<>0)
					then	begin
						dn.count:=dn.count+1;
						dn.dlabels[dn.count].labinfo[0]:=0
						end
				end
			else	scan_error(mypib,'Label termination error                 ')
		end
	end
else	scan_error(mypib,' error                                  ');

getdname:=ok;

end { with }
end; {getdname}
procedure getfn(var mypib:pib;
		var fn:filename);

var	i:integer;
begin
with mypib
do	begin
	for i:=1 to max_fn_chars
	do	fn[i]:=' ';
	toss_blanks(mypib);
	if ismore(mypib)
	then	begin
		i:=1;
		repeat	fn[i]:=chr(gpibch(mypib));
			i:=i+1
		until	(i=(max_fn_chars+1))
			or
			issep(mypib)
			or
			not(ismore(mypib));
		if (i=1) or (i=(max_fn_chars+1))
		then	parse_error(mypib,'filename   ')
		end
	end

end; {getfn}
procedure check_end(var mypib:pib);

{	check_end makes sure that there is not anything left over
	on the line
}

var	foo:integer;

begin
toss_blanks(mypib);
if ismore(mypib)
then	begin
	scan_error(mypib,'Extraneous data on line                 ');
	while ismore(mypib)
	do	foo:=gpibch(mypib)
	end

end. { check_end }