dbf_idxfile.pas

tDBF is new ver, this is BDS 2007 insta

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: PChar): Boolean;
    procedure DeleteKey(Buffer: PChar);
    function  InsertCurrent: Boolean;
    procedure DeleteCurrent;
    function  UpdateCurrent(PrevBuffer, NewBuffer: PChar): Boolean;
    function  UpdateIndex(Index: Integer; PrevBuffer, NewBuffer: PChar): 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: PChar): Boolean;
    function  Update(RecNo: Integer; PrevBuffer, NewBuffer: PChar): Boolean;
    procedure Delete(RecNo: Integer; Buffer: PChar);
    function  CheckKeyViolation(Buffer: PChar): Boolean;
    procedure RecordDeleted(RecNo: Integer; Buffer: PChar);
    function  RecordRecalled(RecNo: Integer; Buffer: PChar): Boolean;
    procedure DeleteIndex(const AIndexName: string);
    procedure RepageFile;
    procedure CompactFile;
    procedure PrepareRename(NewFileName: string);

    procedure CreateIndex(FieldDesc, TagName: string; Options: TIndexOptions);
    function  ExtractKeyFromBuffer(Buffer: PChar): 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: PChar; 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_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