Eran Sandler wrote in <news:comp.lang.pascal.borland>:
> Does someone have a unit that handles DBASE
files with Turbo Pascal 7.
I wrote an x-base-engine for fast and easy dbf-access.
It's called DBFSERV and has a totaly new approach!
First you call CREATEUNIT(DBFPATH,DBFNAME),
then a unit DBFNAME is being created and
now you can access all fields by their name.
Example:
{$DEFINE FIRST}
Uses DBFSERV {$IFNDEF FIRST} ,FAKT {$ENDIF} ;
Var Sum: Number;
Begin {$IFDEF FIRST} CreateUnit('d:\','FAKT'); {$ENDIF}
Sum := 0;
For RECPTR := 1 To RECNO Do
Sum := Sum + FIELD;
WriteLn(Sum:10:2);
End.
It's fast! It processes e.g. a 85 MB dbf-file in 40 s (on P160).
Please send some tips, comments or suggestions on that?
I don't want to bother you with the source and documentation
via usenet, so please take a look at it (http-download):
[DBFSERV complete]
http://home.t-online.de/home/Antivivisektion/dbfserv.zip
(7024 byte)
(TP-links local mirror: ! avs_dbfserv.zip 7kB no maint!)
or:
[DBFSERV pascal source code]
http://home.t-online.de/home/Antivivisektion/dbfserv.pas
(9956 byte) html
[DBFSERV documentation]
http://home.t-online.de/home/Antivivisektion/dbfserv.doc
(6454 byte) html
[pascal source code of sample application]
http://home.t-online.de/home/Antivivisektion/testserv.pas
(639 byte) html
[sample DBF-file]
http://home.t-online.de/home/Antivivisektion/testdata.dbf
(272 byte)
[pascal source code, created by DBFSERV from sample DBF-file]
http://home.t-online.de/home/Antivivisektion/testdata.pas
(1079 byte) html
--
A.E.Neumann für die Antivivisektion e.V., PO-Box 201, D-53569
Unkel
mailto:Antivivisektion@t-online.de
http://Antivivisektion.base.org/
{ððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððð}
{ððð DBFSERV ððð Version:
1.0á (10.IV.1998) ðððððððððððððððððððððððððððððððð}
{ðð Copyrigth (c) 1998 by Antivivisektion@t-online.de
ðððððððððððððððððððððð}
{ððð comes with NO WARRANTY - please
read the disclaimer in DBFSERV.DOC ðððð}
{ððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððð}
{$A+,B-,D+,E-,F-,G+,I+,L+,N+,O-,P+,Q+,R+,S+,T+,V+,X+,Y+}
{$I-,S-,R-,Q-}
Unit DBFSERV;
Interface
{ Ú----- Some runtime-settings and one TYPE
------------------------------- }
{ | }
{ | } Const
{ | } CacheHits: LongInt = 0; { little
statistics }
{ | } CacheMiss: LongInt = 0; { ... }
{ | } AutoTrim: Boolean = TRUE; { perform
an RTRIM on all string-fields }
{ | } BatchMode: Boolean = FALSE; { TRUE
= no Halt after CreateUnit }
{ | } Type
{ | } Number = Single; { our type for
"N"umber-fields }
{ | }
{ Ú----- One-Time user-interface to create
the dbf-Units ------------------ }
{ | }
{ | } Procedure CreateUnit(dbfpath,dbfname: String);
{ | } Procedure Help;
{ | }
{ Ú----- This interface is used by all the
created dbf-Units. ------------- }
{ | *** DON'T CALL
THESE FUNCTIONS DIRECTLY! ***
}
{ | }
{ | } Procedure dbf_Open(Var f: File);
{ | } Procedure dbf_Close(Var f: File);
{ | } Function dbf_RECNO(Var f: File): LongInt;
{ | } Procedure dbf_Get(Var f: File; t: Char; r:
LongInt; o,l,d: Word);
{ | }
{ | } Const UpLink: Pointer = @dbf_Get;
{ | } Type
{ | } CacheArray = Array[Byte] Of Char;
{ | } FileRec = record
{ | } Handle,Mode,RecSize:
Word;
{ | } Private: array[1..26]
of Byte;
{ | } HS,RS: Word;
{ | } OldExit: Pointer;
{ | } Cache: ^CacheArray;
{ | } InCache: LongInt;
{ | } Name: array[0..79]
of Char;
{ | } End;
{ | }
Implementation
Uses DOS; { Import TEXTREC }
{ Ú----- Creates a special unit for the specified
dbf-file ---------------- }
{ | }
{ | } Procedure CreateUnit(dbfpath,dbfname:
String);
{ | }
{ some internal datastructs }
Var
Fields: Record Name: Array [1..11] of Char;
Typ: Char; x: LongInt;
Len: Byte; Dec: Byte; Res: Array [18..31]
of Char; End;
f: File; i,j,Off: Word; o: TEXT;
Function Upper(s: String): String;
var i: Word;
Begin
for i := 1 To Length(s) Do s[i]
:= UpCase(s[i]);
Upper := s;
End;
Procedure Abort(What: String);
Var IO: Byte;
Begin
IO := IOResult;
WriteLn('Runtime-Error ',IO,'
on ¯',What,'®');
Case IO Of
2: Writeln('file not
found');
3: Writeln('path not
found');
4: Writeln('too many
open files (no handles available)');
5: Writeln('access
denied');
End;
Halt;
End;
Begin
Help;
If (InOutRes <> 0) Then Abort('Entry CREATEUNIT');
If (dbfpath[length(dbfpath)] <> '\')
Then
Begin
Inc(dbfpath[0]);
dbfpath[length(dbfpath)] := '\';
End;
Assign(f,dbfpath+dbfname+'.dbf');
dbf_Open(f);
IF (InOutRes <> 0) Then Abort('Open '+dbfpath+dbfname+'.dbf
for read');
{ DEL (generic field) = 1. Field, Typ: L, offset:
0, Size: 1 Byte }
With Fields Do
Begin
Name[1] := 'D'; Name[2] := 'E';
Name[3] := 'L'; Name[4] := #0;
Typ := 'L'; Off := 0; Len := 1;
Dec := 0;
End;
Assign(o,dbfname+'.pas');
Rewrite(o);
IF (InOutRes <> 0)
Then Abort('Open '+dbfname+'.pas
for writing');
WriteLn(o,'{$A+,B-,D+,E-,F-,G+,I+,L+,N+,O-,P+,Q+,R+,S+,T+,V+,X+,Y+}');
WriteLn(o,'{$I+,S-,R-,Q-}');
WriteLn(o,'Unit ',Upper(dbfName),';');
WriteLn(o,'Interface');
WriteLn(o,'Uses DBFSERV;');
WriteLn(o);
WriteLn(o,'Const dbfName: String[63] = ''',dbfpath+dbfname,'.dbf'';');
WriteLn(o,' RECPTR: LongInt = 1;');
WriteLn(o,'Var F: FILE;');
WriteLn(o);
WriteLn(o,'Procedure Open;');
WriteLn(o,'Procedure Close;');
WriteLn(o,'Function RECNO: LongInt;');
WriteLn(o);
Off := 0;
For i := 0 To (FileRec(f).HS-33) Div 32 Do
With Fields Do
Begin
If (i <> 0)
Then
Begin
If (i = 1) Then Seek(f,32);
BlockRead(f,Fields,SizeOf(Fields));
IF (InOutRes <> 0) Then Abort('Read '+dbfpath+dbfname+'.dbf');
End;
j := Pos(#0,Name)-1;
Write(o,'Function ',Copy(Name,1,j),':
');
Case Typ Of
'L': Write(o,'Boolean');
'C': Write(o,'String');
'N': Write(o,'Number');
'D': Write(o,'String');
Else Begin Write('Unknown
typ: ',Typ,', Name: ',Name); RunError(201); End;
End;
{ Function dbf_Get(Var f: File; t: Char; r: LongInt;
o,l,d: Word): ?; }
Write(o,'; { ',TYP,' L',LEN,'
D',DEC,' @',OFF,' } Inline(');
{$IFOPT G+} { uses PUSH IMM8 and PUSH IMM16 }
Write(o,'$1E/');
If (Ofs(f) > $7F) Then Write(o,'$68/>f/')
Else Write(o,'$6A/<f/');
If (Byte(Typ) > $7F) Then Write(o,'$68/>',Ord(Typ),'/')
Else Write(o,'$6A/<',Ord(Typ),'/');
Write(o,#13#10'$FF/$36/>RECPTR+2/$FF/$36/>RECPTR');
If (Off > $7F) Then Write(o,'/$68/>',Off)
Else Write(o,'/$6A/<',Off);
If (LEN > $7F) Then Write(o,'/$68/>',LEN)
Else Write(o,'/$6A/<',LEN);
If (DEC > $7F) Then Write(o,'/$68/>',DEC)
Else Write(o,'/$6A/<',DEC);
{$ELSE}
WriteLn(o,'$1E/$B8/>f/$50/ $B0/<',Ord(Typ),'/$50
/$FF/$36/');
Write(o,'>RECPTR+2/$FF/$36/>RECPTR/
$B8/>',Off,'/$50/');
Write(o,'$B8/>',Len,'/$50/ $B8/>',DEC,'/$50');
{$ENDIF}
WriteLn(o,'/$FF/$1E/>UpLink);');
Inc(Off,Len);
{ PUSH WORD PTR [DATA] = $FF/$36/>DATA
}
{ PUSH WORD DATA
= $68/>DATA }
{ PUSH BYTE DATA
= $6A/<DATA }
{ MOV AX,DATA; PUSH AX = $B8/>DATA/$50
}
End;
WriteLn(o);
WriteLn(o,'Implementation');
WriteLn(o);
WriteLn(o,'Procedure Open;');
WriteLn(o,'Begin');
WriteLn(o,' dbf_Open(f);');
WriteLn(o,'End;');
WriteLn(o);
WriteLn(o,'Procedure Close;');
WriteLn(o,'Begin');
WriteLn(o,' dbf_Close(f);');
WriteLn(o,'End;');
WriteLn(o);
WriteLn(o,'Function RECNO: LongInt;');
WriteLn(o,'Begin');
WriteLn(o,' RECNO := dbf_RECNO(f);');
WriteLn(o,'End;');
WriteLn(o);
WriteLn(o,'Procedure MyExit; Far;');
WriteLn(o,'Begin');
WriteLn(o,' dbf_Close(f);');
WriteLn(o,' ExitProc := FileRec(f).OldExit;');
WriteLn(o,'End;');
WriteLn(o);
WriteLn(o,'Begin');
WriteLn(o,' Assign(f,dbfName);');
WriteLn(o,' FileRec(f).OldExit := ExitProc;');
WriteLn(o,' ExitProc := @MYEXIT;');
WriteLn(o,'End.');
System.Close(o);
dbf_Close(f);
IF (InOutRes <> 0) Then Abort('Write '+dbfname+'.pas
data');
WriteLn(#13#10'Status: ',Upper(Copy(textrec(o).Name,1,Pos(#0,textrec(o).Name)-1)),
' has been successfuly created.'#13#10);
WriteLn('Remove the CREATEUNIT statement now
and include ',
Upper(Copy(textrec(o).Name,1,Pos('.',textrec(o).Name)-1)),
' in the USES clause.');
WriteLn('Please report any compile/runtime-errors
in DBFSERV or in the ',
Upper(copy(textrec(o).Name,1,Pos('.',textrec(o).Name)-1)),'
unit!');
If Not(Batchmode) Then Halt;
End;
Procedure dbf_Open(Var f: File);
Var H : Record VER: Byte; YY,MM,DD: Byte; RECs: Longint;
HS,RS: Word; End;
Begin
Case FileRec(f).Mode Of
fmInput,fmOutput,fmInOut: ;
fmClosed: Begin
FileMode := $40;
Reset(f,1);
If (InOutRes <> 0) Then Exit;
BlockRead(f,H,SizeOf(H));
FileRec(f).HS := H.HS; { Header Size }
FileRec(f).RS := H.RS; { Record Size }
FileRec(f).InCache := -1;
{If (H.RS <= MaxAvail)
Then} GetMem(FileRec(f).Cache,H.RS)
{Else FileRec(f).Cache := NIL};
End;
Else RunError(102); { File not
assigned }
End;
End;
Procedure dbf_Close(Var f: File);
Begin
Case FileRec(f).Mode Of
fmInput,fmOutput,fmInOut:
Begin
System.Close(F);
If (FileRec(f).Cache
<> NIL)
Then FreeMem(FileRec(f).Cache,FileRec(f).RS);
End;
End;
End;
Function dbf_RecNo(Var f: File): LongInt;
Var l: LongInt;
Begin
dbf_Open(f);
Seek(f,4);
BlockRead(f,l,4);
dbf_RecNo := L;
End;
Procedure dbf_Get(Var f: File; t: Char; r: LongInt;
o,l,d: Word);
Var DATA: String[31]; N: Number; i: Word; Result:
^String;
Begin
dbf_Open(f);
If (FileRec(f).InCache = r)
Then Inc(CacheHits)
Else
Begin
FileRec(f).InCache := r;
Seek(f,LongInt(FileRec(f).HS)+Pred(r)*FileRec(f).RS);
BlockRead(f,FileRec(f).Cache^,FileRec(f).RS);
Inc(CacheMiss);
End;
Case T Of
'L': Case UpCase(Char(FileRec(f).Cache^[o]))
Of
'Y','T','*': asm mov al, TRUE; end;
Else asm mov al, FALSE; End;
End;
'C': Begin
asm
les ax, [f+4]
mov word ptr [Result], ax
mov word ptr [Result+2], es
end;
Move(FileRec(f).Cache^[o],Result^[1],l);
Result^[0] := Char(l);
if AutoTrim Then While (Length(Result^) > 0) And
(Result^[Length(Result^)] = ' ') Do Dec(Result^[0]);
End;
'N': Begin
Move(FileRec(f).Cache^[o],Data[1],l);
Data[0] := Char(l);
Val(Data,N,i);
asm
fld N
end;
End;
End;
End;
Procedure Help; Assembler;
asm
mov ah,$40
mov bx,2
mov cx,offset @Z
mov dx,offset @A
sub cx,dx
push ds
push cs
pop ds
int $21
pop ds
ret
@A: db 7,13,10,"DBSERV 1.00á - Copyright (c)
9.IV.1998"
db " by Antivivisektion@t-online.de",13,10
db "Please refer the DBSERV.DOC
file for copyright and help.",13,10
@Z:
End;
Begin
{ OFS(HELP) = 0 >>> no PROCs of this Unit were linked,
so !help! }
If (Ofs(Help) = 0) Then Begin Help; Halt;
End;
End.
{$A+,B-,D+,E-,F-,G+,I+,L+,N+,O-,P+,Q+,R+,S+,T+,V+,X+,Y+}
{$I+,S-,R-,Q-}
{ $DEFINE CREATE}
Uses DBFSERV {$IFNDEF CREATE} ,TESTDATA {$ENDIF} ;
Procedure ClrScr; Inline($B8/>$0003/$CD/$10);
Const
dbfPath = '\\server\d\dbf\';
dbfName = 'testdata';
Clock = $1800B0/24/3600;
Var
Start: LongInt;
SysTick: LongInt Absolute $40:$6C;
Begin
{$IFDEF CREATE}
CreateUnit(dbfPath,dbfName);
{$ELSE}
ClrScr;
Start := SysTick;
For RECPTR := 1 To RECNO Do
Begin
If Not(DEL)
THEN WriteLn(ARTBEZ1:20,COSTS:10:2);
End;
WriteLn('Elapsed time [s]: ',(SysTick-Start)/Clock:10:3);
{$ENDIF}
End.
{$A+,B-,D+,E-,F-,G+,I+,L+,N+,O-,P+,Q+,R+,S+,T+,V+,X+,Y+}
{$I+,S-,R-,Q-}
Unit TESTDATA;
Interface
Uses DBFSERV;
Const dbfName: String[63] = '\\server\d\dbf\testdata.dbf';
RECPTR: LongInt = 1;
Var F: FILE;
Procedure Open;
Procedure Close;
Function RECNO: LongInt;
Function DEL: Boolean; { L L1 D0 @0 } Inline($1E/$68/>f/$6A/<76/
$FF/$36/>RECPTR+2/$FF/$36/>RECPTR/$6A/<0/$6A/<1/$6A/<0/$FF/$1E/>UpLink);
Function ARTBEZ1: String; { C L20 D0 @1 } Inline($1E/$68/>f/$6A/<67/
$FF/$36/>RECPTR+2/$FF/$36/>RECPTR/$6A/<1/$6A/<20/$6A/<0/$FF/$1E/>UpLink);
Function COSTS: Number; { N L8 D2 @21 } Inline($1E/$68/>f/$6A/<78/
$FF/$36/>RECPTR+2/$FF/$36/>RECPTR/$6A/<21/$6A/<8/$6A/<2/$FF/$1E/>UpLink);
Implementation
Procedure Open;
Begin
dbf_Open(f);
End;
Procedure Close;
Begin
dbf_Close(f);
End;
Function RECNO: LongInt;
Begin
RECNO := dbf_RECNO(f);
End;
Procedure MyExit; Far;
Begin
dbf_Close(f);
ExitProc := FileRec(f).OldExit;
End;
Begin
Assign(f,dbfName);
FileRec(f).OldExit := ExitProc;
ExitProc := @MYEXIT;
End.
ððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððð
ððð DBFSERV ððð Version:
1.0á (10.IV.1998) ðððððððððððððððððððððððððððððððððð
ððð Copyrigth (c) 1998 by Antivivisektion@t-online.de
ððððððððððððððððððððððð
ððð comes with NO WARRANTY - please read
the disclaimer at the end ðððððððððð
ððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððððð
=== What is DBFSERV good for? ===============================================
Well, it provides FAST and EASY access to DBF-files
- WITHOUT OVERHEAD.
[creators of dbf-files are for example DBASE (tm),
CLIPPER (tm), etc]
=== OK, lets give an full example to access e.g. FAKT.DBF: ==================
{$DEFINE FIRST}
Uses DBFSERV {$IFNDEF FIRST} ,FAKT {$ENDIF}
;
Var Sum: Number;
Begin {$IFDEF FIRST} CreateUnit('d:\','FAKT');
{$ENDIF}
Sum := 0;
For RECPTR := 1 To RECNO Do
Sum := Sum + FIELD;
WriteLn(Sum:10:2);
End.
RECPTR contains the number of the current record.
RECNO is a function that returns the number of records
in the xbase.
FIELD is a function that returns the content of the
record at RECPTR.
NUMBER is a floating point datatyp (Single) to hold
numerical fields.
=== DBFSERV features ========================================================
- Easy access
You can access all field by their name.
- AutoOpen
On first access to any xbase-field, the xbase
is being opened.
- AutoClose
On HALT or RUNERROR the xbase-file is being
closed.
- Record-Caching
This provides fast access to different fields
of the same record.
- Auto type conversion
In xbase, all fields (even numbers) are stored
as strings. With
DBFSERV you get them as Pascal Types (floats,
booleans or strings).
- Performance
Because the DBFSERV works with an INLINE-machinecode-interface,
it is very fast. And: unused symbols are not
being linked into the
final EXE-file, so no space is wasted.
- Multi-XBASE-access
You can use as many as possible files simultaniously.
=== Now, how-to-do? =========================================================
You have to let the DBFSERV create a special unit
for each dbf-file you
want to access. The name of the unit is equal to
the name of the dbf-file.
Example:
Uses DBFSERV;
Begin
CreateUnit('d:\','FAKT'); { no
.PAS or .DFB extension! }
End.
That's all! A file FAKT.PAS has been created and has
to be compiled.
So you have to add FAKT (or what ever your dbf-file
is named) and delete
the line with "CreateUnit". Now you can access all
the fields in your
database by their names.
Uses DBFSERV,FAKT; { If you don't need the
TYPE NUMBER=FLOAT definition, }
Begin
{ you can delete DBFSERV from USES.
}
WriteLn(FIELD1); { prints field
with name FIELD1 of record 1 (default) }
End.
RECNO gives you the total count of records in your
database.
RECPTR (1 by default) has to be set to the recordnumber,
you want to retrive.
=== Access multiple xbase-files (example) ===================================
{$DEFINE FIRST} { <-- delete after first
BUILD/RUN }
Uses DBFSERV {$IFNDEF FIRST} ,XBASE1,XBASE2,XBASE3
{$ENDIF} ;
Var Sum: Number;
Begin
{$IFDEF FIRST}
BatchMode := True;
{ No AutoHalt after CreateUnit }
CreateUnit('d:\','XBASE1');
CreateUnit('d:\','XBASE2');
CreateUnit('d:\','XBASE3');
Halt;
{$ENDIF}
Sum := 0;
For xbase1.RECPTR := 1 To xbase1.RECNO
Do
Sum := Sum + xbase1.FIELD+xbase2.FIELD+xbase3.FIELD;
WriteLn(Sum:10:2);
End.
That's easy, isn't it?
=== How does it work? =======================================================
Internals:
Each field X has an offset OF in the record R.
The record R has an offset OR in the dbf-file F.
Well, when you access field X - e.g. WriteLn(X) - the following happens:
X is an *inline macro* which expands to
Function GetData(File,RecPtr,FieldOffset,Typ(X),Length(X)):
Result;
First, the GetData-function seeks the field position
in dbf-file with
Seek(File,HeaderSize+RecordSize*RECPTR+FieldOffset);
and now it reads the requested data-string:
BlockRead(File,Result,Length(X));
Then a type-conversion "data-string to pascal-data-type"
is being done.
Yes, it's a bit more complicated...
=== BUGS, KNOWN ERRORS, DISADVANTAGES =======================================
Bugs
(none known)
Known errors
- does not check, if file is really a dbf-file
- does not check the db-version, altough only db3
is supported
- no run-time error checks
Disadvantages
- see TO-DO-LIST (below)
- If the structure of a dbf-database changes, you
have to re-build
the dbf-unit with CreateUnit and re-build
the main application.
- Works only on Intel x86 and in real-mode 'cause
of machine-code-interface.
- The DBFSERV relies on very specific stack-structure
on calls of lib-funcs.
So, with an other pascal-compiler, it will
not work without adaption.
=== TO-DO-LIST ==============================================================
- better documentation
- more-than-one-record cache
- turn-caching-off switch
- writing dbf-fields, records and files
- add more xbase-data-types like MEMO
- add index-support
- add MEMO-support
- implement checking DB-version of xbase-file
currently, only DB3(+) is supported
- add run-time error checks
...
Other features missing?
DISCLAIMER
----------
WE DO NOT WARANTEE ANYTHING CONCERNING
ANY OF THE SOURCES OR FILES
WHICH MAKE UP THIS DBFSERV PACKAGE.
WE ACCEPT NO RESPONSIBILITY FOR
ANY LOSS OR DAMAGE OF ANY KIND,
INCLUDING, BUT NOT LIMITED TO, LOSSES
OF A PHYSICAL, MENTAL, SOCIAL,
FINANCIAL, MARITAL, OR OF WHATEVER
NATURE, RESULTING FROM THE USE,
OR THE PURPORTED USE, OF THIS DBFSERV
PACKAGE OR ANY OF THE FILES IN
THE PACKAGE, FOR ANY PURPOSE WHATSOEVER.
WE DO NOT EVEN WARANTEE THAT THE
FILES WILL NOT KILL YOU.
YOU USE THIS DBFSERV PACKAGE ENTIRELY
AT YOUR OWN RISK, AND YOU SUPPLY
IT TO YOUR CUSTOMERS, FRIENDS,
FAMILY, ACQUAINTANCES, OR ENEMIES,
ENTIRELY AT YOUR OWN RISK.
IF THESE TERMS ARE NOT ACCEPTABLE
TO YOU, THEN PLEASE DELETE ALL
THE FILES FROM YOUR DISKS IMMEDIATELY
AND PERMANENTLY.
In this disclaimer, "WE" refers
to:
Antivivisektion@t-online.de
(Disclaimer written by The-African-Chief
<laa12@cc.keele.ac.uk>)