Why Gemfury?
Push, build, and install
RubyGems
npm packages
Python packages
Maven artifacts
PHP packages
Go Modules
Debian packages
RPM packages
NuGet packages
Repository URL to install this package:
|
Version:
3.2.0 ▾
|
unit dbf_idxfile;
interface
{$I dbf_common.inc}
uses
{$ifdef WINDOWS}
Windows,
{$else}
{$ifdef KYLIX}
Libc,
{$endif}
Types, dbf_wtil,
{$endif}
SysUtils,
Classes,
db,
dbf_pgfile,
{$ifdef USE_CACHE}
dbf_pgcfile,
{$endif}
dbf_parser,
dbf_prsdef,
dbf_cursor,
dbf_collate,
dbf_common;
{$ifdef _DEBUG}
{$define TDBF_INDEX_CHECK}
{$endif}
{$ifdef _ASSERTS}
{$define TDBF_INDEX_CHECK}
{$endif}
const
MaxIndexes = 47;
type
TIndexPage = class;
TIndexTag = class;
TIndexUpdateMode = (umAll, umCurrent);
TLocaleError = (leNone, leUnknown, leTableIndexMismatch, leNotAvailable);
TLocaleSolution = (lsNotOpen, lsNoEdit, lsBinary);
TIndexUniqueType = (iuNormal, iuUnique, iuDistinct);
TIndexModifyMode = (mmNormal, mmDeleteRecall);
TDbfLocaleErrorEvent = procedure(var Error: TLocaleError; var Solution: TLocaleSolution) of object;
TDbfCompareKeysEvent = function(Key1, Key2: PChar): Integer of object;
PDouble = ^Double;
PInteger = ^Integer;
//===========================================================================
TDbfIndexDef = class;
TDbfIndexDef = class(TCollectionItem)
protected
FIndexName: string;
FExpression: string;
FOptions: TIndexOptions;
FTemporary: Boolean; // added at runtime
procedure SetIndexName(NewName: string);
procedure SetExpression(NewField: string);
public
constructor Create(ACollection: TCollection); override;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
property Temporary: Boolean read FTemporary write FTemporary;
property Name: string read FIndexName write SetIndexName;
property Expression: string read FExpression write SetExpression;
published
property IndexFile: string read FIndexName write SetIndexName;
property SortField: string read FExpression write SetExpression;
property Options: TIndexOptions read FOptions write FOptions;
end;
TDbfIndexParser = class(TDbfParser)
protected
FResultLen: Integer;
procedure ValidateExpression(AExpression: string); override;
public
property ResultLen: Integer read FResultLen;
end;
//===========================================================================
TIndexFile = class;
TIndexPageClass = class of TIndexPage;
TIndexPage = class(TObject)
protected
FIndexFile: TIndexFile;
FLowerPage: TIndexPage;
FUpperPage: TIndexPage;
FPageBuffer: Pointer;
FEntry: Pointer;
FEntryNo: Integer;
FLockCount: Integer;
FModified: Boolean;
FPageNo: Integer;
FWeight: Integer;
// bracket props
FLowBracket: Integer; // = FLowIndex if FPageNo = FLowPage
FLowIndex: Integer;
FLowPage: Integer;
FLowPageTemp: Integer;
FHighBracket: Integer; // = FHighIndex if FPageNo = FHighPage
FHighIndex: Integer;
FHighPage: Integer;
FHighPageTemp: Integer;
procedure LocalInsert(RecNo: Integer; Buffer: PChar; LowerPageNo: Integer);
procedure LocalDelete;
procedure Delete;
procedure SyncLowerPage;
procedure WritePage;
procedure Split;
procedure LockPage;
procedure UnlockPage;
function RecurPrev: Boolean;
function RecurNext: Boolean;
procedure RecurFirst;
procedure RecurLast;
procedure SetEntry(RecNo: Integer; AKey: PChar; LowerPageNo: Integer);
procedure SetEntryNo(value: Integer);
procedure SetPageNo(NewPageNo: Integer);
procedure SetLowPage(NewPage: Integer);
procedure SetHighPage(NewPage: Integer);
procedure SetUpperPage(NewPage: TIndexPage);
procedure UpdateBounds(IsInnerNode: Boolean);
protected
function GetEntry(AEntryNo: Integer): Pointer; virtual; abstract;
function GetLowerPageNo: Integer; virtual; abstract;
function GetKeyData: PChar; virtual; abstract;
function GetNumEntries: Integer; virtual; abstract;
function GetKeyDataFromEntry(AEntry: Integer): PChar; virtual; abstract;
function GetRecNo: Integer; virtual; abstract;
function GetIsInnerNode: Boolean; virtual; abstract;
procedure IncNumEntries; virtual; abstract;
procedure SetNumEntries(NewNum: Integer); virtual; abstract;
procedure SetRecLowerPageNo(NewRecNo, NewPageNo: Integer); virtual; abstract;
procedure SetRecLowerPageNoOfEntry(AEntry, NewRecNo, NewPageNo: Integer); virtual; abstract;
{$ifdef TDBF_UPDATE_FIRST_LAST_NODE}
procedure SetPrevBlock(NewBlock: Integer); virtual;
{$endif}
public
constructor Create(Parent: TIndexFile);
destructor Destroy; override;
function FindNearest(ARecNo: Integer): Integer;
function PhysicalRecNo: Integer;
function MatchKey: Integer;
procedure GotoInsertEntry;
procedure Clear;
procedure GetNewPage;
procedure Modified;
procedure RecalcWeight;
procedure UpdateWeight;
procedure Flush;
procedure SaveBracket;
procedure RestoreBracket;
property Key: PChar read GetKeyData;
property Entry: Pointer read FEntry;
property EntryNo: Integer read FEntryNo write SetEntryNo;
property IndexFile: TIndexFile read FIndexFile;
property UpperPage: TIndexPage read FUpperPage write SetUpperPage;
property LowerPage: TIndexPage read FLowerPage;
// property LowerPageNo: Integer read GetLowerPageNo; // never used
property PageBuffer: Pointer read FPageBuffer;
property PageNo: Integer read FPageNo write SetPageNo;
property Weight: Integer read FWeight;
property NumEntries: Integer read GetNumEntries;
property HighBracket: Integer read FHighBracket write FHighBracket;
property HighIndex: Integer read FHighIndex;
property HighPage: Integer read FHighPage write SetHighPage;
property LowBracket: Integer read FLowBracket write FLowBracket;
property LowIndex: Integer read FLowIndex;
property LowPage: Integer read FLowPage write SetLowPage;
end;
//===========================================================================
TIndexTag = class(TObject)
private
FTag: Pointer;
protected
function GetHeaderPageNo: Integer; virtual; abstract;
function GetTagName: string; virtual; abstract;
function GetKeyFormat: Byte; virtual; abstract;
function GetForwardTag1: Byte; virtual; abstract;
function GetForwardTag2: Byte; virtual; abstract;
function GetBackwardTag: Byte; virtual; abstract;
function GetReserved: Byte; virtual; abstract;
function GetKeyType: Char; virtual; abstract;
procedure SetHeaderPageNo(NewPageNo: Integer); virtual; abstract;
procedure SetTagName(NewName: string); virtual; abstract;
procedure SetKeyFormat(NewFormat: Byte); virtual; abstract;
procedure SetForwardTag1(NewTag: Byte); virtual; abstract;
procedure SetForwardTag2(NewTag: Byte); virtual; abstract;
procedure SetBackwardTag(NewTag: Byte); virtual; abstract;
procedure SetReserved(NewReserved: Byte); virtual; abstract;
procedure SetKeyType(NewType: Char); virtual; abstract;
public
property HeaderPageNo: Integer read GetHeaderPageNo write SetHeaderPageNo;
property TagName: string read GetTagName write SetTagName;
property KeyFormat: Byte read GetKeyFormat write SetKeyFormat;
property ForwardTag1: Byte read GetForwardTag1 write SetForwardTag1;
property ForwardTag2: Byte read GetForwardTag2 write SetForwardTag2;
property BackwardTag: Byte read GetBackwardTag write SetBackwardTag;
property Reserved: Byte read GetReserved write SetReserved;
property KeyType: Char read GetKeyType write SetKeyType;
property Tag: Pointer read FTag write FTag;
end;
//===========================================================================
{$ifdef USE_CACHE}
TIndexFile = class(TCachedFile)
{$else}
TIndexFile = class(TPagedFile)
{$endif}
protected
FIndexName: string;
FLastError: string;
FParsers: array[0..MaxIndexes-1] of TDbfIndexParser;
FIndexHeaders: array[0..MaxIndexes-1] of Pointer;
FIndexHeaderModified: array[0..MaxIndexes-1] of Boolean;
FIndexHeader: Pointer;
FIndexVersion: TXBaseVersion;
FRoots: array[0..MaxIndexes-1] of TIndexPage;
FLeaves: array[0..MaxIndexes-1] of TIndexPage;
FCurrentParser: TDbfIndexParser;
FRoot: TIndexPage;
FLeaf: TIndexPage;
FMdxTag: TIndexTag;
FTempMdxTag: TIndexTag;
FEntryHeaderSize: Integer;
FPageHeaderSize: Integer;
FTagSize: Integer;
FTagOffset: Integer;
FHeaderPageNo: Integer;
FSelectedIndex: Integer;
FRangeIndex: Integer;
FIsDescending: Boolean;
FUniqueMode: TIndexUniqueType;
FModifyMode: TIndexModifyMode;
FHeaderLocked: Integer; // used to remember which header page we have locked
FKeyBuffer: array[0..100] of Char;
FLowBuffer: array[0..100] of Char;
FHighBuffer: array[0..100] of Char;
FEntryBof: Pointer;
FEntryEof: Pointer;
FDbfFile: Pointer;
FCanEdit: Boolean;
FOpened: Boolean;
FRangeActive: Boolean;
FUpdateMode: TIndexUpdateMode;
FUserKey: PChar; // find / insert key
FUserRecNo: Integer; // find / insert recno
FUserBCD: array[0..10] of Byte;
FUserNumeric: Double;
FForceClose: Boolean;
FForceReadOnly: Boolean;
FCodePage: Integer;
FCollation: PCollationTable;
FCompareKeys: TDbfCompareKeysEvent;
FOnLocaleError: TDbfLocaleErrorEvent;
function GetNewPageNo: Integer;
procedure TouchHeader(AHeader: Pointer);
function CreateTempFile(BaseName: string): TPagedFile;
procedure ConstructInsertErrorMsg;
procedure WriteIndexHeader(AIndex: Integer);
procedure SelectIndexVars(AIndex: Integer);
procedure CalcKeyProperties;
procedure UpdateIndexProperties;
procedure ClearRoots;
function CalcTagOffset(AIndex: Integer): Pointer;
function FindKey(AInsert: boolean): Integer;
function InsertKey(Buffer: TRecordBuffer): Boolean;
procedure DeleteKey(Buffer: TRecordBuffer);
function InsertCurrent: Boolean;
procedure DeleteCurrent;
function UpdateCurrent(PrevBuffer, NewBuffer: TRecordBuffer): Boolean;
function UpdateIndex(Index: Integer; PrevBuffer, NewBuffer: TRecordBuffer): Boolean;
procedure ReadIndexes;
procedure Resync(Relative: boolean);
procedure ResyncRoot;
procedure ResyncTree;
procedure ResyncRange(KeepPosition: boolean);
procedure ResetRange;
procedure SetBracketLow;
procedure SetBracketHigh;
procedure WalkFirst;
procedure WalkLast;
function WalkPrev: boolean;
function WalkNext: boolean;
function CompareKeysNumericNDX(Key1, Key2: PChar): Integer;
function CompareKeysNumericMDX(Key1, Key2: PChar): Integer;
function CompareKeysString(Key1, Key2: PChar): Integer;
// property functions
function GetName: string;
function GetDbfLanguageId: Byte;
function GetKeyLen: Integer;
function GetKeyType: Char;
// function GetIndexCount Integer;
function GetExpression: string;
function GetPhysicalRecNo: Integer;
function GetSequentialRecNo: Integer;
function GetSequentialRecordCount: Integer;
procedure SetSequentialRecNo(RecNo: Integer);
procedure SetPhysicalRecNo(RecNo: Integer);
procedure SetUpdateMode(NewMode: TIndexUpdateMode);
procedure SetIndexName(const AIndexName: string);
public
constructor Create(ADbfFile: Pointer);
destructor Destroy; override;
procedure Open;
procedure Close;
procedure Clear;
procedure Flush; override;
procedure ClearIndex;
procedure AddNewLevel;
procedure UnlockHeader;
procedure InsertError;
function Insert(RecNo: Integer; Buffer:TRecordBuffer ): Boolean;
function Update(RecNo: Integer; PrevBuffer, NewBuffer: TRecordBuffer): Boolean;
procedure Delete(RecNo: Integer; Buffer: TRecordBuffer);
function CheckKeyViolation(Buffer: TRecordBuffer): Boolean;
procedure RecordDeleted(RecNo: Integer; Buffer: TRecordBuffer);
function RecordRecalled(RecNo: Integer; Buffer: TRecordBuffer): Boolean;
procedure DeleteIndex(const AIndexName: string);
procedure RepageFile;
procedure CompactFile;
procedure PrepareRename(NewFileName: string);
procedure CreateIndex(FieldDesc, TagName: string; Options: TIndexOptions);
function ExtractKeyFromBuffer(Buffer: TRecordBuffer): PChar;
function SearchKey(Key: PChar; SearchType: TSearchKeyType): Boolean;
function Find(RecNo: Integer; Buffer: PChar): Integer;
function IndexOf(const AIndexName: string): Integer;
procedure DisableRange;
procedure EnableRange;
procedure GetIndexNames(const AList: TStrings);
procedure GetIndexInfo(const AIndexName: string; IndexDef: TDbfIndexDef);
procedure WriteHeader; override;
procedure WriteFileHeader;
procedure First;
procedure Last;
function Next: Boolean;
function Prev: Boolean;
procedure SetRange(LowRange, HighRange: PChar);
procedure CancelRange;
function MatchKey(UserKey: PChar): Integer;
function CompareKey(Key: PChar): Integer;
function CompareKeys(Key1, Key2: PChar): Integer;
function PrepareKey(Buffer: TRecordBuffer; ResultType: TExpressionType): PChar;
property KeyLen: Integer read GetKeyLen;
property IndexVersion: TXBaseVersion read FIndexVersion;
property EntryHeaderSize: Integer read FEntryHeaderSize;
property KeyType: Char read GetKeyType;
property SequentialRecordCount: Integer read GetSequentialRecordCount;
property SequentialRecNo: Integer read GetSequentialRecNo write SetSequentialRecNo;
property PhysicalRecNo: Integer read GetPhysicalRecNo write SetPhysicalRecNo;
property HeaderPageNo: Integer read FHeaderPageNo;
property IndexHeader: Pointer read FIndexHeader;
property EntryBof: Pointer read FEntryBof;
property EntryEof: Pointer read FEntryEof;
property UniqueMode: TIndexUniqueType read FUniqueMode;
property IsDescending: Boolean read FIsDescending;
property UpdateMode: TIndexUpdateMode read FUpdateMode write SetUpdateMode;
property IndexName: string read FIndexName write SetIndexName;
property Expression: string read GetExpression;
// property Count: Integer read GetIndexCount;
property ForceClose: Boolean read FForceClose;
property ForceReadOnly: Boolean read FForceReadOnly;
property CodePage: Integer read FCodePage write FCodePage;
property OnLocaleError: TDbfLocaleErrorEvent read FOnLocaleError write FOnLocaleError;
end;
//------------------------------------------------------------------------------
implementation
uses
dbf_dbffile,
dbf_fields,
dbf_str,
dbf_prssupp,
dbf_prscore,
dbf_lang;
const
RecBOF = 0;
RecEOF = MaxInt;
lcidBinary = $0A03;
KeyFormat_Expression = $00;
KeyFormat_Data = $10;
KeyFormat_Descending = $08;
KeyFormat_String = $10;
KeyFormat_Distinct = $20;
KeyFormat_Unique = $40;
Unique_None = $00;
Unique_Unique = $01;
Unique_Distinct = $21;
type
TLCIDList = class(TList)
public
constructor Create;
procedure Enumerate;
end;
PMdxHdr = ^rMdxHdr;
rMdxHdr = record
MdxVersion : Byte; // 0
Year : Byte; // 1
Month : Byte; // 2
Day : Byte; // 3
FileName : array[0..15] of Char; // 4..19
BlockSize : Word; // 20..21
BlockAdder : Word; // 22..23
ProdFlag : Byte; // 24
NumTags : Byte; // 25
TagSize : Byte; // 26
Dummy1 : Byte; // 27
TagsUsed : Word; // 28..29
Dummy2 : Byte; // 30
Language : Byte; // 31
NumPages : Integer; // 32..35
FreePage : Integer; // 36..39
BlockFree : Integer; // 40..43
UpdYear : Byte; // 44
UpdMonth : Byte; // 45
UpdDay : Byte; // 46
Reserved : array[0..481] of Byte; // 47..528
TagFlag : Byte; // 529 // dunno what this means but it ought to be 1 :-)
end;
// Tags -> I don't know what to with them
// KeyType -> Variable position, db7 different from db4
PMdx4Tag = ^rMdx4Tag;
rMdx4Tag = record
HeaderPageNo : Integer; // 0..3
TagName : array [0..10] of Char; // 4..14 of Byte
KeyFormat : Byte; // 15 00h: Calculated
// 10h: Data Field
ForwardTag1 : Byte; // 16
ForwardTag2 : Byte; // 17
BackwardTag : Byte; // 18
Reserved : Byte; // 19
KeyType : Char; // 20 C : Character
// N : Numerical
// D : Date
end;
PMdx7Tag = ^rMdx7Tag;
rMdx7Tag = record
HeaderPageNo : Integer; // 0..3
TagName : array [0..32] of Char; // 4..36 of Byte
KeyFormat : Byte; // 37 00h: Calculated
// 10h: Data Field
ForwardTag1 : Byte; // 38
ForwardTag2 : Byte; // 39
BackwardTag : Byte; // 40
Reserved : Byte; // 41
KeyType : Char; // 42 C : Character
// N : Numerical
// D : Date
end;
PIndexHdr = ^rIndexHdr;
rIndexHdr = record
RootPage : Integer; // 0..3
NumPages : Integer; // 4..7
KeyFormat : Byte; // 8 00h: Right, Left, DTOC
// 08h: Descending order
// 10h: String
// 20h: Distinct
// 40h: Unique
KeyType : Char; // 9 C : Character
// N : Numerical
// D : Date
Dummy : Word; // 10..11
KeyLen : Word; // 12..13
NumKeys : Word; // 14..15
sKeyType : Word; // 16..17 00h: DB4: C/N; DB3: C
// 01h: DB4: D ; DB3: N/D
KeyRecLen : Word; // 18..19 Length of key entry in page
Version : Word; // 20..21
Dummy2 : Byte; // 22
Unique : Byte; // 23
KeyDesc : array [0..219] of Char; // 24..243
Dummy3 : Byte; // 244
ForExist : Byte; // 245
KeyExist : Byte; // 246
FirstNode : Longint; // 248..251 first node that contains data
LastNode : Longint; // 252..255 last node that contains data
// MDX Header has here a 506 byte block reserved
// and then the FILTER expression, which obviously doesn't
// fit in a NDX page, so we'll skip it
end;
PMdxEntry = ^rMdxEntry;
rMdxEntry = record
RecBlockNo: Longint; // 0..3 either recno or blockno
KeyData : Char; // 4.. first byte of data, context => length
end;
PMdxPage = ^rMdxPage;
rMdxPage = record
NumEntries : Integer;
PrevBlock : Integer;
FirstEntry : rMdxEntry;
end;
PNdxEntry = ^rNdxEntry;
rNdxEntry = record
LowerPageNo: Integer; // 0..3 lower page
RecNo : Integer; // 4..7 recno
KeyData : Char;
end;
PNdxPage = ^rNdxPage;
rNdxPage = record
NumEntries: Integer; // 0..3
FirstEntry: rNdxEntry;
end;
//---------------------------------------------------------------------------
TMdxPage = class(TIndexPage)
protected
function GetEntry(AEntryNo: Integer): Pointer; override;
function GetLowerPageNo: Integer; override;
function GetKeyData: PChar; override;
function GetNumEntries: Integer; override;
function GetKeyDataFromEntry(AEntry: Integer): PChar; override;
function GetRecNo: Integer; override;
function GetIsInnerNode: Boolean; override;
procedure IncNumEntries; override;
procedure SetNumEntries(NewNum: Integer); override;
procedure SetRecLowerPageNo(NewRecNo, NewPageNo: Integer); override;
procedure SetRecLowerPageNoOfEntry(AEntry, NewRecNo, NewPageNo: Integer); override;
{$ifdef TDBF_UPDATE_FIRST_LAST_NODE}
procedure SetPrevBlock(NewBlock: Integer); override;
{$endif}
end;
//---------------------------------------------------------------------------
TNdxPage = class(TIndexPage)
protected
function GetEntry(AEntryNo: Integer): Pointer; override;
function GetLowerPageNo: Integer; override;
function GetKeyData: PChar; override;
function GetNumEntries: Integer; override;
function GetKeyDataFromEntry(AEntry: Integer): PChar; override;
function GetRecNo: Integer; override;
function GetIsInnerNode: Boolean; override;
procedure IncNumEntries; override;
procedure SetNumEntries(NewNum: Integer); override;
procedure SetRecLowerPageNo(NewRecNo, NewPageNo: Integer); override;
procedure SetRecLowerPageNoOfEntry(AEntry, NewRecNo, NewPageNo: Integer); override;
end;
//---------------------------------------------------------------------------
TMdx4Tag = class(TIndexTag)
protected
function GetHeaderPageNo: Integer; override;
function GetTagName: string; override;
function GetKeyFormat: Byte; override;
function GetForwardTag1: Byte; override;
function GetForwardTag2: Byte; override;
function GetBackwardTag: Byte; override;
function GetReserved: Byte; override;
function GetKeyType: Char; override;
procedure SetHeaderPageNo(NewPageNo: Integer); override;
procedure SetTagName(NewName: string); override;
procedure SetKeyFormat(NewFormat: Byte); override;
procedure SetForwardTag1(NewTag: Byte); override;
procedure SetForwardTag2(NewTag: Byte); override;
procedure SetBackwardTag(NewTag: Byte); override;
procedure SetReserved(NewReserved: Byte); override;
procedure SetKeyType(NewType: Char); override;
end;
//---------------------------------------------------------------------------
TMdx7Tag = class(TIndexTag)
function GetHeaderPageNo: Integer; override;
function GetTagName: string; override;
function GetKeyFormat: Byte; override;
function GetForwardTag1: Byte; override;
function GetForwardTag2: Byte; override;
function GetBackwardTag: Byte; override;
function GetReserved: Byte; override;
function GetKeyType: Char; override;
procedure SetHeaderPageNo(NewPageNo: Integer); override;
procedure SetTagName(NewName: string); override;
procedure SetKeyFormat(NewFormat: Byte); override;
procedure SetForwardTag1(NewTag: Byte); override;
procedure SetForwardTag2(NewTag: Byte); override;
procedure SetBackwardTag(NewTag: Byte); override;
procedure SetReserved(NewReserved: Byte); override;
procedure SetKeyType(NewType: Char); override;
end;
var
Entry_Mdx_BOF: rMdxEntry; //(RecBOF, #0);
Entry_Mdx_EOF: rMdxEntry; //(RecBOF, #0);
Entry_Ndx_BOF: rNdxEntry; //(0, RecBOF, #0);
Entry_Ndx_EOF: rNdxEntry; //(0, RecEOF, #0);
LCIDList: TLCIDList;
procedure IncWordLE(var AVariable: Word; Amount: Integer);
begin
AVariable := SwapWordLE(SwapWordLE(AVariable) + Amount);
end;
procedure IncIntLE(var AVariable: Integer; Amount: Integer);
begin
AVariable := SwapIntLE(DWord(Integer(SwapIntLE(AVariable)) + Amount));
end;
//==========================================================
// Locale support for all versions of Delphi/C++Builder
function LocaleCallBack(LocaleString: PChar): Integer; stdcall;
begin
LCIDList.Add(Pointer(StrToInt('$'+LocaleString)));
Result := 1;
end;
constructor TLCIDList.Create;
begin
inherited;
end;
procedure TLCIDList.Enumerate;
begin
Clear;
EnumSystemLocales(@LocaleCallBack, LCID_SUPPORTED);
end;
{ TIndexPage }
constructor TIndexPage.Create(Parent: TIndexFile);
begin
FIndexFile := Parent;
GetMem(FPageBuffer, FIndexFile.RecordSize);
FLowerPage := nil;
Clear;
end;
destructor TIndexPage.Destroy;
begin
// no locks anymore?
assert(FLockCount = 0);
if (FLowerPage<>nil) then
LowerPage.Free;
WritePage;
FreeMemAndNil(FPageBuffer);
inherited Destroy;
end;
procedure TIndexPage.Clear;
begin
FillChar(PChar(FPageBuffer)^, FIndexFile.RecordSize, 0);
FreeAndNil(FLowerPage);
FUpperPage := nil;
FPageNo := -1;
FEntryNo := -1;
FWeight := 1;
FModified := false;
FEntry := FIndexFile.EntryBof;
FLowPage := 0;
FHighPage := 0;
FLowIndex := 0;
FHighIndex := -1;
FLockCount := 0;
end;
procedure TIndexPage.GetNewPage;
begin
FPageNo := FIndexFile.GetNewPageNo;
end;
procedure TIndexPage.Modified;
begin
FModified := true;
end;
procedure TIndexPage.LockPage;
begin
// already locked?
if FLockCount = 0 then
FIndexFile.LockPage(FPageNo, true);
// increase count
inc(FLockCount);
end;
procedure TIndexPage.UnlockPage;
begin
// still in domain?
assert(FLockCount > 0);
dec(FLockCount);
// unlock?
if FLockCount = 0 then
begin
if FIndexFile.NeedLocks then
WritePage;
FIndexFile.UnlockPage(FPageNo);
end;
end;
procedure TIndexPage.LocalInsert(RecNo: Integer; Buffer: PChar; LowerPageNo: Integer);
// *) assumes there is at least one entry free
var
source, dest: Pointer;
size, lNumEntries, numKeysAvail: Integer;
begin
// lock page if needed; wait if not available, anyone else updating?
LockPage;
// check assertions
lNumEntries := GetNumEntries;
// if this is inner node, we can only store one less than max entries
numKeysAvail := SwapWordLE(PIndexHdr(FIndexFile.IndexHeader)^.NumKeys) - lNumEntries;
if FLowerPage <> nil then
dec(numKeysAvail);
// check if free space
assert(numKeysAvail > 0);
// first free up some space
source := FEntry;
dest := GetEntry(FEntryNo + 1);
size := (lNumEntries - EntryNo) * SwapWordLE(PIndexHdr(FIndexFile.IndexHeader)^.KeyRecLen);
// if 'rightmost' entry, copy pageno too
if (FLowerPage <> nil) or (numKeysAvail > 1) then
size := size + FIndexFile.EntryHeaderSize;
Move(source^, dest^, size);
// one entry added
Inc(FHighIndex);
IncNumEntries;
// lNumEntries not valid from here
SetEntry(RecNo, Buffer, LowerPageNo);
// done!
UnlockPage;
end;
procedure TIndexPage.LocalDelete;
function IsOnlyEntry(Page: TIndexPage): boolean;
begin
Result := true;
repeat
if Page.HighIndex > 0 then
Result := false;
Page := Page.UpperPage;
until not Result or (Page = nil);
end;
var
source, dest: Pointer;
size, lNumEntries: Integer;
begin
// get num entries
lNumEntries := GetNumEntries;
// is this last entry? if it's not move entries after current one
if EntryNo < FHighIndex then
begin
source := GetEntry(EntryNo + 1);
dest := FEntry;
size := (FHighIndex - EntryNo) * SwapWordLE(PIndexHdr(FIndexFile.IndexHeader)^.KeyRecLen);
Move(source^, dest^, size);
end else
// no need to update when we're about to remove the only entry
if (UpperPage <> nil) and (FHighIndex > FLowIndex) then
begin
// we are about to remove the last on this page, so update search
// key data of parent
EntryNo := FHighIndex - 1;
UpperPage.SetEntry(0, GetKeyData, FPageNo);
end;
// one entry less now
dec(lNumEntries);
dec(FHighIndex);
SetNumEntries(lNumEntries);
// zero last one out to not get confused about internal or leaf pages
// note: need to decrease lNumEntries and HighIndex first, otherwise
// check on page key consistency will fail
SetRecLowerPageNoOfEntry(FHighIndex+1, 0, 0);
// update bracket indexes
if FHighPage = FPageNo then
dec(FHighBracket);
// check if range violated
if EntryNo > FHighIndex then
EntryNo := FHighIndex;
// check if still entries left, otherwise remove page from parent
if FHighIndex = -1 then
begin
if UpperPage <> nil then
if not IsOnlyEntry(UpperPage) then
UpperPage.LocalDelete;
end;
// go to valid record in lowerpage
if FLowerPage <> nil then
SyncLowerPage;
// flag modified page
FModified := true;
// success!
end;
function TIndexPage.MatchKey: Integer;
// assumes Buffer <> nil
var
keyData: PChar;
begin
// get key data
keyData := GetKeyData;
// use locale dependant compare
Result := FIndexFile.CompareKey(keyData);
end;
function TIndexPage.FindNearest(ARecNo: Integer): Integer;
// pre:
// assumes Key <> nil
// assumes FLowIndex <= FHighIndex + 1
// ARecNo = -2 -> search first key matching Key
// ARecNo = -3 -> search first key greater than Key
// ARecNo > 0 -> search key matching Key and its recno = ARecNo
// post:
// Result < 0 -> key,recno smaller than current entry
// Result = 0 -> key,recno found, FEntryNo = found key entryno
// Result > 0 -> key,recno larger than current entry
var
low, high, current: Integer;
begin
// implement binary search, keys are sorted
low := FLowIndex;
high := GetNumEntries;
// always true: Entry(FEntryNo) = FEntry
// FHighIndex >= 0 because no-entry cases in leaves have been filtered out
// entry HighIndex may not be bigger than rest (in inner node)
// ARecNo = -3 -> search last recno matching key
// need to have: low <= high
// define low - 1 = neg.inf.
// define high = pos.inf
// inv1: (ARecNo<>-3) -> Entry(low-1).Key < Key <= Entry(high).Key
// inv2: (ARecNo =-3) -> Entry(low-1).Key <= Key < Entry(high).Key
// vf: high + 1 - low
while low < high do
begin
current := (low + high) div 2;
FEntry := GetEntry(current);
// calc diff
Result := MatchKey;
// test if we need to go lower or higher
// result < 0 implies key smaller than tested entry
// result = 0 implies key equal to tested entry
// result > 0 implies key greater than tested entry
if (Result < 0) or ((ARecNo<>-3) and (Result=0)) then
high := current
else
low := current+1;
end;
// high will contain first greater-or-equal key
// ARecNo <> -3 -> Entry(high).Key will contain first key that matches -> go to high
// ARecNo = -3 -> Entry(high).Key will contain first key that is greater -> go to high
FEntryNo := -1;
EntryNo := high;
// calc end result: can't inspect high if lowerpage <> nil
// if this is a leaf, we need to find specific recno
if (LowerPage = nil) then
begin
if high > FHighIndex then
begin
Result := 1;
end else begin
Result := MatchKey;
// test if we need to find a specific recno
// result < 0 -> current key greater -> nothing found -> don't search
if (ARecNo > 0) then
begin
// BLS to RecNo
high := FHighIndex + 1;
low := FEntryNo;
// inv: FLowIndex <= FEntryNo <= high <= FHighIndex + 1 /\
// (Ai: FLowIndex <= i < FEntryNo: Entry(i).RecNo <> ARecNo)
while FEntryNo <> high do
begin
// FEntryNo < high, get new entry
if low <> FEntryNo then
begin
FEntry := GetEntry(FEntryNo);
// check if entry key still ok
Result := MatchKey;
end;
// test if out of range or found recno
if (Result <> 0) or (GetRecNo = ARecNo) then
high := FEntryNo
else begin
// default to EOF
inc(FEntryNo);
Result := 1;
end;
end;
end;
end;
end else begin
// FLowerPage <> nil -> high contains entry, can not have empty range
Result := 0;
end;
end;
procedure TIndexPage.GotoInsertEntry;
// assures we really can insert here
begin
if FEntry = FIndexFile.EntryEof then
FEntry := GetEntry(FEntryNo);
end;
procedure TIndexPage.SetEntry(RecNo: Integer; AKey: PChar; LowerPageNo: Integer);
var
keyData: PChar;
{$ifdef TDBF_INDEX_CHECK}
prevKeyData, curKeyData, nextKeyData: PChar;
{$endif}
begin
// get num entries
keyData := GetKeyData;
// check valid entryno: we should be able to insert entries!
assert((EntryNo >= 0) and (EntryNo <= FHighIndex));
if (UpperPage <> nil) and (FEntryNo = FHighIndex) then
UpperPage.SetEntry(0, AKey, FPageNo);
{ if PIndexHdr(FIndexFile.IndexHeader).KeyType = 'C' then }
if AKey <> nil then
Move(AKey^, keyData^, SwapWordLE(PIndexHdr(FIndexFile.IndexHeader)^.KeyLen))
else
PChar(keyData)^ := #0;
{
else
if AKey <> nil then
PDouble(keyData)^ := PDouble(AKey)^
else
PDouble(keyData)^ := 0.0;
}
// set entry info
SetRecLowerPageNo(RecNo, LowerPageNo);
// flag we modified the page
FModified := true;
{$ifdef TDBF_INDEX_CHECK}
// check sorted entry sequence
prevKeyData := GetKeyDataFromEntry(FEntryNo-1);
curKeyData := GetKeyDataFromEntry(FEntryNo+0);
nextKeyData := GetKeyDataFromEntry(FEntryNo+1);
// check if prior entry not greater, 'rightmost' key does not have to match
if (FEntryNo > 0) and ((FLowerPage = nil) or (FEntryNo < FHighIndex)) then
begin
if FIndexFile.CompareKeys(prevKeyData, curKeyData) > 0 then
assert(false);
end;
// check if next entry not smaller
if ((FLowerPage = nil) and (FEntryNo < FHighIndex)) or
((FLowerPage <> nil) and (FEntryNo < (FHighIndex - 1))) then
begin
if FIndexFile.CompareKeys(curKeyData, nextKeyData) > 0 then
assert(false);
end;
{$endif}
end;
{$ifdef TDBF_UPDATE_FIRST_LAST_NODE}
procedure TIndexPage.SetPrevBlock(NewBlock: Integer);
begin
end;
{$endif}
procedure TIndexPage.Split;
// *) assumes this page is `nearly' full
var
NewPage: TIndexPage;
source, dest: Pointer;
paKeyData: PChar;
size, oldEntryNo: Integer;
splitRight, lNumEntries, numEntriesNew: Integer;
saveLow, saveHigh: Integer;
newRoot: Boolean;
begin
// assure parent exists, if not -> create & lock, else lock it
newRoot := FUpperPage = nil;
if newRoot then
FIndexFile.AddNewLevel
else
FUpperPage.LockPage;
// lock this page for updates
LockPage;
// get num entries
lNumEntries := GetNumEntries;
// calc split pos: split in half
splitRight := lNumEntries div 2;
if (FLowerPage <> nil) and (lNumEntries mod 2 = 1) then
inc(splitRight);
numEntriesNew := lNumEntries - splitRight;
// check if place to insert has least entries
if (numEntriesNew > splitRight) and (EntryNo > splitRight) then
begin
inc(splitRight);
dec(numEntriesNew);
end else if (numEntriesNew < splitRight) and (EntryNo < splitRight) then
begin
dec(splitRight);
inc(numEntriesNew);
end;
// save current entryno
oldEntryNo := EntryNo;
// check if we need to save high / low bound
if FLowPage = FPageNo then
saveLow := FLowIndex
else
saveLow := -1;
if FHighPage = FPageNo then
saveHigh := FHighIndex
else
saveHigh := -1;
// create new page
NewPage := TIndexPageClass(ClassType).Create(FIndexFile);
try
// get page
NewPage.GetNewPage;
{$ifdef TDBF_UPDATE_FIRSTLAST_NODE}
NewPage.SetPrevBlock(NewPage.PageNo - FIndexFile.PagesPerRecord);
{$endif}
// set modified
FModified := true;
NewPage.FModified := true;
// compute source, dest
dest := NewPage.GetEntry(0);
source := GetEntry(splitRight);
size := numEntriesNew * SwapWordLE(PIndexHdr(FIndexFile.IndexHeader)^.KeyRecLen);
// if inner node, copy rightmost entry too
if FLowerPage <> nil then
size := size + FIndexFile.EntryHeaderSize;
// copy bytes
Move(source^, dest^, size);
// if not inner node, clear possible 'rightmost' entry
if (FLowerPage = nil) then
SetRecLowerPageNoOfEntry(splitRight, 0, 0);
// calc new number of entries of this page
lNumEntries := lNumEntries - numEntriesNew;
// if lower level, then we need adjust for new 'rightmost' node
if FLowerPage <> nil then
begin
// right split, so we need 'new' rightmost node
dec(lNumEntries);
end;
// store new number of nodes
// new page is right page, so update parent to point to new right page
NewPage.SetNumEntries(numEntriesNew);
SetNumEntries(lNumEntries);
// update highindex
FHighIndex := lNumEntries;
if FLowerPage = nil then
dec(FHighIndex);
// get data of last entry on this page
paKeyData := GetKeyDataFromEntry(splitRight - 1);
// reinsert ourself into parent
// FUpperPage.RecurInsert(0, paKeyData, FPageNo);
// we can do this via a localinsert now: we know there is at least one entry
// free in this page and higher up
FUpperPage.LocalInsert(0, paKeyData, FPageNo);
// new page is right page, so update parent to point to new right page
// we can't do this earlier: we will get lost in tree!
FUpperPage.SetRecLowerPageNoOfEntry(FUpperPage.EntryNo+1, 0, NewPage.PageNo);
// NOTE: UpperPage.LowerPage = Self <= inserted FPageNo, not NewPage.PageNo
finally
NewPage.Free;
end;
// done updating: unlock page
UnlockPage;
// save changes to parent
FUpperPage.UnlockPage;
// unlock new root, unlock header too
FIndexFile.UnlockHeader;
// go to entry we left on
if oldEntryNo >= splitRight then
begin
// sync upperpage with right page
FUpperPage.EntryNo := FUpperPage.EntryNo + 1;
FEntryNo := oldEntryNo - splitRight;
FEntry := GetEntry(FEntryNo);
end else begin
// in left page = this page
EntryNo := oldEntryNo;
end;
// check if we have to save high / low bound
// seen the fact that FHighPage = FPageNo -> EntryNo <= FHighIndex, it can in
// theory not happen that page is advanced to right page and high bound remains
// on left page, but we won't check for that here
if saveLow >= splitRight then
begin
FLowPage := FPageNo;
FLowIndex := saveLow - splitRight;
end;
if saveHigh >= splitRight then
begin
FHighPage := FPageNo;
FHighIndex := saveHigh - splitRight;
end;
end;
procedure TIndexPage.Delete;
begin
LocalDelete;
end;
procedure TIndexPage.WritePage;
begin
// check if we modified current page
if FModified and (FPageNo > 0) then
begin
FIndexFile.WriteRecord(FPageNo, FPageBuffer);
FModified := false;
end;
end;
procedure TIndexPage.Flush;
begin
WritePage;
if FLowerPage <> nil then
FLowerPage.Flush;
end;
procedure TIndexPage.RecalcWeight;
begin
if FLowerPage <> nil then
begin
FWeight := FLowerPage.Weight * SwapWordLE(PIndexHdr(FIndexFile.IndexHeader)^.NumKeys);
end else begin
FWeight := 1;
end;
if FUpperPage <> nil then
FUpperPage.RecalcWeight;
end;
procedure TIndexPage.UpdateWeight;
begin
if FLowerPage <> nil then
FLowerPage.UpdateWeight
else
RecalcWeight;
end;
procedure TIndexPage.SetUpperPage(NewPage: TIndexPage);
begin
if FUpperPage <> NewPage then
begin
// root height changed: update weights
FUpperPage := NewPage;
UpdateWeight;
end;
end;
procedure TIndexPage.SetLowPage(NewPage: Integer);
begin
if FLowPage <> NewPage then
begin
FLowPage := NewPage;
UpdateBounds(FLowerPage <> nil);
end;
end;
procedure TIndexPage.SetHighPage(NewPage: Integer);
begin
if FHighPage <> NewPage then
begin
FHighPage := NewPage;
UpdateBounds(FLowerPage <> nil);
end;
end;
procedure TIndexPage.UpdateBounds(IsInnerNode: Boolean);
begin
// update low / high index range
if FPageNo = FLowPage then
FLowIndex := FLowBracket
else
FLowIndex := 0;
if FPageNo = FHighPage then
FHighIndex := FHighBracket
else begin
FHighIndex := GetNumEntries;
if not IsInnerNode then
dec(FHighIndex);
end;
end;
function TMdxPage.GetIsInnerNode: Boolean;
begin
Result := SwapIntLE(PMdxPage(FPageBuffer)^.NumEntries) < SwapWordLE(PIndexHdr(FIndexFile.IndexHeader)^.NumKeys);
// if there is still an entry after the last one, this has to be an inner node
if Result then
Result := PMdxEntry(GetEntry(PMdxPage(FPageBuffer)^.NumEntries))^.RecBlockNo <> 0;
end;
function TNdxPage.GetIsInnerNode: Boolean;
begin
Result := PNdxEntry(GetEntry(0))^.LowerPageNo <> 0;
end;
procedure TIndexPage.SetPageNo(NewPageNo: Integer);
var
isInnerNode: Boolean;
begin
if (NewPageNo <> FPageNo) or FIndexFile.NeedLocks then
begin
// save changes
WritePage;
// no locks
assert(FLockCount = 0);
// goto new page
FPageNo := NewPageNo;
// remind ourselves we need to load new entry when page loaded
FEntryNo := -1;
if (NewPageNo > 0) and (NewPageNo <= FIndexFile.RecordCount) then
begin
// read page from disk
FIndexFile.ReadRecord(NewPageNo, FPageBuffer);
// fixup descending tree
isInnerNode := GetIsInnerNode;
// update low / high index range
UpdateBounds(isInnerNode);
// read inner node if any
if isInnerNode then
begin
if FLowerPage = nil then
begin
FLowerPage := TIndexPageClass(ClassType).Create(FIndexFile);
FLowerPage.UpperPage := Self;
end;
// read first entry, don't do this sooner, not created lowerpage yet
// don't recursively resync all lower pages
{$ifdef TDBF_INDEX_CHECK}
end else if FLowerPage <> nil then
begin
// FLowerPage.Free;
// FLowerPage := nil;
assert(false);
{$endif}
end else begin
// we don't have to check autoresync here because we're already at lowest level
EntryNo := FLowIndex;
end;
end;
end;
end;
procedure TIndexPage.SyncLowerPage;
// *) assumes FLowerPage <> nil!
begin
FLowerPage.PageNo := GetLowerPageNo;
end;
procedure TIndexPage.SetEntryNo(value: Integer);
begin
// do not bother if no change
if value <> FEntryNo then
begin
// check if out of range
if (value < FLowIndex) then
begin
if FLowerPage = nil then
FEntryNo := FLowIndex - 1;
FEntry := FIndexFile.EntryBof;
end else if value > FHighIndex then begin
FEntryNo := FHighIndex + 1;
FEntry := FIndexFile.EntryEof;
end else begin
FEntryNo := value;
FEntry := GetEntry(value);
// sync lowerpage with entry
if (FLowerPage <> nil) then
SyncLowerPage;
end;
end;
end;
function TIndexPage.PhysicalRecNo: Integer;
var
entryRec: Integer;
begin
// get num entries
entryRec := GetRecNo;
// check if in range
if (FEntryNo >= FLowIndex) and (FEntryNo <= FHighIndex) then
Result := entryRec
else
Result := -1;
end;
function TIndexPage.RecurPrev: Boolean;
begin
EntryNo := EntryNo - 1;
Result := Entry <> FIndexFile.EntryBof;
if Result then
begin
if FLowerPage <> nil then
begin
FLowerPage.RecurLast;
end;
end else begin
if FUpperPage<>nil then
begin
Result := FUpperPage.RecurPrev;
end;
end;
end;
function TIndexPage.RecurNext: Boolean;
begin
EntryNo := EntryNo + 1;
Result := Entry <> FIndexFile.EntryEof;
if Result then
begin
if FLowerPage <> nil then
begin
FLowerPage.RecurFirst;
end;
end else begin
if FUpperPage<>nil then
begin
Result := FUpperPage.RecurNext;
end;
end;
end;
procedure TIndexPage.RecurFirst;
begin
EntryNo := FLowIndex;
if (FLowerPage<>nil) then
FLowerPage.RecurFirst;
end;
procedure TIndexPage.RecurLast;
begin
EntryNo := FHighIndex;
if (FLowerPage<>nil) then
FLowerPage.RecurLast;
end;
procedure TIndexPage.SaveBracket;
begin
FLowPageTemp := FLowPage;
FHighPageTemp := FHighPage;
end;
procedure TIndexPage.RestoreBracket;
begin
FLowPage := FLowPageTemp;
FHighPage := FHighPageTemp;
end;
//==============================================================================
//============ Mdx specific access routines
//==============================================================================
function TMdxPage.GetEntry(AEntryNo: Integer): Pointer;
begin
// get base + offset
Result := PChar(@PMdxPage(PageBuffer)^.FirstEntry) + (SwapWordLE(PIndexHdr(
IndexFile.IndexHeader)^.KeyRecLen) * AEntryNo);
end;
function TMdxPage.GetLowerPageNo: Integer;
// *) assumes LowerPage <> nil
begin
// if LowerPage = nil then
// Result := 0
// else
Result := SwapIntLE(PMdxEntry(Entry)^.RecBlockNo);
end;
function TMdxPage.GetKeyData: PChar;
begin
Result := @PMdxEntry(Entry)^.KeyData;
end;
function TMdxPage.GetNumEntries: Integer;
begin
Result := SwapWordLE(PMdxPage(PageBuffer)^.NumEntries);
end;
function TMdxPage.GetKeyDataFromEntry(AEntry: Integer): PChar;
begin
Result := @PMdxEntry(GetEntry(AEntry))^.KeyData;
end;
function TMdxPage.GetRecNo: Integer;
begin
Result := SwapIntLE(PMdxEntry(Entry)^.RecBlockNo);
end;
procedure TMdxPage.SetNumEntries(NewNum: Integer);
begin
PMdxPage(PageBuffer)^.NumEntries := SwapIntLE(NewNum);
end;
procedure TMdxPage.IncNumEntries;
begin
IncIntLE(PMdxPage(PageBuffer)^.NumEntries, 1);
end;
procedure TMdxPage.SetRecLowerPageNo(NewRecNo, NewPageNo: Integer);
begin
if FLowerPage = nil then
PMdxEntry(Entry)^.RecBlockNo := SwapIntLE(NewRecNo)
else
PMdxEntry(Entry)^.RecBlockNo := SwapIntLE(NewPageNo);
end;
procedure TMdxPage.SetRecLowerPageNoOfEntry(AEntry, NewRecNo, NewPageNo: Integer);
begin
if FLowerPage = nil then
PMdxEntry(GetEntry(AEntry))^.RecBlockNo := SwapIntLE(NewRecNo)
else
PMdxEntry(GetEntry(AEntry))^.RecBlockNo := SwapIntLE(NewPageNo);
end;
{$ifdef TDBF_UPDATE_FIRST_LAST_NODE}
procedure TMdxPage.SetPrevBlock(NewBlock: Integer);
begin
PMdxPage(PageBuffer)^.PrevBlock := SwapIntLE(NewBlock);
end;
{$endif}
//==============================================================================
//============ Ndx specific access routines
//==============================================================================
function TNdxPage.GetEntry(AEntryNo: Integer): Pointer;
begin
// get base + offset
Result := PChar(@PNdxPage(PageBuffer)^.FirstEntry) +
(SwapWordLE(PIndexHdr(FIndexFile.IndexHeader)^.KeyRecLen) * AEntryNo);
end;
function TNdxPage.GetLowerPageNo: Integer;
// *) assumes LowerPage <> nil
begin
// if LowerPage = nil then
// Result := 0
// else
Result := SwapIntLE(PNdxEntry(Entry)^.LowerPageNo)
end;
function TNdxPage.GetRecNo: Integer;
begin
Result := SwapIntLE(PNdxEntry(Entry)^.RecNo);
end;
function TNdxPage.GetKeyData: PChar;
begin
Result := @PNdxEntry(Entry)^.KeyData;
end;
function TNdxPage.GetKeyDataFromEntry(AEntry: Integer): PChar;
begin
Result := @PNdxEntry(GetEntry(AEntry))^.KeyData;
end;
function TNdxPage.GetNumEntries: Integer;
begin
Result := SwapIntLE(PNdxPage(PageBuffer)^.NumEntries);
end;
procedure TNdxPage.IncNumEntries;
begin
IncIntLE(PNdxPage(PageBuffer)^.NumEntries, 1);
end;
procedure TNdxPage.SetNumEntries(NewNum: Integer);
begin
PNdxPage(PageBuffer)^.NumEntries := SwapIntLE(NewNum);
end;
procedure TNdxPage.SetRecLowerPageNo(NewRecNo, NewPageNo: Integer);
begin
PNdxEntry(Entry)^.RecNo := SwapIntLE(NewRecNo);
PNdxEntry(Entry)^.LowerPageNo := SwapIntLE(NewPageNo);
end;
procedure TNdxPage.SetRecLowerPageNoOfEntry(AEntry, NewRecNo, NewPageNo: Integer);
begin
PNdxEntry(GetEntry(AEntry))^.RecNo := SwapIntLE(NewRecNo);
PNdxEntry(GetEntry(AEntry))^.LowerPageNo := SwapIntLE(NewPageNo);
end;
//==============================================================================
//============ MDX version 4 header access routines
//==============================================================================
function TMdx4Tag.GetHeaderPageNo: Integer;
begin
Result := SwapIntLE(Unaligned(PMdx4Tag(Tag)^.HeaderPageNo));
end;
function TMdx4Tag.GetTagName: string;
begin
Result := PMdx4Tag(Tag)^.TagName;
end;
function TMdx4Tag.GetKeyFormat: Byte;
begin
Result := PMdx4Tag(Tag)^.KeyFormat;
end;
function TMdx4Tag.GetForwardTag1: Byte;
begin
Result := PMdx4Tag(Tag)^.ForwardTag1;
end;
function TMdx4Tag.GetForwardTag2: Byte;
begin
Result := PMdx4Tag(Tag)^.ForwardTag2;
end;
function TMdx4Tag.GetBackwardTag: Byte;
begin
Result := PMdx4Tag(Tag)^.BackwardTag;
end;
function TMdx4Tag.GetReserved: Byte;
begin
Result := PMdx4Tag(Tag)^.Reserved;
end;
function TMdx4Tag.GetKeyType: Char;
begin
Result := PMdx4Tag(Tag)^.KeyType;
end;
procedure TMdx4Tag.SetHeaderPageNo(NewPageNo: Integer);
begin
Unaligned(PMdx4Tag(Tag)^.HeaderPageNo) := SwapIntLE(NewPageNo);
end;
procedure TMdx4Tag.SetTagName(NewName: string);
begin
StrPLCopy(PMdx4Tag(Tag)^.TagName, NewName, 10);
PMdx4Tag(Tag)^.TagName[10] := #0;
end;
procedure TMdx4Tag.SetKeyFormat(NewFormat: Byte);
begin
PMdx4Tag(Tag)^.KeyFormat := NewFormat;
end;
procedure TMdx4Tag.SetForwardTag1(NewTag: Byte);
begin
PMdx4Tag(Tag)^.ForwardTag1 := NewTag;
end;
procedure TMdx4Tag.SetForwardTag2(NewTag: Byte);
begin
PMdx4Tag(Tag)^.ForwardTag2 := NewTag;
end;
procedure TMdx4Tag.SetBackwardTag(NewTag: Byte);
begin
PMdx4Tag(Tag)^.BackwardTag := NewTag;
end;
procedure TMdx4Tag.SetReserved(NewReserved: Byte);
begin
PMdx4Tag(Tag)^.Reserved := NewReserved;
end;
procedure TMdx4Tag.SetKeyType(NewType: Char);
begin
PMdx4Tag(Tag)^.KeyType := NewType;
end;
//==============================================================================
//============ MDX version 7 headertag access routines
//==============================================================================
function TMdx7Tag.GetHeaderPageNo: Integer;
begin
Result := SwapIntLE(Unaligned(PMdx7Tag(Tag)^.HeaderPageNo));
end;
function TMdx7Tag.GetTagName: string;
begin
Result := PMdx7Tag(Tag)^.TagName;
end;
function TMdx7Tag.GetKeyFormat: Byte;
begin
Result := PMdx7Tag(Tag)^.KeyFormat;
end;
function TMdx7Tag.GetForwardTag1: Byte;
begin
Result := PMdx7Tag(Tag)^.ForwardTag1;
end;
function TMdx7Tag.GetForwardTag2: Byte;
begin
Result := PMdx7Tag(Tag)^.ForwardTag2;
end;
function TMdx7Tag.GetBackwardTag: Byte;
begin
Result := PMdx7Tag(Tag)^.BackwardTag;
end;
function TMdx7Tag.GetReserved: Byte;
begin
Result := PMdx7Tag(Tag)^.Reserved;
end;
function TMdx7Tag.GetKeyType: Char;
begin
Result := PMdx7Tag(Tag)^.KeyType;
end;
procedure TMdx7Tag.SetHeaderPageNo(NewPageNo: Integer);
begin
Unaligned(PMdx7Tag(Tag)^.HeaderPageNo) := SwapIntLE(NewPageNo);
end;
procedure TMdx7Tag.SetTagName(NewName: string);
begin
StrPLCopy(PMdx7Tag(Tag)^.TagName, NewName, 32);
PMdx7Tag(Tag)^.TagName[32] := #0;
end;
procedure TMdx7Tag.SetKeyFormat(NewFormat: Byte);
begin
PMdx7Tag(Tag)^.KeyFormat := NewFormat;
end;
procedure TMdx7Tag.SetForwardTag1(NewTag: Byte);
begin
PMdx7Tag(Tag)^.ForwardTag1 := NewTag;
end;
procedure TMdx7Tag.SetForwardTag2(NewTag: Byte);
begin
PMdx7Tag(Tag)^.ForwardTag2 := NewTag;
end;
procedure TMdx7Tag.SetBackwardTag(NewTag: Byte);
begin
PMdx7Tag(Tag)^.BackwardTag := NewTag;
end;
procedure TMdx7Tag.SetReserved(NewReserved: Byte);
begin
PMdx7Tag(Tag)^.Reserved := NewReserved;
end;
procedure TMdx7Tag.SetKeyType(NewType: Char);
begin
PMdx7Tag(Tag)^.KeyType := NewType;
end;
{ TDbfIndexParser }
procedure TDbfIndexParser.ValidateExpression(AExpression: string);
const
AnsiStrFuncs: array[0..13] of TExprFunc = (FuncUppercase, FuncLowercase, FuncStrI_EQ,
FuncStrIP_EQ, FuncStrI_NEQ, FuncStrI_LT, FuncStrI_GT, FuncStrI_LTE, FuncStrI_GTE,
FuncStrP_EQ, FuncStr_LT, FuncStr_GT, FuncStr_LTE, FuncStr_GTE);
AnsiFuncsToMode: array[boolean] of TStringFieldMode = (smRaw, smAnsi);
var
TempRec: PExpressionRec;
TempBuffer: TRecordBuffer;
I: integer;
hasAnsiFuncs: boolean;
begin
TempRec := CurrentRec;
hasAnsiFuncs := false;
while not hasAnsiFuncs and (TempRec <> nil) do
begin
for I := Low(AnsiStrFuncs) to High(AnsiStrFuncs) do
if @TempRec^.Oper = @AnsiStrFuncs[I] then
begin
hasAnsiFuncs := true;
break;
end;
TempRec := TempRec^.Next;
end;
StringFieldMode := AnsiFuncsToMode[hasAnsiFuncs];
FResultLen := inherited ResultLen;
if FResultLen = -1 then
begin
// make empty record
GetMem(TempBuffer, TDbfFile(DbfFile).RecordSize);
try
TDbfFile(DbfFile).InitRecord(TempBuffer);
FResultLen := StrLen(ExtractFromBuffer(TempBuffer));
finally
FreeMem(TempBuffer);
end;
end;
// check if expression not too long
if FResultLen > 100 then
raise EDbfError.CreateFmt(STRING_INDEX_EXPRESSION_TOO_LONG, [AExpression, FResultLen]);
end;
//==============================================================================
//============ TIndexFile
//==============================================================================
constructor TIndexFile.Create(ADbfFile: Pointer);
var
I: Integer;
begin
inherited Create;
// clear variables
FOpened := false;
FRangeActive := false;
FUpdateMode := umCurrent;
FModifyMode := mmNormal;
FTempMode := TDbfFile(ADbfFile).TempMode;
FRangeIndex := -1;
SelectIndexVars(-1);
for I := 0 to MaxIndexes - 1 do
begin
FParsers[I] := nil;
FRoots[I] := nil;
FLeaves[I] := nil;
FIndexHeaderModified[I] := false;
end;
// store pointer to `parent' dbf file
FDbfFile := ADbfFile;
end;
destructor TIndexFile.Destroy;
begin
// close file
Close;
// call ancestor
inherited Destroy;
end;
procedure TIndexFile.Open;
var
I: Integer;
ext: string;
localeError: TLocaleError;
localeSolution: TLocaleSolution;
DbfLangId: Byte;
begin
if not FOpened then
begin
// open physical file
OpenFile;
// page offsets are not related to header length
PageOffsetByHeader := false;
// we need physical page locks
VirtualLocks := false;
// not selected index expression => can't edit yet
FCanEdit := false;
FUserKey := nil;
FUserRecNo := -1;
FHeaderLocked := -1;
FHeaderPageNo := 0;
FForceClose := false;
FForceReadOnly := false;
FMdxTag := nil;
// get index type
ext := UpperCase(ExtractFileExt(FileName));
if (ext = '.MDX') then
begin
FEntryHeaderSize := 4;
FPageHeaderSize := 8;
FEntryBof := @Entry_Mdx_BOF;
FEntryEof := @Entry_Mdx_EOF;
HeaderSize := 2048;
RecordSize := 1024;
PageSize := 512;
if FileCreated then
begin
FIndexVersion := TDbfFile(FDbfFile).DbfVersion;
if FIndexVersion = xBaseIII then
FIndexVersion := xBaseIV;
end else begin
case PMdxHdr(Header)^.MdxVersion of
3: FIndexVersion := xBaseVII;
else
FIndexVersion := xBaseIV;
end;
end;
case FIndexVersion of
xBaseVII:
begin
FMdxTag := TMdx7Tag.Create;
FTempMdxTag := TMdx7Tag.Create;
end;
else
FMdxTag := TMdx4Tag.Create;
FTempMdxTag := TMdx4Tag.Create;
end;
// get mem for all index headers..we're going to cache these
for I := 0 to MaxIndexes - 1 do
begin
GetMem(FIndexHeaders[I], RecordSize);
FillChar(FIndexHeaders[I]^, RecordSize, 0);
end;
// set pointers to first index
FIndexHeader := FIndexHeaders[0];
end else begin
// don't waste memory on another header block: we can just use
// the pagedfile one, there is only one index in this file
FIndexVersion := xBaseIII;
FEntryHeaderSize := 8;
FPageHeaderSize := 4;
FEntryBof := @Entry_Ndx_BOF;
FEntryEof := @Entry_Ndx_EOF;
HeaderSize := 512;
RecordSize := 512;
// have to read header first before we can assign following vars
FIndexHeaders[0] := Header;
FIndexHeader := Header;
// create default root
FParsers[0] := TDbfIndexParser.Create(FDbfFile);
FRoots[0] := TNdxPage.Create(Self);
FCurrentParser := FParsers[0];
FRoot := FRoots[0];
FSelectedIndex := 0;
// parse index expression
FCurrentParser.ParseExpression(PIndexHdr(FIndexHeader)^.KeyDesc);
// set index locale
FCollation := BINARY_COLLATION;
end;
// determine how to open file
if FileCreated then
begin
FillChar(Header^, HeaderSize, 0);
Clear;
end else begin
// determine locale type
localeError := leNone;
if (FIndexVersion >= xBaseIV) then
begin
// get parent language id
DbfLangId := GetDbfLanguageId;
// no ID?
if (DbfLangId = 0) { and (TDbfFile(FDbfFile).DbfVersion = xBaseIII)} then
begin
// if dbf is version 3, no language id, if no MDX language, use binary
if PMdxHdr(Header)^.Language = 0 then
FCollation := BINARY_COLLATION
else
FCollation := GetCollationTable(PMdxHdr(Header)^.Language);
end else begin
// check if MDX - DBF language id's match
if (PMdxHdr(Header)^.Language = 0) or (PMdxHdr(Header)^.Language = DbfLangId) then
FCollation := GetCollationTable(DbfLangId)
else
localeError := leTableIndexMismatch;
end;
// don't overwrite previous error
if (FCollation = UNKNOWN_COLLATION) and (localeError = leNone) then
localeError := leUnknown;
end else begin
// dbase III always binary?
FCollation := BINARY_COLLATION;
end;
// check if selected locale is available, binary is always available...
if (localeError <> leNone) and (FCollation <> BINARY_COLLATION) then
begin
if LCIDList.IndexOf(Pointer(FCollation)) < 0 then
localeError := leNotAvailable;
end;
// check if locale error detected
if localeError <> leNone then
begin
// provide solution, well, solution...
localeSolution := lsNotOpen;
// call error handler
if Assigned(FOnLocaleError) then
FOnLocaleError(localeError, localeSolution);
// act to solution
case localeSolution of
lsNotOpen: FForceClose := true;
lsNoEdit: FForceReadOnly := true;
else
{ lsBinary }
FCollation := BINARY_COLLATION;
end;
end;
// now read info
if not ForceClose then
ReadIndexes;
end;
// default to update all
UpdateMode := umAll;
// flag open
FOpened := true;
end;
end;
procedure TIndexFile.Close;
var
I: Integer;
begin
if FOpened then
begin
// save headers
Flush;
// remove parser reference
FCurrentParser := nil;
// free roots
if FIndexVersion >= xBaseIV then
begin
for I := 0 to MaxIndexes - 1 do
begin
FreeMemAndNil(FIndexHeaders[I]);
FreeAndNil(FParsers[I]);
FreeAndNil(FRoots[I]);
end;
end else begin
FreeAndNil(FRoot);
end;
// free mem
FMdxTag.Free;
FTempMdxTag.Free;
// close physical file
CloseFile;
// not opened any more
FOpened := false;
end;
end;
procedure TIndexFile.ClearRoots;
//
// *) assumes FIndexVersion >= xBaseIV
//
var
I, prevIndex: Integer;
begin
prevIndex := FSelectedIndex;
for I := 0 to MaxIndexes - 1 do
begin
SelectIndexVars(I);
if FRoot <> nil then
begin
// clear this entry
ClearIndex;
FLeaves[I] := FRoots[I];
end;
end;
// reselect previously selected index
SelectIndexVars(prevIndex);
// deselect index
end;
procedure WriteDBFileName(Header: PMdxHdr; HdrFileName: string);
var
HdrFileExt: string;
lPos, lenFileName: integer;
begin
HdrFileName := ExtractFileName(HdrFileName);
HdrFileExt := ExtractFileExt(HdrFileName);
if Length(HdrFileExt) > 0 then
begin
lPos := System.Pos(HdrFileExt, HdrFileName);
if lPos > 0 then
SetLength(HdrFileName, lPos - 1);
end;
if Length(HdrFileName) > 15 then
SetLength(HdrFileName, 15);
lenFileName := Length(HdrFileName);
Move(PChar(HdrFileName)^, PMdxHdr(Header)^.FileName[0], lenFileName);
FillChar(PMdxHdr(Header)^.FileName[lenFileName], 15-lenFileName, 0);
end;
procedure TIndexFile.Clear;
var
year, month, day: Word;
pos, prevSelIndex, pageno: Integer;
DbfLangId: Byte;
begin
// flush cache to prevent reading corrupted data
Flush;
// completely erase index
if FIndexVersion >= xBaseIV then
begin
DecodeDate(Now, year, month, day);
if FIndexVersion = xBaseVII then
PMdxHdr(Header)^.MdxVersion := 3
else
PMdxHdr(Header)^.MdxVersion := 2;
PMdxHdr(Header)^.Year := year - 1900;
PMdxHdr(Header)^.Month := month;
PMdxHdr(Header)^.Day := day;
WriteDBFileName(PMdxHdr(Header), FileName);
PMdxHdr(Header)^.BlockSize := SwapWordLE(2);
PMdxHdr(Header)^.BlockAdder := SwapWordLE(1024);
PMdxHdr(Header)^.ProdFlag := 1;
PMdxHdr(Header)^.NumTags := 48;
PMdxHdr(Header)^.TagSize := 32;
PMdxHdr(Header)^.Dummy2 := 0;
PMdxHdr(Header)^.Language := GetDbfLanguageID;
PMdxHdr(Header)^.NumPages := SwapIntLE(HeaderSize div PageSize); // = 4
TouchHeader(Header);
PMdxHdr(Header)^.TagFlag := 1;
// use locale id of parent
DbfLangId := GetDbfLanguageId;
if DbfLangId = 0 then
FCollation := BINARY_COLLATION
else
FCollation := GetCollationTable(DbfLangId);
// write index headers
prevSelIndex := FSelectedIndex;
for pos := 0 to SwapWordLE(PMdxHdr(Header)^.TagsUsed) - 1 do
begin
SelectIndexVars(pos);
pageno := GetNewPageNo;
FMdxTag.HeaderPageNo := SwapIntLE(pageno);
WriteRecord(pageno, FIndexHeader);
end;
// reselect previously selected index
SelectIndexVars(prevSelIndex);
// file header done (tags are included in file header)
WriteFileHeader;
// clear roots
ClearRoots;
// init vars
FTagSize := 32;
FTagOffset := 544;
// clear entries
RecordCount := SwapIntLE(PMdxHdr(Header)^.NumPages);
end else begin
// clear single index entry
ClearIndex;
RecordCount := SwapIntLE(PIndexHdr(FIndexHeader)^.NumPages);
end;
end;
procedure TIndexFile.ClearIndex;
var
prevHeaderLocked: Integer;
needHeaderLock: Boolean;
begin
// flush cache to prevent reading corrupted data
Flush;
// modifying header: lock page
needHeaderLock := FHeaderLocked <> 0;
prevHeaderLocked := FHeaderLocked;
if needHeaderLock then
begin
LockPage(0, true);
FHeaderLocked := 0;
end;
// initially, we have 1 page: header
PIndexHdr(FIndexHeader)^.NumPages := SwapIntLE(HeaderSize div PageSize);
// clear memory of root
FRoot.Clear;
// get new page for root
FRoot.GetNewPage;
// store new root page
PIndexHdr(FIndexHeader)^.RootPage := SwapIntLE(FRoot.PageNo);
{$ifdef TDBF_UPDATE_FIRSTLAST_NODE}
PIndexHdr(FIndexHeader)^.FirstNode := SwapIntLE(FRoot.PageNo);
{$endif}
// update leaf pointers
FLeaves[FSelectedIndex] := FRoot;
FLeaf := FRoot;
// write new header
WriteHeader;
FRoot.Modified;
FRoot.WritePage;
// done updating: unlock header
if needHeaderLock then
begin
UnlockPage(0);
FHeaderLocked := prevHeaderLocked;
end;
end;
procedure TIndexFile.CalcKeyProperties;
// given KeyLen, this func calcs KeyRecLen and NumEntries
begin
// now adjust keylen to align on DWORD boundaries
PIndexHdr(FIndexHeader)^.KeyRecLen := SwapWordLE((SwapWordLE(
PIndexHdr(FIndexHeader)^.KeyLen) + FEntryHeaderSize + 3) and not 3);
PIndexHdr(FIndexHeader)^.NumKeys := SwapWordLE((RecordSize - FPageHeaderSize) div
SwapWordLE(PIndexHdr(FIndexHeader)^.KeyRecLen));
end;
function TIndexFile.GetName: string;
begin
// get suitable name of index: if tag name defined use that otherwise filename
if FIndexVersion >= xBaseIV then
Result := FIndexName
else
Result := FileName;
end;
procedure TIndexFile.CreateIndex(FieldDesc, TagName: string; Options: TIndexOptions);
var
tagNo: Integer;
fieldType: Char;
TempParser: TDbfIndexParser;
begin
// check if we have exclusive access to table
TDbfFile(FDbfFile).CheckExclusiveAccess;
// parse index expression; if it cannot be parsed, why bother making index?
TempParser := TDbfIndexParser.Create(FDbfFile);
try
TempParser.ParseExpression(FieldDesc);
// check if result type is correct
fieldType := 'C';
case TempParser.ResultType of
etString: ; { default set above to suppress delphi warning }
etInteger, etLargeInt, etFloat: fieldType := 'N';
else
raise EDbfError.Create(STRING_INVALID_INDEX_TYPE);
end;
finally
TempParser.Free;
end;
// select empty index
if FIndexVersion >= xBaseIV then
begin
// get next entry no
tagNo := SwapWordLE(PMdxHdr(Header)^.TagsUsed);
// check if too many indexes
if tagNo = MaxIndexes then
raise EDbfError.Create(STRING_TOO_MANY_INDEXES);
// get memory for root
if FRoots[tagNo] = nil then
begin
FParsers[tagNo] := TDbfIndexParser.Create(FDbfFile);
FRoots[tagNo] := TMdxPage.Create(Self)
end else begin
FreeAndNil(FRoots[tagNo].FLowerPage);
end;
// set leaves pointer
FLeaves[tagNo] := FRoots[tagNo];
// get pointer to index header
FIndexHeader := FIndexHeaders[tagNo];
// load root + leaf
FCurrentParser := FParsers[tagNo];
FRoot := FRoots[tagNo];
FLeaf := FLeaves[tagNo];
// create new tag
FTempMdxTag.Tag := CalcTagOffset(tagNo);
FTempMdxTag.TagName := UpperCase(TagName);
// if expression then calculate
FTempMdxTag.KeyFormat := KeyFormat_Data;
if ixExpression in Options then
FTempMdxTag.KeyFormat := KeyFormat_Expression;
// what use have these reference tags?
FTempMdxTag.ForwardTag1 := 0;
FTempMdxTag.ForwardTag2 := 0;
FTempMdxTag.BackwardTag := 0;
FTempMdxTag.Reserved := 2;
FTempMdxTag.KeyType := fieldType;
// save this part of tag, need to save before GetNewPageNo,
// it will reread header
WriteFileHeader;
// store selected index
FSelectedIndex := tagNo;
FIndexName := TagName;
// store new headerno
FHeaderPageNo := GetNewPageNo;
FTempMdxTag.HeaderPageNo := FHeaderPageNo;
// increase number of indexes active
IncWordLE(PMdxHdr(Header)^.TagsUsed, 1);
// update updatemode
UpdateMode := umAll;
// index header updated
WriteFileHeader;
end;
// clear index
ClearIndex;
// parse expression, we know it's parseable, we've checked that
FCurrentParser.ParseExpression(FieldDesc);
// looked up index expression: now we can edit
// FIsExpression := ixExpression in Options;
FCanEdit := not FForceReadOnly;
// init key variables
PIndexHdr(FIndexHeader)^.KeyFormat := 0;
// descending
if ixDescending in Options then
PIndexHdr(FIndexHeader)^.KeyFormat := PIndexHdr(FIndexHeader)^.KeyFormat or KeyFormat_Descending;
// key type
if fieldType = 'C' then
PIndexHdr(FIndexHeader)^.KeyFormat := PIndexHdr(FIndexHeader)^.KeyFormat or KeyFormat_String;
PIndexHdr(FIndexHeader)^.KeyType := fieldType;
// uniqueness
PIndexHdr(FIndexHeader)^.Unique := Unique_None;
if ixPrimary in Options then
begin
PIndexHdr(FIndexHeader)^.KeyFormat := PIndexHdr(FIndexHeader)^.KeyFormat or KeyFormat_Distinct or KeyFormat_Unique;
PIndexHdr(FIndexHeader)^.Unique := Unique_Distinct;
end else if ixUnique in Options then
begin
PIndexHdr(FIndexHeader)^.KeyFormat := PIndexHdr(FIndexHeader)^.KeyFormat or KeyFormat_Unique;
PIndexHdr(FIndexHeader)^.Unique := Unique_Unique;
end;
// keylen is exact length of field
if fieldType = 'C' then
PIndexHdr(FIndexHeader)^.KeyLen := SwapWordLE(FCurrentParser.ResultLen)
else if FIndexVersion >= xBaseIV then
PIndexHdr(FIndexHeader)^.KeyLen := SwapWordLE(12)
else
PIndexHdr(FIndexHeader)^.KeyLen := SwapWordLE(8);
CalcKeyProperties;
// key desc
StrPLCopy(PIndexHdr(FIndexHeader)^.KeyDesc, FieldDesc, 219);
PIndexHdr(FIndexHeader)^.KeyDesc[219] := #0;
// init various
if FIndexVersion >= xBaseIV then
PIndexHdr(FIndexHeader)^.Dummy := 0 // MDX -> language driver
else
PIndexHdr(FIndexHeader)^.Dummy := SwapWordLE($5800); // NDX -> same ???
case fieldType of
'C':
PIndexHdr(FIndexHeader)^.sKeyType := 0;
'D':
PIndexHdr(FIndexHeader)^.sKeyType := SwapWordLE(1);
'N', 'F':
if FIndexVersion >= xBaseIV then
PIndexHdr(FIndexHeader)^.sKeyType := 0
else
PIndexHdr(FIndexHeader)^.sKeyType := SwapWordLE(1);
else
PIndexHdr(FIndexHeader)^.sKeyType := 0;
end;
PIndexHdr(FIndexHeader)^.Version := SwapWordLE(2); // this is what DB4 writes into file
PIndexHdr(FIndexHeader)^.Dummy2 := 0;
PIndexHdr(FIndexHeader)^.Dummy3 := 0;
PIndexHdr(FIndexHeader)^.ForExist := 0; // false
PIndexHdr(FIndexHeader)^.KeyExist := 1; // true
{$ifndef TDBF_UPDATE_FIRSTLAST_NODE}
// if not defined, init to zero
PIndexHdr(FIndexHeader)^.FirstNode := 0;
PIndexHdr(FIndexHeader)^.LastNode := 0;
{$endif}
WriteHeader;
// update internal properties
UpdateIndexProperties;
// for searches / inserts / deletes
FKeyBuffer[SwapWordLE(PIndexHdr(FIndexHeader)^.KeyLen)] := #0;
end;
procedure TIndexFile.ReadIndexes;
var
I: Integer;
procedure CheckHeaderIntegrity;
begin
if integer(SwapWordLE(PIndexHdr(FIndexHeader)^.NumKeys) *
SwapWordLE(PIndexHdr(FIndexHeader)^.KeyRecLen)) > RecordSize then
begin
// adjust index header so that integrity is correct
// WARNING: we can't be sure this gives a correct result, but at
// least we won't AV (as easily). user will probably have to regenerate this index
if SwapWordLE(PIndexHdr(FIndexHeader)^.KeyLen) > 100 then
PIndexHdr(FIndexHeader)^.KeyLen := SwapWordLE(100);
CalcKeyProperties;
end;
end;
begin
// force header reread
inherited ReadHeader;
// examine all indexes
if FIndexVersion >= xBaseIV then
begin
// clear all roots
ClearRoots;
// tags are extended at beginning? tagsize is byte sized
FTagSize := PMdxHdr(Header)^.TagSize;
FTagOffset := 544 + FTagSize - 32;
for I := 0 to SwapWordLE(PMdxHdr(Header)^.TagsUsed) - 1 do
begin
// read page header
FTempMdxTag.Tag := CalcTagOffset(I);
ReadRecord(FTempMdxTag.HeaderPageNo, FIndexHeaders[I]);
// select it
FIndexHeader := FIndexHeaders[I];
// create root if needed
if FRoots[I] = nil then
begin
FParsers[I] := TDbfIndexParser.Create(FDbfFile);
FRoots[I] := TMdxPage.Create(Self);
end;
// check header integrity
CheckHeaderIntegrity;
// read tree
FRoots[I].PageNo := SwapIntLE(PIndexHdr(FIndexHeader)^.RootPage);
// go to first record
FRoots[I].RecurFirst;
// store leaf
FLeaves[I] := FRoots[I];
while FLeaves[I].LowerPage <> nil do
FLeaves[I] := FLeaves[I].LowerPage;
// parse expression
FParsers[I].ParseExpression(PIndexHdr(FIndexHeader)^.KeyDesc);
end;
end else begin
// clear root
FRoot.Clear;
// check recordsize constraint
CheckHeaderIntegrity;
// just one index: read tree
FRoot.PageNo := SwapIntLE(PIndexHdr(FIndexHeader)^.RootPage);
// go to first valid record
FRoot.RecurFirst;
// get leaf page
FLeaf := FRoot;
while FLeaf.LowerPage <> nil do
FLeaf := FLeaf.LowerPage;
// write leaf pointer to first index
FLeaves[0] := FLeaf;
// get index properties -> internal props
UpdateIndexProperties;
end;
end;
procedure TIndexFile.DeleteIndex(const AIndexName: string);
var
I, found, numTags, moveItems: Integer;
tempHeader: Pointer;
tempRoot, tempLeaf: TIndexPage;
tempParser: TDbfIndexParser;
begin
// check if we have exclusive access to table
TDbfFile(FDbfFile).CheckExclusiveAccess;
if FIndexVersion = xBaseIII then
begin
Close;
DeleteFile;
end else if FIndexVersion >= xBaseIV then
begin
// find index
found := IndexOf(AIndexName);
if found >= 0 then
begin
// just remove this tag by copying memory over it
numTags := SwapWordLE(PMdxHdr(Header)^.TagsUsed);
moveItems := numTags - found - 1;
// anything to move?
if moveItems > 0 then
begin
// move entries after found one
Move((Header + FTagOffset + (found+1) * FTagSize)^,
(Header + FTagOffset + found * FTagSize)^, moveItems * FTagSize);
// nullify last entry
FillChar((Header + FTagOffset + numTags * FTagSize)^, FTagSize, 0);
// index headers, roots, leaves
tempHeader := FIndexHeaders[found];
tempParser := FParsers[found];
tempRoot := FRoots[found];
tempLeaf := FLeaves[found];
for I := 0 to moveItems - 1 do
begin
FIndexHeaders[found + I] := FIndexHeaders[found + I + 1];
FParsers[found + I] := FParsers[found + I + 1];
FRoots[found + I] := FRoots[found + I + 1];
FLeaves[found + I] := FLeaves[found + I + 1];
FIndexHeaderModified[found + I] := true;
end;
FIndexHeaders[found + moveItems] := tempHeader;
FParsers[found + moveItems] := tempParser;
FRoots[found + moveItems] := tempRoot;
FLeaves[found + moveItems] := tempLeaf;
FIndexHeaderModified[found + moveItems] := false; // non-existant header
end;
// one entry less left
IncWordLE(PMdxHdr(Header)^.TagsUsed, -1);
// ---*** numTags not valid from here ***---
// file header changed
WriteFileHeader;
// repage index to free space used by deleted index
// RepageFile;
end;
end;
end;
procedure TIndexFile.TouchHeader(AHeader: Pointer);
var
year, month, day: Word;
begin
DecodeDate(Now, year, month, day);
PMdxHdr(AHeader)^.UpdYear := year - 1900;
PMdxHdr(AHeader)^.UpdMonth := month;
PMdxHdr(AHeader)^.UpdDay := day;
end;
function TIndexFile.CreateTempFile(BaseName: string): TPagedFile;
var
lModifier: Integer;
begin
// create temporary in-memory index file
lModifier := 0;
FindNextName(BaseName, BaseName, lModifier);
Result := TPagedFile.Create;
Result.FileName := BaseName;
Result.Mode := pfExclusiveCreate;
Result.AutoCreate := true;
Result.OpenFile;
Result.HeaderSize := HeaderSize;
Result.RecordSize := RecordSize;
Result.PageSize := PageSize;
Result.PageOffsetByHeader := false;
end;
procedure TIndexFile.RepageFile;
var
TempFile: TPagedFile;
TempIdxHeader: PIndexHdr;
I, newPageNo: Integer;
prevIndex: Integer;
function AllocNewPageNo: Integer;
begin
Result := newPageNo;
Inc(newPageNo, PagesPerRecord);
if FIndexVersion >= xBaseIV then
IncIntLE(PMdxHdr(TempFile.Header)^.NumPages, PagesPerRecord);
IncIntLE(TempIdxHeader^.NumPages, PagesPerRecord);
end;
function WriteTree(NewPage: TIndexPage): Integer;
var
J: Integer;
begin
// get us a page so that page no's are more logically ordered
Result := AllocNewPageNo;
// use postorder visiting, first do all children
if NewPage.LowerPage <> nil then
begin
for J := 0 to NewPage.HighIndex do
begin
NewPage.EntryNo := J;
WriteTree(NewPage.LowerPage);
end;
end;
// now create new page for ourselves and write
// update page pointer in parent
if NewPage.UpperPage <> nil then
begin
if FIndexVersion >= xBaseIV then
begin
PMdxEntry(NewPage.UpperPage.Entry)^.RecBlockNo := SwapIntLE(Result);
{$ifdef TDBF_UPDATE_FIRSTLAST_NODE}
// write previous node
if FRoot = NewPage then
PMdxPage(NewPage.PageBuffer)^.PrevBlock := 0
else
PMdxPage(NewPage.PageBuffer)^.PrevBlock := SwapIntLE(Result - PagesPerRecord);
{$endif}
end else begin
PNdxEntry(NewPage.UpperPage.Entry)^.LowerPageNo := SwapIntLE(Result);
end;
end;
// store page
TempFile.WriteRecord(Result, NewPage.PageBuffer);
end;
procedure CopySelectedIndex;
var
hdrPageNo: Integer;
begin
// copy current index settings
Move(FIndexHeader^, TempIdxHeader^, RecordSize);
// clear number of pages
TempIdxHeader^.NumPages := PagesPerRecord;
// allocate a page no for header
hdrPageNo := AllocNewPageNo;
// use recursive function to write all pages
TempIdxHeader^.RootPage := SwapIntLE(WriteTree(FRoot));
{$ifdef TDBF_UPDATE_FIRSTLAST_NODE}
TempIdxHeader^.FirstNode := TempIdxHeader^.RootPage;
{$endif}
// write index header now we know the root page
TempFile.WriteRecord(hdrPageNo, TempIdxHeader);
if FIndexVersion >= xBaseIV then
begin
// calculate tag offset in tempfile header
FTempMdxTag.Tag := PChar(TempFile.Header) + (PChar(CalcTagOffset(I)) - Header);
FTempMdxTag.HeaderPageNo := hdrPageNo;
end;
end;
begin
CheckExclusiveAccess;
prevIndex := FSelectedIndex;
newPageNo := HeaderSize div PageSize;
TempFile := CreateTempFile(FileName);
if FIndexVersion >= xBaseIV then
begin
// copy header
Move(Header^, TempFile.Header^, HeaderSize);
TouchHeader(TempFile.Header);
// reset header
PMdxHdr(TempFile.Header)^.NumPages := SwapIntLE(HeaderSize div PageSize);
TempFile.WriteHeader;
GetMem(TempIdxHeader, RecordSize);
// now recreate indexes to that file
for I := 0 to SwapWordLE(PMdxHdr(Header)^.TagsUsed - 1) do
begin
// select this index
SelectIndexVars(I);
CopySelectedIndex;
end;
FreeMem(TempIdxHeader);
end else begin
// indexversion = xBaseIII
TempIdxHeader := PIndexHdr(TempFile.Header);
CopySelectedIndex;
end;
TempFile.WriteHeader;
TempFile.CloseFile;
CloseFile;
// rename temporary file if all went successfull
if not TempFile.WriteError then
begin
SysUtils.DeleteFile(FileName);
SysUtils.RenameFile(TempFile.FileName, FileName);
end;
TempFile.Free;
DisableForceCreate;
OpenFile;
ReadIndexes;
SelectIndexVars(prevIndex);
end;
procedure TIndexFile.CompactFile;
var
TempFile: TPagedFile;
TempIdxHeader: PIndexHdr;
I, newPageNo: Integer;
prevIndex: Integer;
function AllocNewPageNo: Integer;
begin
Result := newPageNo;
Inc(newPageNo, PagesPerRecord);
if FIndexVersion >= xBaseIV then
IncIntLE(PMdxHdr(TempFile.Header)^.NumPages, PagesPerRecord);
IncIntLE(TempIdxHeader^.NumPages, PagesPerRecord);
end;
function CreateNewPage: TIndexPage;
begin
// create new page + space
if FIndexVersion >= xBaseIV then
Result := TMdxPage.Create(Self)
else
Result := TNdxPage.Create(Self);
Result.FPageNo := AllocNewPageNo;
// set new page properties
Result.SetNumEntries(0);
end;
procedure GetNewEntry(APage: TIndexPage);
// makes a new entry available and positions current 'pos' on it
// NOTES: uses TIndexPage *very* carefully
// - may not read from self (tindexfile)
// - page.FLowerPage is assigned -> SyncLowerPage may *not* be called
// - do not set PageNo (= SetPageNo)
// - do not set EntryNo
begin
if APage.HighIndex >= SwapWordLE(PIndexHdr(FIndexHeader)^.NumKeys)-1 then
begin
if APage.UpperPage = nil then
begin
// add new upperlevel to page
APage.FUpperPage := CreateNewPage;
APage.UpperPage.FLowerPage := APage;
APage.UpperPage.FEntryNo := 0;
APage.UpperPage.FEntry := EntryEof;
APage.UpperPage.GotoInsertEntry;
APage.UpperPage.LocalInsert(0, APage.Key, APage.PageNo);
// non-leaf pages need 'rightmost' key; numentries = real# - 1
APage.UpperPage.SetNumEntries(0);
end;
// page done, store
TempFile.WriteRecord(APage.FPageNo, APage.PageBuffer);
// allocate new page
APage.FPageNo := AllocNewPageNo;
// clear
APage.SetNumEntries(0);
APage.FHighIndex := -1;
APage.FLowIndex := 0;
// clear 'right-most' blockno
APage.SetRecLowerPageNoOfEntry(0, 0, 0);
// get new entry in upper page for current new apage
GetNewEntry(APage.UpperPage);
APage.UpperPage.LocalInsert(0, nil, 0);
// non-leaf pages need 'rightmost' key; numentries = real# - 1
if APage.UpperPage.EntryNo = 0 then
APage.UpperPage.SetNumEntries(0);
end;
APage.FEntryNo := APage.HighIndex+1;
APage.FEntry := EntryEof;
APage.GotoInsertEntry;
end;
procedure CopySelectedIndex;
var
APage: TIndexPage;
hdrPageNo: Integer;
begin
// copy current index settings
Move(FIndexHeader^, TempIdxHeader^, RecordSize);
// clear number of pages
TempIdxHeader^.NumPages := SwapIntLE(PagesPerRecord);
// allocate a page no for header
hdrPageNo := AllocNewPageNo;
// copy all records
APage := CreateNewPage;
FLeaf.RecurFirst;
while not (FRoot.Entry = FEntryEof) do
begin
GetNewEntry(APage);
APage.LocalInsert(FLeaf.PhysicalRecNo, FLeaf.Key, 0);
FLeaf.RecurNext;
end;
// flush remaining (partially filled) pages
repeat
TempFile.WriteRecord(APage.FPageNo, APage.PageBuffer);
if APage.UpperPage <> nil then
APage := APage.UpperPage
else break;
until false;
// copy index header + root page
TempIdxHeader^.RootPage := SwapIntLE(APage.PageNo);
{$ifdef TDBF_UPDATE_FIRSTLAST_NODE}
TempIdxHeader^.FirstNode := SwapIntLE(APage.PageNo);
{$endif}
// write index header now we know the root page
TempFile.WriteRecord(hdrPageNo, TempIdxHeader);
if FIndexVersion >= xBaseIV then
begin
// calculate tag offset in tempfile header
FTempMdxTag.Tag := PChar(TempFile.Header) + (PChar(CalcTagOffset(I)) - Header);
FTempMdxTag.HeaderPageNo := hdrPageNo;
end;
end;
begin
CheckExclusiveAccess;
prevIndex := FSelectedIndex;
newPageNo := HeaderSize div PageSize;
TempFile := CreateTempFile(FileName);
if FIndexVersion >= xBaseIV then
begin
// copy header
Move(Header^, TempFile.Header^, HeaderSize);
TouchHeader(TempFile.Header);
// reset header
PMdxHdr(TempFile.Header)^.NumPages := SwapIntLE(HeaderSize div PageSize);
TempFile.WriteHeader;
GetMem(TempIdxHeader, RecordSize);
// now recreate indexes to that file
for I := 0 to SwapWordLE(PMdxHdr(Header)^.TagsUsed) - 1 do
begin
// select this index
SelectIndexVars(I);
CopySelectedIndex;
end;
FreeMem(TempIdxHeader);
end else begin
// indexversion = xBaseIII
TempIdxHeader := PIndexHdr(TempFile.Header);
CopySelectedIndex;
end;
TempFile.WriteHeader;
TempFile.CloseFile;
CloseFile;
// rename temporary file if all went successfull
if not TempFile.WriteError then
begin
SysUtils.DeleteFile(FileName);
SysUtils.RenameFile(TempFile.FileName, FileName);
end;
TempFile.Free;
DisableForceCreate;
OpenFile;
ReadIndexes;
SelectIndexVars(prevIndex);
end;
procedure TIndexFile.PrepareRename(NewFileName: string);
begin
if FIndexVersion >= xBaseIV then
begin
WriteDBFileName(PMdxHdr(Header), NewFileName);
WriteFileHeader;
end;
end;
function TIndexFile.GetNewPageNo: Integer;
var
needLockHeader: Boolean;
begin
// update header -> lock it if not already locked
needLockHeader := FHeaderLocked <> 0;
if needLockHeader then
begin
// lock header page
LockPage(0, true);
// someone else could be inserting records at the same moment
if NeedLocks then
inherited ReadHeader;
end;
if FIndexVersion >= xBaseIV then
begin
Result := SwapIntLE(PMdxHdr(Header)^.NumPages);
IncIntLE(PMdxHdr(Header)^.NumPages, PagesPerRecord);
{$ifdef TDBF_UPDATE_FIRSTLAST_NODE}
// adjust high page
PIndexHdr(FIndexHeader)^.LastNode := SwapIntLE(Result);
{$endif}
WriteFileHeader;
end else begin
Result := SwapIntLE(PIndexHdr(FIndexHeader)^.NumPages);
end;
IncIntLE(PIndexHdr(FIndexHeader)^.NumPages, PagesPerRecord);
WriteHeader;
// done updating header -> unlock if locked
if needLockHeader then
UnlockPage(0);
end;
function TIndexFile.Insert(RecNo: Integer; Buffer: TRecordBuffer): Boolean; {override;}
var
I, curSel, count: Integer;
begin
// check if updating all or only current
FUserRecNo := RecNo;
if (FUpdateMode = umAll) or (FSelectedIndex = -1) then
begin
// remember currently selected index
curSel := FSelectedIndex;
Result := true;
I := 0;
count := SwapWordLE(PMdxHdr(Header)^.TagsUsed);
while I < count do
begin
SelectIndexVars(I);
Result := InsertKey(Buffer);
if not Result then
begin
while I > 0 do
begin
Dec(I);
DeleteKey(Buffer);
end;
break;
end;
Inc(I);
end;
// restore previous selected index
SelectIndexVars(curSel);
end else begin
Result := InsertKey(Buffer);
end;
// check range, disabled by insert
ResyncRange(true);
end;
function TIndexFile.CheckKeyViolation(Buffer: TRecordBuffer): Boolean;
var
I, curSel: Integer;
begin
Result := false;
FUserRecNo := -2;
if FIndexVersion = xBaseIV then
begin
curSel := FSelectedIndex;
for I := 0 to SwapWordLE(PMdxHdr(Header)^.TagsUsed) - 1 do
begin
SelectIndexVars(I);
if FUniqueMode = iuDistinct then
begin
FUserKey := ExtractKeyFromBuffer(Buffer);
Result := FindKey(false) = 0;
if Result then
break;
end;
end;
SelectIndexVars(curSel);
end else begin
if FUniqueMode = iuDistinct then
begin
FUserKey := ExtractKeyFromBuffer(Buffer);
Result := FindKey(false) = 0;
end;
end;
end;
function TIndexFile.PrepareKey(Buffer: TRecordBuffer; ResultType: TExpressionType): PChar;
var
FloatRec: TFloatRec;
I, IntSrc, NumDecimals: Integer;
ExtValue: Extended;
BCDdigit: Byte;
{$ifdef SUPPORT_INT64}
Int64Src: Int64;
{$endif}
begin
// need to convert numeric?
Result := PChar(Buffer);
if PIndexHdr(FIndexHeader)^.KeyType in ['N', 'F'] then
begin
if FIndexVersion = xBaseIII then
begin
// DB3 -> index always 8 byte float, if original integer, convert to double
case ResultType of
etInteger:
begin
FUserNumeric := PInteger(Result)^;
Result := PChar(@FUserNumeric);
end;
{$ifdef SUPPORT_INT64}
etLargeInt:
begin
FUserNumeric := PLargeInt(Result)^;
Result := PChar(@FUserNumeric);
end;
{$endif}
end;
end else begin
// DB4 MDX
NumDecimals := 0;
case ResultType of
etInteger:
begin
IntSrc := PInteger(Result)^;
// handle zero differently: no decimals
if IntSrc <> 0 then
NumDecimals := GetStrFromInt(IntSrc, @FloatRec.Digits[0])
else
NumDecimals := 0;
FloatRec.Negative := IntSrc < 0;
end;
{$ifdef SUPPORT_INT64}
etLargeInt:
begin
Int64Src := PLargeInt(Result)^;
if Int64Src <> 0 then
NumDecimals := GetStrFromInt64(Int64Src, @FloatRec.Digits[0])
else
NumDecimals := 0;
FloatRec.Negative := Int64Src < 0;
end;
{$endif}
etFloat:
begin
ExtValue := PDouble(Result)^;
FloatToDecimal(FloatRec, ExtValue, {$ifndef FPC_VERSION}fvExtended,{$endif} 9999, 15);
if ExtValue <> 0.0 then
NumDecimals := StrLen(@FloatRec.Digits[0])
else
NumDecimals := 0;
// maximum number of decimals possible to encode in BCD is 16
if NumDecimals > 16 then
NumDecimals := 16;
end;
end;
case ResultType of
etInteger {$ifdef SUPPORT_INT64}, etLargeInt{$endif}:
begin
FloatRec.Exponent := NumDecimals;
// MDX-BCD does not count ending zeroes as `data' space length
while (NumDecimals > 0) and (FloatRec.Digits[NumDecimals-1] = '0') do
Dec(NumDecimals);
// null-terminate string
FloatRec.Digits[NumDecimals] := #0;
end;
end;
// write 'header', contains number of digits before decimal separator
FUserBCD[0] := $34 + FloatRec.Exponent;
// clear rest of BCD
FillChar(FUserBCD[1], SizeOf(FUserBCD)-1, 0);
// store number of bytes used (in number of bits + 1)
FUserBCD[1] := (((NumDecimals+1) div 2) * 8) + 1;
// where to store decimal dot position? now implicitly in first byte
// store negative sign
if FloatRec.Negative then
FUserBCD[1] := FUserBCD[1] or $80;
// convert string to BCD
I := 0;
while I < NumDecimals do
begin
// only one byte left?
if FloatRec.Digits[I+1] = #0 then
BCDdigit := 0
else
BCDdigit := Byte(FloatRec.Digits[I+1]) - Byte('0');
// pack two bytes into bcd
FUserBCD[2+(I div 2)] := ((Byte(FloatRec.Digits[I]) - Byte('0')) shl 4) or BCDdigit;
// goto next 2 bytes
Inc(I, 2);
end;
// set result pointer to BCD
Result := PChar(@FUserBCD[0]);
end;
end;
end;
function TIndexFile.ExtractKeyFromBuffer(Buffer: TRecordBuffer): PChar;
begin
// execute expression to get key
Result := PrepareKey(TRecordBuffer(FCurrentParser.ExtractFromBuffer(Buffer)), FCurrentParser.ResultType);
if FCurrentParser.StringFieldMode <> smRaw then
TranslateString(GetACP, FCodePage, Result, Result, KeyLen);
end;
function TIndexFile.InsertKey(Buffer: TRecordBuffer): boolean;
begin
Result := true;
// ignore deleted records
if (FModifyMode = mmNormal) and (FUniqueMode = iuDistinct) and (AnsiChar(Buffer^) = '*') then
exit;
// check proper index and modifiability
if FCanEdit and (PIndexHdr(FIndexHeader)^.KeyLen <> 0) then
begin
// get key from buffer
FUserKey := ExtractKeyFromBuffer(Buffer);
// patch through
Result := InsertCurrent;
end;
end;
function TIndexFile.InsertCurrent: boolean;
// insert in current index
// assumes: FUserKey is an OEM key
begin
// only insert if not recalling or mode = distinct
// modify = mmDeleteRecall /\ unique <> distinct -> key already present
Result := true;
if (FModifyMode <> mmDeleteRecall) or (FUniqueMode = iuDistinct) then
begin
// temporarily remove range to find correct location of key
ResetRange;
// find this record as closely as possible
// if result = 0 then key already exists
// if unique index, then don't insert key if already present
if (FindKey(true) <> 0) or (FUniqueMode = iuNormal) then
begin
// if we found eof, write to pagebuffer
FLeaf.GotoInsertEntry;
// insert requested entry, we know there is an entry available
FLeaf.LocalInsert(FUserRecNo, FUserKey, 0);
end else begin
// key already exists -> test possible key violation
if FUniqueMode = iuDistinct then
begin
// raising -> reset modify mode
FModifyMode := mmNormal;
ConstructInsertErrorMsg;
Result := false;
end;
end;
end;
end;
procedure TIndexFile.ConstructInsertErrorMsg;
var
InfoKey: string;
begin
if Length(FLastError) > 0 then exit;
InfoKey := FUserKey;
SetLength(InfoKey, KeyLen);
FLastError := Format(STRING_KEY_VIOLATION, [GetName,
PhysicalRecNo, TrimRight(InfoKey)]);
end;
procedure TIndexFile.InsertError;
var
errorStr: string;
begin
errorStr := FLastError;
FLastError := '';
raise EDbfError.Create(errorStr);
end;
procedure TIndexFile.Delete(RecNo: Integer; Buffer: TRecordBuffer);
var
I, curSel: Integer;
begin
// check if updating all or only current
FUserRecNo := RecNo;
if (FUpdateMode = umAll) or (FSelectedIndex = -1) then
begin
// remember currently selected index
curSel := FSelectedIndex;
for I := 0 to SwapWordLE(PMdxHdr(Header)^.TagsUsed) - 1 do
begin
SelectIndexVars(I);
DeleteKey(Buffer);
end;
// restore previous selected index
SelectIndexVars(curSel);
end else begin
DeleteKey(Buffer);
end;
// range may be changed
ResyncRange(true);
end;
procedure TIndexFile.DeleteKey(Buffer: TRecordBuffer);
begin
if FCanEdit and (PIndexHdr(FIndexHeader)^.KeyLen <> 0) then
begin
// get key from record buffer
FUserKey := ExtractKeyFromBuffer(Buffer);
// call function
DeleteCurrent;
end;
end;
procedure TIndexFile.DeleteCurrent;
// deletes from current index
begin
// only delete if not delete record or mode = distinct
// modify = mmDeleteRecall /\ unique = distinct -> key needs to be deleted from index
if (FModifyMode <> mmDeleteRecall) or (FUniqueMode = iuDistinct) then
begin
// prevent "confined" view of index while deleting
ResetRange;
// search correct entry to delete
if FLeaf.PhysicalRecNo <> FUserRecNo then
begin
FindKey(false);
end;
// delete selected entry
FLeaf.Delete;
end;
end;
function TIndexFile.UpdateIndex(Index: Integer; PrevBuffer, NewBuffer: TRecordBuffer): Boolean;
begin
SelectIndexVars(Index);
Result := UpdateCurrent(PrevBuffer, NewBuffer);
end;
function TIndexFile.Update(RecNo: Integer; PrevBuffer, NewBuffer: TRecordBuffer): Boolean;
var
I, curSel, count: Integer;
begin
// check if updating all or only current
FUserRecNo := RecNo;
if (FUpdateMode = umAll) or (FSelectedIndex = -1) then
begin
// remember currently selected index
curSel := FSelectedIndex;
Result := true;
I := 0;
count := SwapWordLE(PMdxHdr(Header)^.TagsUsed);
while I < count do
begin
Result := UpdateIndex(I, PrevBuffer, NewBuffer);
if not Result then
begin
// rollback updates to previous indexes
while I > 0 do
begin
Dec(I);
UpdateIndex(I, NewBuffer, PrevBuffer);
end;
break;
end;
Inc(I);
end;
// restore previous selected index
SelectIndexVars(curSel);
end else begin
Result := UpdateCurrent(PrevBuffer, NewBuffer);
end;
// check range, disabled by delete/insert
if (FRoot.LowPage = 0) and (FRoot.HighPage = 0) then
ResyncRange(true);
end;
function TIndexFile.UpdateCurrent(PrevBuffer, NewBuffer: TRecordBuffer): boolean;
var
InsertKey, DeleteKey: PChar;
TempBuffer: array [0..100] of Char;
begin
Result := true;
if FCanEdit and (PIndexHdr(FIndexHeader)^.KeyLen <> 0) then
begin
DeleteKey := ExtractKeyFromBuffer(PrevBuffer);
Move(DeleteKey^, TempBuffer, SwapWordLE(PIndexHdr(FIndexHeader)^.KeyLen));
DeleteKey := @TempBuffer[0];
InsertKey := ExtractKeyFromBuffer(NewBuffer);
// compare to see if anything changed
if CompareKeys(DeleteKey, InsertKey) <> 0 then
begin
FUserKey := DeleteKey;
DeleteCurrent;
FUserKey := InsertKey;
Result := InsertCurrent;
if not Result then
begin
FUserKey := DeleteKey;
InsertCurrent;
FUserKey := InsertKey;
end;
end;
end;
end;
procedure TIndexFile.AddNewLevel;
var
lNewPage: TIndexPage;
pKeyData: PChar;
begin
// create new page + space
if FIndexVersion >= xBaseIV then
lNewPage := TMdxPage.Create(Self)
else
lNewPage := TNdxPage.Create(Self);
lNewPage.GetNewPage;
// lock this new page; will be unlocked by caller
lNewPage.LockPage;
// lock index header; will be unlocked by caller
LockPage(FHeaderPageNo, true);
FHeaderLocked := FHeaderPageNo;
// modify header
PIndexHdr(FIndexHeader)^.RootPage := SwapIntLE(lNewPage.PageNo);
// set new page properties
lNewPage.SetNumEntries(0);
lNewPage.EntryNo := 0;
lNewPage.GotoInsertEntry;
{$ifdef TDBF_UPDATE_FIRST_LAST_NODE}
lNewPage.SetPrevBlock(lNewPage.PageNo - PagesPerRecord);
{$endif}
pKeyData := FRoot.GetKeyDataFromEntry(0);
lNewPage.FLowerPage := FRoot;
lNewPage.FHighIndex := 0;
lNewPage.SetEntry(0, pKeyData, FRoot.PageNo);
// update root pointer
FRoot.UpperPage := lNewPage;
FRoots[FSelectedIndex] := lNewPage;
FRoot := lNewPage;
// write new header
WriteRecord(FHeaderPageNo, FIndexHeader);
end;
procedure TIndexFile.UnlockHeader;
begin
if FHeaderLocked <> -1 then
begin
UnlockPage(FHeaderLocked);
FHeaderLocked := -1;
end;
end;
procedure TIndexFile.ResyncRoot;
begin
if FIndexVersion >= xBaseIV then
begin
// read header page
inherited ReadRecord(FHeaderPageNo, FIndexHeader);
end else
inherited ReadHeader;
// reread tree
FRoot.PageNo := SwapIntLE(PIndexHdr(FIndexHeader)^.RootPage);
end;
function TIndexFile.SearchKey(Key: PChar; SearchType: TSearchKeyType): Boolean;
var
findres, currRecNo: Integer;
begin
// save current position
currRecNo := SequentialRecNo;
// search, these are always from the root: no need for first
findres := Find(-2, Key);
// test result
case SearchType of
stEqual:
Result := findres = 0;
stGreaterEqual:
Result := findres <= 0;
stGreater:
begin
if findres = 0 then
begin
// find next record that is greater
// NOTE: MatchKey assumes key to search for is already specified
// in FUserKey, it is because we have called Find
repeat
Result := WalkNext;
until not Result or (MatchKey(Key) <> 0);
end else
Result := findres < 0;
end;
else
Result := false;
end;
// search failed -> restore previous position
if not Result then
SequentialRecNo := currRecNo;
end;
function TIndexFile.Find(RecNo: Integer; Buffer: PChar): Integer;
begin
// execute find
FUserRecNo := RecNo;
FUserKey := Buffer;
Result := FindKey(false);
end;
function TIndexFile.FindKey(AInsert: boolean): Integer;
//
// if you set Insert = true, you need to re-enable range after insert!!
//
var
TempPage, NextPage: TIndexPage;
numEntries, numKeysAvail, done, searchRecNo: Integer;
begin
// reread index header (to discover whether root page changed)
if NeedLocks then
ResyncRoot;
// if distinct or unique index -> every entry only occurs once ->
// does not matter which recno we search -> search recno = -2 ->
// extra info = recno
if (FUniqueMode = iuNormal) then
begin
// if inserting, search last entry matching key
if AInsert then
searchRecNo := -3
else
searchRecNo := FUserRecNo
end else begin
searchRecNo := -2;
end;
// start from root
TempPage := FRoot;
repeat
// find key
done := 0;
Result := TempPage.FindNearest(searchRecNo);
if TempPage.LowerPage = nil then
begin
// if key greater than last, try next leaf
if (Result > 0) and (searchRecNo > 0) then
begin
// find first parent in tree so we can advance to next item
NextPage := TempPage;
repeat
NextPage := NextPage.UpperPage;
until (NextPage = nil) or (NextPage.EntryNo < NextPage.HighIndex);
// found page?
if NextPage <> nil then
begin
// go to parent
TempPage := NextPage;
TempPage.EntryNo := TempPage.EntryNo + 1;
// resync rest of tree
TempPage.LowerPage.RecurFirst;
// go to lower page to continue search
TempPage := TempPage.LowerPage;
// check if still more lowerpages
if TempPage.LowerPage <> nil then
begin
// flag we need to traverse down further
done := 2;
end else begin
// this is next child, we don't know if found
done := 1;
end;
end;
end;
end else begin
// need to traverse lower down
done := 2;
end;
// check if we need to split page
// done = 1 -> not found entry on insert path yet
if AInsert and (done <> 1) then
begin
// now we are on our path to destination where entry is to be inserted
// check if this page is full, then split it
numEntries := TempPage.NumEntries;
// if this is inner node, we can only store one less than max entries
numKeysAvail := SwapWordLE(PIndexHdr(FIndexHeader)^.NumKeys) - numEntries;
if TempPage.LowerPage <> nil then
dec(numKeysAvail);
// too few available -> split
if numKeysAvail = 0 then
TempPage.Split;
end;
// do we need to go lower down?
if done = 2 then
TempPage := TempPage.LowerPage;
until done = 0;
end;
function TIndexFile.MatchKey(UserKey: PChar): Integer;
begin
// BOF and EOF always false
if FLeaf.Entry = FEntryBof then
Result := 1
else
if FLeaf.Entry = FEntryEof then
Result := -1
else begin
FUserKey := UserKey;
Result := FLeaf.MatchKey;
end;
end;
procedure TIndexFile.SetRange(LowRange, HighRange: PChar);
begin
Move(LowRange^, FLowBuffer[0], KeyLen);
Move(HighRange^, FHighBuffer[0], KeyLen);
FRangeActive := true;
ResyncRange(true);
end;
procedure TIndexFile.RecordDeleted(RecNo: Integer; Buffer: TRecordBuffer);
begin
// are we distinct -> then delete record from index
FModifyMode := mmDeleteRecall;
Delete(RecNo, Buffer);
FModifyMode := mmNormal;
end;
function TIndexFile.RecordRecalled(RecNo: Integer; Buffer: TRecordBuffer): Boolean;
begin
// are we distinct -> then reinsert record in index
FModifyMode := mmDeleteRecall;
Result := Insert(RecNo, Buffer);
FModifyMode := mmNormal;
end;
procedure TIndexFile.SetPhysicalRecNo(RecNo: Integer);
begin
// check if already at specified recno
if FLeaf.PhysicalRecNo = RecNo then
exit;
// check record actually exists
if TDbfFile(FDbfFile).IsRecordPresent(RecNo) then
begin
// read buffer of this RecNo
TDbfFile(FDbfFile).ReadRecord(RecNo, TDbfFile(FDbfFile).PrevBuffer);
// extract key
FUserKey := ExtractKeyFromBuffer(TDbfFile(FDbfFile).PrevBuffer);
// find this key
FUserRecNo := RecNo;
FindKey(false);
end;
end;
procedure TIndexFile.SetUpdateMode(NewMode: TIndexUpdateMode);
begin
// if there is only one index, don't waste time and just set single
if (FIndexVersion = xBaseIII) or (SwapWordLE(PMdxHdr(Header)^.TagsUsed) <= 1) then
FUpdateMode := umCurrent
else
FUpdateMode := NewMode;
end;
procedure TIndexFile.WalkFirst;
begin
// search first node
FRoot.RecurFirst;
// out of index - BOF
FLeaf.EntryNo := FLeaf.EntryNo - 1;
end;
procedure TIndexFile.WalkLast;
begin
// search last node
FRoot.RecurLast;
// out of index - EOF
// we need to skip two entries to go out-of-bound
FLeaf.EntryNo := FLeaf.EntryNo + 2;
end;
procedure TIndexFile.First;
begin
// resync tree
Resync(false);
WalkFirst;
end;
procedure TIndexFile.Last;
begin
// resync tree
Resync(false);
WalkLast;
end;
procedure TIndexFile.ResyncRange(KeepPosition: boolean);
var
Result: Boolean;
currRecNo: integer;
begin
if not FRangeActive then
exit;
// disable current range if any
// init to 0 to suppress delphi warning
currRecNo := 0;
if KeepPosition then
currRecNo := SequentialRecNo;
ResetRange;
// search lower bound
Result := SearchKey(FLowBuffer, stGreaterEqual);
if not Result then
begin
// not found? -> make empty range
WalkLast;
end;
// set lower bound
SetBracketLow;
// search upper bound
Result := SearchKey(FHighBuffer, stGreater);
// if result true, then need to get previous item <=>
// last of equal/lower than key
if Result then
begin
Result := WalkPrev;
if not Result then
begin
// cannot go prev -> empty range
WalkFirst;
end;
end else begin
// not found -> EOF found, go EOF, then to last record
WalkLast;
WalkPrev;
end;
// set upper bound
SetBracketHigh;
if KeepPosition then
SequentialRecNo := currRecNo;
end;
procedure TIndexFile.Resync(Relative: boolean);
begin
if NeedLocks then
begin
if not Relative then
begin
ResyncRoot;
ResyncRange(false);
end else begin
// resyncing tree implies resyncing range
ResyncTree;
end;
end;
end;
procedure TIndexFile.ResyncTree;
var
action, recno: integer;
begin
// if at BOF or EOF, then we need to resync by first or last
// remember where the cursor was
// init to 0 to suppress delphi warning
recno := 0;
if FLeaf.Entry = FEntryBof then
begin
action := 0;
end else if FLeaf.Entry = FEntryEof then begin
action := 1;
end else begin
// read current key into buffer
Move(FLeaf.Key^, FKeyBuffer, SwapWordLE(PIndexHdr(FIndexHeader)^.KeyLen));
recno := FLeaf.PhysicalRecNo;
action := 2;
end;
// we now know cursor position, resync possible range
ResyncRange(false);
// go to cursor position
case action of
0: WalkFirst;
1: WalkLast;
2:
begin
// search current in-mem key on disk
if (Find(recno, FKeyBuffer) <> 0) then
begin
// houston, we've got a problem!
// our `current' record has gone. we need to find it
// find it by using physical recno
PhysicalRecNo := recno;
end;
end;
end;
end;
function TIndexFile.WalkPrev: boolean;
var
curRecNo: Integer;
begin
// save current recno, find different next!
curRecNo := FLeaf.PhysicalRecNo;
repeat
// return false if we are at first entry
Result := FLeaf.RecurPrev;
until not Result or (curRecNo <> FLeaf.PhysicalRecNo);
end;
function TIndexFile.WalkNext: boolean;
var
curRecNo: Integer;
begin
// save current recno, find different prev!
curRecNo := FLeaf.PhysicalRecNo;
repeat
// return false if we are at last entry
Result := FLeaf.RecurNext;
until not Result or (curRecNo <> FLeaf.PhysicalRecNo);
end;
function TIndexFile.Prev: Boolean;
begin
// resync in-mem tree with tree on disk
Resync(true);
Result := WalkPrev;
end;
function TIndexFile.Next: Boolean;
begin
// resync in-mem tree with tree on disk
Resync(true);
Result := WalkNext;
end;
function TIndexFile.GetKeyLen: Integer;
begin
Result := SwapWordLE(PIndexHdr(FIndexHeader)^.KeyLen);
end;
function TIndexFile.GetKeyType: Char;
begin
Result := PIndexHdr(FIndexHeader)^.KeyType;
end;
function TIndexFile.GetPhysicalRecNo: Integer;
begin
Result := FLeaf.PhysicalRecNo;
end;
function TIndexFile.GetSequentialRecordCount: Integer;
begin
Result := FRoot.Weight * (FRoot.HighIndex + 1);
end;
function TIndexFile.GetSequentialRecNo: Integer;
var
TempPage: TIndexPage;
begin
// check if at BOF or EOF, special values
if FLeaf.EntryNo < FLeaf.LowIndex then begin
Result := RecBOF;
end else if FLeaf.EntryNo > FLeaf.HighIndex then begin
Result := RecEOF;
end else begin
// first record is record 1
Result := 1;
TempPage := FRoot;
repeat
inc(Result, TempPage.EntryNo * TempPage.Weight);
TempPage := TempPage.LowerPage;
until TempPage = nil;
end;
end;
procedure TIndexFile.SetSequentialRecNo(RecNo: Integer);
var
TempPage: TIndexPage;
gotoEntry: Integer;
begin
// use our weighting system to quickly go to a seq recno
// recno starts at 1, entries at zero
Dec(RecNo);
TempPage := FRoot;
repeat
// don't div by zero
assert(TempPage.Weight > 0);
gotoEntry := RecNo div TempPage.Weight;
RecNo := RecNo mod TempPage.Weight;
// do we have this much entries?
if (TempPage.HighIndex < gotoEntry) then
begin
// goto next entry in upper page if not
// if recurnext fails, we have come at the end of the index
if (TempPage.UpperPage <> nil) and TempPage.UpperPage.RecurNext then
begin
// lower recno to get because we skipped an entry
TempPage.EntryNo := TempPage.LowIndex;
RecNo := 0;
end else begin
// this can only happen if too big RecNo was entered, go to last
TempPage.RecurLast;
// terminate immediately
TempPage := FLeaf;
end;
end else begin
TempPage.EntryNo := gotoEntry;
end;
// get lower node
TempPage := TempPage.LowerPage;
until TempPage = nil;
end;
procedure TIndexFile.SetBracketLow;
var
TempPage: TIndexPage;
begin
// set current record as lower bound
TempPage := FRoot;
repeat
TempPage.LowBracket := TempPage.EntryNo;
TempPage.LowPage := TempPage.PageNo;
TempPage := TempPage.LowerPage;
until TempPage = nil;
end;
procedure TIndexFile.SetBracketHigh;
var
TempPage: TIndexPage;
begin
// set current record as lower bound
TempPage := FRoot;
repeat
TempPage.HighBracket := TempPage.EntryNo;
TempPage.HighPage := TempPage.PageNo;
TempPage := TempPage.LowerPage;
until TempPage = nil;
end;
procedure TIndexFile.CancelRange;
begin
FRangeActive := false;
ResetRange;
end;
procedure TIndexFile.ResetRange;
var
TempPage: TIndexPage;
begin
// disable lower + upper bound
TempPage := FRoot;
repeat
// set a page the index should never reach
TempPage.LowPage := 0;
TempPage.HighPage := 0;
TempPage := TempPage.LowerPage;
until TempPage = nil;
end;
procedure TIndexFile.DisableRange;
var
TempPage: TIndexPage;
begin
TempPage := FRoot;
repeat
TempPage.SaveBracket;
TempPage := TempPage.LowerPage;
until TempPage = nil;
CancelRange;
end;
procedure TIndexFile.EnableRange;
var
TempPage: TIndexPage;
begin
TempPage := FRoot;
repeat
TempPage.RestoreBracket;
TempPage := TempPage.LowerPage;
until TempPage = nil;
FRangeActive := true;
end;
function MemComp(P1, P2: Pointer; const Length: Integer): Integer;
var
I: Integer;
begin
for I := 0 to Length - 1 do
begin
// still equal?
if PByte(P1)^ <> PByte(P2)^ then
begin
Result := Integer(PByte(P1)^) - Integer(PByte(P2)^);
exit;
end;
// go to next byte
Inc(PChar(P1));
Inc(PChar(P2));
end;
// memory equal
Result := 0;
end;
function TIndexFile.CompareKeys(Key1, Key2: PChar): Integer;
begin
// call compare routine
Result := FCompareKeys(Key1, Key2);
// if descending then reverse order
if FIsDescending then
Result := -Result;
end;
function TIndexFile.CompareKeysNumericNDX(Key1, Key2: PChar): Integer;
var
v1,v2: Double;
begin
v1 := PDouble(Key1)^;
v2 := PDouble(Key2)^;
if v1 > v2 then Result := 1
else if v1 < v2 then Result := -1
else Result := 0;
end;
function TIndexFile.CompareKeysNumericMDX(Key1, Key2: PChar): Integer;
var
neg1, neg2: Boolean;
begin
// first byte - $34 contains dot position
neg1 := (Byte(Key1[1]) and $80) <> 0;
neg2 := (Byte(Key2[1]) and $80) <> 0;
// check if both negative or both positive
if neg1 = neg2 then
begin
// check alignment
if Key1[0] = Key2[0] then
begin
// no alignment needed -> have same alignment
Result := MemComp(Key1+2, Key2+2, 10-2);
end else begin
// greater 10-power implies bigger number except for zero
if (Byte(Key1[0]) = $01) and (Byte(Key1[1]) = $34) then
Result := -1
else
if (Byte(Key2[0]) = $01) and (Byte(Key2[1]) = $34) then
Result := 1
else
Result := Byte(Key1[0]) - Byte(Key2[0]);
end;
// negate result if both negative
if neg1 and neg2 then
Result := -Result;
end else if neg1 {-> not neg2} then
Result := -1
else { not neg1 and neg2 }
Result := 1;
end;
function TIndexFile.CompareKeysString(Key1, Key2: PChar): Integer;
begin
Result := DbfCompareString(FCollation, Key1, KeyLen, Key2, KeyLen);
if Result > 0 then
Dec(Result, 2);
end;
function TIndexFile.CompareKey(Key: PChar): Integer;
begin
Result := CompareKeys(FUserKey, Key);
end;
function TIndexFile.IndexOf(const AIndexName: string): Integer;
// *) assumes FIndexVersion >= xBaseIV
var
I: Integer;
begin
// get index of this index :-)
Result := -1;
for I := 0 to SwapWordLE(PMdxHdr(Header)^.TagsUsed) - 1 do
begin
FTempMdxTag.Tag := CalcTagOffset(I);
if AnsiCompareText(AIndexName, FTempMdxTag.TagName) = 0 then
begin
Result := I;
break;
end;
end;
end;
procedure TIndexFile.SetIndexName(const AIndexName: string);
var
found: Integer;
begin
// we can only select a different index if we are MDX
if FIndexVersion >= xBaseIV then
begin
// find index
found := IndexOf(AIndexName);
end else
found := 0;
// if changing index, range is N/A anymore
if FRangeActive and (found <> FSelectedIndex) then
begin
FRangeIndex := FSelectedIndex;
DisableRange;
end;
// we can now select by index
if found >= 0 then
begin
SelectIndexVars(found);
if found = FRangeIndex then
begin
EnableRange;
FRangeIndex := -1;
end;
end;
end;
function TIndexFile.CalcTagOffset(AIndex: Integer): Pointer;
begin
Result := PChar(Header) + FTagOffset + AIndex * FTagSize;
end;
procedure TIndexFile.SelectIndexVars(AIndex: Integer);
// *) assumes index is in range
begin
if AIndex >= 0 then
begin
// get pointer to index header
FIndexHeader := FIndexHeaders[AIndex];
// load root + leaf
FCurrentParser := FParsers[AIndex];
FRoot := FRoots[AIndex];
FLeaf := FLeaves[AIndex];
// if xBaseIV then we need to store where pageno of current header
if FIndexVersion >= xBaseIV then
begin
FMdxTag.Tag := CalcTagOffset(AIndex);
FIndexName := FMdxTag.TagName;
FHeaderPageNo := FMdxTag.HeaderPageNo;
// does dBase actually use this flag?
// FIsExpression := FMdxTag.KeyFormat = KeyFormat_Expression;
end else begin
// how does dBase III store whether it is expression?
// FIsExpression := true;
end;
// retrieve properties
UpdateIndexProperties;
end else begin
// not a valid index
FIndexName := EmptyStr;
end;
// store selected index
FSelectedIndex := AIndex;
FCanEdit := not FForceReadOnly;
end;
procedure TIndexFile.UpdateIndexProperties;
begin
// get properties
FIsDescending := (PIndexHdr(FIndexHeader)^.KeyFormat and KeyFormat_Descending) <> 0;
FUniqueMode := iuNormal;
if (PIndexHdr(FIndexHeader)^.KeyFormat and KeyFormat_Unique) <> 0 then
FUniqueMode := iuUnique;
if (PIndexHdr(FIndexHeader)^.KeyFormat and KeyFormat_Distinct) <> 0 then
FUniqueMode := iuDistinct;
// select key compare routine
if PIndexHdr(FIndexHeader)^.KeyType = 'C' then
FCompareKeys := CompareKeysString
else
if FIndexVersion >= xBaseIV then
FCompareKeys := CompareKeysNumericMDX
else
FCompareKeys := CompareKeysNumericNDX;
end;
procedure TIndexFile.Flush;
var
I: Integer;
begin
// save changes to pages
if FIndexVersion >= xBaseIV then
begin
for I := 0 to MaxIndexes - 1 do
begin
if FIndexHeaderModified[I] then
WriteIndexHeader(I);
if FRoots[I] <> nil then
FRoots[I].Flush
end;
end else begin
if FRoot <> nil then
FRoot.Flush;
end;
// save changes to header
FlushHeader;
inherited;
end;
(*
function TIndexFile.GetIndexCount: Integer;
begin
if FIndexVersion = xBaseIII then
Result := 1
else
if FIndexVersion = xBaseIV then
Result := PMdxHdr(Header).TagsUsed;
else
Result := 0;
end;
*)
procedure TIndexFile.GetIndexNames(const AList: TStrings);
var
I: Integer;
begin
// only applicable to MDX files
if FIndexVersion >= xBaseIV then
begin
for I := 0 to SwapWordLE(PMdxHdr(Header)^.TagsUsed) - 1 do
begin
FTempMdxTag.Tag := CalcTagOffset(I);
AList.AddObject(FTempMdxTag.TagName, Self);
end;
end;
end;
procedure TIndexFile.GetIndexInfo(const AIndexName: string; IndexDef: TDbfIndexDef);
var
SaveIndexName: string;
begin
// remember current index
SaveIndexName := IndexName;
// select index
IndexName := AIndexName;
// copy properties
IndexDef.IndexFile := AIndexName;
IndexDef.Expression := PIndexHdr(FIndexHeader)^.KeyDesc;
IndexDef.Options := [];
IndexDef.Temporary := true;
if FIsDescending then
IndexDef.Options := IndexDef.Options + [ixDescending];
IndexDef.Options := IndexDef.Options + [ixExpression];
case FUniqueMode of
iuUnique: IndexDef.Options := IndexDef.Options + [ixUnique];
iuDistinct: IndexDef.Options := IndexDef.Options + [ixPrimary];
end;
// reselect previous index
IndexName := SaveIndexName;
end;
function TIndexFile.GetExpression: string;
begin
if FCurrentParser <> nil then
Result := FCurrentParser.Expression
else
Result := EmptyStr;
end;
function TIndexFile.GetDbfLanguageId: Byte;
begin
// check if parent DBF version 7, get language id
if (TDbfFile(FDbfFile).DbfVersion = xBaseVII) then
begin
// get language id of parent dbf
Result := GetLangId_From_LangName(TDbfFile(FDbfFile).LanguageStr);
end else begin
// dBase IV has language id in header
Result := TDbfFile(FDbfFile).LanguageID;
end;
end;
procedure TIndexFile.WriteHeader; {override;}
begin
// if NDX, then this means file header
if FIndexVersion >= xBaseIV then
if NeedLocks then
WriteIndexHeader(FSelectedIndex)
else
FIndexHeaderModified[FSelectedIndex] := true
else
WriteFileHeader;
end;
procedure TIndexFile.WriteFileHeader;
begin
inherited WriteHeader;
end;
procedure TIndexFile.WriteIndexHeader(AIndex: Integer);
begin
FTempMdxTag.Tag := CalcTagOffset(AIndex);
WriteRecord(FTempMdxTag.HeaderPageNo, FIndexHeaders[AIndex]);
FIndexHeaderModified[AIndex] := false;
end;
//==========================================================
//============ TDbfIndexDef
//==========================================================
constructor TDbfIndexDef.Create(ACollection: TCollection); {override;}
begin
inherited Create(ACollection);
FTemporary := false;
end;
destructor TDbfIndexDef.Destroy; {override;}
begin
inherited Destroy;
end;
procedure TDbfIndexDef.Assign(Source: TPersistent);
begin
// we can't do anything with it if not a TDbfIndexDef
if Source is TDbfIndexDef then
begin
FIndexName := TDbfIndexDef(Source).IndexFile;
FExpression := TDbfIndexDef(Source).Expression;
FOptions := TDbfIndexDef(Source).Options;
end else
inherited;
end;
procedure TDbfIndexDef.SetIndexName(NewName: string);
begin
FIndexName := AnsiUpperCase(Trim(NewName));
end;
procedure TDbfIndexDef.SetExpression(NewField: string);
begin
FExpression := AnsiUpperCase(Trim(NewField));
end;
initialization
{
Entry_Mdx_BOF.RecBlockNo := RecBOF;
Entry_Mdx_BOF.KeyData := #0;
Entry_Mdx_EOF.RecBlockNo := RecEOF;
Entry_Mdx_EOF.KeyData := #0;
Entry_Ndx_BOF.LowerPageNo := 0;
Entry_Ndx_BOF.RecNo := RecBOF;
Entry_Ndx_BOF.KeyData := #0;
Entry_Ndx_EOF.LowerPageNo := 0;
Entry_Ndx_EOF.RecNo := RecEOF;
Entry_Ndx_EOF.KeyData := #0;
}
LCIDList := TLCIDList.Create;
LCIDList.Enumerate;
finalization
LCIDList.Free;
end.