home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload / ShartewareOverload.cdr / database / db_dbug2.zip / DB_VARIB.PAS < prev    next >
Pascal/Delphi Source File  |  1987-03-12  |  14KB  |  383 lines
  1. {program DB_VARIBS
  2.  This is one of a series of utilities intended for analyzing dBASE III .PRG
  3.  files.  This program examines the program flow of all available .PRG files in
  4.  a tree structure, then prints out the results of the variables used.
  5.  
  6.                                          Written by Curtis H. Hoffmann
  7.  
  8. version A2 03/10/87
  9.  
  10.    A1 10/20/86   Initial Release
  11.    A2 03/10/87   Check for nonexistant files in DO file statement
  12. }
  13.  
  14.  
  15. const
  16.    blanks= '                                                             ';
  17.    max_col=7;
  18.  
  19. type
  20.    name = string[12];
  21.    stt  = string[255];
  22.    datetype = string[8];
  23.     regtype =record
  24.              ax,bx,cx,dx,bp,si,di,ds,es,flags: integer
  25.              end;
  26.  
  27. var
  28.    file_in, file_out                 : text;
  29.    all_files, abo                    : char;
  30.    in_file, ofl                      : string[8];
  31.    out_file                          : string[12];
  32.    progs                             : array[1..100] of string[8];
  33.    p_kludge                          : array[1..100] of boolean;
  34.    varibs                            : array[1..255] of string[10];
  35.    v_n, v_s                          : array[1..255] of integer;
  36.    prog_stack, line_stack            : array[1..20]  of integer;
  37.    ps, sp, ln_cnt, vp, lp, stat, j   : integer;
  38.    st, outstring, temp_st, path      : string[255];
  39.    next_word, this_word              : string[10];
  40.    more_words, skip_line, push_kludge: boolean;
  41.  
  42.    {v_s[] is variable status: 4 = Not Released, 2 = Used, 1 = Public}
  43.  
  44.  
  45. function time: datetype;
  46. var reg:     regtype;
  47.     h,m,s,w: datetype;
  48.     i:       integer;
  49.  
  50. begin
  51.    reg.ax:=$2c00;
  52.    intr($21,reg);
  53.    str(hi(reg.cx):2,h);
  54.    str(lo(reg.cx):2,m);
  55.    str(hi(reg.dx):2,s);
  56.    w:=h+':'+m+':'+s;
  57.    for i:=1 to length(w) do if w[i]=' ' then w[i]:='0';
  58.    time:=w;
  59. end;
  60.  
  61. function date: datetype;
  62. var reg:     regtype;
  63.     y,m,d,w: datetype;
  64.     i:       integer;
  65.  
  66. begin
  67.    reg.ax:=$2a00;
  68.    intr($21,reg);
  69.    str(reg.cx:4,y);
  70.    delete(y,1,2);
  71.    str(hi(reg.dx):2,m);
  72.    str(lo(reg.dx):2,d);
  73.    w:=m+'/'+d+'/'+y;
  74.    for i:=1 to length(w) do if w[i]=' ' then w[i]:='0';
  75.    date:=w;
  76. end;
  77.  
  78. function exist(filename: name): boolean;      {Do requested files exist?}
  79. var fil: file;
  80. begin
  81.    assign(fil, filename);
  82.    {$I-}
  83.    reset(fil);
  84.    {$I+}
  85.    exist:=(IOresult=0);
  86.    close(fil);
  87. end;
  88.  
  89. function standard_io(h :name): boolean;       {Is requested file PRN or CON?}
  90. begin
  91.    if ((h='prn') or (h='PRN')) or ((h='con') or (h='CON')) then
  92.       standard_io:=true
  93.    else standard_io:=false;
  94. end;
  95.  
  96. procedure get_started;                        {Request I/O files, open them}
  97. var ow: char;
  98. begin
  99.    abo:='N'; clrscr; gotoxy(10,10);
  100.    write('Input .PRG file to check first          : '); read(in_file); gotoxy(10,12);
  101.    write('File to dump output to (prn for printer): '); read(out_file); gotoxy(10,14);
  102.    write('Check all files, or just this one (A/O) : '); readln(all_files);
  103.    all_files:=upcase(all_files);
  104.    if not exist(in_file+'.prg') then begin
  105.       writeln(in_file+'.PRG does not exist, program aborted'); abo:='Y'; end
  106.    else begin
  107.       for j:=1 to length(in_file) do
  108.        if (in_file[j]>='a') and (in_file[j]<='z') then
  109.         in_file[j]:=upcase(in_file[j]);
  110.       assign(file_in, in_file+'.prg'); reset(file_in);
  111.    end;
  112.    textcolor(12);
  113.    if not standard_io(out_file) then if exist(out_file) then begin
  114.       write(out_file+' exists, overwrite it (Y/N)?: '); readln(ow);
  115.       if upcase(ow)<>'Y' then begin write('Program aborted'); abo:='Y'; end;
  116.    end;
  117.    textcolor(14);
  118.    progs[1]:=in_file;
  119.    if abo<>'Y' then begin assign(file_out, out_file); rewrite(file_out); end;
  120. end;
  121.  
  122. procedure init;                                 {Initialize variables}
  123. var i: integer;
  124. begin
  125.    ln_cnt:=0;        vp:=0;      push_kludge:=false;    getdir(0,path);
  126.    sp:=1;            ps:=1;      prog_stack[sp]:=1;
  127.    for i:=1 to 255 do begin
  128.       v_s[i]:=0; varibs[i]:=''; v_n[i]:=0;
  129.    end;
  130.    for i:=1 to 100 do p_kludge[i]:=false;
  131.    for i:=1 to 20  do line_stack[i]:=0;
  132. end;
  133.  
  134. procedure push_stack;                      {Put current .PRG in stack,}
  135. var y: integer;                            {print out filename, variable list}
  136.     v: boolean;                            {then open next called filename}
  137. begin
  138.    v:=false;
  139.    if not p_kludge[prog_stack[ps]] then begin
  140.       outstring:=outstring+'   ';
  141.       p_kludge[prog_stack[ps]]:=true; j:=1;
  142.       temp_st:=outstring+'('+progs[prog_stack[ps]]+copy(blanks,1,8-length(progs[prog_stack[ps]]))+': invoked  )';
  143.       temp_st:=temp_st+copy(blanks,1,27-length(outstring));
  144.       write(file_out,temp_st);
  145.       for y:=1 to vp do if v_n[y]=prog_stack[ps] then begin
  146.          write(file_out,varibs[y]+copy(blanks,1,12-length(varibs[y]))); j:=j+1;
  147.          if j>max_col then begin
  148.             j:=1; writeln(file_out);
  149.             write(file_out,copy(blanks,1,length(temp_st)));
  150.          end;
  151.          v:=true;
  152.       end;
  153.       writeln(file_out);
  154.       if (j<>1) or (not v) then writeln(file_out);
  155.    end
  156.    else begin
  157.       write(file_out,'Variables still in effect:                      '); j:=1;
  158.       for y:=1 to vp do if v_n[y]>0 then begin
  159.          write(file_out,varibs[y],copy(blanks,1,12-length(varibs[y])));
  160.          j:=j+1;
  161.          if j>max_col then begin
  162.             j:=1; writeln(file_out);
  163.             write(file_out,copy(blanks,1,48));
  164.          end;
  165.          v:=true;
  166.       end;
  167.       writeln(file_out);
  168.       if (j<>1) or (not v) then writeln(file_out);
  169.    end;
  170.    if not push_kludge then begin
  171.       line_stack[ps]:=ln_cnt; ps:=ps+1; y:=1;
  172.       while (y<=sp) and (next_word<>progs[y]) do y:=y+1;
  173.       if y>sp then begin sp:=sp+1; progs[sp]:=next_word; end;
  174.       prog_stack[ps]:=y; close(file_in);
  175.       assign(file_in, progs[prog_stack[ps]]+'.prg'); reset(file_in);
  176.       ln_cnt:=0;
  177.    end;
  178. end;
  179.  
  180. procedure pop_stack;                    {Print current filename and list}
  181. var y: integer;                         {of newly released variables, then}
  182.     v: boolean;                         {close current file and open top}
  183. begin                                   {file in the stack}
  184.    j:=1; v:=false;
  185.    temp_st:=outstring+'('+progs[prog_stack[ps]]+copy(blanks,1,8-length(progs[prog_stack[ps]]))+': released) ';
  186.    temp_st:=temp_st+copy(blanks,1,27-length(outstring));
  187.    write(file_out,temp_st);
  188.    for y:=1 to vp do if (v_n[y]=prog_stack[ps]) and (v_s[y]<4) then begin
  189.       v_n[y]:=0; j:=j+1;
  190.       write(file_out,varibs[y]+copy(blanks,1,12-length(varibs[y])));
  191.       if j>max_col then begin
  192.          j:=1; writeln(file_out);
  193.          write(file_out,copy(blanks,1,length(temp_st)));
  194.       end;
  195.       v:=true;
  196.    end;
  197.    if (j<>1) or (not v) then writeln(file_out);
  198.    writeln(file_out); outstring:=copy(outstring,1,length(outstring)-3);
  199.    p_kludge[prog_stack[ps]]:=false; ps:=ps-1;
  200.    if ps>0 then begin
  201.       ln_cnt:=line_stack[ps];
  202.       close(file_in);
  203.       assign(file_in, progs[prog_stack[ps]]+'.prg'); reset(file_in);
  204.       for y:=1 to ln_cnt do readln(file_in, st);
  205.    end;
  206. end;
  207.  
  208. function ltrim(var stg: stt): stt;           {Remove leading blanks}
  209. begin
  210.    while (stg[1]=' ') and (length(stg)>0) do stg:=copy(stg,2,length(stg));
  211.    ltrim:=stg;
  212. end;
  213.  
  214. function get_word(var line: stt): stt;       {Put first, and second, in line}
  215. var word: string[20];                        {words in current sentence into}
  216. begin                                        {This_word and Next_word}
  217.    st:=ltrim(st); word:='';
  218.    while (length(st)>0) and (st[1]<>' ') do begin
  219.       if (st[1]>='a') and (st[1]<='z') then word:=word+upcase(st[1])
  220.       else word:=word+st[1];
  221.       st:=copy(st,2,length(st));
  222.    end;
  223.    get_word:=word;
  224. end;
  225.  
  226. procedure parse;                             {Break sentence up into seperate}
  227. begin                                        {words to be operated on}
  228.    st:=ltrim(st);
  229.    if length(this_word)>0 then begin
  230.       this_word:=next_word; next_word:=get_word(st); end
  231.    else begin
  232.       this_word:=get_word(st); next_word:=get_word(st);
  233.    end;
  234.    more_words:=false;
  235.    if (length(st)>0) or (length(this_word)>0) then more_words:=true;
  236. end;
  237.  
  238. procedure first_char;                         {Check to see if sentence is}
  239. begin                                         {a comment or empty}
  240.    skip_line:=false; st:=ltrim(st);
  241.    if (length(st)=0) or (st[1]='*') then skip_line:=true;
  242. end;
  243.  
  244. procedure add_f;                              {Add variable to variable stack}
  245. var y, t: integer;                            {change appropriate status bit,}
  246. begin                                         {and identify the invoking .PRG}
  247.    if vp=0 then begin                         {file}
  248.       varibs[1]:=this_word; v_n[1]:=prog_stack[ps];
  249.       v_s[1]:=stat; vp:=1;
  250.    end
  251.    else begin
  252.       for y:=1 to vp do begin
  253.          if this_word=varibs[y] then begin
  254.             v_s[y]:=(v_s[y] or 2) or stat;
  255.             if v_n[y]=0 then v_n[y]:=prog_stack[ps];
  256.             y:=vp+5;
  257.          end
  258.          else if varibs[y]>this_word then begin
  259.             vp:=vp+1; t:=vp;
  260.             while t>y do begin
  261.                varibs[t]:=varibs[t-1]; v_n[t]:=v_n[t-1];
  262.                v_s[t]:=v_s[t-1]; t:=t-1;
  263.             end;
  264.             varibs[y]:=this_word; v_n[y]:=prog_stack[ps];
  265.             v_s[y]:=stat; y:=vp+5;
  266.          end;
  267.       end;
  268.       if (this_word>varibs[vp]) and (y<vp+2) then begin
  269.          vp:=vp+1; varibs[vp]:=this_word; v_n[vp]:=prog_stack[ps];
  270.          v_s[vp]:=stat;
  271.       end;
  272.    end;
  273. end;
  274.  
  275. procedure what_cmd;                           {Identify the current dBASE}
  276. var o: integer;                               {command and perform the}
  277.     tw, nw: string[4];                        {appropriate function}
  278. begin
  279.    tw:=this_word; nw:=next_word;
  280.    if all_files='A' then begin
  281.       if (tw='DO') then
  282.          if (nw<>'CASE') and (nw<>'WHIL') then if exist(next_word+'.prg') then push_stack
  283.          else begin
  284.             write(file_out,'ALERT: DO ',next_word,' encountered in ',progs[prog_stack[ps]]+'.PRG.  ');
  285.             writeln(file_out,next_word,'.PRG not found.');
  286.       end;
  287.    end;
  288.    if tw='PUBL' then while more_words do begin
  289.       stat:=5; parse; if length(this_word)>0 then add_f;
  290.    end;
  291.    if nw='=' then begin
  292.       stat:=6; add_f;
  293.    end;
  294.    if ((tw='ACCE') or (tw='COUN')) or ((tw='INPU') or (tw='WAIT')) then while more_words do begin
  295.       stat:=6; parse;
  296.       if this_word='TO' then begin
  297.          this_word:=next_word; add_f; more_words:=false;
  298.       end;
  299.    end
  300.    else if ((tw='STOR') or (tw='AVER')) then while more_words do begin
  301.       stat:=6; parse;
  302.       if this_word='TO' then while more_words do begin
  303.          parse; if length(this_word)>0 then add_f;
  304.       end
  305.       else if (tw='SUM') then while more_words do begin
  306.          stat:=6; parse;
  307.          if this_word='TO' then while more_words and ((this_word<>'FOR') and (this_word<>'WHILE')) do begin
  308.             parse; if length(this_word)>0 then add_f;
  309.          end;
  310.       end;
  311.    end;
  312.    if tw='RELE' then while more_words do begin
  313.       parse;
  314.       if length(this_word)>0 then for o:=1 to vp do if this_word=varibs[o] then begin
  315.          v_s[o]:=v_s[o] and 2; v_n[o]:=prog_stack[ps];
  316.       end;
  317.    end;
  318.    more_words:=false;
  319. end;
  320.  
  321. procedure get_line;                         {Get new sentence and prepare}
  322. var bb: integer;                            {for parsing}
  323.     cc: string[3];
  324.     nn: string[255];
  325.     dq: boolean;
  326. begin
  327.    nn:=''; cc:=''; this_word:=''; next_word:=''; more_words:=true;
  328.    readln(file_in,st); dq:=false;
  329.    for bb:=1 to length(st) do begin
  330.       cc:=st[bb];
  331.       if (cc='"') or (ord(cc)=39) then dq:=true;
  332.       if (cc=',') or ((ord(cc)<31) or (ord(cc)>127)) then cc:=' ';
  333.       if (cc='=') and (not dq) then cc:=' '+cc+' ';
  334.       nn:=nn+cc;
  335.    end;
  336.    st:=nn;
  337.    ln_cnt:=ln_cnt+1; first_char;
  338.    if not skip_line then while more_words begin
  339.       parse; what_cmd;
  340.    end;
  341. end;
  342.  
  343. begin                                   {Main Body of the Program}
  344.    get_started; init;
  345.                 {If abo=Y then the program is to be aborted for some reason}
  346.    if abo<>'Y' then begin
  347.       writeln(file_out,'         dBASE III Program Variable Usage Report       for directory '+path);
  348.       write(file_out,'Starting with: '+in_file+'.PRG'+copy(blanks,1,8-length(in_file)));
  349.       writeln(file_out,'                            run at ',time,' on ',date);
  350.       writeln(file_out);
  351.       outstring:='  ';
  352.       while ps>0 do begin
  353.          while not eof(file_in) do get_line;
  354.          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;
  355.          push_kludge:=true; push_stack; push_kludge:=false; pop_stack;
  356.       end;
  357.  
  358.                                         {Output Unused Variable List}
  359.  
  360.       writeln(file_out); writeln(file_out,'============================================================');
  361.       writeln(file_out); writeln(file_out,'Variables declared but never used:');
  362.       j:=1;
  363.       writeln(file_out);
  364.       for ps:=1 to vp do if (v_s[ps] and 2)=0 then begin
  365.          write(file_out,varibs[ps]+copy(blanks,1,12-length(varibs[ps])));
  366.          j:=j+1; if j>max_col then begin j:=1; writeln(file_out); end;
  367.       end;
  368.  
  369.                                         {Output Unreleased Variable List}
  370.  
  371.       writeln(file_out); writeln(file_out);
  372.       writeln(file_out,'Variables declared PUBLIC but never RELEASEd:');
  373.       writeln(file_out);
  374.       j:=1;
  375.       for ps:=1 to vp do if (v_s[ps] and 4)=4 then begin
  376.          write(file_out,varibs[ps]+copy(blanks,1,12-length(varibs[ps])));
  377.          j:=j+1; if j>max_col then begin j:=1; writeln(file_out); end;
  378.       end;
  379.       writeln(file_out);
  380.       close(file_in); close(file_out);
  381.    end;
  382. end.
  383.