DBF - acessar dbf sem bde

Top Previous Next

sunit DBF;

(* ===========================================================================

* dbf.dcu - tDBF : A custom data set which uses a flat binary

* structured datafile for single client usage only.

* Author: Horacio Jamilis

* ===========================================================================

* 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;

// 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;

// ____________________________________________________________________________

// 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;

// ____________________________________________________________________________

// 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;

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;

fStartData := FStream.Position;

fDBFHeader.BytesInRecords := Offs;

FRecordSize := Offs+FRecordHeaderSize;

WriteHeader;

finally

// close the file

fStream.Free;

fStream := nil;

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;

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;

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;

//////////////////////////////////////////

////// 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;

// 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;

// ____________________________________________________________________________

// 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<l) do

begin

S := S+pChar(Buf2+FieldOffset+i)^;

inc(i);

end;

SetLength(S,l);

S := Trim(S);

CharToOemBuff(PChar(S), Buffer,l);

Result := True;

end

else if Field.DataType = ftFloat then

begin

n := Integer(FFileWidth[Field.FieldNo-1]);

S := '';

for i := FieldOffset to FieldOffset+n-1 do

S := S+pChar(Buf2+i)^;

S := Trim(S);

if S='' then

Result := False

else

begin

if (Pos('.',S) > 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;

// ____________________________________________________________________________

// 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<l) do

begin

S := S+PChar(Buffer)[i];

inc(i);

end;

SetLength(S,l);

OemToCharBuff(PChar(S),PChar(Buf2+FieldOffset),l);

end

else if Field.DataType = ftFloat then

begin

n := Integer(FFileWidth[Field.FieldNo-1]);

Str(pDouble(Buffer)^:n:Integer(FFileDecimals[Field.FieldNo-1]),S);

while Length(S)<n do

S := ' '+S;

if (Pos(DecimalSeparator,S) > 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;

// ____________________________________________________________________________

// 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)<integer(FFileWidth[FieldPos])) do

begin

FieldValue := FieldValue + Buffer[FieldOffset];

FieldOffset := FieldOffset+1;

end;

FieldValue := Trim(FieldValue);

TestValue := Trim(Copy(FilterExpresion,PosComp+2,Length(FilterExpresion)-PosComp-2));

if FilterExpresion[PosComp]='=' then

_ProcessFilter := (FieldValue=TestValue)

else if FilterExpresion[PosComp]='>' then

begin

if FilterExpresion[PosComp+1]='=' then

_ProcessFilter := (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<TestValue);

end

else

_ProcessFilter := False;

except

_ProcessFilter := False;

end;

end

else if FieldDefs.Items[FieldPos].DataType = ftFloat then

begin // FLOAT

try

FieldText := '';

FieldOffset := FieldOffset+1;

While (Buffer[FieldOffset]<>#0) and (Length(FieldText)<integer(FFileWidth[FieldPos])) do

begin

FieldText := FieldText + Buffer[FieldOffset];

FieldOffset := FieldOffset+1;

end;

FieldText := Trim(FieldText);

if Pos('.',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<TestValue);

end

else

_ProcessFilter := False;

except

_ProcessFilter := False;

end;

end

else if FieldDefs.Items[FieldPos].DataType = ftDate then

begin // DATE

OldShortDateFormat := ShortDateFormat;

try

FieldText := '';

FieldOffset := FieldOffset+1;

While (Buffer[FieldOffset]<>#0) and (Length(FieldText)<integer(FFileWidth[FieldPos])) do

begin

FieldText := FieldText + Buffer[FieldOffset];

FieldOffset := FieldOffset+1;

end;

FieldText := Trim(FieldText);

FieldText := Copy(FieldText,1,4)+DateSeparator+Copy(FieldText,5,2)+DateSeparator+Copy(FieldText,7,2);

ShortDateFormat := 'yyyy/mm/dd';

FieldValue := StrToDate(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));

FieldText := Copy(FieldText,1,4)+DateSeparator+Copy(FieldText,5,2)+DateSeparator+Copy(FieldText,7,2);

TestValue := StrToDate(FieldText);

if FilterExpresion[PosComp]='=' then

begin

_ProcessFilter := (FieldValue=TestValue);

end

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<TestValue);

end

else

_ProcessFilter := False;

except

_ProcessFilter := False;

end;

ShortDateFormat := OldShortDateFormat;

end

else

_ProcessFilter := False;

end;

{******************************************************************************}

{* Property Editors Code *}

{******************************************************************************}

procedure TFilenameProperty.Edit;

var

FileOpen: TOpenDialog;

begin

FileOpen := TOpenDialog.Create(Nil);

FileOpen.Filename := GetValue;

FileOpen.Filter := 'dBase Files (*.DBF)|*.DBF|All Files (*.*)|*.*';

FileOpen.Options := FileOpen.Options + [ofPathMustExist, ofFileMustExist];

try

if FileOpen.Execute then SetValue(FileOpen.Filename);

finally

FileOpen.Free;

end;

function TFilenameProperty.GetAttributes: TPropertyAttributes;

begin

Result := [paDialog, paRevertable];

end;

procedure Register;

begin

RegisterComponents('Terabyte', [TDBF]);

RegisterPropertyEditor(TypeInfo(String), TDBF, 'TableName', TFileNameProperty);

end;

end.