home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Overload
/
ShartewareOverload.cdr
/
database
/
db_dbug2.zip
/
DB_STRCT.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1987-03-10
|
13KB
|
339 lines
{program DB_STRCT
This is one of a series of utilities intended for analyzing dBASE III .PRG
files. This program examines the program flow of all available .PRG files in
a tree structure, and then prints out that tree structure, followed by a
listing of the variables encountered in each .PRG file. At the same time, it
also checks for IF-, DO WHILE-, and DO CASE- loop mismatches.
Written by Curtis H. Hoffmann
version A2 03/10/87
A1 10/20/86 Initial Release
A2 03/10/87 Check for nonexistant .PRG in DO filename statement
}
const
dash1 = '------------------------------------';
blanks= ' ';
type
name = string[12];
stt = string[255];
datetype = string[8];
regtype =record
ax,bx,cx,dx,bp,si,di,ds,es,flags: integer
end;
var
file_in, file_out : text;
all_files, abo : char;
in_file, ofl : string[8];
out_file : string[12];
progs : array[1..100] of string[8];
doloop : array[1..100] of string[1];
varibs : array[1..255] of string[10];
prog_stack, line_stack : array[1..20] of integer;
ps, sp, ln_cnt, vp, lp, dp : integer;
st, outstring, path : string[255];
next_word, this_word : string[10];
more_words, pass_one, skip_line : boolean;
{doloop can be C, D, or I for Do Case, Do While, or If Then}
function time: datetype;
var reg: regtype;
h,m,s,w: datetype;
i: integer;
begin
reg.ax:=$2c00;
intr($21,reg);
str(hi(reg.cx):2,h);
str(lo(reg.cx):2,m);
str(hi(reg.dx):2,s);
w:=h+':'+m+':'+s;
for i:=1 to length(w) do if w[i]=' ' then w[i]:='0';
time:=w;
end;
function date: datetype;
var reg: regtype;
y,m,d,w: datetype;
i: integer;
begin
reg.ax:=$2a00;
intr($21,reg);
str(reg.cx:4,y);
delete(y,1,2);
str(hi(reg.dx):2,m);
str(lo(reg.dx):2,d);
w:=m+'/'+d+'/'+y;
for i:=1 to length(w) do if w[i]=' ' then w[i]:='0';
date:=w;
end;
function exist(filename: name): boolean; {Check to see if I/O files exist}
var fil: file;
begin
assign(fil, filename);
{$I-}
reset(fil);
{$I+}
exist:=(IOresult=0);
close(fil);
end;
function standard_io(h :name): boolean; {If output is to screen or printer}
begin {then don't check for existance}
if ((h='prn') or (h='PRN')) or ((h='con') or (h='CON')) then
standard_io:=true
else standard_io:=false;
end;
procedure get_started; {Opening screen, get filenames}
var j: integer;
ow: char;
begin
abo:='N'; clrscr; gotoxy(10,10);
write('Input .PRG file to check first : '); read(in_file); gotoxy(10,12);
write('File to dump output to (prn for printer): '); read(out_file); gotoxy(10,14);
write('Check all files, or just this one (A/O) : '); readln(all_files);
all_files:=upcase(all_files);
if not exist(in_file+'.prg') then begin
writeln(in_file+'.PRG does not exist, program aborted'); abo:='Y'; end
else begin
for j:=1 to length(in_file) do if (in_file[j]>='a') and (in_file[j]<='z') then in_file[j]:=upcase(in_file[j]);
assign(file_in, in_file+'.prg'); reset(file_in);
end;
textcolor(12);
if not standard_io(out_file) then if exist(out_file) then begin
write(out_file+' exists, overwrite it (Y/N)?: '); readln(ow);
if upcase(ow)<>'Y' then begin write('Program aborted'); abo:='Y'; end;
end;
textcolor(14);
progs[1]:=in_file;
if abo<>'Y' then begin assign(file_out, out_file); rewrite(file_out); end;
end;
procedure init; {Initialize stacks and pointers}
var i: integer;
begin
getdir(0,path);
outstring:=''; pass_one:=true; ln_cnt:=0;
sp:=1; ps:=1; prog_stack[sp]:=1;
for i:=1 to 20 do line_stack[i]:=0;
end;
procedure push_stack; {Put current file in top of stack prior}
var y: integer; {to jumping to next called file. Write}
begin {name of file as part of tree structure.}
line_stack[ps]:=ln_cnt; ps:=ps+1; y:=1;
while (y<=sp) and (next_word<>progs[y]) do y:=y+1;
if y>sp then begin sp:=sp+1; progs[sp]:=next_word; end;
prog_stack[ps]:=y; close(file_in);
assign(file_in, progs[prog_stack[ps]]+'.prg'); reset(file_in);
ln_cnt:=0;
writeln(file_out,outstring+'----'+progs[prog_stack[ps]]+copy(dash1,1,8-length(progs[prog_stack[ps]])));
outstring:=outstring+' ';
end;
procedure pop_stack; {Done with current file, so pop last}
var i: integer; {pushed file from stack, make it current}
begin {and write out its name in the tree format}
if ps>1 then begin
ps:=ps-1; ln_cnt:=line_stack[ps]; close(file_in);
assign(file_in, progs[prog_stack[ps]]+'.prg'); reset(file_in);
for i:=1 to ln_cnt do readln(file_in, st);
outstring:=copy(outstring,1,length(outstring)-12); end
else ps:=0;
end;
function ltrim(var stg: stt): stt; {Remove leading blanks}
begin
while (stg[1]=' ') and (length(stg)>0) do stg:=copy(stg,2,length(stg));
ltrim:=stg;
end;
procedure prep_line; {Add spaces to seperate certain}
var bb: integer; {words, eliminate unprintable characters}
cc: string[3];
nn: string[255];
nb_quote: boolean;
begin
nn:=''; cc:=''; nb_quote:=false;
for bb:=1 to length(st) do begin
cc:=st[bb];
if (cc='"') or (ord(cc)=39) then nb_quote:=true;
if (cc=',') or ((ord(cc)<31) or (ord(cc)>127)) then cc:=' ';
if (cc='=') and (not nb_quote) then cc:=' '+cc+' ';
nn:=nn+cc;
end;
st:=nn;
end;
function get_word(var line: stt): stt; {Find next word in sentence}
var word: string[20];
begin
st:=ltrim(st); word:='';
while (length(st)>0) and (st[1]<>' ') do begin
word:=word+upcase(st[1]);
st:=copy(st,2,length(st));
end;
get_word:=word;
end;
procedure parse; {Get words from sentence}
begin
st:=ltrim(st);
if length(this_word)>0 then begin
this_word:=next_word; next_word:=get_word(st); end
else begin
this_word:=get_word(st); next_word:=get_word(st);
end;
more_words:=false;
if (length(st)>0) or (length(this_word)>0) then more_words:=true;
end;
procedure first_char; {Flag any comments or empty lines}
begin {so they can be skipped}
skip_line:=false; st:=ltrim(st);
if (length(st)=0) or (st[1]='*') then skip_line:=true;
end;
procedure add_f; {Add new variables to the list}
var y, t: integer; {and sort in alphabetical order}
begin
if vp=0 then begin varibs[1]:=this_word; vp:=1; end
else begin
for y:=1 to vp do if this_word=varibs[y] then y:=vp+5
else if this_word<varibs[y] then begin
vp:=vp+1; t:=vp;
while t>y do begin
varibs[t]:=varibs[t-1]; t:=t-1;
end;
varibs[y]:=this_word; y:=vp+5;
end;
if (this_word>varibs[vp]) and (y<vp+2) then begin
vp:=vp+1; varibs[vp]:=this_word;
end;
end;
end;
procedure pop_loop; {This uses the stack containing the currently}
var yw: string[10]; {in-force loop statement: DO, IF, CASE. Pop}
begin {it when the matching END statement is found.}
if dp<1 then writeln(file_out,'Caution! ',progs[ps],' has an excess of ',this_word,' statements!')
else if this_word[4]=doloop[dp] then begin
doloop[dp]:=''; dp:=dp-1;
end
else begin
writeln(file_out);
writeln(file_out,'Caution! ',progs[ps],' has mismatched loop statements.');
if doloop[dp]='I' then yw:='ENDIF' else if doloop[dp]='D' then yw:='ENDDO' else yw:='ENDCASE';
writeln(file_out,'Expecting ',yw,', found ',this_word,'.');
writeln(file_out); write(file_out,' ');
end;
end;
procedure what_cmd; {Find the matching shortened form of a command}
var tw, nw: string[4]; {and perform the appropriate operations}
begin
tw:=this_word; nw:=next_word;
if all_files='A' then begin
if (pass_one and (tw='DO')) and ((nw<>'CASE') and (nw<>'WHIL')) then if exist(next_word+'.prg') then push_stack
else begin
write(file_out,'Alert: DO ',next_word,' encountered in ',progs[prog_stack[ps]],'.PRG');
writeln(file_out,' ',next_word,'.PRG not found.');
end;
end;
if (not pass_one) then begin
if (tw='DO') and ((nw='CASE') or (nw='WHIL')) then begin
dp:=dp+1;
if nw='CASE' then doloop[dp]:='C' else doloop[dp]:='D';
end;
if tw='IF' then begin dp:=dp+1; doloop[dp]:='I'; end;
if (tw='ENDC') or ((tw='ENDI') or (tw='ENDD')) then pop_loop;
if tw='PUBL' then while more_words do begin
parse; if length(this_word)>0 then add_f;
end;
if ((tw='ACCE') or (tw='COUN')) or ((tw='INPU') or (tw='WAIT')) then while more_words do begin
parse;
if this_word='TO' then begin
this_word:=next_word; add_f; more_words:=false;
end;
end
else if ((tw='STOR') or (tw='AVER')) then while more_words do begin
parse;
if this_word='TO' then while more_words do begin
parse; if length(this_word)>0 then add_f;
end
else if (tw='SUM') then while more_words do begin
parse;
if this_word='TO' then while more_words and ((this_word<>'FOR') and (this_word<>'WHILE')) do begin
parse; if length(this_word)>0 then add_f;
end;
end;
end;
if nw='=' then add_f;
end;
more_words:=false;
end;
procedure get_line; {Get the next sentence from the file}
begin {and operate on it}
readln(file_in,st); prep_line;
this_word:=''; next_word:=''; more_words:=true;
if pass_one then ln_cnt:=ln_cnt+1;
first_char;
if not skip_line then while more_words begin
parse; what_cmd;
end;
end;
begin {Main body of the program}
get_started; init; {Print the tree structure}
if abo<>'Y' then begin
writeln(file_out,' dBASE III Program Structure Report for directory '+path);
write(file_out,'Starting with: '+in_file+'.PRG'+copy(blanks,1,8-length(in_file)));
writeln(file_out,' run at ',time,' on ',date);
writeln(file_out);
writeln(file_out,in_file+copy(dash1,1,12-length(in_file)));
outstring:=' ';
while ps>0 do begin
while not eof(file_in) do get_line;
pop_stack;
end;
{Print the variables used list and check}
writeln(file_out); {for mismatched loop statements}
writeln(file_out,'=======================================================================================');
for ps:=1 to 4 do writeln(file_out);
writeln(file_out,' Variables used in the above files');
pass_one:=false; vp:=0;
for ps:=1 to sp do begin
writeln(file_out); lp:=1; vp:=0; dp:=0;
for ln_cnt:=1 to 255 do varibs[ln_cnt]:='';
writeln(file_out,progs[ps]); write(file_out,' ');
close(file_in); assign(file_in,progs[ps]+'.prg'); reset(file_in);
while not eof(file_in) do get_line;
for ln_cnt:=1 to vp do begin
if lp<9 then lp:=lp+1 else begin
lp:=2; writeln(file_out); write(file_out,' ');
end;
write(file_out,varibs[ln_cnt],copy(blanks,1,12-length(varibs[ln_cnt])));
end;
writeln(file_out);
for ln_cnt:=1 to dp do begin
if doloop[ln_cnt]='I' then st:='ENDIF' else if doloop[ln_cnt]='C' then st:='ENDCASE' else st:='ENDDO';
writeln(file_out,'Caution! Missing '+st+' at end of '+progs[ps]+'.');
end;
writeln(file_out);
end;
end;
close(file_in); close(file_out);
end.