home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload / ShartewareOverload.cdr / database / db_dbug2.zip / DB_FILES.PAS < prev    next >
Pascal/Delphi Source File  |  1986-11-20  |  16KB  |  470 lines
  1. {program DB_FILES
  2.  This is one of a series of utilities intended for analyzing dBASE III .PRG
  3.  files.  This program prints out the structure of all .DBF files, and the
  4.  keys of the associated .ndx files, used in each .PRG of any given tree.
  5.  
  6.                                          Written by Curtis H. Hoffmann
  7.  
  8. version A1 11/05/86
  9.  
  10.    A1 11/05/86   Initial Release
  11.  
  12. }
  13.  
  14.  
  15. const
  16.    blanks= '                                                             ';
  17.  
  18. type
  19.    name = string[12];
  20.    stt  = string[255];
  21.    datetype = string[8];
  22.     regtype = record
  23.                ax,bx,cx,dx,bp,si,di,ds,es,flags: integer
  24.               end;
  25.  
  26. var
  27.    file_in, file_out                     : text;
  28.    all_files, abo                        : char;
  29.    in_file, ofl                          : string[8];
  30.    out_file                              : string[12];
  31.    mac_name                              : string[13];
  32.    progs, dbf, ndx                       : array[1..100] of string[12];
  33.    macro                                 : array[1..100] of string[15];
  34.    mac_var                               : array[1..100] of string[10];
  35.    ndx_stack                             : array[1..100] of integer;
  36.    dbf_to_ndx                            : array[1..100] of integer;
  37.    sele_stack                            : array[1..10]  of integer;
  38.    prog_stack, line_stack                : array[1..20]  of integer;
  39.    ps, sp, ln_cnt, dp, np, d_p, sx, mp   : integer;
  40.    st, outstring, temp_st, path          : string[255];
  41.    next_word, this_word                  : string[10];
  42.    more_words, skip_line, pass_one, a_d  : boolean;
  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.      j: integer;
  99. begin
  100.    abo:='N'; clrscr; gotoxy(10,10);
  101.    write('Input .PRG file to check first          : '); read(in_file); gotoxy(10,12);
  102.    write('File to dump output to (prn for printer): '); read(out_file); gotoxy(10,14);
  103.    write('Check all files, or just this one (A/O) : '); readln(all_files);
  104.    all_files:=upcase(all_files);
  105.    if not exist(in_file+'.prg') then begin
  106.       writeln(in_file+'.PRG does not exist, program aborted'); abo:='Y'; end
  107.    else begin
  108.       for j:=1 to length(in_file) do
  109.        if (in_file[j]>='a') and (in_file[j]<='z') then
  110.         in_file[j]:=upcase(in_file[j]);
  111.       assign(file_in, in_file+'.prg'); reset(file_in);
  112.    end;
  113.    textcolor(12);
  114.    if not standard_io(out_file) then if exist(out_file) then begin
  115.       write(out_file+' exists, overwrite it (Y/N)?: '); readln(ow);
  116.       if upcase(ow)<>'Y' then begin write('Program aborted'); abo:='Y'; end;
  117.    end;
  118.    textcolor(14);
  119.    progs[1]:=in_file;
  120.    if abo<>'Y' then begin assign(file_out, out_file); rewrite(file_out); end;
  121. end;
  122.  
  123. procedure init;                                 {Initialize variables}
  124. var i: integer;
  125. begin
  126.    ln_cnt:=0;        dp:=0;      getdir(0,path);        np:=0;   mp:=0;
  127.    sp:=1;            ps:=1;      prog_stack[sp]:=1;     sx:=1;
  128.    for i:=1 to 20  do line_stack[i]:=0;
  129. end;
  130.  
  131. procedure push_stack;                      {Put current .PRG in stack,}
  132. var y: integer;                            {print out filename, variable list}
  133.     v: boolean;                            {then open next called filename}
  134. begin
  135.    line_stack[ps]:=ln_cnt; ps:=ps+1; y:=1;
  136.    while (y<=sp) and (next_word<>progs[y]) do y:=y+1;
  137.    if y>sp then begin sp:=sp+1; progs[sp]:=next_word; end;
  138.    prog_stack[ps]:=y; close(file_in);
  139.    assign(file_in, progs[prog_stack[ps]]+'.prg'); reset(file_in);
  140.    ln_cnt:=0;
  141. end;
  142.  
  143. procedure pop_stack;                    {Print current filename and list}
  144. var y: integer;                         {of newly released variables, then}
  145.     v: boolean;                         {close current file and open top}
  146. begin                                   {file in the stack}
  147.    ps:=ps-1;
  148.    if ps>0 then begin
  149.       ln_cnt:=line_stack[ps];
  150.       close(file_in);
  151.       assign(file_in, progs[prog_stack[ps]]+'.prg'); reset(file_in);
  152.       gotoxy(10,20); write('Working on '+progs[prog_stack[ps]]+'        ');
  153.       for y:=1 to ln_cnt do readln(file_in, st);
  154.    end;
  155. end;
  156.  
  157. function ltrim(var stg: stt): stt;           {Remove leading blanks}
  158. begin
  159.    while (stg[1]=' ') and (length(stg)>0) do stg:=copy(stg,2,length(stg));
  160.    ltrim:=stg;
  161. end;
  162.  
  163. function digi_len(ipic: real): integer;
  164. var uv: integer;
  165. begin
  166.    uv:=1;
  167.    while ipic/10>1 do begin
  168.       uv:=uv+1; ipic:=ipic/10;
  169.    end;
  170.    digi_len:=uv;
  171. end;
  172.  
  173. procedure dbf_header;
  174. var df, fg, numb_rec, dd1, dd2, dd3: integer;
  175.     ch, field_length, field_type, dec_length: char;
  176.     field_name: string[10];
  177.     up_date: string[8];
  178.     end_header, end_name: boolean;
  179. procedure get_field;
  180. begin
  181.    fg:=10; end_name:=false;
  182.    if length(field_name)=0 then fg:=11;
  183.    for df:=1 to fg do begin
  184.       read(file_in,ch); if ord(ch)=0 then end_name:=true;
  185.       if not end_name then field_name:=field_name+ch;
  186.    end;
  187. end;
  188.  
  189. procedure f_date;
  190. var kk: string[2];
  191.     ii: integer;
  192. begin
  193.    up_date:=''; str(dd2,kk); up_date:=copy(blanks,1,2-length(kk))+kk+'/';
  194.    str(dd3,kk); up_date:=up_date+copy(blanks,1,2-length(kk))+kk+'/';
  195.    str(dd1,kk); up_date:=up_date+kk;
  196.    for ii:=1 to 8 do if up_date[ii]=' ' then up_date[ii]:='0';
  197. end;
  198.  
  199. begin
  200.    end_header:=false; numb_rec:=0;
  201.    read(file_in,ch);
  202.    read(file_in,ch); dd1:=ord(ch); read(file_in,ch); dd2:=ord(ch); read(file_in,ch); dd3:=ord(ch);
  203.    read(file_in,ch); numb_rec:=ord(ch); read(file_in,ch); numb_rec:=numb_rec+256*ord(ch);
  204.    write(file_out,copy(blanks,1,17-length(dbf[ps])),'# Records= ',numb_rec,copy(blanks,1,10-digi_len(numb_rec)));
  205.    f_date; writeln(file_out,'Last Updated: ',up_date);
  206.    for df:=1 to 26 do read(file_in,ch); field_name:='';
  207.    while not end_header do begin
  208.       get_field; read(file_in,field_type); for df:=1 to 4 do read(file_in,ch);
  209.       read(file_in,field_length); read(file_in,dec_length); read(file_in,ch);
  210.       while (ord(ch)<>13) and ((ord(ch)<32) or (ord(ch)>127)) do read(file_in,ch);
  211.       if ord(ch)=13 then end_header:=true;
  212.       write(file_out,'     ',field_name,copy(blanks,1,12-length(field_name)),field_type,'   ',ord(field_length));
  213.       if field_type='N' then writeln(file_out,'   ',ord(dec_length)) else writeln(file_out);
  214.       field_name:=ch;
  215.    end;
  216. end;
  217.  
  218. procedure ndx_header;
  219. var df: integer;
  220.     ch: char;
  221. begin
  222.    write(file_out,'     ');
  223.    for df:=1 to 25 do read(file_in,ch);
  224.    while ord(ch)<>0 do begin
  225.       write(file_out,ch); read(file_in,ch);
  226.    end;
  227.    writeln(file_out);
  228. end;
  229.  
  230. function get_word(var line: stt): stt;       {Put first, and second, in line}
  231. var word: string[20];                        {words in current sentence into}
  232. begin                                        {This_word and Next_word}
  233.    st:=ltrim(st); word:='';
  234.    while (length(st)>0) and (st[1]<>' ') do begin
  235.       if (st[1]>='a') and (st[1]<='z') then word:=word+upcase(st[1])
  236.       else word:=word+st[1];
  237.       st:=copy(st,2,length(st));
  238.    end;
  239.    get_word:=word;
  240. end;
  241.  
  242. function mac(yy: name): boolean;
  243. var yt: integer;
  244. begin
  245.    mac:=false;
  246.    for yt:=1 to length(yy) do if yy[yt]='&' then mac:=true;
  247. end;
  248.  
  249. procedure parse;                             {Break sentence up into seperate}
  250. begin                                        {words to be operated on}
  251.    st:=ltrim(st);
  252.    if length(this_word)>0 then begin
  253.       this_word:=next_word; next_word:=get_word(st); end
  254.    else begin
  255.       this_word:=get_word(st); next_word:=get_word(st);
  256.    end;
  257.    more_words:=false;
  258.    if (length(st)>0) or (length(this_word)>0) then more_words:=true;
  259. end;
  260.  
  261. procedure first_char;                         {Check to see if sentence is}
  262. begin                                         {a comment or empty}
  263.    skip_line:=false; st:=ltrim(st);
  264.    if (length(st)=0) or (st[1]='*') then skip_line:=true;
  265. end;
  266.  
  267. procedure add_mac;
  268. var s: integer;
  269.     mac_strip: string[15];
  270. begin
  271.    s:=1; while next_word[s]<>'&' do s:=s+1; mac_strip:=copy(next_word,s+1,length(next_word));
  272.    if mp=0 then begin
  273.       mp:=1; macro[1]:=mac_name; mac_var[1]:=mac_strip;
  274.    end;
  275.    s:=1;
  276.    while (s<=mp) and (mac_name<>macro[s]) do s:=s+1;
  277.    if s>mp then begin
  278.       mp:=mp+1; macro[mp]:=mac_name; mac_var[mp]:=mac_strip;
  279.    end;
  280. end;
  281.  
  282. procedure add_dbf;
  283. var j, e: integer;
  284. begin
  285.    if mac(next_word) then begin
  286.       mac_name:='d'+next_word; add_mac;
  287.    end
  288.    else begin
  289.       if dp=0 then begin
  290.          dp:=1; dbf[1]:=next_word; dbf_to_ndx[1]:=1; sele_stack[sx]:=1;
  291.       end
  292.       else begin
  293.          j:=1;
  294.          while j<=dp do begin
  295.             if dbf[j]=next_word then begin
  296.                if a_d then sele_stack[sx]:=dbf_to_ndx[j]; j:=dp+5;
  297.             end
  298.             else if next_word<dbf[j] then begin
  299.                dp:=dp+1; e:=dp;
  300.                while e>j do begin
  301.                   dbf[e]:=dbf[e-1]; dbf_to_ndx[e]:=dbf_to_ndx[e-1]; e:=e-1;
  302.                end;
  303.                dbf[j]:=next_word;
  304.                if a_d then begin dbf_to_ndx[j]:=dp; sele_stack[sx]:=dp; end
  305.                else dbf_to_ndx[j]:=0;
  306.                end
  307.             else j:=j+1;
  308.          end;
  309.          if j<>dp+5 then begin
  310.             dp:=dp+1; dbf[dp]:=next_word; sele_stack[sx]:=dp; dbf_to_ndx[dp]:=dp;
  311.          end;
  312.       end;
  313.    end;
  314. end;
  315.  
  316. procedure add_ndx;
  317. var j: integer;
  318.     e: integer;
  319.     v: char;
  320. begin
  321.    while ((this_word<>'TO') and (copy(this_word,1,4)<>'INDE')) and more_words do parse;
  322.    if (this_word='TO') or (copy(this_word,1,4)='INDE') then while length(next_word)>0 do begin
  323.       v:=copy(next_word,length(next_word),1);
  324.       if v=',' then next_word:=copy(next_word,1,length(next_word)-1);
  325.       if mac(next_word) then begin
  326.          mac_name:='x'+next_word; add_mac;
  327.       end
  328.       else begin
  329.          if np=0 then begin
  330.             np:=1; ndx[1]:=next_word; ndx_stack[1]:=sele_stack[sx];
  331.          end
  332.          else begin
  333.             j:=1;
  334.             while j<=np do begin
  335.                if (ndx[j]=next_word) and (sele_stack[sx]=ndx_stack[j]) then j:=np+5
  336.                else if ndx[j]>next_word then begin
  337.                   np:=np+1; e:=np; while e>j do begin
  338.                      ndx[e]:=ndx[e-1]; ndx_stack[e]:=ndx_stack[e-1]; e:=e-1;
  339.                   end;
  340.                   ndx[j]:=next_word; ndx_stack[j]:=sele_stack[sx]; j:=np+5;
  341.                end
  342.                else j:=j+1;
  343.             end;
  344.             if j<>np+5 then begin
  345.                np:=np+1; ndx[np]:=next_word; ndx_stack[np]:=sele_stack[sx];
  346.             end;
  347.          end;
  348.       end;
  349.       parse;
  350.    end;
  351. end;
  352.  
  353. procedure check_macro;
  354. var i, j: integer;
  355.     chr: char;
  356.     w2: string[255];
  357.     w1: string[15];
  358. begin
  359.    w2:='';
  360.    if next_word='=' then begin
  361.       st:=ltrim(st);
  362.       if (st[1]='"') or (ord(st[1])=39) then begin
  363.          chr:=st[1]; st:=copy(st,2,length(st)); j:=1;
  364.          while (st[j]<>chr) and (j<=length(st)) do j:=j+1;
  365.          w2:=copy(st,1,j-1); i:=1;
  366.          while i<=mp do begin
  367.             w1:=copy(macro[i],2,length(macro[i]));
  368.             if this_word=mac_var[i] then begin
  369.                j:=1;
  370.                while (w1[j]<>'&') and (j<=length(w1)) do j:=j+1;
  371.                next_word:=copy(w1,1,j-1)+w2;
  372.                if copy(macro[i],1,1)='d' then add_dbf
  373.                else begin
  374.                   this_word:='TO'; st:=''; add_ndx;
  375.                end;
  376.             end;
  377.             i:=i+1;
  378.          end;
  379.       end;
  380.    end;
  381. end;
  382.  
  383. procedure what_cmd;                           {Identify the current dBASE}
  384. var o: integer;                               {command and perform the}
  385.     tw, nw: string[4];                        {appropriate function}
  386. begin
  387.    tw:=this_word; nw:=next_word; a_d:=true;
  388.    if pass_one and (all_files='A') then if (tw='DO') then if (nw<>'CASE') and (nw<>'WHIL') then push_stack;
  389.    if pass_one then begin
  390.       if (tw='USE') and (length(nw)>0) then begin
  391.          add_dbf; add_ndx;
  392.       end;
  393.       if (tw='APPE') and (nw='FROM') then begin
  394.          a_d:=false; parse; add_dbf;
  395.       end;
  396.       if ((tw='SET') and (nw='INDE')) or (tw='INDE') then begin
  397.       while (this_word<>'TO') and (more_words) do parse; add_ndx;
  398.       end;
  399.       if (tw='SELE') then begin
  400.          sx:=0; if (length(nw)=1) then sx:=ord(nw)-64;
  401.          if (sx<1) or (sx>10) then sx:=1;
  402.       end;
  403.    end
  404.    else if (tw='STOR') or (nw='=') then check_macro;
  405.    more_words:=false;
  406. end;
  407.  
  408. procedure get_line;                         {Get new sentence and prepare}
  409. var bb: integer;                            {for parsing}
  410.     cc: string[3];
  411.     nn: string[255];
  412.     dq: boolean;
  413. begin
  414.    nn:=''; cc:=''; this_word:=''; next_word:=''; more_words:=true;
  415.    readln(file_in,st); dq:=false;
  416.    for bb:=1 to length(st) do begin
  417.       cc:=st[bb];
  418.       if (cc='"') or (ord(cc)=39) then dq:=true;
  419.       if (cc=',') or ((ord(cc)<31) or (ord(cc)>127)) then cc:=' ';
  420.       if (cc='=') and (not dq) then cc:=' '+cc+' ';
  421.       nn:=nn+cc;
  422.    end;
  423.    st:=nn;
  424.    ln_cnt:=ln_cnt+1; first_char;
  425.    if not skip_line then while more_words begin
  426.       parse; what_cmd;
  427.    end;
  428. end;
  429.  
  430. begin                                   {Main Body of the Program}
  431.    get_started; init; pass_one:=true;
  432.                 {If abo=Y then the program is to be aborted for some reason}
  433.    if abo<>'Y' then begin
  434.       writeln(file_out,'         dBASE III Program Datafile Structure Report       for directory '+path);
  435.       write(file_out,'Starting with: '+in_file+'.PRG'+copy(blanks,1,8-length(in_file)));
  436.       writeln(file_out,'                                run at ',time,' on ',date);
  437.       writeln(file_out);
  438.       outstring:='  ';
  439.       while ps>0 do begin
  440.          while not eof(file_in) do get_line;
  441.          pop_stack;
  442.       end;
  443.  
  444.       pass_one:=false;
  445.       for ps:=1 to sp do begin
  446.          gotoxy(10,20); write('Searching ',progs[ps],'       ');
  447.          close(file_in); assign(file_in,progs[ps]+'.prg'); reset(file_in);
  448.          while not eof(file_in) do get_line;
  449.       end;
  450.       for ps:=1 to dp do begin
  451.          write(file_out,dbf[ps]);
  452.          if exist(dbf[ps]+'.dbf') then begin
  453.             close(file_in); assign(file_in,dbf[ps]+'.dbf'); reset(file_in);
  454.             dbf_header;
  455.          end;
  456.          writeln(file_out);writeln(file_out,'*** Index Files ***');
  457.          for sx:=1 to np do if dbf_to_ndx[ps]=ndx_stack[sx] then begin
  458.             write(file_out,ndx[sx]+copy(blanks,1,8-length(ndx[sx])));
  459.             if exist(ndx[sx]+'.ndx') then begin
  460.                close(file_in); assign(file_in,ndx[sx]+'.ndx'); reset(file_in);
  461.                ndx_header;
  462.             end;
  463.          end;
  464.          writeln(file_out); writeln(file_out,'=============================================================');
  465.          writeln(file_out);
  466.       end;
  467.    end;
  468. close(file_in); close(file_out);
  469. end.
  470.