home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
xbase
/
library
/
dbase
/
debug
/
analyze
/
db_brute.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1987-02-18
|
10KB
|
277 lines
{Brute force method for getting .DBF and .NDX file header data from all of
the files in a particular directory.
GETIT.PAS
}
type datetype= string[8];
regtype = record
ax,bx,cx,dx,bp,si,di,ds,es,flags: integer
end;
strtn = string[255];
userspec = string[64];
filename = string[13];
dtapointer=^dtarecord;
dtarecord = record
dosreserved : array[1..21] of byte;
attribute : byte;
filetime, filedate, sizelow, sizehigh: integer;
foundname : array[1..13] of char;
end;
var ch, ch1 : char;
st : string[255];
name, pst : string[12];
rtd : string[66];
up_date : string[8];
i, l, atop, btop, count, cnt_line : integer;
a, b : array[1..400] of string[12];
c : array[1..400] of integer;
file_in : file of char;
file_out : text;
transferrec : dtapointer;
matchptrn : userspec;
retname : filename;
filsize : real;
nofind, lastfile, subdirec: boolean;
const blanks = ' '; nul = ^@; seekattrib = $10;
function time: datetype;
var reg: regtype; h,m,s,w: datetype; i: integer;
begin
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;
for i:=1 to length(w) do if w[i]=' ' then w[i]:='0'; time:=w;
end;
function date: datetype;
var reg: regtype; y,m,d,w: datetype; i: integer;
begin
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;
for i:=1 to length(w) do if w[i]=' ' then w[i]:='0'; date:=w;
end;
procedure pointdta(var dtarec: dtapointer);
const getdta = $2F00;
var regs : regtype;
begin
regs.ax:=getdta; msdos(regs); dtarec:=Ptr(regs.es,regs.bx);
end;
function sizeoffile(hiword, loword: integer): real;
var bigno, size: real;
begin
bigno:=(maxint*2.0)+2;
if hiword<0 then size:=(bigno+hiword)*bigno else size:=hiword*bigno;
if loword>=0 then size:=size+loword else size:=size+(bigno+loword);
sizeoffile:=size;
end;
procedure findfirst(pattern : userspec;
var found : filename;
var size : real;
var nomatch: boolean;
var lastone: boolean;
var subdir : boolean);
const findfirst = $4E00;
type asciiz = array[1..64] of char;
var
filespec : asciiz;
regs : regtype;
posinstr, count: integer;
foundlen : byte absolute found;
begin
for posinstr:=1 to length(pattern) do filespec[posinstr]:=pattern[posinstr];
filespec[length(pattern)+1]:=nul;
with regs do begin
ds:=seg(filespec); dx:=ofs(filespec); cx:=seekattrib; ax:=findfirst;
msdos(regs);
if (flags and 1)>0 then begin
case ax of
2 : begin nomatch:=true; lastone:=true; end;
18: begin nomatch:=false; lastone:=true; end;
else begin
writeln(^G'Can''t interpret error return code'); halt;
end;
end;
end
else begin nomatch:=false; lastone:=false; end;
end;
if not nomatch then with transferrec^ do begin
found:=foundname; count:=0; while found[count]<>nul do count:=count+1;
foundlen:=count; for count:=length(found)+1 to 13 do found:=found+' ';
if (attribute and seekattrib)>0 then subdir:=true else subdir:=false;
if not subdir then size:=sizeoffile(sizehigh, sizelow) else size:=0.0;
end;
end;
procedure findnext(var found : filename;
var size : real;
var lastone: boolean;
var subdir : boolean);
const findnext = $4F00;
var regs : regtype;
count : integer;
foundlen: byte absolute found;
begin
with regs do begin
ax:=findnext; msdos(regs);
if (flags and 1)>0 then if ax=18 then lastone:=true else begin
writeln(^G'Can''t interpret error return code'); halt;
end
else lastone:=false;
end;
with transferrec^ do begin
found:=foundname; count:=0; while found[count]<>nul do count:=count+1;
foundlen:=count; for count:=length(found)+1 to 13 do found:=found+' ';
if (attribute and seekattrib)>0 then subdir:=true else subdir:=false;
if not subdir then size:=sizeoffile(sizehigh,sizelow) else size:=0.0;
end;
end;
function digi_len(ipic: real): integer;
var uv: integer;
begin
uv:=1; while ipic/10>1 do begin uv:=uv+1; ipic:=ipic/10; end; digi_len:=uv;
end;
procedure dbf_header;
var df, fg, numb_rec, dd1, dd2, dd3: integer;
ch, field_length, field_type, dec_length: char;
field_name: string[10];
end_header, end_name: boolean;
procedure get_field;
begin
fg:=10; end_name:=false;
if length(field_name)=0 then fg:=11;
for df:=1 to fg do begin
read(file_in,ch); if ord(ch)=0 then end_name:=true;
if not end_name then field_name:=field_name+ch;
end;
end;
procedure f_date;
var kk: string[2];
ii: integer;
begin
up_date:=''; str(dd2,kk); up_date:=copy(blanks,1,2-length(kk))+kk+'/';
str(dd3,kk); up_date:=up_date+copy(blanks,1,2-length(kk))+kk+'/';
str(dd1,kk); up_date:=up_date+kk;
for ii:=1 to 8 do if up_date[ii]=' ' then up_date[ii]:='0';
end;
begin
end_header:=false; numb_rec:=0;
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);
read(file_in,ch); numb_rec:=ord(ch); read(file_in,ch); numb_rec:=numb_rec+256*ord(ch);
write(file_out,copy(blanks,1,17-length(a[i])),'# Records= ',numb_rec,copy(blanks,1,10-digi_len(numb_rec)));
f_date; writeln(file_out,'Last Updated: ',up_date);
seek(file_in,32); field_name:='';
while not end_header do begin
get_field; read(file_in,field_type); for df:=1 to 4 do read(file_in,ch);
read(file_in,field_length); read(file_in,dec_length); read(file_in,ch);
while (ord(ch)<>13) and ((ord(ch)<32) or (ord(ch)>127)) do read(file_in,ch);
if ord(ch)=13 then end_header:=true;
write(file_out,' ',field_name,copy(blanks,1,12-length(field_name)),field_type,' ',ord(field_length));
if field_type='N' then writeln(file_out,' ',ord(dec_length)) else writeln(file_out);
field_name:=ch;
end;
end;
procedure ndx_header;
var df: integer;
ch: char;
begin
assign(file_in,name); reset(file_in); ch:='@';
writeln(file_out); write(file_out,name,': '); seek(file_in,24);
while ch<>#0 do begin read(file_in,ch); if ch<>#0 then write(file_out,ch); end;
writeln(file_out); close(file_in);
end;
procedure stackit_dbf;
var j, m: integer;
b: boolean;
begin
j:=1; b:=true;
while (j<=atop) and b do begin
if name<a[j] then j:=j+1
else begin
atop:=atop+1; m:=atop; b:=false;
while m>j do begin
a[m]:=a[m-1]; m:=m-1;
end;
a[m]:=name;
end;
end;
if b then begin
atop:=atop+1; a[atop]:=name;
end;
end;
procedure stackit_ndx;
var j, m: integer;
g: boolean;
function dbf_number: integer;
var dtc, vv: integer;
stc: string[12];
bc : boolean;
begin
assign(file_in,name); reset(file_in); seek(file_in,496); stc:='';
for dtc:=1 to 13 do begin read(file_in,ch); stc:=stc+upcase(ch); end;
dtc:=1; bc:=true; while bc and (dtc<=atop) do if stc=a[dtc] then bc:=false else dtc:=dtc+1;
if bc then dbf_number:=0 else dbf_number:=dtc;
close(file_in);
end;
begin
j:=1; g:=true;
while (j<=btop) and g do begin
if name<b[j] then j:=j+1
else begin
btop:=btop+1; m:=btop; g:=false;
while m>j do begin
b[m]:=b[m-1]; c[m]:=c[m-1]; m:=m-1;
end;
b[m]:=name; c[m]:=dbf_number;
end;
end;
if g then begin
btop:=btop+1; b[btop]:=name; c[btop]:=dbf_number;
end;
end;
function rtrim(stg: strtn): strtn;
begin
while (upcase(copy(stg,length(stg),1))<'A') or (upcase(copy(stg,length(stg),1))>'Z') do stg:=copy(stg,1,length(stg)-1);
rtrim:=stg;
end;
procedure getname;
begin
findfirst(matchptrn,retname,filsize,nofind,lastfile,subdirec);
if nofind or lastfile then writeln('File not found.') else begin
while not lastfile do begin
name:=retname; if matchptrn[3]='d' then stackit_dbf else stackit_ndx;
findnext(retname,filsize,lastfile,subdirec);
end;
end;
end;
begin
writeln('Working.');
atop:=0; btop:=0; for i:=1 to 400 do begin a[i]:=''; b[i]:=''; end; getdir(0,rtd);
pst:=paramstr(1); if paramcount=0 then pst:='prn'; assign(file_out,pst); rewrite(file_out);
pointdta(transferrec);
matchptrn:='*.dbf'; getname; matchptrn:='*.ndx'; getname;
writeln(file_out,'All dBASE .DBF structures and .NDX keys for '+rtd);
writeln(file_out,' run at ',time,' on ',date);
for i:=atop downto 1 do begin
writeln(file_out);
if pst='prn' then write(file_out,chr(27)+'G'+a[i]+chr(27)+'H') else write(file_out,a[i]);
assign(file_in,a[i]); reset(file_in); dbf_header; close(file_in);
writeln(file_out); writeln(file_out,'*** Index Files ***');
for l:=btop downto 1 do if c[l]=i then begin name:=b[l]; ndx_header; end;
writeln(file_out); writeln(file_out,'==========================================================================');
end;
writeln(file_out); writeln(file_out,'****** Untagged Index Files *****');
for l:=btop downto 1 do if c[l]=0 then begin name:=b[l]; ndx_header; end;
close(file_out);
end.