unit GSOB_DBS;
{-----------------------------------------------------------------------------
dBase III/IV DataBase Handler
GSOB_DBS Copyright (c) Richard F. Griffin
27 January 1993
102 Molded Stone Pl
Warner Robins, GA 31088
-------------------------------------------------------------
This unit contains the objects to manipulate the data, index, and
memo files that constitute a database.
SHAREWARE -- COMMERCIAL USE RESTRICTED
Changes:
19 Apr 93 - Corrected Skip procedure to correctly handle end-of-file
and top-of-file conditions in an indexed database.
02 May 93 - Routines used for conversion to/from numbers have been
modified to be of type FloatNum. This allows numbers to
have up to 20 significant digits. Note that the $N+ and
$E+ switches must be set (Alt O,C,8,E in IDE) to compile
using this feature. Otherwise, 11-12 digits will be used.
The use of the $N+,E+ switch adds 10K to program size.
When you compile a program in the $N+,E+ state, the
compiler links with the full 80x87 emulator. The resulting
.EXE file can be run on any machine, regardless of whether
that machine has an 80x87. If an 80x87 is present, the
program will use it; otherwise, the run-time library
emulates it. This gives you access to four additional
real types: Single, Double, Extended, and Comp. The $E+
directive will emulate the 80x87. This gives you access
to the IEEE floating-point types without requiring that you
install an 80x87 chip.
30 Jun 93 - Replaced the call to IndexUpdate in Append to eliminate the
call to Formula.
15 Jul 93 - Added Global variable DBFCacheSize to allow the programmer
to adjust the size of the cache used.
24 Jul 93 - Modified Find to go to the end of file if no match. This
makes it compatible with the dBase Find procedure.
24 Jul 93 - Added a FindNear function to find either the matching key
or position the file to the record with the next greater
key if not found. The Found flag will be set if a key
is matched.
25 Jul 93 - Improved the speed of switching indexes in the IndexOrder
method. Replaced routine to do a sequential search for the
index key with record number matching the current number.
New routine Finds matching record key and then confirms the
record number matches. Provides significant reduction in
time required.
07 Aug 93 - Fixed Skip method to properly load the first record or the
ending record in the file if the skip count resulted in a
skip distance that caused access beyond file limits.
------------------------------------------------------------------------------}
{$V-}
interface
uses
GSOB_Var,
GSOB_Dte,
GSOB_MMo,
GSOB_DBF,
GSOB_Dsk,
GSOB_Inx,
GSOB_Str,
{$IFDEF CLIPPER}
GSOB_Ntx,
{$ELSE}
GSOB_Ndx,
{$ENDIF}
{$IFDEF WINDOWS}
Objects;
{$ELSE}
GSOB_Obj;
{$ENDIF}
const
IndexesAvail = 64;
DBFCacheSize : word = 32768;
type
GSP_FormRec = ^GSR_FormRec;
GSR_FormRec = record
FType : Char;
FDcml : byte;
FSize : integer;
FPosn : array[0..32] of integer;
FAlias: string[10];
end;
GSP_dBHandler = ^GSO_dBHandler;
GSP_dBIndex = ^GSO_dBIndex;
GSO_dBIndex = object(GSO_IndexFile)
DBFObj : GSP_dBHandler;
PassCount : integer;
FormRec : GSR_FormRec;
Constructor Init(dbfilobj : GSP_dBHandler; IName : string);
Constructor NewInit(dbfilobj : GSP_dBHandler; filname,
formla : string; lth, dcl : integer; typ : char);
Procedure IndexUpdate(rnum: longint; fml: GSR_FormRec; apnd: boolean);
Procedure WriteStatus(RNum : longint); virtual;
end;
GSO_dBHandler = object(GSO_dBaseFld)
IndexHandle : integer;
IndexMaster : GSP_dBIndex;
IndexStack : array[1..IndexesAvail] of GSP_dBIndex;
MemoFile : GSP_dBMemo;
CacheFirst : Longint;
CacheLast : Longint;
CachePtr : PByteArray;
CacheRecs : integer;
CacheSize : LongInt;
CacheRead : boolean;
Found : boolean;
constructor Init(FName : string);
destructor Done; virtual;
procedure Append; virtual;
procedure Close; virtual;
procedure CopyFile(filname: string);
procedure CopyFromIndex(ixColl: GSP_IndxColl; filname: string);
procedure CopyMemoRecord(df : GSP_dBHandler);
procedure CopyStructure(filname : string);
Function Find(st : string) : boolean; virtual;
Function FindNear(st : string) : boolean; virtual;
Procedure Formula(st : string; var fmrec: GSR_FormRec); virtual;
Function FormXtract(fmrec : GSR_FormRec) : string; virtual;
procedure GetRec(RecNum : LongInt); virtual;
Procedure Index(IName : string);
Function IndexOrder(AIndexHandle : integer) : boolean;
function IndexInsert(ix : GSP_dBIndex) : integer;
function IndexMore(IName : string) : integer;
Function IndexTo(filname, formla : string) : integer;
Procedure LoadToIndex(ixColl: GSP_IndxColl; zfld: string);
Procedure MemoClear;
function MemoGetLine(linenum : integer) : string;
Procedure MemoInsLine(linenum : integer; st : string); virtual;
procedure MemoGet(st : string);
procedure MemoGetN(n : integer);
Procedure MemoWidth(l : integer);
function MemoLines : integer;
procedure MemoPut(st : string);
procedure MemoPutN(n : integer);
procedure Open; virtual;
Procedure Pack;
Procedure ReIndex;
procedure PutRec(RecNum : LongInt); virtual;
Procedure Read(blk : longint; var dat; len : word); virtual;
procedure SetDBFCache(tf: boolean); virtual;
procedure Skip(RecCnt : LongInt); virtual;
procedure SortFile(filname, zfld: string; isascend : SortStatus);
Procedure StatusUpdate(stat1,stat2,stat3 : longint); virtual;
function TestFilter : boolean; virtual;
Procedure Write(blk : longint; var dat; len : word); virtual;
Procedure Zap;
Procedure ZapIndexes;
end;
GSP_dbTable = ^GSO_dbTable;
GSO_dBTable = Object(GSO_IndxColl)
dbas : GSP_dBHandler; {Object to refer to}
Sel_Item : longint; {Last entry selected}
Scn_Key : string; {Holds select key formula}
fmRec : GSR_FormRec;
fmType : char;
tbEntry : GSP_IndxEtry;
tbSorted : boolean;
Constructor Init(var Fil : GSO_dBHandler; zfld : string;
sortseq : SortStatus);
procedure Build_dBTabl; virtual;
function FilterKey : string; virtual;
function FindKey_dBTabl(pcnd : string) : boolean; virtual;
function FindRec_dBTabl(pcnd : string) : boolean; virtual;
function GetKey_dBTabl(keynum: longint): boolean; virtual;
function GetRec_dBTabl(keynum: longint): boolean; virtual;
end;
implementation
var
FieldPtr : GSP_DBFField;
IxOrder : integer;
constructor GSO_dBHandler.Init(FName : string);
var
i : integer;
begin
GSO_dBaseFld.Init(FName);
if WithMemo then
case FileVers of
DB3WithMemo : MemoFile := New(GSP_dBMemo3, Init(FName,FileVers));
DB4WithMemo : MemoFile := New(GSP_dBMemo4, Init(FName,FileVers));
end
else MemoFile := nil;
IndexHandle := -1;
IndexMaster := nil;
for i := 1 to IndexesAvail do IndexStack[i] := nil;
CacheRead := false;
CachePtr := nil;
Found := false;
end;
destructor GSO_dBHandler.Done;
var
i : integer;
begin
GSO_dBHandler.Close;
if WithMemo then
begin
Dispose(MemoFile, Done);
WithMemo := false;
end;
GSO_dBaseFld.Done;
end;
{------------------------------------------------------------------------------
Record Processing
------------------------------------------------------------------------------}
procedure GSO_dBHandler.Append;
var
i : integer;
ftyp : char;
begin
GSO_dBaseFld.Append;
if (IndexHandle > 0) then
begin
for i := 1 to IndexesAvail do
begin
if IndexStack[i] <> nil then
begin
IndexStack[i]^.IndexUpdate(RecNumber,IndexStack[i]^.FormRec,true);
end;
end;
end;
end; {Append}
procedure GSO_dBHandler.Close;
var
i : integer;
ix : GSP_dBIndex;
begin
if WithMemo then MemoFile^.Close;
for i := 1 to IndexesAvail do
if IndexStack[i] <> nil then
begin
Dispose(IndexStack[i], Done);
IndexStack[i] := nil;
end;
IndexMaster := nil; {Set index active flag to false}
IndexHandle := -1;
if CachePtr <> nil then FreeMem(CachePtr, CacheSize);
CachePtr := nil;
CacheSize := 0;
GSO_dBaseFld.Close;
end;
Function GSO_dBHandler.Find(st : string) : boolean;
var
RNum : longint;
begin
if (IndexMaster <> nil) then
begin
RNum := IndexMaster^.KeyFind(st);
if RNum > 0 then {RNum = 0 if no match, otherwise}
{it holds the valid record number}
begin
GetRec(RNum); {If match found, read the record}
Found := True; {Set Match Found flag true}
end else
begin {If no matching index key, then}
Found := False; {Set Match Found Flag False}
GetRec(Bttm_Record);
File_EOF := True;
end;
end else {If there is no index file, then}
Found := False; {Set Match Found Flag False}
Find := Found;
end; {Find}
Function GSO_dBHandler.FindNear(st : string) : boolean;
var
RNum : longint;
begin
if (IndexMaster <> nil) then
begin
RNum := IndexMaster^.KeyFind(st);
if RNum > 0 then {RNum = 0 if no match, otherwise}
{it holds the valid record number}
begin
GetRec(RNum); {If match found, read the record}
Found := True; {Set Match Found flag true}
end else
begin {If no matching index key, then}
Found := False; {Set Match Found Flag False}
if IndexMaster^.ixEOF then
begin
GetRec(Bttm_Record);
File_EOF := True;
end
else
begin
RNum := IndexMaster^.KeyRead(-5); {Read current index pos}
GetRec(RNum); {read the record}
end;
end;
end else {If there is no index file, then}
Found := False; {Set Match Found Flag False}
FindNear := Found;
end; {Find}
procedure GSO_dBHandler.GetRec(RecNum : LongInt);
var
rnum : longint;
cread : boolean;
okread: boolean;
begin
cread := CacheRead;
okread := false;
File_EOF := false;
File_TOF := false;
rnum := RecNum;
case RecNum of
Top_Record : RecNum := Next_Record;
Bttm_Record : RecNum := Prev_Record;
end;
repeat
if (IndexMaster <> nil) and (RecNum < 0) then
begin
CacheRead := false;
rnum := IndexMaster^.KeyRead(rnum);
File_EOF := IndexMaster^.ixEOF;
File_TOF := IndexMaster^.ixBOF;
end;
if (not File_EOF) and (not File_TOF) then {done if EOF reached}
begin
GSO_dBaseDBF.GetRec(rnum);
if RecNum > 0 then okread := true {done if physical record access}
else okread := TestFilter;
rnum := RecNum;
end;
until okread or File_EOF or File_TOF;
CacheRead := cread;
end;
procedure GSO_dBHandler.Open;
begin
GSO_dBaseFld.Open;
if WithMemo then MemoFile^.Open;
end;
procedure GSO_dBHandler.PutRec(RecNum : LongInt);
var
i : integer;
ftyp : char;
begin
GSO_dBaseFld.PutRec(RecNum);
if (IndexHandle > 0) then
begin
for i := 1 to IndexesAvail do
begin
if IndexStack[i] <> nil then
begin
IndexStack[i]^.IndexUpdate(RecNumber,IndexStack[i]^.FormRec,false);
end;
end;
end;
end; {PutRec}
Procedure GSO_DBHandler.Read(blk : longint; var dat; len : word);
begin
if (not CacheRead) or (blk < HeadLen) then
GSO_DiskFile.Read(blk,dat,len)
else
begin
if (CacheFirst = -1) or
(blk < CacheFirst) or
(blk > CacheLast) then
begin
GSO_DiskFile.Read(blk,CachePtr^,CacheSize);
CacheFirst := blk;
CacheLast := (blk + (dfGoodRec-RecLen));
end;
if blk > CacheLast then dfGoodRec := 0
else
begin
dfGoodRec := RecLen;
Move(CachePtr^[blk - CacheFirst],dat,RecLen);
end;
end;
end;
Procedure GSO_DBHandler.SetDBFCache(tf: boolean);
begin
if tf and CacheRead then exit;
CacheRead := tf;
if not tf then
begin
if CachePtr <> nil then FreeMem(CachePtr, CacheSize);
CachePtr := nil;
CacheSize := 0;
end
else
begin
CacheSize := MaxAvail;
if CacheSize > DBFCacheSize then
CacheSize := DBFCacheSize
else CacheSize := CacheSize - 16384;
CacheSize := CacheSize - (CacheSize mod RecLen);
if CacheSize < RecLen then CacheSize := RecLen;
GetMem(CachePtr, CacheSize);
CacheFirst := -1;
CacheRecs := CacheSize div RecLen;
end;
end;
PROCEDURE GSO_dBHandler.Skip(RecCnt : LongInt);
VAR
i : integer;
rs : word;
rn : longint;
de : longint;
dr : longint;
rl : longint;
rc : longint;
begin;
If RecCnt <> 0 then
begin
if RecCnt < 0 then de := Top_Record else de := Bttm_Record;
rl := RecNumber;
rn := abs(RecCnt);
if RecCnt > 0 then dr := Next_Record else dr := Prev_Record;
if (IndexMaster <> nil) then
begin
i := 1;
repeat
rc := IndexMaster^.KeyRead(dr);
if rc > 0 then
begin
rl := rc;
File_EOF := IndexMaster^.ixEOF;
File_TOF := IndexMaster^.ixBOF;
end
else
begin
rl := IndexMaster^.KeyRead(de);
GetRec(rl); {restore top/bottom record}
File_EOF := RecCnt > 0; {set EOF flag}
File_TOF := RecCnt < 0;
end;
inc(i);
until (i > rn) or (File_EOF) or (File_TOF);
end
else
begin
rl := Recnumber + RecCnt;
File_EOF := (rl > NumRecs);
File_TOF := (rl < 1);
if rl < 1 then rl := 1;
if rl > NumRecs then rl := NumRecs;
end;
if File_EOF or File_TOF then
begin
if File_EOF then
begin
GetRec(rl);
File_EOF := true;
end
else
begin
GetRec(rl);
File_TOF := true;
end;
end
else
begin
GetRec(rl);
if not TestFilter then
repeat
GetRec(dr);
until TestFilter or File_EOF or File_TOF;
end;
end;
end;
function GSO_dBHandler.TestFilter: boolean;
begin
TestFilter := not(DelFlag and (not UseDelRecord));
end;
Procedure GSO_DBHandler.Write(blk : longint; var dat; len : word);
begin
GSO_DiskFile.Write(blk,dat,len);
if (CacheRead) then CacheFirst := -1;
end;
{------------------------------------------------------------------------------
Formula Processing
------------------------------------------------------------------------------}
Procedure GSO_dBHandler.Formula(st : string; var fmrec : GSR_FormRec);
var
FldVal,
FldWrk : string;
FldPos : integer;
FldCnt : integer;
Procedure EvalField(fldst : string);
var
fldp : GSP_DBFField;
strf : boolean;
prnd : integer;
begin
fldst := TrimL(TrimR(fldst));
if fldst = '' then exit;
fldst := AllCaps(fldst);
prnd := 0;
strf := false;
if pos('STR(',fldst) = 1 then prnd := 4
else
if pos('DTOC(',fldst) = 1 then prnd := 5
else
if pos('DTOS(',fldst) = 1 then prnd := 5;
if prnd > 0 then
begin
strf := true;
system.Delete(fldst,1,prnd);
prnd := pos(')',fldst);
if prnd > 0 then fldst[0] := chr(prnd-1);
end;
fldp := AnalyzeField(fldst);
if fldp <> nil then
begin
if not strf and (fldp^.FieldType <> 'C') and (FldCnt = 0) then
begin
fmrec.FType := fldp^.FieldType;
fmrec.FDcml := fldp^.FieldDec;
end;
fmrec.FSize := fmrec.FSize + fldp^.FieldLen;
fmrec.FPosn[FldCnt] := fldp^.FieldNum;
end
else
Error(gsBadFormula, dbsFormulaError);
end;
begin
for FldCnt := 0 to 32 do fmrec.FPosn[FldCnt] := 0;
fmrec.FType := 'C';
fmrec.FDcml := 0;
fmrec.FSize := 0;
FldCnt := 0;
FldVal := ''; {Initialize the return string value}
FldWrk := st; {Move the input string to a work field}
while (FldWrk <> '') and
(FldCnt < 32) and
(fmrec.FType = 'C') do {Repeat while there is still}
{something in the work field.}
begin
FldPos := pos('+', FldWrk); {Search for a '+' delimiter}
if FldPos = 0 then FldPos := length(FldWrk)+1;
{If no '+' then simulate for this pass}
{by setting position to one beyond the}
{end of the target field string.}
EvalField(SubStr(FldWrk,1,FldPos-1));
{Go find the field using the substring}
{from the string's beginning to one }
{position before the '+' character.}
system.delete(FldWrk,1,FldPos); {Delete the string up through the '+'};
FldWrk := TrimL(FldWrk); {Remove leading spaces}
inc(FldCnt);
end;
end;
Function GSO_dBHandler.FormXtract(fmrec : GSR_FormRec) : string;
var
s : string;
i : integer;
begin
s := '';
i := 0;
while fmrec.FPosn[i] <> 0 do
begin
s := s + FieldGetN(fmRec.FPosn[i]);
inc(i);
end;
FormXtract := s;
end;
{------------------------------------------------------------------------------
Index Processing
------------------------------------------------------------------------------}
Procedure GSO_dBHandler.Index(IName : String);
var
i,j : integer; {Local working variable }
st : String[64]; {Local working variable}
ix : GSP_dBIndex;
begin
for i := 1 to IndexesAvail do
if IndexStack[i] <> nil then
begin
Dispose(IndexStack[i], Done);
IndexStack[i] := nil;
end;
IndexMaster := nil; {Set index active flag to false}
IName := StripChar(' ',IName);
while (IName <> '') do
begin
j := pos(',',IName);
if j = 0 then j := ord(IName[0]) + 1;
st := copy(IName,1,j-1);
System.Delete(IName,1,j);
if st <> '' then
begin
ix := New(GSP_dBIndex, Init(@Self,st));
i := IndexInsert(ix);
end;
end;
end;
Function GSO_dBHandler.IndexInsert(ix : GSP_dBIndex) : integer;
var
i : integer; {Local working variable }
begin
i := 1;
while (IndexStack[i] <> nil) and (i <= IndexesAvail) do inc(i);
if i <= IndexesAvail then
begin
IndexStack[i] := ix;
IndexInsert := i;
if IndexMaster = nil then
begin
IndexMaster := ix;
IndexHandle := i;
end;
end else IndexInsert := -1;
end;
Function GSO_dBHandler.IndexOrder(AIndexHandle : integer) : boolean;
var
s : string;
b : longint;
i : byte;
ix : GSP_dBIndex;
begin
IndexOrder := true;
case AIndexHandle of
0 : begin
IndexMaster := nil;
IndexHandle := 0;
end;
1..IndexesAvail : begin
IndexMaster := IndexStack[AIndexHandle];
IndexHandle := AIndexHandle;
if IndexMaster <> nil then
if RecNumber = 0 then GetRec(Top_Record)
else
begin
s := FormXtract(IndexMaster^.FormRec);
b := IndexMaster^.KeyFind(s);
while (b <> RecNumber) and (b <> 0) do
b := IndexMaster^.KeyRead(Next_Record);
end;
end;
else IndexOrder := false;
end;
end;
Function GSO_dBHandler.IndexMore(IName : String) : integer;
var
ix : GSP_dBIndex;
begin
ix := nil;
IName := StripChar(' ',IName);
if IName <> '' then ix := New(GSP_dBIndex, Init(@Self,IName));
if ix <> nil then IndexMore := IndexInsert(ix)
else IndexMore := -1;
end;
Function GSO_dBHandler.IndexTo(filname, formla : string) : integer;
var
i,
j,
fl : integer; {Local working variable}
ftyp : char;
fval : longint;
fkey : string;
s : string;
ix : GSP_dBIndex;
excl : boolean;
delf : boolean;
fmrec : GSR_FormRec;
{
????????????????????????????????????????????????????
? Main routine. This takes and analyzes the ?
? argument to build an index file. It does the ?
? following: ?
? 1. Reset current index files. ?
? 2. Get the total new formula field length. ?
? 3. Create an index file. ?
? 4. Build the index by reading all dbase ?
? records and updating the index file. ?
????????????????????????????????????????????????????
}
begin
StatusUpdate(StatusStart,StatusIndexTo,NumRecs);
ix := IndexMaster;
if formla <> '' then
begin
s := AllCaps(TrimR(filname));
i := length(s);
j := i;
while (i > 0) and not (s[i] in ['\',':']) do dec(i);
FmRec.FAlias := copy(s,i+1,(j-i));
Formula(formla,fmrec); {Get field length/type of the formula}
if fmrec.FSize = 0 then exit; {Exit if formula is no good}
Open;
ix := nil;
filname := StripChar(' ',filname);
excl := GS_Exclusive;
GS_SetExclusive(On);
if filname <> '' then
ix := New(GSP_dBIndex, NewInit(@Self, filname, formla, fmrec.FSize,
fmrec.FDcml, fmrec.FType));
if ix = nil then
begin
IndexTo := -1;
exit;
end;
IndexMaster := nil;
ix^.KeySort(fmrec.FSize,SortUp); {Ascending Sort}
SetDBFCache(On);
delf := UseDelRecord;
UseDelRecord := true;
GetRec(Top_Record); {Read all dBase file records}
while not File_EOF do
begin
fkey := FormXtract(fmrec);
ix^.ixColl^.InsertKey(RecNumber,fkey);
StatusUpdate(StatusIndexTo,RecNumber,0);
GetRec(Next_Record);
end;
UseDelRecord := delf;
SetDBFCache(Off);
StatusUpdate(StatusStop,0,0);
StatusUpdate(StatusStart,StatusIndexWr,NumRecs);
ix^.IndxStore(ix^.ixColl,true);
GetRec(Top_Record); {Reset to top record}
Dispose(ix, Done);
GS_SetExclusive(excl);
ix := New(GSP_dBIndex, Init(@Self,filname));
if ix <> nil then
begin
IndexTo := IndexInsert(ix);
IndexMaster := ix;
end;
end
else IndexTo := -1;
StatusUpdate(StatusStop,0,0);
end;
Procedure GSO_dBHandler.ReIndex;
var
rxIndexHandle : integer;
rxIndexMaster : GSP_dBIndex;
rxIndexStack : array[1..IndexesAvail] of GSP_dBIndex;
fm
