www.pudn.com > oicqspysrc.zip > DBF.pas
unit DBF;
(* ===========================================================================
* dbf.dcu - tDBF : A custom data set which uses a flat binary
* structured datafile for single client usage only.
*
* Author: Horacio Jamilis
* Copyright (C) 1998, Terabyte Computacion
*
* ===========================================================================
* v 0.91
* - Fixed error on deleting records
* - Added filtering capabilities (work wrong when there are no records within
* the filter expresion - Only support expresion with one field like
* "NUMFIELD>10" or "TEXTFIELD<='TEST'" or "DATEFIELD=19980626"
* (in yyyymmdd format)).
* ===========================================================================
* FOR C++ Builder users:
* Use the file named DBF_C instead of this one.
* Especial thanks to Michael Beauregard (Michael_Beauregard@mck.com).
* ===========================================================================
*)
interface
uses
SysUtils, Classes, Db, DsgnIntf;
type
TFilenameProperty = class(TStringProperty)
public
procedure Edit; override;
function GetAttributes: TPropertyAttributes; override;
end;
EDBFError = class (Exception);
pDateTime = ^TDateTime;
pBoolean = ^Boolean;
pInteger = ^Integer;
PRecInfo = ^TRecInfo;
TRecInfo = record
Bookmark: Longint;
BookmarkFlag: TBookmarkFlag;
end;
TdbfHeader = record { Dbase III + header definition }
VersionNumber :byte; { version number (03h or 83h ) }
LastUpdateYear :byte; { last update YY MM DD }
LastUpdateMonth :byte;
LastUpdateDay :byte;
NumberOfRecords :longint; { number of record in database }
BytesInHeader :smallint;{ number of bytes in header }
BytesInRecords :smallint;{ number of bytes in records }
ReservedInHeader :array[1..20] of char; { reserved bytes in header }
end;
TdbfField = record
FieldName :array[1..11] of char; { Name of this record }
FieldType :char; { type of record - C,N,D,L,etc. }
fld_addr :longint; { not used }
Width :byte; { total field width of this record }
Decimals :byte; { number of digits to right of decimal }
MultiUser :smallint; { reserved for multi user }
WorkAreaID :byte; { Work area ID }
MUser :smallint; { reserved for multi_user }
SetFields :byte; { SET_FIELDS flag }
Reserved :array[1..4] of byte; { 8 bytes reserved }
end; { record starts }
Type
pRecordHeader = ^tRecordHeader;
tRecordHeader = record
DeletedFlag : char;
end;
type
TDBF = class(TDataSet)
protected
FStream: TStream; // the physical table
FTableName: string; // table path and file name
fDBFHeader : TdbfHeader;
// record data
fRecordHeaderSize : Integer; // The size of the record header
FRecordCount, // current number of record
FRecordSize, // the size of the actual data
FRecordBufferSize, // data + housekeeping (TRecInfo)
FRecordInfoOffset, // offset of RecInfo in record buffer
FCurrentRecord, // current record (0 to FRecordCount - 1)
BofCrack, // before the first record (crack)
EofCrack: Integer; // after the last record (crack)
FIsTableOpen: Boolean; // status
FFileWidth, // field widths in record
FFileDecimals, // field decimals in record
FFileOffset: TList; // field offsets in record
fReadOnly : Boolean; // Enhancements
fStartData : Integer; // Position in file where data starts
function FFieldType(F : char):TFieldType;
function FFieldSize(FType:char;FWidth:integer):integer;
protected
// TDataSet virtual abstract method
function AllocRecordBuffer: PChar; override;
procedure FreeRecordBuffer(var Buffer: PChar); override;
procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override;
function GetRecordSize: Word; override;
procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;
procedure InternalClose; override;
procedure InternalDelete; override;
procedure InternalFirst; override;
procedure InternalGotoBookmark(Bookmark: Pointer); override;
procedure InternalHandleException; override;
procedure InternalInitFieldDefs; override;
procedure InternalInitRecord(Buffer: PChar); override;
procedure InternalLast; override;
procedure InternalOpen; override;
procedure InternalPost; override;
procedure InternalSetToRecord(Buffer: PChar); override;
function IsCursorOpen: Boolean; override;
procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
procedure SetFieldData(Field: TField; Buffer: Pointer); override;
// TDataSet virtual method (optional)
function GetRecordCount: Integer; override;
procedure SetRecNo(Value: Integer); override;
function GetRecNo: Integer; override;
Procedure WriteHeader;
private
Procedure _ReadRecord(Buffer:PChar;IntRecNum:Integer);
Procedure _WriteRecord(Buffer:PChar;IntRecNum:Integer);
Procedure _AppendRecord(Buffer:PChar);
Procedure _SwapRecords(Rec1,REc2:Integer);
Function _CompareRecords(SortFields:Array of String;Rec1,Rec2:Integer):Integer;
Function _ProcessFilter(Buffer:PChar):boolean;
public
constructor Create(AOwner:tComponent); override;
procedure CreateTable;
Procedure PackTable;
Procedure SortTable(SortFields : Array of String);
Procedure UnsortTable;
published
property TableName: string read FTableName write FTableName;
property ReadOnly : Boolean read fReadOnly write fReadonly default False;
property DBFHeader : tDBFHeader read fDBFHeader;
// redeclared data set properties
property Active;
property Filter;
property Filtered;
property BeforeOpen;
property AfterOpen;
property BeforeClose;
property AfterClose;
property BeforeInsert;
property AfterInsert;
property BeforeEdit;
property AfterEdit;
property BeforePost;
property AfterPost;
property BeforeCancel;
property AfterCancel;
property BeforeDelete;
property AfterDelete;
property BeforeScroll;
property AfterScroll;
property OnCalcFields;
property OnDeleteError;
property OnEditError;
property OnNewRecord;
property OnPostError;
end;
procedure Register;
implementation
uses
TypInfo, Dialogs, Windows, Forms, Controls, IniFiles;
Const
dfhVersionNumber = 13;
TYPE
PBufArray = ^BufArray;
BufArray = Array[0..0] of Char;
// ****************************************************************************
// Low Level Routines for accessing an internal record
// ____________________________________________________________________________
// TDBF._ReadRecord
Procedure TDBF._ReadRecord(Buffer:PChar;IntRecNum:Integer);
{-Read a record based on the internal record number (absolute)}
BEGIN
FStream.Position := FStartData + (FRecordSize * IntRecNum);
try
FStream.ReadBuffer(Buffer^, FRecordSize);
except
end;
END;
// ____________________________________________________________________________
// TDBF._WriteRecord
Procedure TDBF._WriteRecord(Buffer:PChar;IntRecNum:Integer);
{-Write a record based on the internal record number (absolute)}
BEGIN
FStream.Position := FStartData + (FRecordSize * IntRecNum);
FStream.WriteBuffer (Buffer^, FRecordSize);
END;
// ____________________________________________________________________________
// TDBF._AppendRecord
Procedure TDBF._AppendRecord(Buffer:PChar);
BEGIN
FStream.Position := FStartData + (FRecordSize * (FRecordCount{+FDeletedCount}));
FStream.WriteBuffer (Buffer^, FRecordSize);
END;
/////////////////////////////////////////////////
////// Part I:
////// Initialization, opening, and closing
/////////////////////////////////////////////////
// ____________________________________________________________________________
// TDBF.InternalOpen
// I: open the table/file
procedure TDBF.InternalOpen;
var
Field : TField;
i,j : integer;
d : string;
begin
// check if the file exists
if not FileExists (FTableName) then
raise eDBFError.Create ('Open: Table file not found');
// create a stream for the file
if fReadOnly then
fStream := tFileStream.Create( fTableName, fmOpenRead + fmShareDenyWrite)
else
FStream := TFileStream.Create (FTableName, fmOpenReadWrite + fmShareExclusive);
fStream.ReadBuffer(fDBFHeader,SizeOf(TDBFHeader));
// sets cracks and record position
BofCrack := -1;
EofCrack := fRecordCount{+fDeletedCount};
FCurrentRecord := BofCrack;
// set the bookmark size
BookmarkSize := sizeOf (Integer);
if not (assigned(FFileOffset)) then
FFileOffset := TList.Create;
if not (assigned(FFileWidth)) then
FFileWidth := TList.Create;
if not (assigned(FFileDecimals)) then
FFileDecimals := TList.Create;
// initialize the field definitions
// (another virtual abstract method of TDataSet)
InternalInitFieldDefs;
FRecordInfoOffset := FRecordSize;
FRecordBufferSize := FRecordSize + sizeof (TRecInfo);
// if there are no persistent field objects,
// create the fields dynamically
if DefaultFields then
CreateFields;
// connect the TField objects with the actual fields
BindFields (True);
for i := 0 to FieldCount-1 do
begin
Field := Fields[i];
if (Field.DataType = ftFloat) and (Integer(FFileDecimals[i])>0) then
begin
d := '0.';
for j := 1 to Integer(FFileDecimals[i]) do
d := d + '0';
(Field as TFloatField).DisplayFormat := d;
end;
end;
// get the number of records and check size
fRecordCount := fDBFHeader.NumberOfRecords;
// everything OK: table is now open
FIsTableOpen := True;
// ShowMessage ('InternalOpen: RecCount: ' + IntToStr (FRecordCount));
end;
// Returns the Type of the field
function TDBF.FFieldType(F : char):TFieldType;
begin
if F = 'C' then
FFieldType := ftString
else if (F = 'N') or (F = 'F') then
FFieldType := ftFloat
else if F = 'L' then
FFieldType := ftBoolean
else if F = 'D' then
FFieldType := ftDate
// FFieldType := ftString
else
FFieldType := ftUnknown;
end;
function TDBF.FFieldSize(FType:char;FWidth:integer):integer;
begin
if FType = 'C' then
FFieldSize := FWidth
else if (FType = 'N') or (FType = 'F') then
FFieldSize := 0
else if FType = 'L' then
FFieldSize := 0
else if FType = 'D' then
FFieldSize := 0
// FFieldSize := 8
else
FFieldSize := 0;
end;
// ____________________________________________________________________________
// TDBF.InternalInitFieldDefs
// I: define the fields
procedure TDBF.InternalInitFieldDefs;
var
Il : Integer;
TmpFileOffset : Integer;
NumberOfFields : integer;
Fld : TDBFField;
FldName : PChar;
begin
FieldDefs.Clear;
FStream.Seek(SizeOf(TDbfHeader),soFromBeginning);
NumberOfFields := ((fDbfHeader.BytesInHeader-sizeof(DbfHeader))div 32);
if not (assigned(FFileOffset)) then
FFileOffset := TList.Create;
FFileOffset.Clear;
if not (assigned(FFileWidth)) then
FFileWidth := TList.Create;
FFileWidth.Clear;
if not (assigned(FFileDecimals)) then
FFileDecimals := TList.Create;
FFileDecimals.Clear;
TmpFileOffset := 0;
if (NumberOfFields>0) then
begin
for Il:=0 to NumberOfFields-1 do
begin
FStream.Read(Fld,SizeOf(Fld));
GetMem(FldName,Length(Fld.FieldName)+1);
CharToOem(PChar(@Fld.FieldName),FldName);
TFieldDef.Create(FieldDefs, FldName,FFieldType(Fld.FieldType){DescribF.DataType},
FFieldSize(Fld.FieldType,Fld.Width){DescribF.Size},False,Il+1);
FreeMem(FldName);
FFileOffset.Add(Pointer(TmpFileOffset));
FFileWidth.Add(Pointer(Fld.Width));
FFileDecimals.Add(Pointer(Fld.Decimals));
Inc(tmpFileOffset,Fld.Width);
end;
fRecordSize := tmpFileOffset+FrecordHeaderSize;
FStartData := FStream.Position+1;
end;
end;
// ____________________________________________________________________________
// TDBF.InternalClose
// I: close the table/file
procedure TDBF.InternalClose;
begin
// if required, save updated header
if (fDBFHeader.NumberOfRecords <> fRecordCount) or
(fDBFHeader.BytesInRecords = 0) then
BEGIN
fDBFHeader.BytesInRecords := fRecordSize;
fDBFHeader.NumberOfRecords := fRecordCount;
WriteHeader;
END;
// disconnet field objects
BindFields(False);
// destroy field object (if not persistent)
if DefaultFields then
DestroyFields;
// free the internal list field offsets
if Assigned(FFileOffset) then
FFileOffset.Free;
FFileOffset := nil;
if Assigned(FFileWidth) then
FFileWidth.Free;
FFileWidth := nil;
if Assigned(FFileDecimals) then
FFileDecimals.Free;
FFileDecimals := nil;
FCurrentRecord := -1;
// close the file
FIsTableOpen := False;
FStream.Free;
FStream := nil;
end;
// ____________________________________________________________________________
// TDBF.IsCursorOpen
// I: is table open
function TDBF.IsCursorOpen: Boolean;
begin
Result := FIsTableOpen;
end;
// ____________________________________________________________________________
// TDBF.WriteHeader
procedure TDBF.WriteHeader;
begin
// Assert(FStream<>nil,'fStream=Nil');
if fStream <> nil then
begin
FSTream.Seek(0,soFromBeginning);
FStream.WriteBuffer(fDBFHeader,SizeOf(TDbfHeader));
end;
end;
// ____________________________________________________________________________
// TDBF.Create
constructor TDBF.Create(AOwner:tComponent);
BEGIN
inherited create(aOwner);
fRecordHeaderSize := SizeOf(tRecordHeader);
END;
// ____________________________________________________________________________
// TDBF.CreateTable
// I: Create a new table/file
procedure TDBF.CreateTable;
var
Ix : Integer;
// DescribF : TBDescribField;
Offs : Integer;
Fld : TDbfField;
FldName : PChar;
i : integer;
begin
CheckInactive;
// InternalInitFieldDefs;
// create the new file
if FileExists (FTableName) and
(MessageDlg ('File ' + FTableName +
' already exists. OK to override?',
mtConfirmation, [mbYes, mbNo], 0) = mrNo) then
Exit;
if FieldDefs.Count = 0 then
begin
for Ix := 0 to FieldCount - 1 do
begin
with Fields[Ix] do
begin
if FieldKind = fkData then
FieldDefs.Add(FieldName,DataType,Size,Required);
end;
end;
end;
FStream := TFileStream.Create (FTableName,
fmCreate or fmShareExclusive);
try
FillChar(fDBFHeader,SizeOf(TDbfHeader),0);
fDBFHeader.BytesInRecords := 0; // filled later
fDBFHeader.NumberOfRecords := 0; // empty
WriteHeader;
Offs:=0;
for Ix:=0 to FieldDefs.Count-1 do
begin
with FieldDefs.Items[Ix] do
begin
FillChar(Fld,SizeOf(TDbfField),#0);
Fld.FieldType := 'C';
Fld.Width := Size;
GetMem(FldName,SizeOf(FieldDefs.Items[Ix].Name));
OemToChar(PChar(FieldDefs.Items[Ix].Name),FldName);
for i := 1 to Length(FldName) do
Fld.FieldName[i] := FldName[i];
Fld.FieldName[Length(FldName)+1] := #0;
FreeMem(FldName);
Inc(Offs,Fld.Width);
FStream.Write(Fld,SizeOf(TDbfField));
end;
end;
fStartData := FStream.Position;
fDBFHeader.BytesInRecords := Offs;
FRecordSize := Offs+FRecordHeaderSize;
WriteHeader;
finally
// close the file
fStream.Free;
fStream := nil;
end;
end;
// ____________________________________________________________________________
// TDBF.PackTable
//Enhancement: Remove all deleted items from the table.
Procedure TDBF.PackTable;
var
NewStream, OldStream : tStream;
PC : PChar;
Ix : Integer;
// DescribF : TBDescribField;
NewDataFileHeader : tDBFHeader;
DataBuffer : Pointer;
NumberOfFields : integer;
Fld : TDBFField;
BEGIN
OldStream := Nil;
NewStream := Nil;
CheckInactive;
// if Active then
// raise eBinaryDataSetError.Create ('Dataset must be closed before packing.');
if fTableName = '' then
raise EDBFError.Create('Table name not specified.');
if not FileExists (FTableName) then
raise EDBFError.Create('Table '+fTableName+' does not exist.');
PC := @fTablename[1];
CopyFile(PChar(PC),PChar(PC+',old'+#0),False);
// create the new file
if FieldDefs.Count = 0 then
begin
for Ix := 0 to FieldCount - 1 do
begin
with Fields[Ix] do
begin
if FieldKind = fkData then
FieldDefs.Add(FieldName,DataType,Size,Required);
end;
end;
end;
TRY
NewStream := TFileStream.Create (FTableName+',new',
fmCreate or fmShareExclusive);
OldStream := tFileStream.Create (fTableName+',old',
fmOpenRead or fmShareExclusive);
OldStream.ReadBuffer(NewDataFileHeader,SizeOf(TDbfHeader));
NewStream.WriteBuffer(NewDataFileHeader,SizeOf(TDbfHeader));
NumberOfFields := ((NewDataFileHeader.BytesInHeader-sizeof(TDbfHeader))div 32);
for IX := 0 to NumberOfFields do
BEGIN
OldStream.Read(Fld,SizeOf(TDbfField));
NewStream.Write(Fld,SizeOf(TDbfField));
END;
GetMem(DataBuffer,NewDataFileHeader.BytesInRecords);
REPEAT
IX := OldStream.Read(DataBuffer^,NewDataFileHeader.BytesInRecords);
if (IX = NewDataFileHeader.BytesInRecords) and (pRecordHeader(DataBuffer)^.DeletedFlag <> '*') then
NewStream.WRite(DataBuffer^,NewDataFileHeader.BytesInRecords);
Until IX <> NewDataFileHeader.BytesInRecords;
FreeMem(DataBuffer,NewDataFileHeader.BytesInRecords);
finally
// close the file
NewStream.Free;
OldStream.Free;
end;
CopyFile(PChar(PC+',new'+#0),PChar(PC),False);
DeleteFile(Pchar(PC+',new'+#0));
DeleteFile(Pchar(PC+',old'+#0));
END;
// ____________________________________________________________________________
// TDBF._SwapRecords
// Enhancement: Quick swap of two records. Used primarily for sorting.
Procedure TDBF._SwapRecords(Rec1,REc2:Integer);
VAR
Buffer1, Buffer2 : PChar;
Bookmark1, BOokmark2 : TBookmarkFlag;
BEGIN
Rec1 := Rec1 - 1;
Rec2 := Rec2 - 1;
if Rec1 < 0 then Exit;
if Rec2 < 0 then Exit;
Buffer1 := AllocRecordBuffer;
Buffer2 := AllocRecordBuffer;
_ReadRecord(Buffer1,Rec1);
_ReadRecord(Buffer2,Rec2);
Bookmark1 := GetBookmarkFlag(Buffer1);
Bookmark2 := GetBookmarkFlag(Buffer2);
SetBookmarkFlag(Buffer1,Bookmark2);
SetBookmarkFlag(Buffer2,Bookmark1);
_WriteRecord(Buffer1,Rec2);
_WriteRecord(Buffer2,Rec1);
StrDispose(Buffer1);
StrDispose(Buffer2);
END;
// ____________________________________________________________________________
// TDBF._CompareRecords
// Compare two records. Returns -1 if REC1 < REC2, 0 if REC1 = REC2, or
// 1 if REC1 > REC2.
Function TDBF._CompareRecords(SortFields:Array of String;Rec1,Rec2:Integer):Integer; FAR;
{-Compare the records Rec1, Rec2 and return -1 if Rec1 < Rec2, 0 if Rec1 = Rec2,
1 if Rec1 > Rec2 }
VAR
IX : Integer;
Function CompareHelper(KeyId:String;Rec1,Rec2:Integer):Integer;
VAR
SKey1, SKey2 : String;
IKey1, IKey2 : Integer;
fKey1, fKey2 : Double;
dKey1, dKey2 : tDateTime;
CompareType : tFieldType;
KeyField : tField;
BEGIN
KeyField := FieldByName(KeyID);
CompareType := KeyField.DataType;
Case CompareType of
ftFloat,
ftCurrency,
ftBCD :
BEGIN
_ReadRecord(ActiveBuffer,Rec1-1);
fKey1 := KeyField.AsFloat;
_ReadRecord(ActiveBuffer,Rec2-1);
fKey2 := KeyField.AsFloat;
if fKey1 < fKey2 then
Result := -1
else
if fKey1 > fKey2 then
Result := 1
else
Result := 0;
END;
ftSmallInt,
ftInteger,
ftWord :
BEGIN
_ReadRecord(ActiveBuffer,Rec1-1);
IKey1 := KeyField.AsInteger;
_ReadRecord(ActiveBuffer,Rec2-1);
IKey2 := KeyField.AsInteger;
if IKey1 < IKey2 then
Result := -1
else
if IKey1 > IKey2 then
Result := 1
else
Result := 0;
END;
ftDate,
ftTime,
ftDateTime :
BEGIN
_ReadRecord(ActiveBuffer,Rec1-1);
dKey1 := KeyField.AsDateTime;
_ReadRecord(ActiveBuffer,Rec2-1);
dKey2 := KeyField.AsDateTime;
if dKey1 < dKey2 then
Result := -1
else
if dKey1 > dKey2 then
Result := 1
else
Result := 0;
END;
else
BEGIN
_ReadRecord(ActiveBuffer,Rec1-1);
SKey1 := KeyField.AsString;
_ReadRecord(ActiveBuffer,Rec2-1);
SKey2 := KeyField.AsString;
if SKey1 < SKey2 then
Result := -1
else
if SKey1 > SKey2 then
Result := 1
else
Result := 0;
END;
END;
END;
BEGIN
IX := 0;
REPEAT // Loop through all available sortfields until not equal or no more sort fiels.
Result := CompareHelper(SortFields[IX],Rec1,Rec2);
Inc(IX);
UNTIL (Result <> 0) or (IX > High(SortFields));
END;
// ____________________________________________________________________________
// TDBF.SortTable
// Enhancement: Sort the table by the fields passed.
Procedure TDBF.SortTable(SortFields : Array of String);
{ This is the main sorting routine. It is passed the number of elements and the
two callback routines. The first routine is the function that will perform
the comparison between two elements. The second routine is the procedure that
will swap two elements if necessary } // Source: UNDU #8
procedure QSort(uNElem: Integer);
{ uNElem - number of elements to sort }
procedure qSortHelp(pivotP: Integer; nElem: word);
label
TailRecursion,
qBreak;
var
leftP, rightP, pivotEnd, pivotTemp, leftTemp: word;
lNum: Integer;
retval: integer;
begin
TailRecursion:
if (nElem <= 2) then
begin
if (nElem = 2) then
begin
rightP := pivotP +1;
if (_CompareRecords(SortFields,pivotP, rightP) > 0) then
_SwapRecords(pivotP, rightP);
end;
exit;
end;
rightP := (nElem -1) + pivotP;
leftP := (nElem shr 1) + pivotP;
{ sort pivot, left, and right elements for "median of 3" }
if (_CompareRecords(SortFields,leftP, rightP) > 0) then _SwapRecords(leftP, rightP);
if (_CompareRecords(SortFields,leftP, pivotP) > 0) then _SwapRecords(leftP, pivotP)
else if (_CompareRecords(SortFields,pivotP, rightP) > 0) then _SwapRecords(pivotP, rightP);
if (nElem = 3) then
begin
_SwapRecords(pivotP, leftP);
exit;
end;
{ now for the classic Horae algorithm }
pivotEnd := pivotP + 1;
leftP := pivotEnd;
repeat
retval := _CompareRecords(SortFields,leftP, pivotP);
while (retval <= 0) do
begin
if (retval = 0) then
begin
_SwapRecords(LeftP, PivotEnd);
Inc(PivotEnd);
end;
if (leftP < rightP) then
Inc(leftP)
else
goto qBreak;
retval := _CompareRecords(SortFields,leftP, pivotP);
end; {while}
while (leftP < rightP) do
begin
retval := _CompareRecords(SortFields,pivotP, rightP);
if (retval < 0) then
Dec(rightP)
else
begin
_SwapRecords(leftP, rightP);
if (retval <> 0) then
begin
Inc(leftP);
Dec(rightP);
end;
break;
end;
end; {while}
until (leftP >= rightP);
qBreak:
if (_CompareRecords(SortFields,leftP, pivotP) <= 0) then Inc(leftP);
leftTemp := leftP -1;
pivotTemp := pivotP;
while ((pivotTemp < pivotEnd) and (leftTemp >= pivotEnd)) do
begin
_SwapRecords(pivotTemp, leftTemp);
Inc(pivotTemp);
Dec(leftTemp);
end; {while}
lNum := (leftP - pivotEnd);
nElem := ((nElem + pivotP) -leftP);
if (nElem < lNum) then
begin
qSortHelp(leftP, nElem);
nElem := lNum;
end
else
begin
qSortHelp(pivotP, lNum);
pivotP := leftP;
end;
goto TailRecursion;
end; {qSortHelp }
begin
if (uNElem < 2) then exit; { nothing to sort }
qSortHelp(1, uNElem);
end; { QSort }
BEGIN
CheckActive;
if fReadOnly then
raise eDBFError.Create ('Dataset must be opened for read/write to perform sort.');
// if fDataFileHeader.DeletedCount > 0 then
// BEGIN
// Close;
// PackTable;
// Open;
// END;
QSort(FRecordCount {+ fDeletedCount});
First;
END;
// ____________________________________________________________________________
// TDBF.UnsortTable
// Used to help test the sort routine. Attempts to generate a random
// dispersment of the records in the dataset.
Procedure TDBF.UnsortTable;
Var
IX : Integer;
BEGIN
First;
Randomize;
for IX := 0 to RecordCOunt do
BEGIN
_SwapRecords(IX,Random(RecordCount+1));
END;
First;
END;
////////////////////////////////////////
////// Part II:
////// Bookmarks management and movement
////////////////////////////////////////
// ____________________________________________________________________________
// TDBF.InternalGotoBookmark
// II: set the requested bookmark as current record
procedure TDBF.InternalGotoBookmark (Bookmark: Pointer);
var
ReqBookmark: Integer;
begin
ReqBookmark := PInteger (Bookmark)^;
// ShowMessage ('InternalGotoBookmark: ' +
// IntToStr (ReqBookmark));
if (ReqBookmark >= 0) and (ReqBookmark < FRecordCount {+ fDeletedCount}) then
FCurrentRecord := ReqBookmark
else
raise eDBFError.Create ('Bookmark ' +
IntToStr (ReqBookmark) + ' not found');
end;
// ____________________________________________________________________________
// TDBF.InternalSetToRecord
// II: same as above (but passes a buffer)
procedure TDBF.InternalSetToRecord (Buffer: PChar);
var
ReqBookmark: Integer;
begin
// ShowMessage ('InternalSetToRecord');
ReqBookmark := PRecInfo(Buffer + FRecordInfoOffset).Bookmark;
InternalGotoBookmark (@ReqBookmark);
end;
// ____________________________________________________________________________
// TDBF.GetBookmarkFlag
// II: retrieve bookmarks flags from buffer
function TDBF.GetBookmarkFlag (
Buffer: PChar): TBookmarkFlag;
begin
// ShowMessage ('GetBookmarkFlag');
Result := PRecInfo(Buffer + FRecordInfoOffset).BookmarkFlag;
end;
// ____________________________________________________________________________
// TDBF.SetBookmarkFlag
// II: change the bookmark flags in the buffer
procedure TDBF.SetBookmarkFlag (Buffer: PChar;
Value: TBookmarkFlag);
begin
// ShowMessage ('SetBookmarkFlag');
PRecInfo(Buffer + FRecordInfoOffset).BookmarkFlag := Value;
end;
// ____________________________________________________________________________
// TDBF.GetBookmarkData
// II: read the bookmark data from record buffer
procedure TDBF.GetBookmarkData (
Buffer: PChar; Data: Pointer);
begin
// ShowMessage ('GetBookmarkData: ' + IntToStr (PRecInfo(Buffer + FRecordInfoOffset).Bookmark));
PInteger(Data)^ :=
PRecInfo(Buffer + FRecordInfoOffset).Bookmark;
end;
// ____________________________________________________________________________
// TDBF.SetBookmarkData
// II: set the bookmark data in the buffer
procedure TDBF.SetBookmarkData (
Buffer: PChar; Data: Pointer);
begin
// ShowMessage ('SetBookmarkData: ' + IntToStr (PInteger(Data)^));
PRecInfo(Buffer + FRecordInfoOffset).Bookmark :=
PInteger(Data)^;
end;
// ____________________________________________________________________________
// TDBF.InternalFirst
// II: Go to a special position before the first record
procedure TDBF.InternalFirst;
begin
FCurrentRecord := BofCrack;
end;
// ____________________________________________________________________________
// TDBF.InternalLast
// II: Go to a special position after the last record
procedure TDBF.InternalLast;
begin
EofCrack := FRecordCount {+ fDeletedCount};
FCurrentRecord := EofCrack;
end;
// ____________________________________________________________________________
// TDBF.GetRecordCount
// II (optional): Record count
function TDBF.GetRecordCount: Longint;
begin
CheckActive;
Result := FRecordCount;
end;
// ____________________________________________________________________________
// TDBF.GetRecNo
// II (optional): Get the number of the current record
function TDBF.GetRecNo: Longint;
begin
UpdateCursorPos;
if FCurrentRecord < 0 then
Result := 1
else
Result := FCurrentRecord + 1;
end;
// ____________________________________________________________________________
// TDBF.SetRecNo
// II (optional): Move to the given record number
procedure TDBF.SetRecNo(Value: Integer);
begin
CheckBrowseMode;
if (Value > 1) and (Value <= (FRecordCount{+FDeletedCount})) then
begin
FCurrentRecord := Value - 1;
Resync([]);
end;
end;
//////////////////////////////////////////
////// Part III:
////// Record buffers and field management
//////////////////////////////////////////
// ____________________________________________________________________________
// TDBF.GetRecordSize
/// III: Determine the size of each record buffer in memory
function TDBF.GetRecordSize: Word;
begin
Result := FRecordSize; // data only
end;
// ____________________________________________________________________________
// TDBF.AllocRecordBuffer
/// III: Allocate a buffer for the record
function TDBF.AllocRecordBuffer: PChar;
begin
Result := StrAlloc(FRecordBufferSize+1);
end;
// ____________________________________________________________________________
// TDBF.InternalInitRecord
// III: Initialize the record (set to zero)
procedure TDBF.InternalInitRecord(Buffer: PChar);
(*var
Field : TField;
i : integer;
FieldOffset : integer;
S : string; *)
begin
FillChar(Buffer^, FRecordBufferSize, 32);
(* for i := 0 to FieldCount-1 do
begin
Field := Fields[i];
FieldOffset := Integer(FFileOffset[Field.FieldNo-1])+FRecordHeaderSize;
if Field.DataType = ftString then
begin
pChar(Buffer+FieldOffset)^ := #0;
end
else if Field.DataType = ftFloat then
begin
pChar(Buffer+FieldOffset)^ := '0';
pChar(Buffer+FieldOffset+1)^ := #0;
end
else if Field.DataType = ftDate then
begin
S := '19900101';
CopyMemory(PChar(Buffer+FieldOffset),PChar(S),8);
end
else if Field.DataType = ftBoolean then
begin
pChar(Buffer+FieldOffset)^ := 'F';
end;
end; *)
end;
// ____________________________________________________________________________
// TDBF.FreeRecordBuffer
// III: Free the buffer
procedure TDBF.FreeRecordBuffer (var Buffer: PChar);
begin
StrDispose(Buffer);
end;
// ____________________________________________________________________________
// TDBF.GetRecord
// III: Retrieve data for current, previous, or next record
// (eventually moving to it) and return the status
function TDBF.GetRecord(Buffer: PChar;
GetMode: TGetMode; DoCheck: Boolean): TGetResult;
var
Acceptable : Boolean;
begin
result := grOk;
if FRecordCount < 1 then
Result := grEOF
else
repeat
case GetMode of
gmCurrent :
begin
// ShowMessage ('GetRecord Current');
if (FCurrentRecord >= FRecordCount{+fDeletedCount}) or
(FCurrentRecord < 0) then
Result := grError;
end;
gmNext :
begin
if (fCurrentRecord < (fRecordCount{+fDeletedCount})-1) then
Inc (FCurrentRecord)
else
Result := grEOF;
end;
gmPrior :
begin
if (fCurrentRecord > 0) then
Dec(fCurrentRecord)
else
Result := grBOF;
end;
end;
// fill record data area of buffer
if Result = grOK then
begin
_ReadRecord(Buffer, fCurrentRecord );
{FStream.Position := FDataFileHeader.StartData +
FRecordSize * FCurrentRecord;
FStream.ReadBuffer (Buffer^, FRecordSize);}
ClearCalcFields(Buffer);
GetCalcFields(Buffer);
with PRecInfo(Buffer + FRecordInfoOffset)^ do
begin
BookmarkFlag := bfCurrent;
Bookmark := FCurrentRecord;
end;
end
else
if (Result = grError) and DoCheck then
raise eDBFError.Create('GetRecord: Invalid record');
Acceptable := pRecordHeader(Buffer)^.DeletedFlag <> '*';
if Filtered then
Acceptable := Acceptable and (_ProcessFilter(Buffer));
if (GetMode=gmCurrent) and Not Acceptable then
Result := grError;
until (Result <> grOK) or Acceptable;
if ((Result=grEOF)or(Result=grBOF)) and Filtered and not (_ProcessFilter(Buffer)) then
Result := grError;
end;
// ____________________________________________________________________________
// TDBF.InternalPost
// III: Write the current data to the file
procedure TDBF.InternalPost;
begin
CheckActive;
if State = dsEdit then
begin
// replace data with new data
{FStream.Position := FDataFileHeader.StartData + (FRecordSize * FCurrentRecord);
FStream.WriteBuffer (ActiveBuffer^, FRecordSize);}
_WriteRecord (ActiveBuffer, fCurrentRecord);
end
else
begin
// always append
InternalLast;
{FStream.Seek (0, soFromEnd);
FStream.WriteBuffer (ActiveBuffer^, FRecordSize);}
pRecordHeader(ActiveBuffer)^.DeletedFlag := ' ';
_AppendRecord(ActiveBuffer);
Inc (FRecordCount);
end;
end;
// ____________________________________________________________________________
// TDBF.InternalAddRecord
// III: Add the current data to the file
procedure TDBF.InternalAddRecord(Buffer:Pointer; Append:Boolean);
begin
// always append
InternalLast;
// add record at the end of the file
{FStream.Seek (0, soFromEnd);}
pRecordHeader(ActiveBuffer)^.DeletedFlag := ' ';
_AppendRecord(ActiveBuffer);
{FStream.WriteBuffer (ActiveBuffer^, FRecordSize);}
Inc (FRecordCount);
end;
// ____________________________________________________________________________
// TDBF.InternalDelete
// III: Delete the current record
procedure TDBF.InternalDelete;
begin
CheckActive;
// not supported in this version
{ raise eBinaryDataSetError.Create (
'Delete: Operation not supported');}
// pRecordHeader(ActiveBuffer)^.DeletedFlag := fDataFileHeader.LastDeleted;
PChar(ActiveBuffer)^ := '*';
_WriteRecord(ActiveBuffer,fCurrentRecord);
{FStream.Position := FDataFileHeader.StartData + (FRecordSize * FCurrentRecord);
FStream.WriteBuffer (ActiveBuffer^, FRecordSize);}
// fDBFHeader.LastDeleted := GetRecNo;
// Inc(fDeletedCount);
// Dec(fRecordCount);
// fDBFHeader.NumberOfRecords := fRecordCount;
// WriteHeader;
Resync([]);
end;
// ____________________________________________________________________________
// TDBF.GetFieldData
// III: Move data from record buffer to field
function TDBF.GetFieldData(Field:TField; Buffer:Pointer):Boolean;
var
FieldOffset: Integer;
S : string;
Buf2 : PChar;
i,l : integer;
D : Double;
n : integer;
T : TDateTime;
j : integer;
OldDateFormat : string;
begin
Result := False;
Buf2 := ActiveBuffer;
if (FRecordCount>0) and (Field.FieldNo > 0) and (Assigned(Buffer)) and (Assigned(Buf2)) then
begin
FieldOffset := Integer(FFileOffset[Field.FieldNo-1])+FRecordHeaderSize;
if Field.DataType = ftString then
begin
l := Integer(FFileWidth[Field.FieldNo-1]);
S := '';
i := 0;
While (Buf2[FieldOffset+i] <> #0) and (i 0) and (DecimalSeparator <> '.') then
S[Pos('.',S)] := DecimalSeparator;
Result := True;
try
D := StrToFloat(S);
except
D := 0;
Result := False;
end;
PDouble(Buffer)^ := D;
end;
end
else if Field.DataType = ftDate then
begin
S := '';
for j := 0 to 7 do
S := S + pChar(Buf2+FieldOffset+j);
SetLength(S,8);
if (trim(S) = '') or (S='00000000') then
Result := false
else
begin
S := Copy(S,7,2)+DateSeparator+Copy(S,5,2)+DateSeparator+Copy(S,1,4);
OldDateFormat := ShortDateFormat;
ShortDateFormat := 'dd/mm/yyyy';
t := StrToDate(S);
ShortDateFormat := OldDateFormat;
j := Trunc(pDouble(@t)^)+693594;
pInteger(Buffer)^ := j;
result := True;
end;
end
else if Field.DataType = ftBoolean then
begin
Result := True;
if PChar(Buf2+FieldOffset)^ in ['S','T','Y'] then
pBoolean(Buffer)^ := True
else if PChar(Buf2+FieldOffset)^ in ['N','F'] then
pBoolean(Buffer)^ := False
else
Result := False;
end
else
begin
ShowMessage ('very bad error in get field data');
Result := False;
end;
end;
end;
// ____________________________________________________________________________
// TDBF.SetFieldData
// III: Move data from field to record buffer
procedure TDBF.SetFieldData(Field: TField; Buffer: Pointer);
var
FieldOffset: Integer;
Buf2 : PChar;
l,i,n:integer;
S : string;
D : TDateTime;
j : integer;
begin
Buf2 := ActiveBuffer;
if (Field.FieldNo >= 0) and (Assigned(Buffer)) and (Assigned(Buf2)) then
begin
FieldOffset := Integer(FFileOffset[Field.FieldNo-1])+FRecordHeaderSize;
if Field.DataType = ftString then
begin
l := Integer(FFileWidth[Field.FieldNo-1]);
S := '';
i := 0;
While (PChar(Buffer)[i] <> #0) and (i 0) and (DecimalSeparator <> '.') then
S[Pos(DecimalSeparator,S)] := '.';
CopyMemory(Pchar(Buf2+FieldOffset),PChar(S),n);
end
else if Field.DataType = ftDate then
begin
j := pInteger(Buffer)^-693594;
pDouble(@d)^ := j;
S := FormatDateTime('yyyymmdd',d);
StrLCopy(pChar(Buf2+FieldOffset),pChar(S),8);
end
else if Field.DataType = ftBoolean then
begin
if pBoolean(Buffer)^ then
PChar(Buf2+FieldOffset)^ := 'T'
else
PChar(Buf2+FieldOffset)^ := 'F';
end
else
ShowMessage ('very bad error in setfield data');
DataEvent (deFieldChange, Longint(Field));
end;
end;
// ____________________________________________________________________________
// TDBF.InternalHandleException
// default exception handling
procedure TDBF.InternalHandleException;
begin
// standard exception handling
Application.HandleException(Self);
end;
Function TDBF._ProcessFilter(Buffer:PChar):boolean;
var
FilterExpresion : string;
PosComp : integer;
FName : string;
FieldPos : integer;
FieldOffset : integer;
FieldValue : Variant;
TestValue : Variant;
FieldText : string;
OldShortDateFormat : string;
begin
FilterExpresion := Filter;
PosComp := Pos('>',FilterExpresion);
if PosComp=0 then
PosComp := Pos('<',FilterExpresion);
if PosComp=0 then
PosComp := Pos('=',FilterExpresion);
if PosComp=0 then
begin
_ProcessFilter := True;
Exit;
end;
FName := Trim(Copy(FilterExpresion,1,PosComp-1));
FieldPos := FieldDefs.IndexOf(FName);
FieldOffset := integer(FFileOffset[FieldPos]);
if FieldPos < 0 then
_ProcessFilter := True
else if FieldDefs.Items[FieldPos].DataType = ftString then
begin // STRING
try
FieldValue := '';
FieldOffset := FieldOffset+1;
While (Buffer[FieldOffset]<>#0) and (Length(FieldValue)=Copy(TestValue,2,(Length(TestValue)-1)))
else
_ProcessFilter := (FieldValue>TestValue);
end
else if FilterExpresion[PosComp]='<' then
begin
if FilterExpresion[PosComp+1]='=' then
_ProcessFilter := (FieldValue<=Copy(TestValue,2,(Length(TestValue)-1)))
else
_ProcessFilter := (FieldValue#0) and (Length(FieldText)0 then
FieldText[Pos('.',FieldText)] := DecimalSeparator;
FieldValue := StrToFloat(FieldText);
if FilterExpresion[PosComp+1]='='then
FieldText := Trim(Copy(FilterExpresion,PosComp+2,Length(FilterExpresion)-PosComp-1))
else
FieldText := Trim(Copy(FilterExpresion,PosComp+1,Length(FilterExpresion)-PosComp));
if Pos('.',FieldText)>0 then
FieldText[Pos('.',FieldText)] := DecimalSeparator;
TestValue := StrToFloat(FieldText);
if FilterExpresion[PosComp]='=' then
_ProcessFilter := (FieldValue=TestValue)
else if FilterExpresion[PosComp]='>'then
begin
if FilterExpresion[PosComp+1]='='then
_ProcessFilter := (FieldValue>=TestValue)
else
_ProcessFilter := (FieldValue>TestValue);
end
else if FilterExpresion[PosComp]='<'then
begin
if FilterExpresion[PosComp+1]='='then
_ProcessFilter := (FieldValue<=TestValue)
else
_ProcessFilter := (FieldValue#0) and (Length(FieldText)=TestValue)
else
_ProcessFilter := (FieldValue>TestValue);
end
else if FilterExpresion[PosComp]='<' then
begin
if FilterExpresion[PosComp+1]='='then
_ProcessFilter := (FieldValue<=TestValue)
else
_ProcessFilter := (FieldValue