home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload / ShartewareOverload.cdr / database / db_dbug2.zip / DB_COMP.PAS < prev    next >
Pascal/Delphi Source File  |  1986-10-27  |  18KB  |  423 lines
  1. {program DB_COMP
  2.    This is one of a series of utilities designed to aid in the debugging and
  3. operation of dBASE III .PRG files.  This utility strips out all comment lines,
  4. blank lines, and leading blanks, and reduces all command and function words to
  5. their minimum possible length (usually only 4 characters) in an attempt to
  6. speed the programs up by reducing the amount of unnecessary characters in them.
  7. This utility can also reverse the process, but the comment and blank lines are
  8. lost.
  9.    The main advantage of this utility is that it can perform these operations
  10. on all of the .PRG files in a particular tree formation, as well as one
  11. program at a time, or starting from any particular file in that tree.
  12.  
  13.                                          Written by Curtis H. Hoffmann
  14.  
  15. version A1 10/25/86
  16.  
  17.    A1 10/25/86   Initial Release
  18.  
  19. }
  20.  
  21.  
  22. const
  23.    blanks= '                                                                 ';
  24.  
  25.    set_list: array[1..38] of string[10] =
  26. ('ALTERNATE','CARRY',    'CATALOG',  'CENTURY','COLOR',  'CONFIRM','CONSOLE','DEBUG',    'DECIMALS','DEFAULT','DELETED',
  27.  'DEVICE',   'DOHISTORY','ESCAPE',   'EXACT',  'FIELDS', 'FILTER', 'FIXED',  'FORMAT',   'FUNCTION','HEADING','HISTORY',
  28.  'INTENSITY','MARGIN',   'MEMOWIDTH','MENUS',  'MESSAGE','ORDER',  'PRINTER','PROCEDURE','RELATION','SAFETY', 'DELIMITERS',
  29.  'STATUS',   'TITLE',    'TYPEAHEAD','UNIQUE', 'INDEX');
  30.  
  31.    as_is_list: array[1..20] of string[10] =
  32. ('?',   '??',  'CALL','DIR','FIND','LOAD','LOOP','EXIT','PACK','QUIT','SET','READ','HELP','RUN','SAVE','SKIP',
  33.  'TEXT','TYPE','WAIT','ZAP');
  34.  
  35.    sgl_word: array[1..12] of string[10] =
  36. ('APPEND','ASSIST','CLEAR','CANCEL','CONTINUE','EJECT','REINDEX','RESUME','RETRY','SUSPEND','ENDTEXT','OTHERWISE');
  37.  
  38.    plus_phrase: array[1..15] of string[10] =
  39. ('ACCEPT','ERASE', 'EXPORT','IMPORT','INPUT','PARAMETERS','PRIVATE','PROCEDURE','PUBLIC','RELEASE','RENAME','RESTORE',
  40.  'RETURN','SELECT','STORE');
  41.  
  42.    fn_list: array[1..41] of string[10] =
  43. ('WHILE',    'PRINT',  'FIELDS', 'UNIQUE','SAMPLE',   'PLAIN',   'HEADING','NOEJECT',',SUMMARY', 'CMONTH', 'DELETED',
  44.  'DISKSPACE','ERROR',  'FKLABEL','FKMAX', 'FOUND',    'GETENV',  'INKEY',  'ISALPHA','ISCOLOR',  'ISLOWER','ISUPPER',
  45.  'LTRIM',    'LUPDATE','MESSAGE','MONTH', 'READKEY',  'RECCOUNT','RECNO',  'RECSIZE','REPLICATE','RIGHT',  'ROUND',
  46.  'RTRIM',    'SPACE',  'STUFF',  'SUBSTR','TRANSFORM','UPPER',   'LOWER',  'VERSION');
  47.  
  48.    command_list: array[1..17] of string[10] =
  49. ('APPEND', 'AVERAGE','CHANGE','COUNT','DELETE','EDIT','INDEX','JOIN','LABEL','LOCATE','RECALL',
  50.  'REPLACE','REPORT', 'SEEK',  'SORT', 'SUM',   'TOTAL');
  51.  
  52.    spl_cmd: array[1..14] of string[10] =
  53. ('@','BROWSE','CLEAR','CLOSE','COPY','CREATE','DISPLAY','GO','INSERT','LIST','MODIFY','ON','UPDATE','USE');
  54.  
  55.    special_fn_list: array[1..37] of string[11] =
  56. ('PICTURE',  'RANGE',    'CLEAR',    'DOUBLE',     'FIELDS','FREEZE',   'NOFOLLOW', 'NOMENU','WIDTH',   'NOAPPEND',
  57.  'TYPEAHEAD','ALTERNATE','DATABASES','FORMAT',     'INDEX', 'PROCEDURE','STRUCTURE','WHILE', 'EXTENDED','LABEL',
  58.  'QUERY',    'REPORT',   'SCREEN',   'ENVIRONMENT','PRINT', 'HISTORY',  'MEMORY',   'STATUS','BOTTOM',  'BLANK',
  59.  'ALIAS',    'REPLACE',  'RANDOM',   'ERROR',      'ESCAPE','COMMAND',  'BEFORE');
  60.  
  61. type
  62.    name = string[12];
  63.    stt  = string[255];
  64. var
  65.    file_in, file_out                 : text;
  66.    all_files, abo, c_x               : char;
  67.    in_file, ofl                      : string[8];
  68.    progs                             : array[1..100] of string[8];
  69.    prog_stack, line_stack            : array[1..20]  of integer;
  70.    ps, sp, ln_cnt, indent, ind_stat  : integer;
  71.    st, outstring, hold_st            : string[255];
  72.    next_word, this_word              : string[10];
  73.    more_words, skip_line             : boolean;
  74.  
  75.  
  76. function exist(filename: name): boolean;     {Check to see if I/O files exist}
  77. var fil: file;
  78. begin
  79.    assign(fil, filename);
  80.    {$I-}
  81.    reset(fil);
  82.    {$I+}
  83.    exist:=(IOresult=0);
  84.    close(fil);
  85. end;
  86.  
  87. procedure get_started;                      {Opening screen, get filename}
  88. var j: integer;
  89. begin
  90.    abo:='N'; clrscr; gotoxy(10,10);
  91.    write('Input .PRG file to convert first         : '); read(in_file); gotoxy(10,12);
  92.    write('Compress or Expand file(s) (C/X)         : '); read(c_x); gotoxy(10,14);
  93.    write('Convert all files, or just this one (A/O): '); readln(all_files);
  94.    all_files:=upcase(all_files);
  95.    if not exist(in_file+'.prg') then begin
  96.       writeln(in_file+'.PRG does not exist, program aborted'); abo:='Y'; end
  97.    else begin
  98.       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]);
  99.       assign(file_in, in_file+'.prg'); reset(file_in);
  100.    end;
  101.    c_x:=upcase(c_x); if (c_x<>'C') and (c_x<>'X') then abo:='Y';
  102.    progs[1]:=in_file;
  103. end;
  104.  
  105. procedure init;                              {Initialize stacks and pointers}
  106. var i: integer;
  107. begin
  108.    outstring:=''; ln_cnt:=0; sp:=1; ps:=1; prog_stack[1]:=1;
  109.    for i:=1 to 20 do begin line_stack[i]:=0; end
  110. end;
  111.  
  112. procedure push_stack;                {Put current file in top of stack prior}
  113. var y: integer;                      {to jumping to next called file.}
  114. begin
  115.    line_stack[ps]:=ln_cnt; ps:=ps+1; y:=1;
  116.    while (y<=sp) and (next_word<>progs[y]) do y:=y+1;
  117.    if y>sp then begin sp:=sp+1; progs[sp]:=next_word; end;
  118.    prog_stack[ps]:=y; close(file_in);
  119.    gotoxy(10,20);
  120.    writeln('Adding ',progs[prog_stack[ps]],copy(blanks,1,8-length(progs[prog_stack[ps]])),'.PRG to the tree formation');
  121.    assign(file_in, progs[prog_stack[ps]]+'.prg'); reset(file_in);
  122.    ln_cnt:=0;
  123. end;
  124.  
  125. procedure pop_stack;              {Done with current file, so pop last}
  126. var i: integer;                   {pushed file from stack, make it current.}
  127. begin
  128.    ps:=ps-1;
  129.    if ps>0 then begin
  130.       ln_cnt:=line_stack[ps]; close(file_in);
  131.       assign(file_in, progs[prog_stack[ps]]+'.prg'); reset(file_in);
  132.       for i:=1 to ln_cnt do readln(file_in, st);
  133.    end;
  134. end;
  135.  
  136. function ltrim(var stg: stt): stt;           {Remove leading blanks}
  137. begin
  138.    while (stg[1]=' ') and (length(stg)>0) do stg:=copy(stg,2,length(stg));
  139.    ltrim:=stg;
  140. end;
  141.  
  142. function rtrim(var stg: stt): stt;           {Remove trailing blanks}
  143. begin
  144.    while (stg[length(stg)]=' ') and (length(stg)>0) do stg:=copy(stg,1,length(stg)-1);
  145.    rtrim:=stg;
  146. end;
  147.  
  148. function get_word(var line: stt): stt;       {Find next word in sentence}
  149. var word: string[20];
  150. begin
  151.    st:=ltrim(st); word:=''; hold_st:=st;
  152.    while (length(st)>0) and (st[1]<>' ') do begin
  153.       word:=word+st[1]; st:=copy(st,2,length(st));
  154.    end;
  155.    get_word:=word;
  156. end;
  157.  
  158. procedure parse;                             {Get words from sentence}
  159. begin
  160.    st:=ltrim(st);
  161.    if length(this_word)>0 then begin
  162.       this_word:=next_word; next_word:=get_word(st); end
  163.    else begin
  164.       this_word:=get_word(st); next_word:=get_word(st);
  165.    end;
  166.    more_words:=false;
  167.    if (length(st)>0) or (length(this_word)>0) then more_words:=true;
  168. end;
  169.  
  170. procedure first_char;                       {Flag any comments or empty lines}
  171. var c: string[3];                           {so they can be skipped, else}
  172.     u: integer;                             {prep the line prior to being}
  173.     uq, os: boolean;                        {parsed}
  174.     stg: string[255];
  175.     d: char;
  176. begin
  177.    skip_line:=false; st:=ltrim(st); stg:='';
  178.    if (length(st)=0) or (st[1]='*') then skip_line:=true
  179.    else begin
  180.       uq:=false; os:=false;
  181.       for u:=1 to length(st) do begin
  182.          if (st[u]='"') or (ord(st[u])=39) then if not uq then begin
  183.             uq:=true; d:=st[u];
  184.          end
  185.          else if st[u]=d then uq:=false;
  186.          c:=st[u];
  187.          if (ord(c)<32) or (ord(c)>127) then c:=''
  188.          else if not uq then if c=' ' then begin
  189.             if os then c:='' else os:=true;
  190.          end
  191.          else begin
  192.             os:=false;
  193.             if (c>='a') and (c<='z') then c:=upcase(c)
  194.             else if c='=' then begin
  195.                os:=true; stg:=rtrim(stg); c:=' = ';
  196.             end;
  197.          end;
  198.          stg:=stg+c;
  199.       end;
  200.       st:=stg;
  201.       if copy(st,1,4)='NOTE'then skip_line:=true;
  202.    end;
  203. end;
  204.  
  205. procedure f_c;                              {Flag any comments or empty lines}
  206. begin
  207.    skip_line:=false; st:=ltrim(st);
  208.    if (length(st)=0) or (st[1]='*') then skip_line:=true;
  209. end;
  210.  
  211. procedure find_function;                     {Look for special dBASE function}
  212. var r, v:       integer;                     {words inside of key expressions}
  213.     word, stg:  string[255];                 {ie - if <expression>}
  214.     uq, fv:     boolean;
  215.     c:          char;
  216. begin
  217.    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);
  218.    stg:=''; word:=''; uq:=false; st:=ltrim(st);
  219.    for r:=1 to length(st) do begin
  220.       if (st[r]='"') or (ord(st[r])=39) then if not uq then begin
  221.          stg:=stg+st[r]; uq:=true; c:=st[r]
  222.       end
  223.       else if st[r]=c then uq:=false;
  224.       if uq and (st[r]<>c) then stg:=stg+st[r];
  225.       if not uq then begin
  226.          if ((st[r]>='A') and (st[r]<='Z')) then word:=word+st[r]
  227.          else begin
  228.             fv:=false; v:=1;
  229.             while (v<=41) and not fv do begin
  230.                if copy(word,1,4)=copy(fn_list[v],1,4) then begin
  231.                   if c_x='C' then stg:=stg+copy(fn_list[v],1,4)+st[r] else stg:=stg+fn_list[v]+st[r];
  232.                   word:=''; fv:=true;
  233.                end;
  234.                v:=v+1;
  235.             end;
  236.             if not fv then begin stg:=stg+word+st[r]; word:=''; end;
  237.          end;
  238.       end;
  239.    end;
  240.    if length(word)>0 then stg:=stg+word;
  241.    st:=stg;
  242. end;
  243.  
  244. procedure special_fn;                        {Process all of the odd extra}
  245. var r, v:       integer;                     {function and secondary command}
  246.     word, stg:  string[255];                 {words that can't be easily}
  247.     uq, fv:     boolean;                     {handled by any of the other}
  248.     c:          char;                        {methods.}
  249. begin                                        {ie- @ SAY PICTURE}
  250.    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);
  251.    stg:=''; word:=''; uq:=false; st:=ltrim(st);
  252.    for r:=1 to length(st) do begin
  253.       if (st[r]='"') or (ord(st[r])=39) then if not uq then begin
  254.          stg:=stg+st[r]; uq:=true; c:=st[r]
  255.       end
  256.       else if st[r]=c then uq:=false;
  257.       if uq and (st[r]<>c) then stg:=stg+st[r];
  258.       if not uq then begin
  259.          if ((st[r]>='A') and (st[r]<='Z')) then word:=word+st[r]
  260.          else begin
  261.             fv:=false; v:=1;
  262.             while (v<=37) and not fv do begin
  263.                if copy(word,1,4)=copy(special_fn_list[v],1,4) then begin
  264.                   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];
  265.                   word:=''; fv:=true;
  266.                end;
  267.                v:=v+1;
  268.             end;
  269.             if not fv then begin stg:=stg+word+st[r]; word:=''; end;
  270.          end;
  271.       end;
  272.    end;
  273.    if length(word)>0 then stg:=stg+word;
  274.    st:=stg;
  275. end;
  276.  
  277. procedure what_cmd;            {Find the matching shortened form of a command}
  278. var tw, nw: string[4];         {and perform the appropriate operations}
  279.     u: integer;
  280.     fnd: boolean;
  281. begin
  282.    tw:=this_word; nw:=next_word;                {Initialize}
  283.    fnd:=false; u:=1;
  284.    if nw='=' then begin                         {For straight assignment}
  285.       fnd:=true; find_function;                 {commands}
  286.       if c_x='C' then outstring:=this_word+nw+st else outstring:=this_word+' = '+st;
  287.    end;
  288.    while (not fnd) and (u<=20) do begin
  289.       if as_is_list[u]=tw then begin            {For lines that stand as-is}
  290.          fnd:=true;
  291.          if length(nw)=0 then outstring:=tw else outstring:=tw+' '+hold_st;
  292.          if (tw='SET') and (length(nw)>0) then fnd:=false;
  293.       end;
  294.       u:=u+1;
  295.    end;
  296.    if not fnd then begin                      {For single word commands}
  297.       u:=1;                                   {greater than 4 characters long}
  298.       while (not fnd) and (u<=9) do begin
  299.          if copy(sgl_word[u],1,4)=tw then
  300.          if not ((tw='CLEA') and (length(nw)>0)) then begin
  301.             fnd:=true;
  302.             if c_x='C' then outstring:=tw else outstring:=sgl_word[u];
  303.             if (tw='APPE') and (nw='BLAN') then if c_x='C' then outstring:='APPE BLAN' else outstring:='APPEND BLANK';
  304.          end;
  305.          u:=u+1;
  306.       end;
  307.    end;
  308.    if not fnd then begin                          {For commands where only the}
  309.       u:=1; while (not fnd) and (u<=15) do begin  {first word changes}
  310.          if copy(plus_phrase[u],1,4)=tw then begin
  311.             fnd:=true;
  312.             if c_x='C' then outstring:=tw+' '+hold_st else outstring:=plus_phrase[u]+' '+hold_st;
  313.          end;
  314.          u:=u+1;
  315.       end;
  316.    end;
  317.    if (not fnd) and (tw<>'@') then begin          {For regular commands that}
  318.       u:=1;                                       {can have expressions in}
  319.       while (not fnd) and (u<=18) do begin        {them}
  320.          if copy(command_list[u],1,4)=tw then begin
  321.             fnd:=true; st:=hold_st; find_function;
  322.             if c_x='C' then outstring:=tw+' '+st else outstring:=command_list[u]+' '+st;
  323.          end;
  324.          u:=u+1;
  325.       end;
  326.    end;
  327.    if not fnd then if tw='SET' then begin         {Treat SET WHATEVER as a}
  328.       if c_x='C' then begin                       {class to itself}
  329.          fnd:=true; outstring:=tw+' '+nw+' '+ltrim(st)
  330.       end
  331.       else begin
  332.          u:=1;
  333.          if length(nw)<4 then outstring:=tw+' '+nw+' '+ltrim(st)
  334.          else while (not fnd) and (u<39) do begin
  335.             if copy(set_list[u],1,4)=nw then begin
  336.                fnd:=true; outstring:=tw+' '+set_list[u]+' '+ltrim(st);
  337.             end;
  338.             u:=u+1;
  339.          end;
  340.       end;
  341.    end;                                                   {IF and DO strings}
  342.    if not fnd then if (tw='IF') or (tw='DO') then begin
  343.       fnd:=true;
  344.       if (tw='DO') and ((nw<>'CASE') and (nw<>'WHIL')) then outstring:='DO '+ltrim(hold_st)
  345.       else if tw='IF' then begin
  346.         ind_stat:=1;
  347.         st:=hold_st; find_function; outstring:='IF '+st;
  348.       end
  349.       else begin
  350.          ind_stat:=1;
  351.          if nw='WHIL' then begin
  352.             find_function; if c_x='C' then outstring:='DO WHIL '+st else outstring:='DO WHILE '+st;
  353.          end
  354.          else outstring:='DO CASE';
  355.       end;
  356.    end;                                        {End of loop statements}
  357.    if not fnd then if (tw='ENDC') or ((tw='ENDI') or (tw='ENDD')) then begin
  358.       fnd:=true; if c_x='C' then outstring:=tw
  359.       else begin
  360.          ind_stat:=2;
  361.          if tw[4]='I' then outstring:='ENDIF' else if tw[4]='D' then outstring:='ENDDO' else outstring:='ENDCASE';
  362.       end;
  363.    end;
  364.    if not fnd then begin            {For irregular commands that don't follow}
  365.       u:=1;                         {regular syntax structures}
  366.       while (not fnd) and (u<=14) do begin
  367.          if copy(spl_cmd[u],1,4)=tw then begin
  368.             fnd:=true; st:=hold_st; special_fn;
  369.             if c_x='C' then outstring:=tw+' '+st else outstring:=spl_cmd[u]+' '+st;
  370.          end;
  371.          u:=u+1;
  372.       end;
  373.    end;                                      {Process CASE and expressions}
  374.    if (not fnd) and (tw='CASE') then begin
  375.       fnd:=true; st:=hold_st; find_function; outstring:=tw+' '+st;
  376.       ind_stat:=3;
  377.    end;                                               {Catch-all phrase}
  378.    if not fnd then outstring:=this_word+' '+hold_st;  
  379. end;
  380.  
  381. procedure get_line;              {Get the next sentence from the file}
  382. begin                            {and operate on it}
  383.    readln(file_in,st); first_char;
  384.    if not skip_line then begin
  385.       this_word:=''; next_word:=''; more_words:=true; ind_stat:=0;
  386.       parse; what_cmd;
  387.       if ind_stat in [2,3] then indent:=indent-1;
  388.       if c_x='C' then indent:=0;
  389.       writeln(file_out,copy(blanks,1,3*indent)+outstring);
  390.       if ind_stat in [1,3] then indent:=indent+1;
  391.    end;
  392. end;
  393.  
  394. begin                            {Main body of the program}
  395.    get_started; init;            {Get the tree structure}
  396.    if abo<>'Y' then begin
  397.       while ps>0 do begin
  398.          while not eof(file_in) do begin
  399.             readln(file_in,st); ln_cnt:=ln_cnt+1; f_c;
  400.             if (not skip_line) and (all_files='A') then begin
  401.                this_word:=''; next_word:=''; more_words:=true; parse;
  402.                if (this_word='DO') and ((next_word<>'CASE') and (copy(next_word,1,4)<>'WHIL')) then begin
  403.                   push_stack;
  404.                end;
  405.             end;
  406.          end;
  407.          pop_stack;
  408.       end;
  409.  
  410.                                   {Do Compression or Expansion}
  411.       for ps:=1 to sp do begin
  412.          indent:=0;
  413.          close(file_in); assign(file_in,progs[ps]+'.prg'); reset(file_in);
  414.          gotoxy(10,21); writeln('Working on ',progs[ps],'         ');
  415.          assign(file_out,progs[ps]+'.new'); rewrite(file_out);
  416.          while not eof(file_in) do get_line;
  417.          close(file_out);
  418.       end;
  419.       gotoxy(10,22); writeln('Done.');
  420.       close(file_in); close(file_out);
  421.    end;
  422. end.
  423.