home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload / ShartewareOverload.cdr / database / db_dbug2.zip / DB_BRUTE.PAS < prev    next >
Pascal/Delphi Source File  |  1987-02-18  |  10KB  |  277 lines
  1. {Brute force method for getting .DBF and .NDX file header data from all of
  2.  the files in a particular directory.
  3.  GETIT.PAS
  4.  }
  5.  
  6. type datetype= string[8];
  7.      regtype = record
  8.                  ax,bx,cx,dx,bp,si,di,ds,es,flags: integer
  9.                end;
  10.    strtn     = string[255];
  11.    userspec  = string[64];
  12.    filename  = string[13];
  13.    dtapointer=^dtarecord;
  14.    dtarecord = record
  15.                  dosreserved                          : array[1..21] of byte;
  16.                  attribute                            : byte;
  17.                  filetime, filedate, sizelow, sizehigh: integer;
  18.                  foundname                            : array[1..13] of char;
  19.                end;
  20.  
  21. var ch, ch1                   : char;
  22.     st                        : string[255];
  23.     name, pst                 : string[12];
  24.     rtd                       : string[66];
  25.     up_date                   : string[8];
  26.     i, l, atop, btop, count, cnt_line  : integer;
  27.     a, b                      : array[1..400] of string[12];
  28.     c                         : array[1..400] of integer;
  29.     file_in                   : file of char;
  30.     file_out                  : text;
  31.     transferrec               : dtapointer;
  32.     matchptrn                 : userspec;
  33.     retname                   : filename;
  34.     filsize                   : real;
  35.     nofind, lastfile, subdirec: boolean;
  36.  
  37. const blanks = '                      ';   nul = ^@;     seekattrib = $10;
  38.  
  39. function time: datetype;
  40. var reg: regtype; h,m,s,w: datetype; i: integer;
  41. begin
  42.    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;
  43.    for i:=1 to length(w) do if w[i]=' ' then w[i]:='0'; time:=w;
  44. end;
  45.  
  46. function date: datetype;
  47. var reg: regtype; y,m,d,w: datetype; i: integer;
  48. begin
  49.    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;
  50.    for i:=1 to length(w) do if w[i]=' ' then w[i]:='0'; date:=w;
  51. end;
  52.  
  53. procedure pointdta(var dtarec: dtapointer);
  54. const getdta = $2F00;
  55. var   regs   : regtype;
  56. begin
  57.    regs.ax:=getdta; msdos(regs); dtarec:=Ptr(regs.es,regs.bx);
  58. end;
  59.  
  60. function sizeoffile(hiword, loword: integer): real;
  61. var bigno, size: real;
  62. begin
  63.    bigno:=(maxint*2.0)+2;
  64.    if hiword<0 then size:=(bigno+hiword)*bigno else size:=hiword*bigno;
  65.    if loword>=0  then size:=size+loword else size:=size+(bigno+loword);
  66.    sizeoffile:=size;
  67. end;
  68.  
  69. procedure findfirst(pattern    : userspec;
  70.                     var found  : filename;
  71.                     var size   : real;
  72.                     var nomatch: boolean;
  73.                     var lastone: boolean;
  74.                     var subdir : boolean);
  75. const findfirst = $4E00;
  76. type asciiz = array[1..64] of char;
  77. var
  78.    filespec       : asciiz;
  79.    regs           : regtype;
  80.    posinstr, count: integer;
  81.    foundlen       : byte absolute found;
  82.  
  83. begin
  84.    for posinstr:=1 to length(pattern) do filespec[posinstr]:=pattern[posinstr];
  85.    filespec[length(pattern)+1]:=nul;
  86.    with regs do begin
  87.       ds:=seg(filespec); dx:=ofs(filespec); cx:=seekattrib; ax:=findfirst;
  88.       msdos(regs);
  89.       if (flags and 1)>0 then begin
  90.          case ax of
  91.             2 : begin nomatch:=true;  lastone:=true; end;
  92.             18: begin nomatch:=false; lastone:=true; end;
  93.             else begin
  94.                writeln(^G'Can''t interpret error return code'); halt;
  95.             end;
  96.          end;
  97.       end
  98.       else begin nomatch:=false; lastone:=false; end;
  99.    end;
  100.    if not nomatch then with transferrec^ do begin
  101.       found:=foundname; count:=0; while found[count]<>nul do count:=count+1;
  102.       foundlen:=count; for count:=length(found)+1 to 13 do found:=found+' ';
  103.       if (attribute and seekattrib)>0 then subdir:=true else subdir:=false;
  104.       if not subdir then size:=sizeoffile(sizehigh, sizelow) else size:=0.0;
  105.    end;
  106. end;
  107.  
  108. procedure findnext(var found  : filename;
  109.                    var size   : real;
  110.                    var lastone: boolean;
  111.                    var subdir : boolean);
  112. const findnext = $4F00;
  113. var   regs    : regtype;
  114.       count   : integer;
  115.       foundlen: byte absolute found;
  116. begin
  117.    with regs do begin
  118.       ax:=findnext; msdos(regs);
  119.       if (flags and 1)>0 then if ax=18 then lastone:=true else begin
  120.          writeln(^G'Can''t interpret error return code'); halt;
  121.       end
  122.       else lastone:=false;
  123.    end;
  124.    with transferrec^ do begin
  125.       found:=foundname; count:=0; while found[count]<>nul do count:=count+1;
  126.       foundlen:=count; for count:=length(found)+1 to 13 do found:=found+' ';
  127.       if (attribute and seekattrib)>0 then subdir:=true else subdir:=false;
  128.       if not subdir then size:=sizeoffile(sizehigh,sizelow) else size:=0.0;
  129.    end;
  130. end;
  131.  
  132. function digi_len(ipic: real): integer;
  133. var uv: integer;
  134. begin
  135.    uv:=1; while ipic/10>1 do begin uv:=uv+1; ipic:=ipic/10; end; digi_len:=uv;
  136. end;
  137.  
  138. procedure dbf_header;
  139. var df, fg, numb_rec, dd1, dd2, dd3: integer;
  140.     ch, field_length, field_type, dec_length: char;
  141.     field_name: string[10];
  142.     end_header, end_name: boolean;
  143. procedure get_field;
  144. begin
  145.    fg:=10; end_name:=false;
  146.    if length(field_name)=0 then fg:=11;
  147.    for df:=1 to fg do begin
  148.       read(file_in,ch); if ord(ch)=0 then end_name:=true;
  149.       if not end_name then field_name:=field_name+ch;
  150.    end;
  151. end;
  152. procedure f_date;
  153. var kk: string[2];
  154.     ii: integer;
  155. begin
  156.    up_date:=''; str(dd2,kk); up_date:=copy(blanks,1,2-length(kk))+kk+'/';
  157.    str(dd3,kk); up_date:=up_date+copy(blanks,1,2-length(kk))+kk+'/';
  158.    str(dd1,kk); up_date:=up_date+kk;
  159.    for ii:=1 to 8 do if up_date[ii]=' ' then up_date[ii]:='0';
  160. end;
  161. begin
  162.    end_header:=false; numb_rec:=0;
  163.    seek(file_in,1); read(file_in,ch); dd1:=ord(ch); read(file_in,ch); dd2:=ord(ch); read(file_in,ch); dd3:=ord(ch);
  164.    read(file_in,ch); numb_rec:=ord(ch); read(file_in,ch); numb_rec:=numb_rec+256*ord(ch);
  165.    write(file_out,copy(blanks,1,17-length(a[i])),'# Records= ',numb_rec,copy(blanks,1,10-digi_len(numb_rec)));
  166.    f_date; writeln(file_out,'Last Updated: ',up_date);
  167.    seek(file_in,32); field_name:='';
  168.    while not end_header do begin
  169.       get_field; read(file_in,field_type); for df:=1 to 4 do read(file_in,ch);
  170.       read(file_in,field_length); read(file_in,dec_length); read(file_in,ch);
  171.       while (ord(ch)<>13) and ((ord(ch)<32) or (ord(ch)>127)) do read(file_in,ch);
  172.       if ord(ch)=13 then end_header:=true;
  173.       write(file_out,'     ',field_name,copy(blanks,1,12-length(field_name)),field_type,'   ',ord(field_length));
  174.       if field_type='N' then writeln(file_out,'   ',ord(dec_length)) else writeln(file_out);
  175.       field_name:=ch;
  176.    end;
  177. end;
  178.  
  179. procedure ndx_header;
  180. var df: integer;
  181.     ch: char;
  182. begin
  183.    assign(file_in,name); reset(file_in); ch:='@';
  184.    writeln(file_out); write(file_out,name,':     '); seek(file_in,24);
  185.    while ch<>#0 do begin read(file_in,ch); if ch<>#0 then write(file_out,ch); end;
  186.    writeln(file_out); close(file_in);
  187. end;
  188.  
  189. procedure stackit_dbf;
  190. var j, m: integer;
  191.     b: boolean;
  192. begin
  193.    j:=1; b:=true;
  194.    while (j<=atop) and b do begin
  195.       if name<a[j] then j:=j+1
  196.       else begin
  197.          atop:=atop+1; m:=atop; b:=false;
  198.          while m>j do begin
  199.             a[m]:=a[m-1]; m:=m-1;
  200.          end;
  201.          a[m]:=name;
  202.       end;
  203.    end;
  204.    if b then begin
  205.       atop:=atop+1; a[atop]:=name;
  206.    end;
  207. end;
  208.  
  209. procedure stackit_ndx;
  210. var j, m: integer;
  211.     g: boolean;
  212. function dbf_number: integer;
  213. var dtc, vv: integer;
  214.     stc: string[12];
  215.     bc : boolean;
  216. begin
  217.    assign(file_in,name); reset(file_in); seek(file_in,496); stc:='';
  218.    for dtc:=1 to 13 do begin read(file_in,ch); stc:=stc+upcase(ch); end;
  219.    dtc:=1; bc:=true; while bc and (dtc<=atop) do if stc=a[dtc] then bc:=false else dtc:=dtc+1;
  220.    if bc then dbf_number:=0 else dbf_number:=dtc;
  221.    close(file_in);
  222. end;
  223. begin
  224.    j:=1; g:=true;
  225.    while (j<=btop) and g do begin
  226.       if name<b[j] then j:=j+1
  227.       else begin
  228.          btop:=btop+1; m:=btop; g:=false;
  229.          while m>j do begin
  230.             b[m]:=b[m-1]; c[m]:=c[m-1]; m:=m-1;
  231.          end;
  232.          b[m]:=name; c[m]:=dbf_number;
  233.       end;
  234.    end;
  235.    if g then begin
  236.       btop:=btop+1; b[btop]:=name; c[btop]:=dbf_number;
  237.    end;
  238. end;
  239.  
  240. function rtrim(stg: strtn): strtn;
  241. begin
  242.    while (upcase(copy(stg,length(stg),1))<'A') or (upcase(copy(stg,length(stg),1))>'Z') do stg:=copy(stg,1,length(stg)-1);
  243.    rtrim:=stg;
  244. end;
  245.  
  246. procedure getname;
  247. begin
  248.    findfirst(matchptrn,retname,filsize,nofind,lastfile,subdirec);
  249.    if nofind or lastfile then writeln('File not found.') else begin
  250.       while not lastfile do begin
  251.          name:=retname; if matchptrn[3]='d' then stackit_dbf else stackit_ndx;
  252.          findnext(retname,filsize,lastfile,subdirec);
  253.       end;
  254.    end;
  255. end;
  256.  
  257. begin
  258.    writeln('Working.');
  259.    atop:=0; btop:=0; for i:=1 to 400 do begin a[i]:=''; b[i]:=''; end; getdir(0,rtd);
  260.    pst:=paramstr(1); if paramcount=0 then pst:='prn'; assign(file_out,pst); rewrite(file_out);
  261.    pointdta(transferrec);
  262.    matchptrn:='*.dbf'; getname; matchptrn:='*.ndx'; getname;
  263.    writeln(file_out,'All dBASE .DBF structures and .NDX keys for '+rtd);
  264.    writeln(file_out,'                          run at ',time,' on ',date);
  265.    for i:=atop downto 1 do begin
  266.       writeln(file_out);
  267.       if pst='prn' then write(file_out,chr(27)+'G'+a[i]+chr(27)+'H') else write(file_out,a[i]);
  268.       assign(file_in,a[i]); reset(file_in); dbf_header; close(file_in);
  269.       writeln(file_out); writeln(file_out,'*** Index Files ***');
  270.       for l:=btop downto 1 do if c[l]=i then begin name:=b[l]; ndx_header; end;
  271.       writeln(file_out); writeln(file_out,'==========================================================================');
  272.    end;
  273.    writeln(file_out); writeln(file_out,'****** Untagged Index Files *****');
  274.    for l:=btop downto 1 do if c[l]=0 then begin name:=b[l]; ndx_header; end;
  275.    close(file_out);
  276. end.
  277.