home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Overload
/
ShartewareOverload.cdr
/
database
/
db_dbug2.zip
/
DB_VARIB.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1987-03-12
|
14KB
|
383 lines
{program DB_VARIBS
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, then prints out the results of the variables used.
Written by Curtis H. Hoffmann
version A2 03/10/87
A1 10/20/86 Initial Release
A2 03/10/87 Check for nonexistant files in DO file statement
}
const
blanks= ' ';
max_col=7;
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];
p_kludge : array[1..100] of boolean;
varibs : array[1..255] of string[10];
v_n, v_s : array[1..255] of integer;
prog_stack, line_stack : array[1..20] of integer;
ps, sp, ln_cnt, vp, lp, stat, j : integer;
st, outstring, temp_st, path : string[255];
next_word, this_word : string[10];
more_words, skip_line, push_kludge: boolean;
{v_s[] is variable status: 4 = Not Released, 2 = Used, 1 = Public}
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; {Do requested 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; {Is requested file PRN or CON?}
begin
if ((h='prn') or (h='PRN')) or ((h='con') or (h='CON')) then
standard_io:=true
else standard_io:=false;
end;
procedure get_started; {Request I/O files, open them}
var 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 variables}
var i: integer;
begin
ln_cnt:=0; vp:=0; push_kludge:=false; getdir(0,path);
sp:=1; ps:=1; prog_stack[sp]:=1;
for i:=1 to 255 do begin
v_s[i]:=0; varibs[i]:=''; v_n[i]:=0;
end;
for i:=1 to 100 do p_kludge[i]:=false;
for i:=1 to 20 do line_stack[i]:=0;
end;
procedure push_stack; {Put current .PRG in stack,}
var y: integer; {print out filename, variable list}
v: boolean; {then open next called filename}
begin
v:=false;
if not p_kludge[prog_stack[ps]] then begin
outstring:=outstring+' ';
p_kludge[prog_stack[ps]]:=true; j:=1;
temp_st:=outstring+'('+progs[prog_stack[ps]]+copy(blanks,1,8-length(progs[prog_stack[ps]]))+': invoked )';
temp_st:=temp_st+copy(blanks,1,27-length(outstring));
write(file_out,temp_st);
for y:=1 to vp do if v_n[y]=prog_stack[ps] then begin
write(file_out,varibs[y]+copy(blanks,1,12-length(varibs[y]))); j:=j+1;
if j>max_col then begin
j:=1; writeln(file_out);
write(file_out,copy(blanks,1,length(temp_st)));
end;
v:=true;
end;
writeln(file_out);
if (j<>1) or (not v) then writeln(file_out);
end
else begin
write(file_out,'Variables still in effect: '); j:=1;
for y:=1 to vp do if v_n[y]>0 then begin
write(file_out,varibs[y],copy(blanks,1,12-length(varibs[y])));
j:=j+1;
if j>max_col then begin
j:=1; writeln(file_out);
write(file_out,copy(blanks,1,48));
end;
v:=true;
end;
writeln(file_out);
if (j<>1) or (not v) then writeln(file_out);
end;
if not push_kludge then begin
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;
end;
end;
procedure pop_stack; {Print current filename and list}
var y: integer; {of newly released variables, then}
v: boolean; {close current file and open top}
begin {file in the stack}
j:=1; v:=false;
temp_st:=outstring+'('+progs[prog_stack[ps]]+copy(blanks,1,8-length(progs[prog_stack[ps]]))+': released) ';
temp_st:=temp_st+copy(blanks,1,27-length(outstring));
write(file_out,temp_st);
for y:=1 to vp do if (v_n[y]=prog_stack[ps]) and (v_s[y]<4) then begin
v_n[y]:=0; j:=j+1;
write(file_out,varibs[y]+copy(blanks,1,12-length(varibs[y])));
if j>max_col then begin
j:=1; writeln(file_out);
write(file_out,copy(blanks,1,length(temp_st)));
end;
v:=true;
end;
if (j<>1) or (not v) then writeln(file_out);
writeln(file_out); outstring:=copy(outstring,1,length(outstring)-3);
p_kludge[prog_stack[ps]]:=false; ps:=ps-1;
if ps>0 then begin
ln_cnt:=line_stack[ps];
close(file_in);
assign(file_in, progs[prog_stack[ps]]+'.prg'); reset(file_in);
for y:=1 to ln_cnt do readln(file_in, st);
end;
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;
function get_word(var line: stt): stt; {Put first, and second, in line}
var word: string[20]; {words in current sentence into}
begin {This_word and Next_word}
st:=ltrim(st); word:='';
while (length(st)>0) and (st[1]<>' ') do begin
if (st[1]>='a') and (st[1]<='z') then word:=word+upcase(st[1])
else word:=word+st[1];
st:=copy(st,2,length(st));
end;
get_word:=word;
end;
procedure parse; {Break sentence up into seperate}
begin {words to be operated on}
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; {Check to see if sentence is}
begin {a comment or empty}
skip_line:=false; st:=ltrim(st);
if (length(st)=0) or (st[1]='*') then skip_line:=true;
end;
procedure add_f; {Add variable to variable stack}
var y, t: integer; {change appropriate status bit,}
begin {and identify the invoking .PRG}
if vp=0 then begin {file}
varibs[1]:=this_word; v_n[1]:=prog_stack[ps];
v_s[1]:=stat; vp:=1;
end
else begin
for y:=1 to vp do begin
if this_word=varibs[y] then begin
v_s[y]:=(v_s[y] or 2) or stat;
if v_n[y]=0 then v_n[y]:=prog_stack[ps];
y:=vp+5;
end
else if varibs[y]>this_word then begin
vp:=vp+1; t:=vp;
while t>y do begin
varibs[t]:=varibs[t-1]; v_n[t]:=v_n[t-1];
v_s[t]:=v_s[t-1]; t:=t-1;
end;
varibs[y]:=this_word; v_n[y]:=prog_stack[ps];
v_s[y]:=stat; y:=vp+5;
end;
end;
if (this_word>varibs[vp]) and (y<vp+2) then begin
vp:=vp+1; varibs[vp]:=this_word; v_n[vp]:=prog_stack[ps];
v_s[vp]:=stat;
end;
end;
end;
procedure what_cmd; {Identify the current dBASE}
var o: integer; {command and perform the}
tw, nw: string[4]; {appropriate function}
begin
tw:=this_word; nw:=next_word;
if all_files='A' then begin
if (tw='DO') then
if (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 tw='PUBL' then while more_words do begin
stat:=5; parse; if length(this_word)>0 then add_f;
end;
if nw='=' then begin
stat:=6; add_f;
end;
if ((tw='ACCE') or (tw='COUN')) or ((tw='INPU') or (tw='WAIT')) then while more_words do begin
stat:=6; 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
stat:=6; 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
stat:=6; 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 tw='RELE' then while more_words do begin
parse;
if length(this_word)>0 then for o:=1 to vp do if this_word=varibs[o] then begin
v_s[o]:=v_s[o] and 2; v_n[o]:=prog_stack[ps];
end;
end;
more_words:=false;
end;
procedure get_line; {Get new sentence and prepare}
var bb: integer; {for parsing}
cc: string[3];
nn: string[255];
dq: boolean;
begin
nn:=''; cc:=''; this_word:=''; next_word:=''; more_words:=true;
readln(file_in,st); dq:=false;
for bb:=1 to length(st) do begin
cc:=st[bb];
if (cc='"') or (ord(cc)=39) then dq:=true;
if (cc=',') or ((ord(cc)<31) or (ord(cc)>127)) then cc:=' ';
if (cc='=') and (not dq) then cc:=' '+cc+' ';
nn:=nn+cc;
end;
st:=nn;
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;
{If abo=Y then the program is to be aborted for some reason}
if abo<>'Y' then begin
writeln(file_out,' dBASE III Program Variable Usage 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);
outstring:=' ';
while ps>0 do begin
while not eof(file_in) do get_line;
for j:=1 to vp do if ((v_s[j] and 1)=0) and (v_n[j]=prog_stack[ps]) then v_s[j]:=v_s[j] and 3;
push_kludge:=true; push_stack; push_kludge:=false; pop_stack;
end;
{Output Unused Variable List}
writeln(file_out); writeln(file_out,'============================================================');
writeln(file_out); writeln(file_out,'Variables declared but never used:');
j:=1;
writeln(file_out);
for ps:=1 to vp do if (v_s[ps] and 2)=0 then begin
write(file_out,varibs[ps]+copy(blanks,1,12-length(varibs[ps])));
j:=j+1; if j>max_col then begin j:=1; writeln(file_out); end;
end;
{Output Unreleased Variable List}
writeln(file_out); writeln(file_out);
writeln(file_out,'Variables declared PUBLIC but never RELEASEd:');
writeln(file_out);
j:=1;
for ps:=1 to vp do if (v_s[ps] and 4)=4 then begin
write(file_out,varibs[ps]+copy(blanks,1,12-length(varibs[ps])));
j:=j+1; if j>max_col then begin j:=1; writeln(file_out); end;
end;
writeln(file_out);
close(file_in); close(file_out);
end;
end.