home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
xbase
/
library
/
dbase
/
debug
/
analyze
/
db_comp.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1986-10-27
|
18KB
|
423 lines
{program DB_COMP
This is one of a series of utilities designed to aid in the debugging and
operation of dBASE III .PRG files. This utility strips out all comment lines,
blank lines, and leading blanks, and reduces all command and function words to
their minimum possible length (usually only 4 characters) in an attempt to
speed the programs up by reducing the amount of unnecessary characters in them.
This utility can also reverse the process, but the comment and blank lines are
lost.
The main advantage of this utility is that it can perform these operations
on all of the .PRG files in a particular tree formation, as well as one
program at a time, or starting from any particular file in that tree.
Written by Curtis H. Hoffmann
version A1 10/25/86
A1 10/25/86 Initial Release
}
const
blanks= ' ';
set_list: array[1..38] of string[10] =
('ALTERNATE','CARRY', 'CATALOG', 'CENTURY','COLOR', 'CONFIRM','CONSOLE','DEBUG', 'DECIMALS','DEFAULT','DELETED',
'DEVICE', 'DOHISTORY','ESCAPE', 'EXACT', 'FIELDS', 'FILTER', 'FIXED', 'FORMAT', 'FUNCTION','HEADING','HISTORY',
'INTENSITY','MARGIN', 'MEMOWIDTH','MENUS', 'MESSAGE','ORDER', 'PRINTER','PROCEDURE','RELATION','SAFETY', 'DELIMITERS',
'STATUS', 'TITLE', 'TYPEAHEAD','UNIQUE', 'INDEX');
as_is_list: array[1..20] of string[10] =
('?', '??', 'CALL','DIR','FIND','LOAD','LOOP','EXIT','PACK','QUIT','SET','READ','HELP','RUN','SAVE','SKIP',
'TEXT','TYPE','WAIT','ZAP');
sgl_word: array[1..12] of string[10] =
('APPEND','ASSIST','CLEAR','CANCEL','CONTINUE','EJECT','REINDEX','RESUME','RETRY','SUSPEND','ENDTEXT','OTHERWISE');
plus_phrase: array[1..15] of string[10] =
('ACCEPT','ERASE', 'EXPORT','IMPORT','INPUT','PARAMETERS','PRIVATE','PROCEDURE','PUBLIC','RELEASE','RENAME','RESTORE',
'RETURN','SELECT','STORE');
fn_list: array[1..41] of string[10] =
('WHILE', 'PRINT', 'FIELDS', 'UNIQUE','SAMPLE', 'PLAIN', 'HEADING','NOEJECT',',SUMMARY', 'CMONTH', 'DELETED',
'DISKSPACE','ERROR', 'FKLABEL','FKMAX', 'FOUND', 'GETENV', 'INKEY', 'ISALPHA','ISCOLOR', 'ISLOWER','ISUPPER',
'LTRIM', 'LUPDATE','MESSAGE','MONTH', 'READKEY', 'RECCOUNT','RECNO', 'RECSIZE','REPLICATE','RIGHT', 'ROUND',
'RTRIM', 'SPACE', 'STUFF', 'SUBSTR','TRANSFORM','UPPER', 'LOWER', 'VERSION');
command_list: array[1..17] of string[10] =
('APPEND', 'AVERAGE','CHANGE','COUNT','DELETE','EDIT','INDEX','JOIN','LABEL','LOCATE','RECALL',
'REPLACE','REPORT', 'SEEK', 'SORT', 'SUM', 'TOTAL');
spl_cmd: array[1..14] of string[10] =
('@','BROWSE','CLEAR','CLOSE','COPY','CREATE','DISPLAY','GO','INSERT','LIST','MODIFY','ON','UPDATE','USE');
special_fn_list: array[1..37] of string[11] =
('PICTURE', 'RANGE', 'CLEAR', 'DOUBLE', 'FIELDS','FREEZE', 'NOFOLLOW', 'NOMENU','WIDTH', 'NOAPPEND',
'TYPEAHEAD','ALTERNATE','DATABASES','FORMAT', 'INDEX', 'PROCEDURE','STRUCTURE','WHILE', 'EXTENDED','LABEL',
'QUERY', 'REPORT', 'SCREEN', 'ENVIRONMENT','PRINT', 'HISTORY', 'MEMORY', 'STATUS','BOTTOM', 'BLANK',
'ALIAS', 'REPLACE', 'RANDOM', 'ERROR', 'ESCAPE','COMMAND', 'BEFORE');
type
name = string[12];
stt = string[255];
var
file_in, file_out : text;
all_files, abo, c_x : char;
in_file, ofl : string[8];
progs : array[1..100] of string[8];
prog_stack, line_stack : array[1..20] of integer;
ps, sp, ln_cnt, indent, ind_stat : integer;
st, outstring, hold_st : string[255];
next_word, this_word : string[10];
more_words, skip_line : boolean;
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;
procedure get_started; {Opening screen, get filename}
var j: integer;
begin
abo:='N'; clrscr; gotoxy(10,10);
write('Input .PRG file to convert first : '); read(in_file); gotoxy(10,12);
write('Compress or Expand file(s) (C/X) : '); read(c_x); gotoxy(10,14);
write('Convert 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<='z') then in_file[j]:=upcase(in_file[j]);
assign(file_in, in_file+'.prg'); reset(file_in);
end;
c_x:=upcase(c_x); if (c_x<>'C') and (c_x<>'X') then abo:='Y';
progs[1]:=in_file;
end;
procedure init; {Initialize stacks and pointers}
var i: integer;
begin
outstring:=''; ln_cnt:=0; sp:=1; ps:=1; prog_stack[1]:=1;
for i:=1 to 20 do begin line_stack[i]:=0; end
end;
procedure push_stack; {Put current file in top of stack prior}
var y: integer; {to jumping to next called file.}
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);
gotoxy(10,20);
writeln('Adding ',progs[prog_stack[ps]],copy(blanks,1,8-length(progs[prog_stack[ps]])),'.PRG to the tree formation');
assign(file_in, progs[prog_stack[ps]]+'.prg'); reset(file_in);
ln_cnt:=0;
end;
procedure pop_stack; {Done with current file, so pop last}
var i: integer; {pushed file from stack, make it current.}
begin
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 i:=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 rtrim(var stg: stt): stt; {Remove trailing blanks}
begin
while (stg[length(stg)]=' ') and (length(stg)>0) do stg:=copy(stg,1,length(stg)-1);
rtrim:=stg;
end;
function get_word(var line: stt): stt; {Find next word in sentence}
var word: string[20];
begin
st:=ltrim(st); word:=''; hold_st:=st;
while (length(st)>0) and (st[1]<>' ') do begin
word:=word+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}
var c: string[3]; {so they can be skipped, else}
u: integer; {prep the line prior to being}
uq, os: boolean; {parsed}
stg: string[255];
d: char;
begin
skip_line:=false; st:=ltrim(st); stg:='';
if (length(st)=0) or (st[1]='*') then skip_line:=true
else begin
uq:=false; os:=false;
for u:=1 to length(st) do begin
if (st[u]='"') or (ord(st[u])=39) then if not uq then begin
uq:=true; d:=st[u];
end
else if st[u]=d then uq:=false;
c:=st[u];
if (ord(c)<32) or (ord(c)>127) then c:=''
else if not uq then if c=' ' then begin
if os then c:='' else os:=true;
end
else begin
os:=false;
if (c>='a') and (c<='z') then c:=upcase(c)
else if c='=' then begin
os:=true; stg:=rtrim(stg); c:=' = ';
end;
end;
stg:=stg+c;
end;
st:=stg;
if copy(st,1,4)='NOTE'then skip_line:=true;
end;
end;
procedure f_c; {Flag any comments or empty lines}
begin
skip_line:=false; st:=ltrim(st);
if (length(st)=0) or (st[1]='*') then skip_line:=true;
end;
procedure find_function; {Look for special dBASE function}
var r, v: integer; {words inside of key expressions}
word, stg: string[255]; {ie - if <expression>}
uq, fv: boolean;
c: char;
begin
for r:=1 to (length(st)-4) do if copy(st,r,3)=' = ' then st:=copy(st,1,r-1)+'='+copy(st,r+3,length(st)-3);
stg:=''; word:=''; uq:=false; st:=ltrim(st);
for r:=1 to length(st) do begin
if (st[r]='"') or (ord(st[r])=39) then if not uq then begin
stg:=stg+st[r]; uq:=true; c:=st[r]
end
else if st[r]=c then uq:=false;
if uq and (st[r]<>c) then stg:=stg+st[r];
if not uq then begin
if ((st[r]>='A') and (st[r]<='Z')) then word:=word+st[r]
else begin
fv:=false; v:=1;
while (v<=41) and not fv do begin
if copy(word,1,4)=copy(fn_list[v],1,4) then begin
if c_x='C' then stg:=stg+copy(fn_list[v],1,4)+st[r] else stg:=stg+fn_list[v]+st[r];
word:=''; fv:=true;
end;
v:=v+1;
end;
if not fv then begin stg:=stg+word+st[r]; word:=''; end;
end;
end;
end;
if length(word)>0 then stg:=stg+word;
st:=stg;
end;
procedure special_fn; {Process all of the odd extra}
var r, v: integer; {function and secondary command}
word, stg: string[255]; {words that can't be easily}
uq, fv: boolean; {handled by any of the other}
c: char; {methods.}
begin {ie- @ SAY PICTURE}
for r:=1 to (length(st)-4) do if copy(st,r,3)=' = ' then st:=copy(st,1,r-1)+'='+copy(st,r+3,length(st)-3);
stg:=''; word:=''; uq:=false; st:=ltrim(st);
for r:=1 to length(st) do begin
if (st[r]='"') or (ord(st[r])=39) then if not uq then begin
stg:=stg+st[r]; uq:=true; c:=st[r]
end
else if st[r]=c then uq:=false;
if uq and (st[r]<>c) then stg:=stg+st[r];
if not uq then begin
if ((st[r]>='A') and (st[r]<='Z')) then word:=word+st[r]
else begin
fv:=false; v:=1;
while (v<=37) and not fv do begin
if copy(word,1,4)=copy(special_fn_list[v],1,4) then begin
if c_x='C' then stg:=stg+copy(special_fn_list[v],1,4)+st[r] else stg:=stg+special_fn_list[v]+st[r];
word:=''; fv:=true;
end;
v:=v+1;
end;
if not fv then begin stg:=stg+word+st[r]; word:=''; end;
end;
end;
end;
if length(word)>0 then stg:=stg+word;
st:=stg;
end;
procedure what_cmd; {Find the matching shortened form of a command}
var tw, nw: string[4]; {and perform the appropriate operations}
u: integer;
fnd: boolean;
begin
tw:=this_word; nw:=next_word; {Initialize}
fnd:=false; u:=1;
if nw='=' then begin {For straight assignment}
fnd:=true; find_function; {commands}
if c_x='C' then outstring:=this_word+nw+st else outstring:=this_word+' = '+st;
end;
while (not fnd) and (u<=20) do begin
if as_is_list[u]=tw then begin {For lines that stand as-is}
fnd:=true;
if length(nw)=0 then outstring:=tw else outstring:=tw+' '+hold_st;
if (tw='SET') and (length(nw)>0) then fnd:=false;
end;
u:=u+1;
end;
if not fnd then begin {For single word commands}
u:=1; {greater than 4 characters long}
while (not fnd) and (u<=9) do begin
if copy(sgl_word[u],1,4)=tw then
if not ((tw='CLEA') and (length(nw)>0)) then begin
fnd:=true;
if c_x='C' then outstring:=tw else outstring:=sgl_word[u];
if (tw='APPE') and (nw='BLAN') then if c_x='C' then outstring:='APPE BLAN' else outstring:='APPEND BLANK';
end;
u:=u+1;
end;
end;
if not fnd then begin {For commands where only the}
u:=1; while (not fnd) and (u<=15) do begin {first word changes}
if copy(plus_phrase[u],1,4)=tw then begin
fnd:=true;
if c_x='C' then outstring:=tw+' '+hold_st else outstring:=plus_phrase[u]+' '+hold_st;
end;
u:=u+1;
end;
end;
if (not fnd) and (tw<>'@') then begin {For regular commands that}
u:=1; {can have expressions in}
while (not fnd) and (u<=18) do begin {them}
if copy(command_list[u],1,4)=tw then begin
fnd:=true; st:=hold_st; find_function;
if c_x='C' then outstring:=tw+' '+st else outstring:=command_list[u]+' '+st;
end;
u:=u+1;
end;
end;
if not fnd then if tw='SET' then begin {Treat SET WHATEVER as a}
if c_x='C' then begin {class to itself}
fnd:=true; outstring:=tw+' '+nw+' '+ltrim(st)
end
else begin
u:=1;
if length(nw)<4 then outstring:=tw+' '+nw+' '+ltrim(st)
else while (not fnd) and (u<39) do begin
if copy(set_list[u],1,4)=nw then begin
fnd:=true; outstring:=tw+' '+set_list[u]+' '+ltrim(st);
end;
u:=u+1;
end;
end;
end; {IF and DO strings}
if not fnd then if (tw='IF') or (tw='DO') then begin
fnd:=true;
if (tw='DO') and ((nw<>'CASE') and (nw<>'WHIL')) then outstring:='DO '+ltrim(hold_st)
else if tw='IF' then begin
ind_stat:=1;
st:=hold_st; find_function; outstring:='IF '+st;
end
else begin
ind_stat:=1;
if nw='WHIL' then begin
find_function; if c_x='C' then outstring:='DO WHIL '+st else outstring:='DO WHILE '+st;
end
else outstring:='DO CASE';
end;
end; {End of loop statements}
if not fnd then if (tw='ENDC') or ((tw='ENDI') or (tw='ENDD')) then begin
fnd:=true; if c_x='C' then outstring:=tw
else begin
ind_stat:=2;
if tw[4]='I' then outstring:='ENDIF' else if tw[4]='D' then outstring:='ENDDO' else outstring:='ENDCASE';
end;
end;
if not fnd then begin {For irregular commands that don't follow}
u:=1; {regular syntax structures}
while (not fnd) and (u<=14) do begin
if copy(spl_cmd[u],1,4)=tw then begin
fnd:=true; st:=hold_st; special_fn;
if c_x='C' then outstring:=tw+' '+st else outstring:=spl_cmd[u]+' '+st;
end;
u:=u+1;
end;
end; {Process CASE and expressions}
if (not fnd) and (tw='CASE') then begin
fnd:=true; st:=hold_st; find_function; outstring:=tw+' '+st;
ind_stat:=3;
end; {Catch-all phrase}
if not fnd then outstring:=this_word+' '+hold_st;
end;
procedure get_line; {Get the next sentence from the file}
begin {and operate on it}
readln(file_in,st); first_char;
if not skip_line then begin
this_word:=''; next_word:=''; more_words:=true; ind_stat:=0;
parse; what_cmd;
if ind_stat in [2,3] then indent:=indent-1;
if c_x='C' then indent:=0;
writeln(file_out,copy(blanks,1,3*indent)+outstring);
if ind_stat in [1,3] then indent:=indent+1;
end;
end;
begin {Main body of the program}
get_started; init; {Get the tree structure}
if abo<>'Y' then begin
while ps>0 do begin
while not eof(file_in) do begin
readln(file_in,st); ln_cnt:=ln_cnt+1; f_c;
if (not skip_line) and (all_files='A') then begin
this_word:=''; next_word:=''; more_words:=true; parse;
if (this_word='DO') and ((next_word<>'CASE') and (copy(next_word,1,4)<>'WHIL')) then begin
push_stack;
end;
end;
end;
pop_stack;
end;
{Do Compression or Expansion}
for ps:=1 to sp do begin
indent:=0;
close(file_in); assign(file_in,progs[ps]+'.prg'); reset(file_in);
gotoxy(10,21); writeln('Working on ',progs[ps],' ');
assign(file_out,progs[ps]+'.new'); rewrite(file_out);
while not eof(file_in) do get_line;
close(file_out);
end;
gotoxy(10,22); writeln('Done.');
close(file_in); close(file_out);
end;
end.