mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2026-01-15 23:31:38 +01:00
2900 lines
76 KiB
ObjectPascal
2900 lines
76 KiB
ObjectPascal
unit dbf;
|
||
{===============================================================================
|
||
|| TDbf Component || http://tdbf.netfirms.com ||
|
||
===============================================================================}
|
||
interface
|
||
|
||
uses
|
||
{$ifdef fpc}
|
||
SysUtils, Classes, db;
|
||
{$else}
|
||
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
|
||
Db, DsgnIntf, ExptIntf;
|
||
{$endif}
|
||
// If you got a compilation error here or asking for dsgntf.pas, then just add
|
||
// this file in your project:
|
||
// dsgnintf.pas in 'C:\Program Files\Borland\Delphi5\Source\Toolsapi\dsgnintf.pas'
|
||
|
||
const
|
||
_MAJOR_VERSION = 3;
|
||
_MINOR_VERSION = 007;
|
||
|
||
|
||
{$ifdef VER100} // Delphi 3
|
||
{$define DELPHI_3}
|
||
{$endif}
|
||
|
||
{$ifdef VER110} // CBuilder 3
|
||
{$define DELPHI_3}
|
||
{$endif}
|
||
|
||
{$ifdef unix}
|
||
DirSeparator = '/';
|
||
{$else}
|
||
DirSeparator = '\';
|
||
{$endif}
|
||
|
||
//====================================================================
|
||
// Delphi is a bit to permissive for me, I mean protected doesn't work within
|
||
// one unit. So i decided that convention:
|
||
// private member begins by '_'
|
||
// It's forbidden to access any '_something' except from the class where it
|
||
// is defined. To check that, I just have to look for '._' anywhere in the code.
|
||
//====================================================================
|
||
type
|
||
|
||
//====================================================================
|
||
//=== Common exceptions and constants
|
||
//====================================================================
|
||
EBinaryDataSetError = class (Exception);
|
||
EFieldToLongError = class (Exception);
|
||
|
||
xBaseVersion = (xBaseIII,xBaseIV,xBaseV);
|
||
|
||
//====================================================================
|
||
//=== Utility classes
|
||
//====================================================================
|
||
TPagedFile = class(TObject)
|
||
protected
|
||
Stream : TStream;
|
||
HeaderSize : Integer;
|
||
RecordSize : Integer;
|
||
_cntuse:integer;
|
||
_Filename:string;
|
||
public
|
||
constructor Create(const FileName: string; Mode: Word);
|
||
destructor Destroy; override;
|
||
|
||
procedure Release;
|
||
function CalcRecordCount:Integer;
|
||
procedure _Seek(page:Integer);
|
||
procedure ReadRecord(IntRecNum:Integer;Buffer:Pointer);
|
||
procedure WriteRecord(IntRecNum:Integer;Buffer:Pointer);
|
||
end;
|
||
//====================================================================
|
||
//=== Dbf support (first part)
|
||
//====================================================================
|
||
rDbfHdr = record
|
||
VerDBF : byte; // 0
|
||
Year : byte; // 1
|
||
Month : byte; // 2
|
||
Day : byte; // 3
|
||
RecordCount : Integer; // 4-7
|
||
FullHdrSize : word; // 8-9
|
||
RecordSize : word; // 10-11
|
||
Dummy1 : Word; // 12-13
|
||
IncTrans : byte; // 14
|
||
Encrypt : byte; // 15
|
||
Dummy2 : Integer; // 16-19
|
||
Dummy3 : array[20..27] of byte; // 20-27
|
||
MDXFlag : char; // 28
|
||
Language : char; // 29
|
||
dummy4 : word; // 30-31
|
||
end;
|
||
//====================================================================
|
||
TMyFieldInfo = class
|
||
public
|
||
FieldName:string;
|
||
Size:Integer;
|
||
Prec:Integer;
|
||
Offset:Integer;
|
||
end;
|
||
//====================================================================
|
||
TDbfFile = class(TPagedFile)
|
||
protected
|
||
_RecordBufferSize:integer;
|
||
_DataHdr : rDbfHdr;
|
||
_DbfVersion : xBaseVersion;
|
||
_MyFieldInfos: TList;
|
||
public
|
||
constructor Create(const FileName: string; Mode: Word);
|
||
destructor Destroy; override;
|
||
function RecordCount:integer;
|
||
procedure CreateFieldDefs(FieldDefs:TFieldDefs);
|
||
procedure ClearMyFieldInfos;
|
||
procedure DbfFile_CreateTable(FieldDefs:TFieldDefs);
|
||
procedure DbfFile_PackTable;
|
||
function GetFieldInfo(FieldName:string):TMyFieldInfo;
|
||
function GetFieldData(Column:Integer;DataType:TFieldType; Src,Dst: Pointer): Boolean;
|
||
procedure SetFieldData(Column:integer;DataType:TFieldType; Src,Dst: Pointer);
|
||
procedure WriteHeader;
|
||
|
||
end;
|
||
//====================================================================
|
||
//=== Index support
|
||
//====================================================================
|
||
TIndex = class;
|
||
//====================================================================
|
||
rNdxHdr = record
|
||
startpage : Integer; // 0..3
|
||
nbPage : Integer; // 4..7
|
||
keyformat: Char; //8
|
||
keytype : char; //9
|
||
dummy : Word; // 10..11
|
||
keylen : Word; // 12..13
|
||
nbkey : Word; // 14..15
|
||
skeytype : Word; // 16..17
|
||
keyreclen : Word; // 18..19
|
||
dummy2 : Word; // 20..21
|
||
dummy3 : Byte; // 22
|
||
Unique : Byte; // 23
|
||
KeyDesc : array[0..255] of char; // 24...
|
||
end;
|
||
|
||
rMdxTag = record
|
||
pageno : Integer; // 0..3
|
||
tagname : array [0..11] of char; // 4..14
|
||
keyformat : byte; // 15
|
||
forwardTag1 : char; // 16
|
||
forwardTag2 : byte; // 17
|
||
backwardTag : byte; // 18
|
||
dummy : byte; // 19
|
||
keytype : byte; // 20
|
||
end;
|
||
|
||
NdxKeyType = (N,C);
|
||
PNdxPage = ^rNdxPage;
|
||
rNdxPage = record
|
||
NbEntries : longint; // 0..3 lower page
|
||
Entries : ARRAY [0..507] OF char;
|
||
end;
|
||
|
||
PNdxentry = ^rNdxentry;
|
||
rNdxentry = record
|
||
_LowerPage : longint; // 0..3 lower page
|
||
RecNo : Longint; // 4..7 recno
|
||
case NdxKeyType of
|
||
N: ( NKey: double);
|
||
C: ( CKey: array [0..503] of char);
|
||
end;
|
||
//====================================================================
|
||
rMdxHdr = record
|
||
MdxHdr : byte; // 0
|
||
Year : byte; // 1
|
||
Month : byte; // 2
|
||
Day : byte; // 3
|
||
FileName : array[0..15] of char; // 4..19 of byte
|
||
BlockSize : word; // 20 21
|
||
BlockAdder : word; // 22 23
|
||
IndexFlag : byte; // 24
|
||
NoTag : byte; // 25
|
||
TagSize : byte; // 26
|
||
Dummy1 : byte; // 27
|
||
TagUsed : word; // 28..29
|
||
Dummy2 : word; // 30..31
|
||
NbPage : Integer; // 32..35
|
||
FreePage : Integer; // 36..39
|
||
BlockFree : Integer; // 40..43
|
||
UpdYear : byte; // 44
|
||
UpdMonth : byte; // 45
|
||
UpdDay : byte; // 46
|
||
end;
|
||
//====================================================================
|
||
TIndexFile = class(TPagedFile)
|
||
protected
|
||
_IndexVersion : xBaseVersion;
|
||
_MdxHdr : rMdxHdr;
|
||
public
|
||
constructor Create(const FileName: string; Mode: Word);
|
||
destructor Destroy; override;
|
||
end;
|
||
//====================================================================
|
||
PIndexPosInfo = ^TIndexPage;
|
||
TIndexPage = class
|
||
protected
|
||
_Index : TIndex;
|
||
_PageNo : Integer;
|
||
_EntryNo : Integer;
|
||
Entry : PNdxentry;
|
||
_LowerLevel : TIndexPage;
|
||
_UpperLevel : TIndexPage;
|
||
_PageBuff:rNdxPage;
|
||
|
||
procedure LocalFirst;
|
||
procedure LocalLast;
|
||
function LocalPrev:boolean;
|
||
function LocalNext:boolean;
|
||
function LastEntryNo:integer;
|
||
function LocalInsert(Recno:Integer; Buffer:PChar; LowerPage:integer):boolean;
|
||
function LocalDelete:boolean;
|
||
|
||
function GetPEntry(EntryNo:integer):PNdxEntry;
|
||
procedure First;
|
||
procedure Last;
|
||
function Prev:boolean;
|
||
function Next:boolean;
|
||
procedure Write;
|
||
procedure AddNewLevel;
|
||
public
|
||
constructor Create(Parent:TIndex);
|
||
destructor Destroy; override;
|
||
|
||
procedure SetPageNo(page:Integer);
|
||
procedure SetEntryNo(entryno:Integer);
|
||
procedure WritePage(Page:integer);
|
||
function FindNearest(Recno:integer; Key:PChar):integer;
|
||
function Insert(Recno:integer; Buffer:pchar; LowerPage:integer):boolean;
|
||
procedure SetEntry(Recno:integer; key:pchar; LowerPage:integer);
|
||
function Delete:boolean;
|
||
function LowerLevel : TIndexPage;
|
||
end;
|
||
//====================================================================
|
||
TIndex = class(TObject)
|
||
protected
|
||
_IndexFile:TIndexFile;
|
||
_NdxHdr:rNdxHdr;
|
||
_Root:TIndexPage;
|
||
_TagPosition:Integer;
|
||
_FieldPos : integer;
|
||
_FieldLen : integer;
|
||
_NbLevel : integer;
|
||
_RootPage: integer;
|
||
|
||
function Pos:TIndexPage;
|
||
public
|
||
IndexRecNo:integer;
|
||
function Prev:boolean;
|
||
function Next:boolean;
|
||
procedure First;
|
||
procedure Last;
|
||
function Find(Recno:integer; Buffer:PChar; var pPos:TIndexPage):integer;
|
||
procedure Insert(Recno:integer; Buffer:PChar);
|
||
function Delete:boolean;
|
||
procedure GotoKey(Recno:integer; Buffer:PChar);
|
||
procedure Update(Recno: integer; PrevBuffer,NewBuffer: PChar);
|
||
// procedure ResyncInd;
|
||
function GetRealRecNo: Integer;
|
||
constructor Create(Parent:TIndexFile; RootPage:integer;CreateIt:boolean);
|
||
procedure InitFieldDef(dbfFile:TDbfFile;FieldDesc:string);
|
||
destructor Destroy; override;
|
||
// optionnal
|
||
function GuessRecordCount: Integer;
|
||
function GuessRecNo: Integer;
|
||
end;
|
||
//====================================================================
|
||
//=== Memo and binary fields support
|
||
//====================================================================
|
||
rDbtHdr = record
|
||
NextBlock:Longint;
|
||
Dummy : array [4..7] of byte;
|
||
_dbfFile : array [0..7] of Byte; //8..15
|
||
bVer : Byte; //16
|
||
Dummy2 : array [17..19] of byte;
|
||
BlockLen: Word;
|
||
end;
|
||
//====================================================================
|
||
TDbtFile = class(TPagedFile)
|
||
protected
|
||
_DbtVersion:xBaseVersion;
|
||
_MemoHdr:rDbtHdr;
|
||
public
|
||
constructor Create(const FileName: string; Mode: Word; Ver:xBaseVersion);
|
||
procedure ReadMemo(recno:Integer;Dst:TStream);
|
||
procedure WriteMemo(var MemoRecno:Integer;ReadSize:Integer;Src:TStream);
|
||
end;
|
||
//====================================================================
|
||
TMyBlobFile = class(TMemoryStream)
|
||
public
|
||
Mode: TBlobStreamMode;
|
||
Field:TField;
|
||
MemoRecno:Integer;
|
||
ReadSize:Integer;
|
||
constructor Create(ModeVal:TBlobStreamMode; FieldVal:TField);
|
||
destructor destroy; override;
|
||
end;
|
||
//====================================================================
|
||
//=== Dbf support 2
|
||
//====================================================================
|
||
rFieldHdrIII = record
|
||
FieldName : array[0..10] of char;
|
||
FieldType : char; // 11
|
||
Dummy : array[12..15] of byte;
|
||
FieldSize : byte; // 16
|
||
FieldPrecision : byte; //17
|
||
dummy2 : array[18..31] of byte;
|
||
end;
|
||
//====================================================================
|
||
rFieldHdrV = record
|
||
FieldName : array[0..10] of char;
|
||
Dummy0 : array[11..31] of byte;
|
||
FieldType : char; // 32
|
||
FieldSize : byte; // 33
|
||
FieldPrecision : byte; //34
|
||
dummy2 : array[35..47] of byte;
|
||
end;
|
||
//====================================================================
|
||
PBookMarkData = ^rBookMarkData;
|
||
rBookmarkData = record
|
||
RecNo:longint;
|
||
end;
|
||
//====================================================================
|
||
rBeforeRecord = record
|
||
BookmarkData: rBookmarkData;
|
||
BookmarkFlag: TBookmarkFlag;
|
||
//... record come here
|
||
end;
|
||
//====================================================================
|
||
pDbfRecord = ^rDbfRecord;
|
||
rDbfRecord = record
|
||
BookmarkData: rBookmarkData;
|
||
BookmarkFlag: TBookmarkFlag;
|
||
DeletedFlag : char;
|
||
Fields : array[0..4000] of char;
|
||
end;
|
||
//====================================================================
|
||
PRecInfo = ^TRecInfo;
|
||
TRecInfo = record
|
||
Bookmark: Longint;
|
||
IdxBookmark: Longint;
|
||
BookmarkFlag: TBookmarkFlag;
|
||
end;
|
||
//====================================================================
|
||
pRecordHdr = ^tRecordHdr;
|
||
tRecordHdr = record
|
||
DeletedFlag : char;
|
||
end;
|
||
|
||
// and at LEAST the most useful class : TDbf
|
||
//====================================================================
|
||
TDbf = class(TDataSet)
|
||
private
|
||
_ShowDeleted:boolean;
|
||
_TableName: string; // table path and file name
|
||
_RunTimePath: string; // table path and file name
|
||
_DesignTimePath: string; // table path and file name
|
||
_ReadOnly : Boolean;
|
||
_FilterBuffer:pchar;
|
||
_PrevBuffer:pchar;
|
||
_IndexFiles:TStrings;
|
||
protected
|
||
function _FullRecordSize:integer;
|
||
function _FilterRecord(Buffer: PChar): Boolean;
|
||
procedure _OpenFiles(CreateIt:boolean);
|
||
procedure _CloseFiles;
|
||
procedure _ResyncIndexes(Buffer: PChar);
|
||
function _GetIndexName: string;
|
||
procedure _SetIndexName(const Value: string);
|
||
function _GetIndex(filename:string):TIndex;
|
||
function _GetPath:string;
|
||
function _ComponentInfo:string;
|
||
public
|
||
{ my own methods and properties}
|
||
{ most looks like ttable functions but they are not tdataset related
|
||
I use the same syntax to facilitate the conversion between bde and tdbf }
|
||
easyfilter:string;
|
||
procedure CreateTable; //(FieldDefs:TFieldDefs);
|
||
procedure DeleteIndex(const AName: string);
|
||
property IndexName: string read _GetIndexName write _SetIndexName;
|
||
|
||
{$ifdef DELPHI_3}
|
||
procedure AddIndex(const IndexName, Fields: String; Options: TIndexOptions);
|
||
{$else}
|
||
{$ifndef FPC}
|
||
procedure AddIndex(const IndexName, Fields: String; Options: TIndexOptions; const DescFields: String='');
|
||
{$else}
|
||
procedure AddIndex(const AnIndexName, IndexFields: String; Options: TIndexOptions);
|
||
procedure AddIndex(const AnIndexName, IndexFields: String; Options: TIndexOptions; const DescFields: String);
|
||
|
||
{$endif}
|
||
{$endif}
|
||
procedure CloseIndexFile(const IndexFileName: string);
|
||
procedure OpenIndexFile(AnIndexName:string);
|
||
procedure PackTable;
|
||
public
|
||
{ abstract methods }
|
||
function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override; {virtual abstract}
|
||
{virtual methods (mostly optionnal) }
|
||
function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override; {virtual}
|
||
{$ifdef DELPHI_3}
|
||
procedure Translate(Src, Dest: PChar; ToOem: Boolean); override; {virtual}
|
||
{$else}
|
||
{$ifdef fpc}
|
||
procedure Translate(Src, Dest: PChar; ToOem: Boolean); override; {virtual}
|
||
{$else}
|
||
function Translate(Src, Dest: PChar; ToOem: Boolean): Integer; override; {virtual}
|
||
{$endif}
|
||
{$endif}
|
||
procedure ClearCalcFields(Buffer : PChar); override;
|
||
protected
|
||
{ abstract methods }
|
||
function AllocRecordBuffer: PChar; override; {virtual abstract}
|
||
procedure FreeRecordBuffer(var Buffer: PChar); override; {virtual abstract}
|
||
procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override; {virtual abstract}
|
||
function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override; {virtual abstract}
|
||
function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override; {virtual abstract}
|
||
function GetRecordSize: Word; override; {virtual abstract}
|
||
procedure InternalAddRecord(Buffer: Pointer; DoAppend: Boolean); override; {virtual abstract}
|
||
procedure InternalClose; override; {virtual abstract}
|
||
procedure InternalDelete; override; {virtual abstract}
|
||
procedure InternalFirst; override; {virtual abstract}
|
||
procedure InternalGotoBookmark(ABookmark: Pointer); override; {virtual abstract}
|
||
procedure InternalHandleException; override; {virtual abstract}
|
||
procedure InternalInitFieldDefs; override; {virtual abstract}
|
||
procedure InternalInitRecord(Buffer: PChar); override; {virtual abstract}
|
||
procedure InternalLast; override; {virtual abstract}
|
||
procedure InternalOpen; override; {virtual abstract}
|
||
procedure InternalPost; override; {virtual abstract}
|
||
procedure InternalSetToRecord(Buffer: PChar); override; {virtual abstract}
|
||
function IsCursorOpen: Boolean; override; {virtual abstract}
|
||
procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override; {virtual abstract}
|
||
procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override; {virtual abstract}
|
||
procedure SetFieldData(Field: TField; Buffer: Pointer); override; {virtual abstract}
|
||
{virtual methods (mostly optionnal) }
|
||
|
||
function GetRecordCount: Integer; override; {virtual}
|
||
function GetRecNo: Integer; override; {virtual}
|
||
procedure SetRecNo(Value: Integer); override; {virual}
|
||
|
||
public
|
||
constructor Create(AOwner: TComponent); override;
|
||
destructor Destroy; override;
|
||
|
||
published
|
||
property ComponentInfo: string read _ComponentInfo;
|
||
property TableName: string read _TableName write _TableName;
|
||
property RunTimePath: string read _RunTimePath write _RunTimePath;
|
||
property DesignTimePath: string read _DesignTimePath write _DesignTimePath;
|
||
property ReadOnly : Boolean read _ReadOnly write _Readonly default False;
|
||
property ShowDeleted:boolean read _ShowDeleted write _ShowDeleted;
|
||
// redeclared data set properties
|
||
property Active;
|
||
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 OnFilterRecord;
|
||
property OnNewRecord;
|
||
property OnPostError;
|
||
|
||
//my datas....
|
||
protected
|
||
_IsCursorOpen:boolean;
|
||
_PhysicalRecno:integer;
|
||
_CurIndex: TIndex;
|
||
_Indexes:TList; // index
|
||
_indexFile : TIndexFile;
|
||
_dbtFile : TDbtFile;
|
||
public
|
||
_dbfFile:TDbfFile;
|
||
property PhysicalRecno:integer read _PhysicalRecno;
|
||
function _RecordDataSize:integer;
|
||
end;
|
||
|
||
{$ifndef fpc}
|
||
procedure Register;
|
||
{$endif}
|
||
|
||
var
|
||
tDbf_TrimFields : boolean;
|
||
|
||
implementation
|
||
|
||
var
|
||
_PagedFiles : TList;
|
||
|
||
//====================================================================
|
||
// Some types and consts which are not useful in the interface.
|
||
//====================================================================
|
||
(*
|
||
* tSmallint 16 bits = -32768 to 32767
|
||
* 123456 = 6 digit max
|
||
* ftInteger 32 bits = -2147483648 to 2147483647
|
||
* 12345678901 = 11 digits max
|
||
* ftLargeInt 64 bits = -9223372036854775808 to 9223372036854775807
|
||
* 12345678901234567890 = 20 digits max
|
||
*)
|
||
const
|
||
DIGITS_SMALLINT = 6;
|
||
DIGITS_INTEGER = 11;
|
||
DIGITS_LARGEINT = 20;
|
||
sDBF_DEC_SEP= '.';
|
||
|
||
type
|
||
rAfterHdrIII = record // Empty
|
||
end;
|
||
|
||
rAfterHdrV = record
|
||
Dummy : array[32..67] of byte;
|
||
end;
|
||
|
||
PMdxTag = ^rMdxTag;
|
||
|
||
rMdxTagHdr = record
|
||
RootPage : longint;// 0..3
|
||
FilePages : longint;// 4..7
|
||
KeyFormat : byte; // 8
|
||
KeyType : char; // 9
|
||
dummy : word; // 10..11
|
||
IndexKeyLength : word; // 12..13
|
||
MaxNbKeys : word; // 14..15
|
||
SecondKeyType : word; // 16..17
|
||
IndexKeyItemLen : word; // 18..19
|
||
dummy2 : array [20..22] of byte;
|
||
UniqueFlag : byte; // 23
|
||
end;
|
||
|
||
|
||
rAfterHdrV3 = record
|
||
Dummy : array[12..31] of byte;
|
||
end;
|
||
|
||
rAfterHdrV4 = record
|
||
Dummy : array[12..67] of byte;
|
||
end;
|
||
|
||
rFieldHdrV3 = record
|
||
FieldName : array[0..10] of char;
|
||
FieldType : char; // 11
|
||
Dummy : array[12..15] of byte;
|
||
FieldSize : byte; // 16
|
||
FieldPrecision : byte; //17
|
||
dummy2 : array[18..31] of byte;
|
||
end;
|
||
|
||
rFieldHdrV4 = record
|
||
FieldName : array[0..10] of char;
|
||
Dummy0 : array[11..31] of byte;
|
||
FieldType : char; // 32
|
||
FieldSize : byte; // 33
|
||
FieldPrecision : byte; //34
|
||
dummy2 : array[35..47] of byte;
|
||
end;
|
||
PDouble = ^double;
|
||
//====================================================================
|
||
// Now some common functions and procedure
|
||
//====================================================================
|
||
// ****************************************************************************
|
||
// International separator
|
||
// thanks to Bruno Depero from Italy
|
||
// and Andreas W<>llenstein from Denmark
|
||
|
||
function DbfStrToFloat(s: string): Extended;
|
||
var iPos: integer;
|
||
eValue: extended;
|
||
begin
|
||
iPos:= Pos(sDBF_DEC_SEP, s);
|
||
if iPos> 0 then
|
||
s[iPos]:= DecimalSeparator;
|
||
{$ifndef fpc}
|
||
if TextToFloat(pchar(s), eValue, fvExtended) then
|
||
{$else}
|
||
Val(s,eValue,Ipos);
|
||
If Ipos=0 then
|
||
{$endif}
|
||
Result:= eValue
|
||
else Result:= 0;
|
||
end;
|
||
|
||
function FloatToDbfStr(f: Extended; size, prec: integer): string;
|
||
var iPos: integer;
|
||
begin
|
||
Result:= FloatToStrF(f, ffFixed, Size, prec);
|
||
iPos:= Pos(DecimalSeparator, Result);
|
||
if iPos> 0 then
|
||
Result[iPos]:= sDBF_DEC_SEP;
|
||
end;
|
||
|
||
procedure MyMove(Source, Dest:PChar; Count: Integer);
|
||
var
|
||
c:char;
|
||
i:integer;
|
||
begin
|
||
i:=0;
|
||
while i<Count do begin
|
||
c:=PChar(Source)[i];
|
||
if c=#0 then break;
|
||
PChar(Dest)[i]:=c;
|
||
Inc(i);
|
||
end;
|
||
while i<Count do begin
|
||
PChar(Dest)[i]:=' ';
|
||
Inc(i);
|
||
end;
|
||
end;
|
||
//====================================================================
|
||
// TPagedFile
|
||
//====================================================================
|
||
function GetPagedFile(FileName: string):TPagedFile;
|
||
var
|
||
idx:integer;
|
||
idf:TPagedFile;
|
||
begin
|
||
FileName:=LowerCase(FileName);
|
||
for idx:=0 to _PagedFiles.Count-1 do begin
|
||
idf:= TPagedFile(_PagedFiles[idx]);
|
||
if idf._FileName=FileName then begin
|
||
result:=idf;
|
||
exit;
|
||
end;
|
||
end;
|
||
result:=nil;
|
||
end;
|
||
|
||
procedure TPagedFile.Release;
|
||
var
|
||
i: integer;
|
||
begin
|
||
dec(_cntuse);
|
||
if _cntuse<=0 then begin
|
||
i:=_PagedFiles.IndexOf(self);
|
||
if i>=0 then _PagedFiles.Delete(i);
|
||
Free;
|
||
end;
|
||
end;
|
||
|
||
function TPagedFile.CalcRecordCount:Integer;
|
||
begin
|
||
if RecordSize = 0 then Result:=0
|
||
else Result:=(Stream.Size - HeaderSize) div RecordSize;
|
||
end;
|
||
|
||
constructor TPagedFile.Create(const FileName: string; Mode: Word);
|
||
begin
|
||
if filename='' then Stream:=TMemoryStream.Create()
|
||
else begin
|
||
Stream:=TFileStream.Create(FileName,Mode);
|
||
end;
|
||
HeaderSize:=0;
|
||
RecordSize:=0;
|
||
_cntuse:=0;
|
||
_filename:=lowercase(filename);
|
||
_PagedFiles.Add(Self);
|
||
end;
|
||
|
||
destructor TPagedFile.Destroy;
|
||
begin
|
||
Stream.Free;
|
||
Stream:=nil;
|
||
inherited;
|
||
end;
|
||
|
||
procedure TPagedFile._Seek(page:Integer);
|
||
var
|
||
p:Integer;
|
||
begin
|
||
p:=HeaderSize + (RecordSize * page );
|
||
Stream.Position := p;
|
||
end;
|
||
|
||
Procedure TPagedFile.ReadRecord(IntRecNum:Integer; Buffer:Pointer);
|
||
begin
|
||
_Seek(IntRecNum);
|
||
Stream.Read(Buffer^,RecordSize);
|
||
end;
|
||
|
||
procedure TPagedFile.WriteRecord(IntRecNum:Integer; Buffer:Pointer);
|
||
begin
|
||
_Seek(IntRecNum);
|
||
Stream.Write(Buffer^, RecordSize);
|
||
end;
|
||
|
||
//====================================================================
|
||
// TDbfFile
|
||
//====================================================================
|
||
constructor TDbfFile.Create(const FileName: string; Mode: Word);
|
||
var
|
||
lRecordCount:Integer;
|
||
begin
|
||
_MyFieldInfos:=TList.Create;
|
||
// check if the file exists
|
||
inherited Create(Filename, Mode);
|
||
|
||
|
||
if Mode = fmCreate then begin
|
||
FillChar(_DataHdr,sizeof(_DataHdr),0);
|
||
HeaderSize:=0;
|
||
RecordSize:=0;
|
||
_DataHdr.VerDBF:=$03; // Default version xBaseIV without memo
|
||
_DataHdr.Language:='X';
|
||
end else begin
|
||
Stream.Seek(0,soFromBeginning);
|
||
Stream.ReadBuffer (_DataHdr, SizeOf(_DataHdr));
|
||
case _DataHdr.VerDBF of
|
||
$03,$83: _DbfVersion:=xBaseIII;
|
||
$04,$8B,$8E,$7B: _DbfVersion:=xBaseIV;
|
||
$05 : _DbfVersion:=xbaseV;
|
||
else
|
||
_DbfVersion:=xBaseIV; // My favorite...
|
||
end;
|
||
HeaderSize:=_DataHdr.FullHdrSize;
|
||
RecordSize:=_DataHdr.RecordSize;
|
||
lRecordCount:=CalcRecordCount;
|
||
if _DataHdr.RecordCount <> lRecordCount then begin
|
||
{$ifndef fpc}
|
||
ShowMessage('Invalid Record Count,'+^M+
|
||
'RecordCount in Hdr : '+IntToStr(_DataHdr.RecordCount)+^M+
|
||
'expected : '+IntToStr(lRecordCount));
|
||
{$endif}
|
||
_DataHdr.RecordCount := lRecordCount;
|
||
end;
|
||
end;
|
||
|
||
end;
|
||
|
||
|
||
destructor TDbfFile.Destroy;
|
||
begin
|
||
inherited;
|
||
ClearMyFieldInfos;
|
||
_MyFieldInfos.Free;
|
||
_MyFieldInfos:=nil;
|
||
|
||
end;
|
||
|
||
function TDbfFile.RecordCount:integer;
|
||
begin
|
||
if RecordSize=0 then result:=0
|
||
else result:=(Stream.Size - HeaderSize) div RecordSize;
|
||
if result<0 then result:=0;
|
||
end;
|
||
|
||
procedure TDbfFile.ClearMyFieldInfos;
|
||
var
|
||
i:Integer;
|
||
begin
|
||
for i:=0 to _MyFieldInfos.Count-1 do begin
|
||
TMyFieldInfo(_MyFieldInfos.Items[i]).Free;
|
||
end;
|
||
_MyFieldInfos.Clear;
|
||
end;
|
||
|
||
procedure TDbfFile.CreateFieldDefs(FieldDefs:TFieldDefs);
|
||
var
|
||
lColumnCount,lHeaderSize,lFieldSize:Integer;
|
||
Il : Integer;
|
||
lFieldOffset : Integer;
|
||
fn:string;
|
||
ft:TFieldType;
|
||
fs,nfs,fd:Integer;
|
||
MyFieldInfo:TMyFieldInfo;
|
||
lFieldHdrIII:rFieldHdrIII;
|
||
lFieldHdrV:rFieldHdrV;
|
||
|
||
function ToFieldType(dbasetype:char;fs,fd:Integer):TFieldType;
|
||
begin
|
||
case dbasetype of
|
||
'C' :
|
||
begin
|
||
Result:=ftString;
|
||
end;
|
||
'L' :
|
||
begin
|
||
Result:=ftBoolean;
|
||
end;
|
||
'F' :
|
||
begin
|
||
Result:=ftFloat;
|
||
end;
|
||
'N' :
|
||
begin
|
||
if fd=0 then begin
|
||
if fs <= DIGITS_SMALLINT then begin
|
||
Result:=ftSmallInt;
|
||
end else begin
|
||
{$ifdef DELPHI_3}
|
||
Result:=ftInteger;
|
||
{$else}
|
||
if fs <= DIGITS_INTEGER then Result:=ftInteger
|
||
else Result:=ftLargeInt;
|
||
{$endif}
|
||
end;
|
||
end else begin
|
||
Result:=ftFloat;
|
||
end;
|
||
end;
|
||
'D' :
|
||
begin
|
||
Result:=ftDate;
|
||
end;
|
||
'M' :
|
||
begin
|
||
Result:=ftMemo;
|
||
end;
|
||
else
|
||
begin
|
||
Result:=ftString;
|
||
end;
|
||
end; //case
|
||
end;
|
||
begin
|
||
ClearMyFieldInfos;
|
||
|
||
if _DbfVersion>=xBaseV then begin
|
||
lHeaderSize:=SizeOf(rAfterHdrV) + SizeOf(rDbfHdr);
|
||
lFieldSize:=SizeOf(rFieldHdrV);
|
||
end else begin
|
||
lHeaderSize:=SizeOf(rAfterHdrIII) + SizeOf(rDbfHdr);
|
||
lFieldSize:=SizeOf(rFieldHdrIII);
|
||
end;
|
||
lColumnCount:= (_DataHdr.FullHdrSize - lHeaderSize) div lFieldSize;
|
||
|
||
if (lColumnCount <= 0) or (lColumnCount > 255) then
|
||
Raise eBinaryDataSetError.Create('Invalid field count : ' + IntToStr(lColumnCount) + ' (must be between 1 and 255)');
|
||
|
||
lFieldOffset := 1;
|
||
|
||
Stream.Position := lHeaderSize;
|
||
for Il:=0 to lColumnCount-1 do begin
|
||
if _DbfVersion>=xBaseV then begin
|
||
Stream.ReadBuffer(lFieldHdrV,SizeOf(lFieldHdrV));
|
||
fn:=PCHAR(@lFieldHdrV.FieldName[0]);
|
||
fs:=lFieldHdrV.FieldSize;
|
||
fd:=lFieldHdrV.FieldPrecision;
|
||
nfs:=fs;
|
||
ft:=ToFieldType(lFieldHdrV.FieldType,nfs,fd);
|
||
end else begin
|
||
Stream.ReadBuffer(lFieldHdrIII,SizeOf(lFieldHdrIII));
|
||
fn:=PCHAR(@lFieldHdrIII.FieldName[0]);
|
||
fs:=lFieldHdrIII.FieldSize;
|
||
fd:=lFieldHdrIII.FieldPrecision;
|
||
nfs:=fs;
|
||
ft:=ToFieldType(lFieldHdrIII.FieldType,nfs,fd);
|
||
|
||
end;
|
||
// first create the bde field
|
||
if ft in [ftString,ftBCD] then fieldDefs.Add(fn,ft,fs,false)
|
||
else fieldDefs.Add(fn,ft,0,false);
|
||
// then create the for our own fieldinfo
|
||
MyFieldInfo:=TMyFieldInfo.Create;
|
||
MyFieldInfo.Offset:=lFieldOffset;
|
||
MyFieldInfo.Size:=fs;
|
||
MyFieldInfo.Prec:=fd;
|
||
MyFieldInfo.FieldName:=lowercase(fn);
|
||
|
||
_MyFieldInfos.Add(MyFieldInfo);
|
||
Inc(lFieldOffset,fs);
|
||
end;
|
||
if (lFieldOffset <> _DataHdr.RecordSize) then begin
|
||
{$ifndef fpc}
|
||
ShowMessage('Invalid Record Size,'+^M+
|
||
'Record Size in Hdr : '+IntToStr(_DataHdr.RecordSize)+^M+
|
||
'Expected : '+IntToStr(lFieldOffset));
|
||
{$endif}
|
||
_DataHdr.RecordSize := lFieldOffset;
|
||
end;
|
||
end;
|
||
|
||
procedure TDbfFile.DbfFile_CreateTable(FieldDefs:TFieldDefs);
|
||
var
|
||
ix:Integer;
|
||
lFieldHdrIII:rFieldHdrIII;
|
||
lType:Char;
|
||
lSize,lPrec:Integer;
|
||
Offs:Integer;
|
||
lterminator:Byte;
|
||
begin
|
||
// first reset file.
|
||
Stream.Size:= 0;
|
||
Stream.Position:=SizeOf(rDbfHdr) + SizeOf(rAfterHdrIII);
|
||
Offs:=1; // deleted mark count 1.
|
||
for Ix:=0 to FieldDefs.Count-1 do
|
||
begin
|
||
with FieldDefs.Items[Ix] do
|
||
begin
|
||
FillChar(lFieldHdrIII,SizeOf(lFieldHdrIII),#0);
|
||
lPrec:=0;
|
||
case DataType of
|
||
ftString:
|
||
begin
|
||
ltype:='C';
|
||
lSize := Size;
|
||
end;
|
||
ftBoolean:
|
||
begin
|
||
ltype:='L';
|
||
lSize := 1;
|
||
end;
|
||
ftSmallInt:
|
||
begin
|
||
ltype:='N';
|
||
lSize := 6;
|
||
end;
|
||
ftInteger:
|
||
begin
|
||
ltype:='N';
|
||
lSize := 11;
|
||
end;
|
||
ftCurrency:
|
||
begin
|
||
ltype:='N';
|
||
lSize := 20;
|
||
lPrec := 2;
|
||
end;
|
||
{$ifndef DELPHI_3}
|
||
ftLargeInt:
|
||
begin
|
||
ltype:='N';
|
||
lSize := 20;
|
||
lPrec := 0;
|
||
end;
|
||
{$endif}
|
||
ftFloat:
|
||
begin
|
||
ltype:='N';
|
||
lSize := 20;
|
||
lPrec := 4;
|
||
end;
|
||
ftDate:
|
||
begin
|
||
ltype:='D';
|
||
lSize := 8;
|
||
end;
|
||
ftMemo:
|
||
begin
|
||
ltype:='M';
|
||
lSize := 10;
|
||
end;
|
||
else
|
||
begin
|
||
raise EBinaryDataSetError.Create(
|
||
'InitFieldDefs: Unsupported field type');
|
||
end;
|
||
end; // case
|
||
|
||
lFieldHdrIII.FieldType:=ltype; //DataType;
|
||
StrPCopy(lFieldHdrIII.FieldName,FieldDefs.Items[Ix].Name);
|
||
lFieldHdrIII.FieldSize:=lSize;
|
||
lFieldHdrIII.FieldPrecision:=lPrec;
|
||
|
||
Stream.Write(lFieldHdrIII,SizeOf(lFieldHdrIII));
|
||
Inc(Offs,lSize);
|
||
end;
|
||
end;
|
||
// end of header
|
||
lterminator := $0d;
|
||
Stream.Write(lterminator,SizeOf(lterminator));
|
||
|
||
// update header
|
||
_DataHdr.RecordSize := Offs;
|
||
_DataHdr.FullHdrSize := Stream.Position;
|
||
RecordSize := _DataHdr.RecordSize;
|
||
HeaderSize := _DataHdr.FullHdrSize;
|
||
// write the updated header
|
||
WriteHeader;
|
||
end;
|
||
|
||
procedure TDbfFile.DbfFile_PackTable;
|
||
var
|
||
first,last:integer;
|
||
p: Pointer;
|
||
begin
|
||
// Non tested.
|
||
if (RecordSize <> 0) then
|
||
begin
|
||
first:=0;
|
||
last:=CalcRecordCount-1;
|
||
GetMem(p, RecordSize);
|
||
try
|
||
while first<last do begin
|
||
// first find the first hole
|
||
while first<last do begin
|
||
ReadRecord(first, p);
|
||
if (pRecordHdr(p)^.DeletedFlag <> ' ') then break;
|
||
inc(first);
|
||
end;
|
||
// now find last one non deleted.
|
||
while first<last do begin
|
||
ReadRecord(last, p);
|
||
if (pRecordHdr(p)^.DeletedFlag = ' ') then break;
|
||
dec(last);
|
||
end;
|
||
if first<last then begin
|
||
// found a non deleted record to put in the hole.
|
||
WriteRecord(first, p);
|
||
inc(first);
|
||
dec(last);
|
||
end;
|
||
end;
|
||
last:=CalcRecordCount;
|
||
Stream.Size:=(last+1) * RecordSize + HeaderSize;
|
||
finally
|
||
FreeMem(p);
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
function TDbfFile.GetFieldInfo(FieldName:string):TMyFieldInfo;
|
||
var
|
||
i:Integer;
|
||
lfi:TMyFieldInfo;
|
||
begin
|
||
FieldName:=LowerCase(FieldName);
|
||
for i:=0 to _MyFieldInfos.Count-1 do begin
|
||
lfi:=TMyFieldInfo(_MyFieldInfos.Items[i]);
|
||
if lfi.FieldName = FieldName then begin
|
||
result:=lfi;
|
||
exit;
|
||
end;
|
||
end;
|
||
result:=nil;
|
||
end;
|
||
|
||
function TDbfFile.GetFieldData(Column:Integer;DataType:TFieldType; Src,Dst:Pointer): Boolean;
|
||
var
|
||
FieldOffset: Integer;
|
||
FieldSize: Integer;
|
||
s:string;
|
||
d:TDateTime;
|
||
ld,lm,ly: word;
|
||
MyFieldInfo:TMyFieldInfo;
|
||
function TrimStr(const s: string): string;
|
||
var
|
||
iPos: integer;
|
||
begin
|
||
if DataType=ftString then
|
||
begin
|
||
if tDbf_TrimFields then Result:=Trim(s)
|
||
else Result:=TrimRight(s);
|
||
end
|
||
else Result:= Trim(s);
|
||
end;
|
||
procedure CorrectYear(var wYear: word);
|
||
var wD, wM, wY, CenturyBase: word;
|
||
{$ifdef DELPHI_3}
|
||
// Delphi 3 standard-behavior no change possible
|
||
const TwoDigitYearCenturyWindow= 0;
|
||
{$endif}
|
||
begin
|
||
if wYear>= 100 then
|
||
Exit;
|
||
DecodeDate(Date, wY, wm, wD);
|
||
// use Delphi-Date-Window
|
||
CenturyBase := wY{must be CurrentYear} - TwoDigitYearCenturyWindow;
|
||
Inc(wYear, CenturyBase div 100 * 100);
|
||
if (TwoDigitYearCenturyWindow > 0) and (wYear < CenturyBase) then
|
||
Inc(wYear, 100);
|
||
end;
|
||
begin
|
||
MyFieldInfo:=TMyFieldInfo(_MyFieldInfos.Items[Column]);
|
||
FieldOffset := MyFieldInfo.Offset;
|
||
FieldSize := MyFieldInfo.Size;
|
||
SetString(s, PChar(Src) + FieldOffset, FieldSize );
|
||
s:=TrimStr(s);
|
||
result:=length(s)>0; // return if field is empty
|
||
if Result and (Dst<>nil) then// data not needed if Result= FALSE or Dst=nil
|
||
case DataType of
|
||
ftBoolean:
|
||
begin
|
||
// in DBase- FileDescription lowercase t is allowed too
|
||
// with asking for Result= TRUE s must be longer then 0
|
||
// else it happens an AV, maybe field is NULL
|
||
if (UpCase(s[1])='T') then Word(Dst^) := 1
|
||
else Word(Dst^) := 0;
|
||
end;
|
||
ftInteger, ftSmallInt{$ifndef DELPHI_3},ftLargeInt{$endif}:
|
||
begin
|
||
case DataType of
|
||
ftSmallInt : SmallInt(Dst^):= StrToIntDef(s, 0);
|
||
{$ifndef DELPHI_3}
|
||
ftLargeint : LargeInt(Dst^):= StrToInt64Def(s, 0);
|
||
{$endif}
|
||
else // ftInteger :
|
||
Integer(Dst^):= StrToIntDef(s, 0);
|
||
end; // case
|
||
end;
|
||
ftFloat:
|
||
begin
|
||
Extended(Dst^) := DBFStrToFloat(s);
|
||
end;
|
||
ftCurrency:
|
||
begin
|
||
Extended(Dst^) := DBFStrToFloat(s);
|
||
end;
|
||
ftDate:
|
||
begin
|
||
ld:=StrToIntDef(Copy(s,7,2),1);
|
||
lm:=StrToIntDef(Copy(s,5,2),1);
|
||
ly:=StrToIntDef(Copy(s,1,4),0);
|
||
if ld=0 then ld:=1;
|
||
if lm=0 then lm:=1;
|
||
// if (ly<1900) or (ly>2100) then ly:=1900;
|
||
// Year from 0001 to 9999 is possible
|
||
// everyting else is an error, an empty string too
|
||
// Do DateCorrection with Delphis possibillities for one or two digits
|
||
if (ly< 100) and (Length(Trim(Copy(s,1,4)))in [1, 2]) then CorrectYear(ly);
|
||
try
|
||
d:=EncodeDate(ly,lm,ld);
|
||
if Assigned(Dst) then Integer(Dst^) := DateTimeToTimeStamp(d).Date;
|
||
except
|
||
Integer(Dst^) := 0;
|
||
end;
|
||
end;
|
||
ftString: begin
|
||
StrPCopy(Dst,s);
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
procedure TDbfFile.SetFieldData(Column:integer;DataType:TFieldType; Src,Dst:Pointer);
|
||
var
|
||
FieldSize,FieldPrec: Integer;
|
||
s:string;
|
||
fl:Double;
|
||
ts:TTimeStamp;
|
||
MyFieldInfo:TMyFieldInfo;
|
||
begin
|
||
MyFieldInfo:=TMyFieldInfo(_MyFieldInfos.Items[Column]);
|
||
FieldSize := MyFieldInfo.Size;
|
||
FieldPrec := MyFieldInfo.Prec;
|
||
|
||
Dst:=PChar(Dst)+MyFieldInfo.Offset;
|
||
if src<>nil then begin
|
||
case DataType of
|
||
ftBoolean:
|
||
begin
|
||
if Word(Src^) = 1 then s:='T'
|
||
else s:='F';
|
||
end;
|
||
ftInteger, ftSmallInt {$ifndef DELPHI_3},ftLargeInt{$endif}:
|
||
begin
|
||
case DataType of
|
||
ftSmallInt : s:= IntToStr(SmallInt(Src^));
|
||
{$ifndef DELPHI_3}
|
||
ftLargeInt: s:= IntToStr(LargeInt(Src^));
|
||
{$endif}
|
||
else //ftInteger
|
||
s:= IntToStr(Integer(Src^));
|
||
end;
|
||
// left filling
|
||
if Length(s)<FieldSize then s:=StringOfChar(' ',FieldSize-Length(s)) + s;
|
||
end;
|
||
ftFloat,ftCurrency:
|
||
begin
|
||
fl := Double(Src^);
|
||
s:=FloatToDbfStr(fl,FieldSize,FieldPrec);
|
||
if Length(s)<FieldSize then s:=StringOfChar(' ',FieldSize-Length(s)) + s;
|
||
end;
|
||
ftDate:
|
||
begin
|
||
ts.Time:=0;
|
||
ts.Date:=Integer(Src^);
|
||
s:= FormatDateTime('yyyymmdd', TimeStampToDateTime(ts));
|
||
end;
|
||
ftString:
|
||
begin
|
||
s:=PChar(Src); // finish with first 0
|
||
end;
|
||
end; // case
|
||
end; // if src<>nil (thanks andreas)
|
||
if Length(s)<FieldSize then begin
|
||
s:=s+StringOfChar(' ',FieldSize-Length(s));
|
||
end else if (Length(s)>FieldSize) then begin
|
||
if DataType= ftString then begin
|
||
// never raise for strings to long, its not customary
|
||
// TTable never raises
|
||
SetLength(s, FieldSize)
|
||
end else begin
|
||
raise eFieldToLongError.Create('Fielddata too long :' + IntToStr(Length(s))
|
||
+ ' (must be between 1 and ' + IntToStr(FieldSize) + ').');
|
||
end;
|
||
end;
|
||
Move(PChar(s)^, Dst^, FieldSize);
|
||
end;
|
||
|
||
|
||
procedure TDbfFile.WriteHeader;
|
||
var
|
||
SystemTime: TSystemTime;
|
||
lAfterHdrIII:rAfterHdrIII;
|
||
lAfterHdrV:rAfterHdrV;
|
||
lterminator:Byte;
|
||
begin
|
||
Assert(Stream<>nil,'_dbfFile=Nil');
|
||
|
||
Stream.Position:=0;
|
||
GetLocalTime(SystemTime);
|
||
{$ifndef fpc}
|
||
_DataHdr.Year := SystemTime.wYear - 1900;
|
||
_DataHdr.Month := SystemTime.wMonth;
|
||
_DataHdr.Day := SystemTime.wDay;
|
||
{$else}
|
||
_DataHdr.Year := SystemTime.Year - 1900;
|
||
_DataHdr.Month := SystemTime.Month;
|
||
_DataHdr.Day := SystemTime.Day;
|
||
{$endif}
|
||
Stream.Seek(0,soFromBeginning);
|
||
Stream.WriteBuffer (_DataHdr, SizeOf(_DataHdr));
|
||
_DataHdr.RecordCount := CalcRecordCount;
|
||
|
||
if _DbfVersion >= xBaseV then begin
|
||
FillChar(lAfterHdrV,SizeOf(lAfterHdrV),0);
|
||
Stream.WriteBuffer (lAfterHdrV, SizeOf(lAfterHdrV));
|
||
end else begin
|
||
FillChar(lAfterHdrIII,SizeOf(lAfterHdrIII),0);
|
||
Stream.WriteBuffer (lAfterHdrIII, SizeOf(lAfterHdrIII));
|
||
end;
|
||
_Seek(_DataHdr.RecordCount); // last byte usually...
|
||
lterminator := $1A;
|
||
Stream.Write(lterminator,SizeOf(lterminator));
|
||
end;
|
||
|
||
function TDbf._ComponentInfo:string;
|
||
begin
|
||
Result:='TDbf V' + IntToStr(_MAJOR_VERSION) + '.' + IntToStr(_MINOR_VERSION);
|
||
end;
|
||
|
||
procedure TDbf._OpenFiles(CreateIt:boolean);
|
||
var
|
||
fileopenmode : integer;
|
||
lPath,lFilename,lIndexName,lMemoName : string;
|
||
isAbsolute:boolean;
|
||
design,doreadonly:boolean;
|
||
|
||
begin
|
||
design:=(csDesigning in ComponentState);
|
||
doreadonly:=design or _ReadOnly;
|
||
|
||
lPath:=_GetPath;
|
||
isAbsolute:=((length(_TableName)>=1) and (_TableName[1]='\'))
|
||
or ((length(_TableName)>=2) and (_TableName[2]=':'));
|
||
if isAbsolute then lfilename:=_TableName
|
||
else lFilename:=lPath+_TableName;
|
||
lFilename:=ChangeFileExt(lFilename,'.dbf');
|
||
lIndexName:=ChangeFileExt(lFilename,'.mdx');
|
||
lMemoName:=ChangeFileExt(lFilename,'.dbt');
|
||
|
||
// check if the file exists
|
||
_dbfFile:=TDbfFile(GetPagedFile(lFileName));
|
||
_indexFile:=TIndexFile(GetPagedFile(lIndexName));
|
||
_dbtFile:=TDbtFile(GetPagedFile(lMemoName));
|
||
|
||
if CreateIt then begin
|
||
if _dbfFile=nil then _dbfFile:=TDbfFile.Create(lFileName,fmCreate);
|
||
//if _indexfile=nil then _indexFile := TIndexFile.Create(lIndexName, fmCreate);
|
||
if _dbtfile=nil then _dbtFile := TDbtFile.Create(lMemoName, fmCreate,_dbfFile._DbfVersion);
|
||
end else if not FileExists(lFileName) then begin
|
||
raise eBinaryDataSetError.Create ('Open: Table file not found : ' + lFileName);
|
||
end else begin
|
||
if DoReadOnly then
|
||
fileopenmode := fmOpenRead + fmShareDenyNone
|
||
else
|
||
fileopenmode := fmOpenReadWrite + fmShareDenyWrite;
|
||
|
||
if _dbfFile=nil then _dbfFile := TDBFFile.Create(lFileName, fileopenmode);
|
||
if (_indexFile=nil) and FileExists (lIndexName) then begin
|
||
_indexFile := TIndexFile.Create(lIndexName, fileopenmode);
|
||
end;
|
||
if (_dbtFile=nil) and FileExists (lMemoName) then begin
|
||
_dbtFile := TDbtFile.Create(lMemoName, fileopenmode,_dbfFile._DbfVersion);
|
||
end;
|
||
end;
|
||
_PrevBuffer:=AllocRecordBuffer;
|
||
_IsCursorOpen:=true;
|
||
|
||
end;
|
||
|
||
function TDbf._GetPath:string;
|
||
var
|
||
lPath:string;
|
||
begin
|
||
if (csDesigning in ComponentState) then begin
|
||
lPath:=_DesignTimePath;
|
||
end else begin
|
||
if ((length(_RunTimePath)>=1) and (_RunTimePath[1]=DirSeparator))
|
||
or ((length(_RunTimePath)>=2) and (_RunTimePath[2]=':'))
|
||
then begin
|
||
// if the _RunTimePath is absolute...
|
||
// it is either \ or \blahblah or c:\
|
||
lPath:=_RunTimePath;
|
||
end else begin
|
||
{$ifndef fpc}
|
||
lPath:=extractfilepath(Application.Exename)+_RunTimePath;
|
||
{$else}
|
||
lPath:=extractfilepath(paramstr(0))+_RunTimePath;
|
||
{$endif}
|
||
end;
|
||
end;
|
||
lPath:=ExpandFileName(trim(lPath));
|
||
if (length(lPath)>0) and (lPath[length(lPath)]<>DirSeparator) then lPath:=lPath+DirSeparator;
|
||
result:=lPath;
|
||
end;
|
||
|
||
procedure TDbf._CloseFiles;
|
||
var
|
||
i:integer;
|
||
begin
|
||
if _dbfFile<>nil then begin
|
||
if not _ReadOnly then _dbfFile.WriteHeader;
|
||
_dbfFile.Release;
|
||
_dbfFile:=nil;
|
||
end;
|
||
if _indexFile<>nil then begin
|
||
_indexFile.Release;
|
||
_indexFile:=nil;
|
||
end;
|
||
|
||
if _dbtFile<>nil then begin
|
||
_dbtFile.Release;
|
||
_dbtFile:=nil;
|
||
end;
|
||
|
||
if _indexes<>nil then begin
|
||
for i:=0 to _Indexes.Count-1 do begin
|
||
TIndex(_Indexes[i]).Free;
|
||
end;
|
||
_Indexes.Clear;
|
||
_CurIndex:=nil;
|
||
end;
|
||
if (_PrevBuffer<>nil) then begin
|
||
FreeRecordBuffer(_PrevBuffer);
|
||
_PrevBuffer:=nil;
|
||
end;
|
||
_IsCursorOpen:=false;
|
||
end;
|
||
|
||
procedure TDbf._SetIndexName(const Value: string);
|
||
begin
|
||
_CurIndex:=_GetIndex(Value);
|
||
Resync([]);
|
||
end;
|
||
|
||
function TDbf._GetIndexName: string;
|
||
begin
|
||
if _CurIndex=nil then Result:=''
|
||
else Result:=_CurIndex._IndexFile._Filename;
|
||
end;
|
||
|
||
function TDbf._GetIndex(filename:string):TIndex;
|
||
var
|
||
i:integer;
|
||
lindex:TIndex;
|
||
begin
|
||
result:=nil;
|
||
filename:=lowercase(_GetPath + filename);
|
||
for i:=0 to _indexes.Count-1 do begin
|
||
lindex:=TIndex(_indexes.Items[i]);
|
||
if lindex._IndexFile._Filename=filename then begin
|
||
result:=lindex;
|
||
exit;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
|
||
//==========================================================
|
||
//============ TMyBlobFile
|
||
//==========================================================
|
||
constructor TMyBlobFile.Create(ModeVal:TBlobStreamMode;FieldVal:TField);
|
||
begin
|
||
Mode:=ModeVal;
|
||
Field:=FieldVal;
|
||
end;
|
||
|
||
destructor TMyBlobFile.destroy;
|
||
var
|
||
Dbf:TDbf;
|
||
begin
|
||
if (Mode=bmWrite) then begin
|
||
Size:=Position; // Strange but it leave tailing trash bytes if I do not write that.
|
||
Dbf:=TDbf(Field.DataSet);
|
||
Dbf._dbtFile.WriteMemo(MemoRecno,ReadSize,Self);
|
||
|
||
Dbf._dbfFile.SetFieldData(Field.FieldNo-1,
|
||
ftInteger,@MemoRecno,@pDbfRecord(TDbf(Field.DataSet).ActiveBuffer)^.deletedflag);
|
||
// seems not bad
|
||
{$ifndef fpc}
|
||
// FPC doesn't allow to call protected methods ?!!
|
||
Dbf.SetModified(true);
|
||
{$endif}
|
||
// but would that be better
|
||
//if not (State in [dsCalcFields, dsFilter, dsNewValue]) then begin
|
||
// DataEvent(deFieldChange, Longint(Field));
|
||
//end;
|
||
end;
|
||
inherited;
|
||
end;
|
||
|
||
//====================================================================
|
||
// TDbf = TDataset Descendant.
|
||
//====================================================================
|
||
constructor TDbf.Create(AOwner: TComponent); {override;}
|
||
begin
|
||
inherited create(aOwner);
|
||
BookmarkSize:=sizeof(rBookmarkData);
|
||
|
||
_RunTimePath:='.';
|
||
_IsCursorOpen:=false;
|
||
_Indexes:=TList.Create;
|
||
_CurIndex:=nil;
|
||
_IndexFiles:=TStringList.Create;
|
||
end;
|
||
|
||
destructor TDbf.Destroy; {override;}
|
||
var
|
||
i:integer;
|
||
begin
|
||
inherited;
|
||
_CurIndex:=nil;
|
||
for i:=0 to _Indexes.Count-1 do begin
|
||
TIndex(_Indexes[i]).Free;
|
||
end;
|
||
_Indexes.Free;
|
||
_IndexFiles.Free;
|
||
// _MemIndex.Free;
|
||
end;
|
||
|
||
|
||
function TDbf._FilterRecord(Buffer: PChar): Boolean;
|
||
var
|
||
SaveState: TDatasetState;
|
||
s:string;
|
||
begin
|
||
Result:=True;
|
||
if Length(easyfilter)<>0 then begin
|
||
SetString(s,buffer,RecordSize);
|
||
s:=LowerCase(s);
|
||
if Pos(easyfilter,s)=0 then begin
|
||
Result:=False;
|
||
Exit;
|
||
end;
|
||
end;
|
||
if not Assigned(OnFilterRecord) then Exit;
|
||
if not Filtered then Exit;
|
||
_FilterBuffer:=buffer;
|
||
SaveState:=SetTempState(dsFilter);
|
||
OnFilterRecord(self,Result);
|
||
RestoreState(SaveState);
|
||
end;
|
||
|
||
function TDbf._RecordDataSize:integer;
|
||
begin
|
||
if _dbfFile=nil then result:=0
|
||
else result:=_dbfFile.RecordSize;
|
||
end;
|
||
|
||
function TDbf._FullRecordSize:integer;
|
||
begin
|
||
result:=sizeof(rBeforeRecord) + _RecordDataSize + CalcFieldsSize;
|
||
end;
|
||
|
||
function TDbf.AllocRecordBuffer: PChar; {override virtual abstract from TDataset}
|
||
begin
|
||
result:=StrAlloc(_FullRecordSize);
|
||
InternalInitRecord(result);
|
||
end;
|
||
|
||
procedure TDbf.FreeRecordBuffer(var Buffer: PChar); {override virtual abstract from TDataset}
|
||
begin
|
||
StrDispose(Buffer);
|
||
end;
|
||
|
||
procedure TDbf.GetBookmarkData(Buffer: PChar; Data: Pointer); {override virtual abstract from TDataset}
|
||
var
|
||
prec:pDbfRecord;
|
||
begin
|
||
prec:=pDbfRecord(Buffer);
|
||
pBookMarkData(Data)^:=prec^.BookMarkData;
|
||
end;
|
||
|
||
function TDbf.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; {override virtual abstract from TDataset}
|
||
var
|
||
prec:pDbfRecord;
|
||
begin
|
||
prec:=pDbfRecord(Buffer);
|
||
result:=prec^.BookMarkFlag;
|
||
end;
|
||
|
||
function TDbf.GetFieldData(Field: TField; Buffer: Pointer): Boolean; {override virtual abstract from TDataset}
|
||
var
|
||
ptr:pointer;
|
||
begin
|
||
Result := False;
|
||
if State=dsFilter then begin
|
||
Ptr:=_FilterBuffer;
|
||
end else if State = dsCalcFields then begin
|
||
// ***** calc fields ***** set correct buffer
|
||
ptr := @(pDbfRecord(CalcBuffer)^.deletedflag);
|
||
end else begin
|
||
if IsEmpty then exit;
|
||
ptr:=@(pDbfRecord(ActiveBuffer)^.deletedflag);
|
||
end;
|
||
|
||
if Field.FieldNo>0 then begin
|
||
Result:=_dbfFile.GetFieldData(Field.FieldNo - 1,Field.DataType,ptr,Buffer);
|
||
end else begin { calculated fields.... }
|
||
Inc(PChar(Ptr), Field.Offset + GetRecordSize);
|
||
{$ifndef fpc}
|
||
Result := Boolean(PChar(Ptr)[0]);
|
||
{$else}
|
||
Result := (Pchar(ptr)[0]<>#0);
|
||
{$endif}
|
||
if Result and (Buffer <> nil) then
|
||
Move(PChar(Ptr)[1], Buffer^, Field.DataSize);
|
||
end;
|
||
end;
|
||
|
||
|
||
function TDbf.GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; {override virtual abstract from TDataset}
|
||
var
|
||
Acceptable : Boolean;
|
||
prec:pDBFRecord;
|
||
begin
|
||
prec:=pDBFRecord(Buffer);
|
||
if _dbfFile.RecordCount < 1 then
|
||
Result := grEOF
|
||
else repeat
|
||
result := grOk;
|
||
case GetMode of
|
||
gmCurrent :
|
||
begin
|
||
if prec^.BookmarkData.Recno=_PhysicalRecno then begin
|
||
exit; // try to fasten a bit...
|
||
end;
|
||
end;
|
||
gmNext :
|
||
begin
|
||
if _curIndex<>nil then begin
|
||
Acceptable:=_curIndex.Next;
|
||
end else begin
|
||
inc(_PhysicalRecno);
|
||
Acceptable:=(_PhysicalRecno<_dbfFile.RecordCount);
|
||
end;
|
||
if Acceptable then begin
|
||
result:= grOk;
|
||
end else begin
|
||
InternalLast;
|
||
result:= grEOF
|
||
end;
|
||
end;
|
||
gmPrior :
|
||
begin
|
||
if _curIndex<>nil then begin
|
||
Acceptable:=_curIndex.Prev;
|
||
end else begin
|
||
dec(_PhysicalRecno);
|
||
Acceptable:=(_PhysicalRecno>=0);
|
||
end;
|
||
if Acceptable then begin
|
||
result:= grOk;
|
||
end else begin
|
||
InternalFirst;
|
||
result:= grBOF
|
||
end;
|
||
end;
|
||
end;
|
||
if result=grOk then begin
|
||
if _curIndex<>nil then _PhysicalRecno:=_CurIndex.GetRealRecNo;
|
||
if (_PhysicalRecno>=_dbfFile.RecordCount)
|
||
or (_PhysicalRecno<0) then begin
|
||
result:=grError;
|
||
end else begin
|
||
_dbfFile.ReadRecord(_PhysicalRecno,@prec^.DeletedFlag);
|
||
result:=grOk;
|
||
end;
|
||
if Result = grOK then begin
|
||
ClearCalcFields(Buffer);
|
||
GetCalcFields(Buffer);
|
||
prec^.BookmarkFlag := bfCurrent;
|
||
prec^.BookmarkData.Recno:=PhysicalRecno;
|
||
end else if (Result = grError) and DoCheck then
|
||
raise eBinaryDataSetError.Create ('GetRecord: Invalid record');
|
||
end;
|
||
Acceptable := (_ShowDeleted or (prec^.DeletedFlag = ' '))
|
||
and _FilterRecord(Buffer);
|
||
if (GetMode=gmCurrent) and Not Acceptable then Result := grError;
|
||
until (Result <> grOK) or Acceptable;
|
||
end;
|
||
|
||
function TDbf.GetRecordSize: Word; {override virtual abstract from TDataset}
|
||
begin
|
||
Result := _RecordDataSize; // data only
|
||
end;
|
||
|
||
procedure TDbf.InternalAddRecord(Buffer: Pointer; DoAppend: Boolean); {override virtual abstract from TDataset}
|
||
begin
|
||
end;
|
||
|
||
procedure TDbf.InternalClose; {override virtual abstract from TDataset}
|
||
begin
|
||
_CloseFiles;
|
||
|
||
// disconnect field objects
|
||
BindFields(False);
|
||
// destroy field object (if not persistent)
|
||
if DefaultFields then
|
||
DestroyFields;
|
||
end;
|
||
|
||
procedure TDbf.InternalDelete; {override virtual abstract from TDataset}
|
||
begin
|
||
// CheckActive;
|
||
pRecordHdr(ActiveBuffer)^.DeletedFlag := '*'; //_DataHdr.LastDeleted;
|
||
_dbfFile.WriteRecord(_PhysicalRecNo,ActiveBuffer);
|
||
Resync([]);
|
||
end;
|
||
|
||
procedure TDbf.InternalFirst; {override virtual abstract from TDataset}
|
||
begin
|
||
if _dbfFile.RecordCount=0 then InternalLast
|
||
else if _curindex=nil then _PhysicalRecno:=-1
|
||
else _curIndex.First;
|
||
end;
|
||
|
||
procedure TDbf.InternalGotoBookmark(ABookmark: Pointer); {override virtual abstract from TDataset}
|
||
var
|
||
RecInfo: TRecInfo;
|
||
begin
|
||
RecInfo := TRecInfo(ABookmark^);
|
||
if (RecInfo.Bookmark >= 0) and (RecInfo.Bookmark < _dbfFile.RecordCount) then begin
|
||
_PhysicalRecno:=RecInfo.Bookmark;
|
||
end else
|
||
raise eBinaryDataSetError.Create ('Bookmark ' +
|
||
IntToStr (RecInfo.Bookmark) + ' not found');
|
||
end;
|
||
|
||
procedure TDbf.InternalHandleException; {override virtual abstract from TDataset}
|
||
begin
|
||
{$ifndef fpc}
|
||
Application.HandleException(Self);
|
||
{$endif}
|
||
end;
|
||
|
||
procedure TDbf.InternalInitFieldDefs; {override virtual abstract from TDataset}
|
||
begin
|
||
FieldDefs.Clear;
|
||
with FieldDefs do
|
||
begin
|
||
if IsCursorOpen then begin
|
||
_dbfFile.CreateFieldDefs(FieldDefs);
|
||
end else begin
|
||
_OpenFiles(false);
|
||
_dbfFile.CreateFieldDefs(FieldDefs);
|
||
Close();
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
procedure TDbf.InternalInitRecord(Buffer: PChar); {override virtual abstract from TDataset}
|
||
var
|
||
prec:pDbfRecord;
|
||
begin
|
||
prec:=pDbfRecord(Buffer);
|
||
prec^.BookmarkData.RecNo:=-1;
|
||
prec^.BookmarkFlag:=TBookmarkFlag(0);
|
||
fillchar(prec^.DeletedFlag,_RecordDataSize,' ');
|
||
end;
|
||
|
||
procedure TDbf.InternalLast; {override virtual abstract from TDataset}
|
||
begin
|
||
if _curindex=nil then _PhysicalRecno:=_dbfFile.RecordCount
|
||
else _curIndex.Last;
|
||
end;
|
||
|
||
procedure TDbf.InternalOpen; {override virtual abstract from TDataset}
|
||
begin
|
||
_OpenFiles(false);
|
||
// if there are no persistent field objects,
|
||
InternalInitFieldDefs;
|
||
// create the fields dynamically
|
||
if DefaultFields then begin
|
||
CreateFields;
|
||
end;
|
||
BindFields (True);
|
||
// connect the TField objects with the actual fields
|
||
|
||
InternalFirst;
|
||
end;
|
||
|
||
procedure TDbf.InternalPost; {override virtual abstract from TDataset}
|
||
var
|
||
prec:pDbfRecord;
|
||
lIndex:TIndex;
|
||
i:integer;
|
||
begin
|
||
CheckActive;
|
||
prec:=pDbfRecord(ActiveBuffer);
|
||
prec^.DeletedFlag:=' ';
|
||
|
||
if State = dsEdit then
|
||
begin
|
||
// replace data with new data
|
||
if _indexes.Count>0 then begin
|
||
_dbfFile.ReadRecord(_PhysicalRecno,_PrevBuffer);
|
||
for i:=0 to _indexes.Count-1 do begin
|
||
lindex:=TIndex(_indexes.Items[i]);
|
||
lindex.Update(_PhysicalRecno,_PrevBuffer,@prec^.DeletedFlag);
|
||
end;
|
||
end;
|
||
end else begin
|
||
// append
|
||
_PhysicalRecno:=_dbfFile._DataHdr.RecordCount;
|
||
inc(_dbfFile._DataHdr.RecordCount);
|
||
if _indexes.Count>0 then begin
|
||
_dbfFile.ReadRecord(_PhysicalRecno,_PrevBuffer);
|
||
for i:=0 to _indexes.Count-1 do begin
|
||
lindex:=TIndex(_indexes.Items[i]);
|
||
lindex.Insert(_PhysicalRecno,@prec^.DeletedFlag);
|
||
end;
|
||
end;
|
||
end;
|
||
_dbfFile.WriteRecord(_PhysicalRecno,@prec^.DeletedFlag);
|
||
end;
|
||
|
||
|
||
procedure TDbf.CreateTable; //(FieldDefs:TFieldDefs);
|
||
var
|
||
ix:integer;
|
||
begin
|
||
CheckInactive;
|
||
// InternalInitFieldDefs;
|
||
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;
|
||
_OpenFiles(true);
|
||
try
|
||
_dbfFile.DbfFile_CreateTable(FieldDefs);
|
||
finally
|
||
// close the file
|
||
_CloseFiles;
|
||
end;
|
||
end;
|
||
|
||
procedure TDbf.PackTable;
|
||
begin
|
||
_dbfFile.dbfFile_PackTable;
|
||
Resync([]);
|
||
end;
|
||
|
||
|
||
function TDbf.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; {override virtual}
|
||
var
|
||
Memoi:array[1..32] of char;
|
||
lBlob:TMyBlobFile;
|
||
begin
|
||
lBlob:=TMyBlobFile.Create(Mode,Field);
|
||
if _dbfFile.GetFieldData(Field.FieldNo-1, ftString,@pDbfRecord(ActiveBuffer)^.deletedflag,@Memoi[1]) then begin
|
||
lBlob.MemoRecno:=StrToIntDef(Memoi,0);
|
||
_dbtFile.ReadMemo(lBlob.MemoRecno,lBlob);
|
||
lBlob.ReadSize:=lBlob.Size;
|
||
end else lBlob.MemoRecno:=0;
|
||
Result:=lBlob;
|
||
end;
|
||
|
||
{$ifdef DELPHI_3}
|
||
procedure TDbf.Translate(Src, Dest: PChar; ToOem: Boolean); {override virtual}
|
||
begin
|
||
if (Src <> nil) and (Dest<>nil) then begin
|
||
if ToOem then CharToOem(Src,Dest)
|
||
else OemToChar(Src,Dest);
|
||
end;
|
||
end;
|
||
{$else}
|
||
{$ifndef fpc}
|
||
function TDbf.Translate(Src, Dest: PChar; ToOem: Boolean): Integer; {override virtual}
|
||
begin
|
||
if (Src <> nil) and (Dest<>nil) then begin
|
||
if ToOem then CharToOem(Src,Dest)
|
||
else OemToChar(Src,Dest);
|
||
result:= StrLen(Dest);
|
||
end else result:=0;
|
||
end;
|
||
{$else}
|
||
procedure TDbf.Translate(Src, Dest: PChar; ToOem: Boolean); {override virtual}
|
||
begin
|
||
end;
|
||
{$endif}
|
||
{$endif}
|
||
|
||
procedure TDbf.ClearCalcFields(Buffer: PChar);
|
||
begin
|
||
FillChar(Buffer[_dbfFile.RecordSize], CalcFieldsSize, 0);
|
||
end;
|
||
|
||
procedure TDbf.InternalSetToRecord(Buffer: PChar); {override virtual abstract from TDataset}
|
||
var
|
||
prec:pDbfRecord;
|
||
begin
|
||
if Buffer=nil then exit;
|
||
prec:=pDbfRecord(Buffer);
|
||
_PhysicalRecno:=prec^.BookmarkData.RecNo;
|
||
_ResyncIndexes(Buffer);
|
||
end;
|
||
|
||
procedure TDbf._ResyncIndexes(Buffer: PChar);
|
||
var
|
||
i:integer;
|
||
lindex:TIndex;
|
||
begin
|
||
if _indexes.Count>0 then begin
|
||
_dbfFile.ReadRecord(_PhysicalRecno,_PrevBuffer);
|
||
for i:=0 to _indexes.Count-1 do begin
|
||
lindex:=TIndex(_indexes.Items[i]);
|
||
lindex.GotoKey(_physicalRecno,nil);
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
function TDbf.IsCursorOpen: Boolean; {override virtual abstract from TDataset}
|
||
begin
|
||
result:=_IsCursorOpen;
|
||
end;
|
||
|
||
procedure TDbf.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); {override virtual abstract from TDataset}
|
||
var
|
||
prec:pDbfRecord;
|
||
begin
|
||
prec:=pDbfRecord(Buffer);
|
||
prec^.BookMarkFlag:=Value;
|
||
end;
|
||
|
||
procedure TDbf.SetBookmarkData(Buffer: PChar; Data: Pointer); {override virtual abstract from TDataset}
|
||
var
|
||
prec:pDbfRecord;
|
||
begin
|
||
prec:=pDbfRecord(Buffer);
|
||
prec^.BookMarkData:=pBookMarkData(Data)^;
|
||
end;
|
||
|
||
procedure TDbf.SetFieldData(Field: TField; Buffer: Pointer); {override virtual abstract from TDataset}
|
||
var
|
||
prec:pDbfRecord;
|
||
dst:pointer;
|
||
begin
|
||
if (Field.FieldNo >= 0) then begin
|
||
prec:=pDbfRecord(ActiveBuffer);
|
||
dst:=@prec^.DeletedFlag;
|
||
_dbfFile.SetFieldData(Field.FieldNo - 1,Field.DataType,Buffer,Dst);
|
||
end else begin { ***** fkCalculated, fkLookup ***** }
|
||
prec:=pDbfRecord(CalcBuffer);
|
||
dst:=@prec^.DeletedFlag;
|
||
Inc(integer(dst), GetRecordSize + Field.Offset);
|
||
Boolean(dst^) := LongBool(Buffer);
|
||
if Boolean(dst^) then begin
|
||
Inc(integer(dst), 1);
|
||
Move(Buffer^, dst^, Field.DataSize);
|
||
end;
|
||
end; { end of ***** fkCalculated, fkLookup ***** }
|
||
if not (State in [dsCalcFields, dsFilter, dsNewValue]) then begin
|
||
DataEvent(deFieldChange, Longint(Field));
|
||
end;
|
||
end;
|
||
|
||
|
||
// this function is just for the grid scrollbars
|
||
// it doesn't have to be perfectly accurate, but fast.
|
||
function TDbf.GetRecordCount: Integer; {override virtual}
|
||
begin
|
||
if _curIndex=nil then begin
|
||
result:=_dbfFile.RecordCount;
|
||
end else begin
|
||
result:=_curIndex.GuessRecordCount;
|
||
end;
|
||
end;
|
||
|
||
// this function is just for the grid scrollbars
|
||
// it doesn't have to be perfectly accurate, but fast.
|
||
function TDbf.GetRecNo: Integer; {override virtual}
|
||
begin
|
||
UpdateCursorPos;
|
||
if _curIndex=nil then begin
|
||
result:=_PhysicalRecno+1;
|
||
end else begin
|
||
result:=_curIndex.GuessRecNo;
|
||
end;
|
||
end;
|
||
|
||
procedure TDbf.SetRecNo(Value: Integer); {override virual}
|
||
begin
|
||
if _curIndex=nil then begin
|
||
_PhysicalRecno:=Value-1;
|
||
end else begin
|
||
//result:=_curIndex.GuessRecNo;
|
||
end;
|
||
Resync([rmExact]);
|
||
end;
|
||
|
||
procedure TDBf.DeleteIndex(const AName: string);
|
||
|
||
begin
|
||
// I must admit that is seems a bit expeditive.
|
||
// but I does implement this method because TTable does
|
||
DeleteFile(_GetPath + Name);
|
||
end;
|
||
|
||
procedure TDbf.CloseIndexFile(const IndexFileName: string);
|
||
var
|
||
lindex:tindex;
|
||
begin
|
||
lindex:=_GetIndex(IndexFileName);
|
||
if lindex<>nil then begin
|
||
lindex.Free;
|
||
_indexes.Delete(_indexes.IndexOf(lindex));
|
||
if _curindex = lindex then begin
|
||
_curindex:=nil;
|
||
resync([]);
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
procedure TDbf.OpenIndexFile(AnIndexName:string);
|
||
var
|
||
lIndexFile:TIndexFile;
|
||
lIndex:TIndex;
|
||
begin
|
||
lindex:=_GetIndex(IndexName);
|
||
if lindex=nil then begin
|
||
IndexName:=lowercase(_GetPath + IndexName);
|
||
lIndexFile:=TIndexFile(GetPagedFile(IndexName));
|
||
if lIndexFile=nil then begin
|
||
lIndexFile:=TIndexFile.Create(IndexName,fmOpenReadWrite + fmShareDenyWrite);
|
||
end;
|
||
lIndex:=TIndex.Create(lIndexFile,0,false);
|
||
_Indexes.Add(lIndex);
|
||
lIndex.InitFieldDef(_DbfFile,lIndex._NdxHdr.KeyDesc);
|
||
end;
|
||
end;
|
||
|
||
(*
|
||
procedure TDbfFile.DbfFile_PackTable;
|
||
var
|
||
begin
|
||
end;
|
||
*)
|
||
{$ifdef fpc}
|
||
procedure TDbf.AddIndex(const AnIndexName, IndexFields: String; Options: TIndexOptions);
|
||
|
||
begin
|
||
AddIndex(indexName,IndexFields,options,'');
|
||
end;
|
||
{$endif}
|
||
|
||
{$ifdef DELPHI_3}
|
||
procedure TDbf.AddIndex(const IndexName, Fields: String; Options: TIndexOptions);
|
||
var
|
||
DescFields:string;
|
||
{$else}
|
||
{$ifndef fpc}
|
||
procedure TDbf.AddIndex(const IndexName, Fields: String; Options: TIndexOptions; const DescFields: String='');
|
||
var
|
||
{$else}
|
||
procedure TDbf.AddIndex(const AnIndexName, IndexFields: String; Options: TIndexOptions; const DescFields: String);
|
||
var
|
||
{$endif}
|
||
{$endif}
|
||
lfilename:string;
|
||
lIndexFile:TIndexFile;
|
||
lIndex:TIndex;
|
||
cur,thelast:integer;
|
||
begin
|
||
lfilename:=lowercase(_GetPath+IndexName);
|
||
lIndexFile:=TIndexFile(GetPagedFile(lfilename));
|
||
if lIndexFile<>nil then exit;
|
||
lIndexFile:=TIndexFile.Create(lfilename,fmCreate);
|
||
lIndex:=TIndex.Create(lIndexFile,0,true);
|
||
{$ifndef fpc}
|
||
lIndex.InitFieldDef(_DbfFile,Fields);
|
||
{$else}
|
||
lIndex.InitFieldDef(_DbfFile,IndexFields);
|
||
{$endif}
|
||
with lIndex._NdxHdr do begin
|
||
startpage:=1;
|
||
nbPage:=1;
|
||
keyformat:=#0;
|
||
keytype:='C';
|
||
dummy:=$5800;
|
||
keylen:=lindex._FieldLen;
|
||
nbkey:=(512-8) div (lindex._FieldLen+8);
|
||
keyreclen:=lindex._FieldLen+8;
|
||
Unique:=0;
|
||
KeyDesc[0]:=' ';
|
||
{$ifndef fpc}
|
||
StrLCopy(KeyDesc,PChar(UpperCase(Fields)),255);
|
||
{$else}
|
||
StrLCopy(KeyDesc,PChar(UpperCase(IndexFields)),255);
|
||
{$endif}
|
||
end;
|
||
lindex._IndexFile._Seek(lindex._RootPage);
|
||
lindex._IndexFile.Stream.Write(lindex._NdxHdr,SizeOf(lindex._NdxHdr));
|
||
|
||
cur:=0;
|
||
thelast:=_DbfFile.CalcRecordCount;
|
||
|
||
while cur<thelast do begin
|
||
_DbfFile.ReadRecord(cur, _PrevBuffer);
|
||
lIndex.Insert(cur,_PrevBuffer);
|
||
inc(cur);
|
||
end;
|
||
_Indexes.Add(lIndex);
|
||
end;
|
||
//==========================================================
|
||
//============ dbtfile
|
||
//==========================================================
|
||
constructor TDbtFile.Create(const FileName: string; Mode: Word; Ver:xBaseVersion);
|
||
begin
|
||
inherited Create(FileName,Mode);
|
||
_DbtVersion:=Ver;
|
||
if mode = fmCreate then begin
|
||
FillChar(_MemoHdr,sizeof(_MemoHdr),0);
|
||
end else begin
|
||
Stream.Position:=0;
|
||
Stream.read(_MemoHdr,SizeOf(_MemoHdr));
|
||
end;
|
||
HeaderSize:=0;
|
||
RecordSize:=_MemoHdr.BlockLen;
|
||
|
||
if (RecordSize=0) or ((RecordSize mod 128)<>0) then begin
|
||
_MemoHdr.BlockLen := $200;
|
||
RecordSize := $200;
|
||
end;
|
||
// Can you tell me why the header of dbase3 memo contains 1024 and it 512 ?
|
||
if _DbtVersion=xBaseIII then RecordSize:=512;
|
||
end;
|
||
|
||
procedure TDbtFile.ReadMemo(recno:Integer;Dst:TStream);
|
||
var
|
||
Buff:array[0..511] of char;
|
||
i,lsize:integer;
|
||
finish:boolean;
|
||
lastc:char;
|
||
begin
|
||
if recno=0 then Exit;
|
||
Stream.Position:= RecordSize * recno;
|
||
if _DbtVersion >= xBaseIV then begin // dBase4 memofiles
|
||
Stream.read(Buff[0],8);
|
||
if (Buff[0]=#$ff) and (Buff[1]=#$ff) and
|
||
(Buff[2]=#$08) and (Buff[3]=#$00) then begin
|
||
// dbase IV memo
|
||
lsize:=(PInteger(@Buff[4])^)-8;
|
||
end else begin
|
||
lsize:=0;
|
||
end;
|
||
repeat
|
||
if lsize>SizeOf(Buff) then begin
|
||
Stream.read(Buff,SizeOf(Buff));
|
||
Dst.Write(buff,SizeOf(Buff));
|
||
Dec(lsize,SizeOf(Buff));
|
||
end else if lsize>0 then begin
|
||
Stream.read(Buff,lsize);
|
||
Dst.Write(buff,lsize);
|
||
lsize:=0;
|
||
end;
|
||
until lsize=0;
|
||
end else begin
|
||
finish:=False;
|
||
Stream.read(Buff,SizeOf(Buff));
|
||
lastc:=#0;
|
||
repeat
|
||
for i:=0 to SizeOf(Buff)-2 do begin
|
||
if ((Buff[i]=#$1A) and
|
||
((Buff[i+1]=#$1A) or ((i=0) and (lastc=#$1A))))
|
||
or (Buff[i]=#$0)
|
||
then begin
|
||
if i>0 then Dst.Write(buff,i);
|
||
finish:=True;
|
||
break;
|
||
end;
|
||
end;
|
||
if finish then Break;
|
||
Dst.Write(buff,512);
|
||
lastc:=Buff[511];
|
||
Stream.read(Buff,SizeOf(Buff));
|
||
until finish;
|
||
end;
|
||
Dst.Seek(0,0);
|
||
end;
|
||
|
||
procedure TDbtFile.WriteMemo(var MemoRecno:Integer;ReadSize:Integer;Src:TStream);
|
||
var
|
||
ByteBefore:Integer;
|
||
ByteAfter:Integer;
|
||
Buff:array[0..511] of char;
|
||
i:Integer;
|
||
c:Byte;
|
||
Append:Boolean;
|
||
begin
|
||
if _DbtVersion >= xBaseIV then begin // dBase4 memofiles
|
||
ByteBefore:=8;
|
||
ByteAfter:=0;
|
||
end else begin // stupid files
|
||
ByteBefore:=0;
|
||
ByteAfter:=2;
|
||
end;
|
||
if Src.Size = 0 then begin
|
||
MemoRecno:=0;
|
||
end else begin
|
||
if ((ByteBefore+Src.Size+ByteAfter+_MemoHdr.BlockLen-1) div _MemoHdr.BlockLen)
|
||
<= ((ReadSize+_MemoHdr.BlockLen-1) div _MemoHdr.BlockLen)
|
||
then begin
|
||
Append:=false;
|
||
//MemoRecno:=MemoRecno;
|
||
end else begin
|
||
Append:=True;
|
||
MemoRecno:=_MemoHdr.NextBlock;
|
||
if MemoRecno=0 then begin
|
||
_MemoHdr.NextBlock:=1;
|
||
MemoRecno:=1;
|
||
end;
|
||
end;
|
||
Stream.Seek(_MemoHdr.BlockLen * MemoRecno,0);
|
||
i:=Src.Position;
|
||
Src.Seek(0,0);
|
||
if ByteBefore=8 then begin
|
||
i:=$0008ffff;
|
||
Stream.Write(i,4);
|
||
i:=Src.Size+ByteBefore+ByteAfter;
|
||
Stream.Write(i,4);
|
||
end;
|
||
repeat
|
||
i:=Src.Read(buff,512);
|
||
if i=0 then break;
|
||
Inc(_MemoHdr.NextBlock);
|
||
Stream.Write(Buff,i);
|
||
until i<512;
|
||
if ByteAfter=2 then begin
|
||
c:=$1A;
|
||
Stream.Write(c,1);
|
||
Stream.Write(c,1);
|
||
end;
|
||
if Append then begin
|
||
Stream.Seek(0,0);
|
||
Stream.Write(_MemoHdr,SizeOf(_MemoHdr))
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
//==========================================================
|
||
//============ TIndexFile
|
||
//==========================================================
|
||
constructor TIndexFile.Create(const FileName: string; Mode: Word);
|
||
var
|
||
ext:string;
|
||
i:Integer;
|
||
begin
|
||
inherited Create(FileName,Mode);
|
||
HeaderSize:=0;
|
||
RecordSize:=512;
|
||
|
||
ext:=ExtractFileExt(FileName);
|
||
if (ext='.mdx') then begin
|
||
_IndexVersion:=xBaseIV;
|
||
if Mode = fmCreate then begin
|
||
FillChar(_MdxHdr,sizeof(_MdxHdr),0);
|
||
end else begin
|
||
Stream.read(_MdxHdr,SizeOf(_MdxHdr));
|
||
end;
|
||
for i:= 0 to _MdxHdr.TagUsed-1 do begin
|
||
// Stream.Position :=544 + i * _MdxHdr.TagSize;
|
||
// Stream.read(lMdxTag,SizeOf(rMdxTag));
|
||
// lIndex:=TIndex.Create(Self,lMdxTag.pageno);
|
||
// _Indexes.Add(lIndex);
|
||
// if i=0 then lIndex.ReadPage(lIndex._NdxHdr.startpage);
|
||
end;
|
||
end else begin
|
||
_IndexVersion:=xBaseIII;
|
||
(*
|
||
_IndexFile._Seek(Pos);
|
||
_IndexFile.Stream.Read(_NdxHdr,SizeOf(_NdxHdr));
|
||
_Root:=TIndexPage.Create(Self);
|
||
_Root.SetPageNo(_NdxHdr.startpage);
|
||
lPos:=_Root;
|
||
_nblevel:=1;
|
||
repeat
|
||
lPos.LocalFirst;
|
||
if lPos.Entry._LowerPage=0 then break;
|
||
inc(_nblevel);
|
||
lChild:=TIndexPage.Create(Self);
|
||
lChild._UpperLevel:=lPos;
|
||
lPos._LowerLevel:=lChild;
|
||
lChild.SetPageNo(lPos.Entry._LowerPage);
|
||
lPos:=lChild;
|
||
until false;
|
||
|
||
_Spare:=TIndexPage.Create(Self);
|
||
// _Field:=_IndexFile._Dbf.FindField(_NdxHdr.KeyDesc);
|
||
First;
|
||
*)
|
||
end;
|
||
end;
|
||
|
||
destructor TIndexFile.Destroy;
|
||
begin
|
||
inherited;
|
||
end;
|
||
|
||
//==========================================================
|
||
//============ TIndexPage
|
||
//==========================================================
|
||
constructor TIndexPage.Create(Parent:TIndex);
|
||
begin
|
||
_LowerLevel:=nil;
|
||
_UpperLevel:=nil;
|
||
_Index:=Parent;
|
||
_PageNo:=-1;
|
||
_EntryNo:=-1;
|
||
end;
|
||
|
||
destructor TIndexPage.Destroy;
|
||
begin
|
||
if _LowerLevel<>nil then _LowerLevel.Free;
|
||
end;
|
||
|
||
function TIndexPage.GetPEntry(EntryNo:integer):PNdxEntry;
|
||
begin
|
||
Result:=PNdxentry(@_PageBuff.Entries[_Index._NdxHdr.keyreclen*entryno]);
|
||
end;
|
||
|
||
function TIndexPage.LocalInsert(Recno:integer; Buffer:Pchar;LowerPage:integer):boolean;
|
||
var
|
||
src,dst:pointer;
|
||
siz:integer;
|
||
begin
|
||
if _PageBuff.NbEntries < _Index._NdxHdr.nbkey then begin
|
||
src:=Entry;
|
||
dst:=GetPEntry(_EntryNo+1);
|
||
siz:=(_PageBuff.NbEntries - _EntryNo)
|
||
* _Index._NdxHdr.keyreclen + 8;
|
||
Move(Src^, Dst^, Siz);
|
||
inc(_PageBuff.NbEntries);
|
||
SetEntry(Recno,Buffer,LowerPage);
|
||
Write;
|
||
Result:=true;
|
||
end else begin
|
||
Result:=false;
|
||
end;
|
||
end;
|
||
|
||
|
||
function TIndexPage.LocalDelete:boolean;
|
||
var
|
||
src,dst:pointer;
|
||
siz:integer;
|
||
begin
|
||
if _PageBuff.NbEntries >=0 then begin
|
||
if _EntryNo<_PageBuff.NbEntries then begin
|
||
src:=GetPEntry(_EntryNo+1);
|
||
dst:=Entry;
|
||
siz:=(_PageBuff.NbEntries - _EntryNo - 1)
|
||
* _Index._NdxHdr.keyreclen + 8;
|
||
Move(Src^, Dst^, Siz);
|
||
end;
|
||
dec(_PageBuff.NbEntries);
|
||
Write;
|
||
if ((_PageBuff.NbEntries=0) and (_lowerlevel=nil))
|
||
or (_PageBuff.NbEntries<0) then begin
|
||
if _UpperLevel<>nil then begin
|
||
_UpperLevel.LocalDelete;
|
||
end;
|
||
end else if (_EntryNo>LastEntryNo) then begin
|
||
SetEntryNo(LastEntryNo); // We just removed the last on this page.
|
||
if (_UpperLevel<>nil) then begin
|
||
_UpperLevel.SetEntry(0,Entry^.CKey,_PageNo);
|
||
end;
|
||
end;
|
||
Result:=true;
|
||
end else begin
|
||
Result:=false;
|
||
end;
|
||
end;
|
||
|
||
function TIndexPage.LastEntryNo:integer;
|
||
begin
|
||
if (_LowerLevel=nil) then begin
|
||
result := _PageBuff.NbEntries - 1;
|
||
end else begin
|
||
result := _PageBuff.NbEntries;
|
||
end;
|
||
end;
|
||
|
||
procedure TIndexPage.LocalFirst;
|
||
begin
|
||
SetEntryNo(0);
|
||
end;
|
||
|
||
procedure TIndexPage.LocalLast;
|
||
begin
|
||
SetEntryNo(LastEntryNo);
|
||
end;
|
||
|
||
function TIndexPage.LocalPrev:boolean;
|
||
begin
|
||
if _EntryNo>0 then begin
|
||
SetEntryNo(_EntryNo-1);
|
||
Result:=true;
|
||
end else begin
|
||
Result:=false;
|
||
end;
|
||
end;
|
||
|
||
function TIndexPage.LocalNext:boolean;
|
||
begin
|
||
if (_EntryNo<LastEntryNo) then begin
|
||
SetEntryNo(_EntryNo+1);
|
||
Result:=true;
|
||
end else begin
|
||
Result:=false;
|
||
end;
|
||
end;
|
||
|
||
procedure TIndexPage.First;
|
||
begin
|
||
LocalFirst;
|
||
if (_LowerLevel<>nil) then LowerLevel.First;
|
||
end;
|
||
|
||
procedure TIndexPage.Last;
|
||
begin
|
||
LocalLast;
|
||
if (_LowerLevel<>nil) then LowerLevel.Last;
|
||
end;
|
||
|
||
function TIndexPage.Prev:boolean;
|
||
begin
|
||
if (_LowerLevel<>nil) and LowerLevel.Prev then begin
|
||
result:=true;
|
||
exit;
|
||
end;
|
||
Result:=LocalPrev;
|
||
if Result and (Entry^._LowerPage>0) then LowerLevel.Last;
|
||
end;
|
||
|
||
function TIndexPage.Next:boolean;
|
||
begin
|
||
if (_LowerLevel<>nil) and LowerLevel.next then begin
|
||
result:=true;
|
||
exit;
|
||
end;
|
||
Result:=LocalNext;
|
||
if Result and (Entry^._LowerPage>0) then LowerLevel.First;
|
||
end;
|
||
|
||
|
||
function TIndexPage.FindNearest(Recno:integer; Key:pchar):integer;
|
||
var
|
||
cmpres:integer;
|
||
v1,v2:double;
|
||
p:TIndexPage;
|
||
begin
|
||
Result:=-1;
|
||
if @Key=nil then begin
|
||
Exit;
|
||
end;
|
||
SetEntryNo(0);
|
||
while _EntryNo<=_PageBuff.NbEntries do begin
|
||
if _EntryNo=_PageBuff.NbEntries then break;
|
||
if _Index._NdxHdr.keytype='C' then begin
|
||
cmpres:=StrLIComp(PChar(Key),Entry^.CKey,_Index._FieldLen);
|
||
end else begin
|
||
// Numeric field... to do
|
||
v1:=PDouble(Key)^;
|
||
v2:=Entry^.NKey;
|
||
if v1>v2 then cmpres:=1
|
||
else if v1<v2 then cmpres:=-1
|
||
else cmpres:=0;
|
||
end;
|
||
if cmpres=0 then begin
|
||
if _LowerLevel=nil then begin
|
||
if (Entry^.RecNo=Recno) then begin
|
||
result:=0;
|
||
Exit;
|
||
end else if (Entry^.Recno>Recno) then begin
|
||
result:=-1;
|
||
Exit;
|
||
end;
|
||
end else begin
|
||
p:=self;
|
||
while p._LowerLevel<>nil do begin
|
||
p:=p.LowerLevel;
|
||
p.LocalLast;
|
||
end;
|
||
if (p.Entry^.Recno>=Recno) then begin
|
||
result:=-1;
|
||
Exit;
|
||
end;
|
||
end;
|
||
end else if cmpres<0 then begin
|
||
result:=-1;
|
||
exit;
|
||
end;
|
||
SetEntryNo(_EntryNo+1);
|
||
end;
|
||
result:=1;
|
||
Exit;
|
||
end;
|
||
|
||
procedure TIndexPage.SetEntry(Recno:Integer; key:PChar; LowerPage:integer);
|
||
begin
|
||
assert((_EntryNo>=0) and (_EntryNo<=_PageBuff.NbEntries));
|
||
if (_EntryNo=self._PageBuff.NbEntries) then begin
|
||
if (_UpperLevel<>nil) then begin
|
||
_UpperLevel.SetEntry(0,key,Self._PageNo);
|
||
end;
|
||
end else begin
|
||
if _Index._NdxHdr.keytype='C' then begin
|
||
mymove(key,Entry^.CKey,_Index._NdxHdr.keylen);
|
||
end else begin
|
||
Entry^.NKey:=PDouble(key)^;
|
||
end;
|
||
end;
|
||
Entry^.RecNo:=RecNo;
|
||
Entry^._LowerPage:=LowerPage;
|
||
Write;
|
||
end;
|
||
function TIndexPage.LowerLevel : TIndexPage;
|
||
begin
|
||
if (_LowerLevel<>nil) and (_LowerLevel._PageNo<>Entry^._LowerPage) then begin
|
||
_LowerLevel.SetPageNo(Entry^._LowerPage);
|
||
end;
|
||
result:=_LowerLevel;
|
||
end;
|
||
|
||
function TIndexPage.Insert(Recno:Integer; Buffer:PChar; LowerPage:integer):boolean;
|
||
var
|
||
src,dst:PNdxEntry;
|
||
siz:integer;
|
||
split,old_entry:integer;
|
||
lSpare:TIndexPage;
|
||
begin
|
||
if not LocalInsert(recno,buffer,lowerpage) then begin
|
||
// The entry is FULL so we will split this page
|
||
// 1 - Check parent exist
|
||
if _UpperLevel=nil then begin
|
||
AddNewLevel;
|
||
end;
|
||
|
||
old_entry:=_EntryNo;
|
||
split:=_EntryNo;
|
||
if split < _Index._NdxHdr.nbkey div 2 then begin
|
||
split:=_Index._NdxHdr.nbkey div 2;
|
||
end;
|
||
lSpare:=TIndexPage.Create(_Index);
|
||
try
|
||
// 2 - Create new page with first part
|
||
inc(_Index._NdxHdr.nbPage);
|
||
lSpare._PageNo:=_Index._NdxHdr.nbPage;
|
||
_Index._IndexFile._Seek(_Index._RootPage);
|
||
_Index._IndexFile.Stream.WriteBuffer (_Index._NdxHdr, SizeOf(_Index._NdxHdr));
|
||
|
||
if _lowerlevel=nil then begin
|
||
lSpare._PageBuff.NbEntries:=split;
|
||
end else begin
|
||
lSpare._PageBuff.NbEntries:=split-1;
|
||
end;
|
||
siz:=split*_Index._NdxHdr.keyreclen+8;
|
||
src:=@_PageBuff.Entries;
|
||
dst:=@lSpare._PageBuff.Entries;
|
||
Move(src^,dst^,siz);
|
||
lSpare.Write;
|
||
|
||
// 3 - Keep only end-part in this page
|
||
siz:=(_PageBuff.NbEntries-Split);
|
||
_PageBuff.NbEntries:=siz;
|
||
|
||
siz:=siz*_Index._NdxHdr.keyreclen+8;
|
||
SetEntryNo(split);
|
||
src:=Entry;
|
||
SetEntryNo(0);
|
||
dst:=Entry;
|
||
Move(src^,dst^,siz);
|
||
|
||
// 3 - Update upper level
|
||
lSpare.SetEntryNo(split-1);
|
||
_UpperLevel.Insert(0,lSpare.Entry^.CKey,lSpare._PageNo);
|
||
|
||
// We just need to go on inserted record now
|
||
|
||
if old_entry>=split then begin
|
||
_UpperLevel.LocalNext;
|
||
SetEntryNo(old_entry - split);
|
||
LocalInsert(Recno,Buffer,LowerPage);
|
||
lSpare.Write;
|
||
end else begin
|
||
lSpare.SetEntryNo(old_entry);
|
||
lSpare.LocalInsert(Recno,Buffer,LowerPage);
|
||
Write;
|
||
end;
|
||
finally
|
||
lspare.free;
|
||
end;
|
||
end;
|
||
Result:=true;
|
||
end;
|
||
|
||
function TIndexPage.Delete:boolean;
|
||
begin
|
||
Result:=LocalDelete;
|
||
end;
|
||
|
||
procedure TIndexPage.SetPageNo(page:Integer);
|
||
begin
|
||
if (_PageNo<>page) and (page>0) then begin
|
||
_Index._IndexFile.ReadRecord(Page,@_PageBuff);
|
||
_PageNo:=page;
|
||
_EntryNo:=-1;
|
||
end;
|
||
end;
|
||
|
||
procedure TIndexPage.AddNewLevel;
|
||
var
|
||
lNewPage:TIndexPage;
|
||
begin
|
||
lNewPage:=TIndexPage.Create(_Index);
|
||
inc(_Index._NdxHdr.nbPage);
|
||
lNewPage._PageNo:= _Index._NdxHdr.nbPage;
|
||
_Index._NdxHdr.startpage:= _Index._NdxHdr.nbPage;
|
||
_Index._IndexFile._Seek(_Index._RootPage);
|
||
_Index._IndexFile.Stream.WriteBuffer (_Index._NdxHdr, SizeOf(_Index._NdxHdr));
|
||
|
||
lNewPage._PageBuff.NbEntries:=0;
|
||
lNewPage._UpperLevel:=nil;
|
||
lNewPage._LowerLevel:=_Index._Root;
|
||
lNewPage.SetEntryNo(0);
|
||
lNewPage.SetEntry(0,nil,_PageNo);
|
||
_Index._Root._UpperLevel:=lNewPage;
|
||
_Index._Root:=lNewPage;
|
||
lNewPage:=nil;
|
||
end;
|
||
|
||
procedure TIndexPage.Write;
|
||
begin
|
||
_Index._IndexFile.WriteRecord(_PageNo,@_PageBuff);
|
||
end;
|
||
|
||
procedure TIndexPage.SetEntryNo(entryno:Integer);
|
||
begin
|
||
if (_EntryNo<>entryno) then begin
|
||
_EntryNo:=entryno;
|
||
if _EntryNo>=0 then Entry:=PNdxentry(@_PageBuff.Entries[_Index._NdxHdr.keyreclen*entryno]);
|
||
end;
|
||
end;
|
||
|
||
procedure TIndexPage.WritePage(Page:integer);
|
||
begin
|
||
_Index._IndexFile.WriteRecord(Page,@_PageBuff);
|
||
end;
|
||
|
||
//==========================================================
|
||
//============ TIndex
|
||
//==========================================================
|
||
constructor TIndex.Create(Parent:TIndexFile; RootPage:integer;CreateIt:boolean);
|
||
var
|
||
lPos:TIndexPage;
|
||
lChild:TIndexPage;
|
||
begin
|
||
_RootPage:=RootPage;
|
||
_IndexFile:=Parent;
|
||
//_IndexOrder:=TList.Create;
|
||
if CreateIt then begin
|
||
FillChar(_NdxHdr,sizeof(_NdxHdr),0);
|
||
_NdxHdr.startpage:=1;
|
||
_NdxHdr.nbPage:=2;
|
||
_NdxHdr.keyformat:=#0;
|
||
_NdxHdr.keytype:='C';
|
||
|
||
_IndexFile._Seek(RootPage);
|
||
_IndexFile.Stream.Write(_NdxHdr,SizeOf(_NdxHdr));
|
||
_FieldPos := 0;
|
||
_FieldLen := 0;
|
||
end else begin
|
||
_IndexFile._Seek(RootPage);
|
||
_IndexFile.Stream.Read(_NdxHdr,SizeOf(_NdxHdr));
|
||
end;
|
||
|
||
_Root:=TIndexPage.Create(Self);
|
||
_Root.SetPageNo(_NdxHdr.startpage);
|
||
lPos:=_Root;
|
||
_nblevel:=1;
|
||
repeat
|
||
lPos.LocalFirst;
|
||
if lPos.Entry^._LowerPage=0 then break;
|
||
inc(_nblevel);
|
||
lChild:=TIndexPage.Create(Self);
|
||
lChild._UpperLevel:=lPos;
|
||
lPos._LowerLevel:=lChild;
|
||
lChild.SetPageNo(lPos.Entry^._LowerPage);
|
||
lPos:=lChild;
|
||
until false;
|
||
|
||
inc(_IndexFile._cntuse);
|
||
First;
|
||
end;
|
||
|
||
destructor TIndex.Destroy;
|
||
begin
|
||
_IndexFile.Release;
|
||
_Root.Free;
|
||
end;
|
||
|
||
|
||
function TIndex.Find(Recno:integer; Buffer:PChar; var pPos:TIndexPage):integer;
|
||
var
|
||
res:integer;
|
||
begin
|
||
pPos:=_Root;
|
||
repeat
|
||
res:=pPos.FindNearest(Recno,Buffer);
|
||
if res<>0 then begin
|
||
if pPos.Entry^._LowerPage<>0 then begin
|
||
pPos:=pPos.LowerLevel;
|
||
res:=2;
|
||
end;
|
||
end;
|
||
until res<>2;
|
||
Result:=res;
|
||
end;
|
||
|
||
procedure TIndex.Update(Recno: integer; PrevBuffer,NewBuffer: PChar);
|
||
var
|
||
lPos:TIndexPage;
|
||
begin
|
||
if _FieldLen=0 then exit;
|
||
|
||
inc(PrevBuffer,_FieldPos);
|
||
inc(NewBuffer,_FieldPos);
|
||
|
||
if StrLIComp(PrevBuffer,NewBuffer,_FieldLen)<>0 then begin
|
||
Delete;
|
||
Find(Recno+1,NewBuffer,lPos);
|
||
lPos.Insert(Recno+1,NewBuffer,0);
|
||
end;
|
||
end;
|
||
|
||
procedure TIndex.Insert(Recno:integer; Buffer:PChar);
|
||
var
|
||
lPos:TIndexPage;
|
||
begin
|
||
if _FieldLen=0 then exit;
|
||
|
||
inc(Buffer,_FieldPos);
|
||
|
||
Find(Recno+1,Buffer,lPos);
|
||
lPos.Insert(Recno+1,Buffer,0);
|
||
end;
|
||
|
||
function TIndex.Delete:boolean;
|
||
var
|
||
lPos:TIndexPage;
|
||
begin
|
||
lpos:=_root;
|
||
while lpos._LowerLevel<>nil do begin
|
||
lPos:=lPos.LowerLevel;
|
||
end;
|
||
lPos.Delete;
|
||
Result:=true;
|
||
end;
|
||
|
||
|
||
function TIndex.Pos:TIndexPage;
|
||
var
|
||
p:TIndexPage;
|
||
begin
|
||
p:=_Root;
|
||
while p.Entry^._LowerPage>0 do begin
|
||
p:=p.LowerLevel;
|
||
end;
|
||
result:=p;
|
||
end;
|
||
|
||
procedure TIndex.First;
|
||
begin
|
||
_Root.First;
|
||
dec(Pos._EntryNo);
|
||
end;
|
||
|
||
procedure TIndex.Last;
|
||
begin
|
||
_Root.Last;
|
||
inc(Pos._EntryNo);
|
||
end;
|
||
|
||
function TIndex.Prev:boolean;
|
||
begin
|
||
result:=_Root.Prev;
|
||
end;
|
||
|
||
function TIndex.Next:boolean;
|
||
begin
|
||
result:=_Root.Next;
|
||
end;
|
||
|
||
(*
|
||
procedure TIndex.SetRecNo(Value: Integer);
|
||
var
|
||
pos:integer;
|
||
p:TIndexPage;
|
||
i:integer;
|
||
ldiv:integer;
|
||
begin
|
||
p:=_Root;
|
||
ldiv:=1;
|
||
while p.Entry^._LowerPage>0 do begin
|
||
ldiv:=ldiv*(_NdxHdr.nbkey+1);
|
||
p:=p._LowerLevel;
|
||
end;
|
||
pos:=value div ldiv;
|
||
p:=_Root;
|
||
while p.Entry^._LowerPage>0 do begin
|
||
p._EntryNo:=pos;
|
||
value:=value - pos * (_NdxHdr.nbkey+1);
|
||
ldiv:=ldiv div (_NdxHdr.nbkey+1);
|
||
pos:=value div ldiv;
|
||
p:=p._LowerLevel;
|
||
end;
|
||
{
|
||
pos:=1;
|
||
First;
|
||
While pos<value do begin
|
||
if Next = false then break;
|
||
inc(pos);
|
||
end;
|
||
}
|
||
end;
|
||
*)
|
||
function TIndex.GuessRecordCount: Integer;
|
||
var
|
||
lPos:TIndexPage;
|
||
nbrecord:integer;
|
||
begin
|
||
// I just read first level and Guess an approximate record count...
|
||
nbrecord:=_Root._PageBuff.NbEntries;
|
||
lPos:=_Root.LowerLevel;
|
||
while lpos<>nil do begin
|
||
nbrecord:=nbrecord*(_NdxHdr.nbkey+1);
|
||
lPos:=lPos.LowerLevel;
|
||
end;
|
||
result:=nbrecord;
|
||
end;
|
||
|
||
|
||
function TIndex.GuessRecNo:Integer;
|
||
var
|
||
p:TIndexPage;
|
||
begin
|
||
p:=_Root;
|
||
result:=p._EntryNo;
|
||
while p.Entry^._LowerPage>0 do begin
|
||
p:=p.LowerLevel;
|
||
Result:=Result*(_NdxHdr.nbkey+1) + p._EntryNo;
|
||
end;
|
||
end;
|
||
|
||
function TIndex.GetRealRecNo:integer;
|
||
var
|
||
ippos : TIndexPage;
|
||
begin
|
||
ippos:=_Root;
|
||
while ippos._LowerLevel<>nil do begin
|
||
ippos:=pos.LowerLevel;
|
||
end;
|
||
if (ippos._EntryNo<0) or (ippos._EntryNo>=ippos._PageBuff.NbEntries) then Result:=-1
|
||
else Result:=ippos.Entry^.RecNo-1;
|
||
end;
|
||
|
||
procedure TIndex.GotoKey(recno:integer; buffer:pchar);
|
||
begin
|
||
// very temporary implementation
|
||
// could definitely be a bit faster.
|
||
_Root.First;
|
||
repeat
|
||
if self.Pos.Entry^.RecNo=(recno+1) then begin
|
||
exit;
|
||
end;
|
||
until Next=false;
|
||
end;
|
||
|
||
procedure TIndex.InitFieldDef(dbfFile:TDbfFile;FieldDesc:string);
|
||
var
|
||
FieldInfo:TMyFieldInfo;
|
||
begin
|
||
FieldInfo:=DbfFile.GetFieldInfo(FieldDesc);
|
||
if FieldInfo<>nil then begin
|
||
_FieldPos:=FieldInfo.Offset;
|
||
_FieldLen:=FieldInfo.Size;
|
||
end;
|
||
end;
|
||
|
||
//==========================================================
|
||
//============ initialization
|
||
//==========================================================
|
||
|
||
{$ifndef fpc}
|
||
type
|
||
|
||
TTableNameProperty = class(TStringProperty)
|
||
public
|
||
procedure Edit; override;
|
||
function GetAttributes: TPropertyAttributes; override;
|
||
end;
|
||
|
||
procedure TTableNameProperty.Edit; {override;}
|
||
var
|
||
FileOpen: TOpenDialog;
|
||
Dbf: TDbf;
|
||
begin
|
||
FileOpen := TOpenDialog.Create(Application);
|
||
try
|
||
with fileopen do begin
|
||
Dbf:=GetComponent(0) as TDbf;
|
||
Filename := Dbf.DesignTimePath + GetValue;
|
||
Filter := 'Dbf table|*.dbf';
|
||
if Execute then begin
|
||
SetValue(ExtractFilename(Filename));
|
||
Dbf.DesignTimePath:=ExtractFilePath(Filename);
|
||
end;
|
||
end;
|
||
finally
|
||
Fileopen.free;
|
||
end;
|
||
end;
|
||
|
||
function TTableNameProperty.GetAttributes: TPropertyAttributes; {override;}
|
||
begin
|
||
Result := [paDialog, paRevertable];
|
||
end;
|
||
|
||
|
||
|
||
type
|
||
TRunTimePathProperty = class(TStringProperty)
|
||
end;
|
||
|
||
TDesignTimePathProperty = class(TStringProperty)
|
||
end;
|
||
|
||
//==========================================================
|
||
//============ initialization
|
||
//==========================================================
|
||
|
||
procedure Register;
|
||
begin
|
||
RegisterComponents('Exemples', [TDbf]);
|
||
RegisterPropertyEditor(TypeInfo(string), TDbf, 'TableName', TTableNameProperty);
|
||
RegisterPropertyEditor(TypeInfo(string), TDbf, 'RunTimePath', TRunTimePathProperty);
|
||
RegisterPropertyEditor(TypeInfo(string), TDbf, 'DesignTimePath', TDesignTimePathProperty);
|
||
// RegisterPropertyEditor(TypeInfo(TStrings), TDbf, 'IndexFiles', TIndexFilesProperty);
|
||
// ShowMessage(ToolServices.GetProjectName);
|
||
end;
|
||
{$endif fpc}
|
||
|
||
initialization
|
||
_PagedFiles := TList.Create;
|
||
tDbf_TrimFields := true;
|
||
|
||
finalization
|
||
_PagedFiles.free;
|
||
|
||
end.
|