1 unit dbf_idxfile;
2
3 interface
4
5 {$I dbf_common.inc}
6
7 uses
8 {$ifdef WINDOWS}
9 Windows,
10 {$else}
11 {$ifdef KYLIX}
12 Libc,
13 {$endif}
14 Types, dbf_wtil,
15 {$endif}
16 SysUtils,
17 Classes,
18 db,
19 dbf_pgfile,
20 {$ifdef USE_CACHE}
21 dbf_pgcfile,
22 {$endif}
23 dbf_parser,
24 dbf_prsdef,
25 dbf_cursor,
26 dbf_collate,
27 dbf_common;
28
29 {$ifdef _DEBUG}
30 {$define TDBF_INDEX_CHECK}
31 {$endif}
32 {$ifdef _ASSERTS}
33 {$define TDBF_INDEX_CHECK}
34 {$endif}
35
36 const
37 MaxIndexes = 47;
38
39 type
40 TIndexPage = class;
41 TIndexTag = class;
42
43 TIndexUpdateMode = (umAll, umCurrent);
44 TLocaleError = (leNone, leUnknown, leTableIndexMismatch, leNotAvailable);
45 TLocaleSolution = (lsNotOpen, lsNoEdit, lsBinary);
46 TIndexUniqueType = (iuNormal, iuUnique, iuDistinct);
47 TIndexModifyMode = (mmNormal, mmDeleteRecall);
48
49 TDbfLocaleErrorEvent = procedure(var Error: TLocaleError; var Solution: TLocaleSolution) of object;
ey1null50 TDbfCompareKeysEvent = function(Key1, Key2: PChar): Integer of object;
51
52 PDouble = ^Double;
53 PInteger = ^Integer;
54
55 //===========================================================================
56 TDbfIndexDef = class;
57 TDbfIndexDef = class(TCollectionItem)
58 protected
59 FIndexName: string;
60 FExpression: string;
61 FOptions: TIndexOptions;
62 FTemporary: Boolean; // added at runtime
63
64 procedure SetIndexName(NewName: string);
65 procedure SetExpression(NewField: string);
66 public
67 constructor Create(ACollection: TCollection); override;
68 destructor Destroy; override;
69
70 procedure Assign(Source: TPersistent); override;
71 property Temporary: Boolean read FTemporary write FTemporary;
72 property Name: string read FIndexName write SetIndexName;
73 property Expression: string read FExpression write SetExpression;
74 published
75 property IndexFile: string read FIndexName write SetIndexName;
76 property SortField: string read FExpression write SetExpression;
77 property Options: TIndexOptions read FOptions write FOptions;
78 end;
79
80 TDbfIndexParser = class(TDbfParser)
81 protected
82 FResultLen: Integer;
83
84 procedure ValidateExpression(AExpression: string); override;
85 public
86 property ResultLen: Integer read FResultLen;
87 end;
88 //===========================================================================
89 TIndexFile = class;
90 TIndexPageClass = class of TIndexPage;
91
92 TIndexPage = class(TObject)
93 protected
94 FIndexFile: TIndexFile;
95 FLowerPage: TIndexPage;
96 FUpperPage: TIndexPage;
97 FPageBuffer: Pointer;
98 FEntry: Pointer;
99 FEntryNo: Integer;
100 FLockCount: Integer;
101 FModified: Boolean;
102 FPageNo: Integer;
103 FWeight: Integer;
104
105 // bracket props
106 FLowBracket: Integer; // = FLowIndex if FPageNo = FLowPage
107 FLowIndex: Integer;
108 FLowPage: Integer;
109 FLowPageTemp: Integer;
110 FHighBracket: Integer; // = FHighIndex if FPageNo = FHighPage
111 FHighIndex: Integer;
112 FHighPage: Integer;
113 FHighPageTemp: Integer;
114
115 procedure LocalInsert(RecNo: Integer; Buffer: PChar; LowerPageNo: Integer);
116 procedure LocalDelete;
117 procedure Delete;
118
119 procedure SyncLowerPage;
120 procedure WritePage;
121 procedure Split;
122 procedure LockPage;
123 procedure UnlockPage;
124
RecurPrevnull125 function RecurPrev: Boolean;
RecurNextnull126 function RecurNext: Boolean;
127 procedure RecurFirst;
128 procedure RecurLast;
129
130 procedure SetEntry(RecNo: Integer; AKey: PChar; LowerPageNo: Integer);
131 procedure SetEntryNo(value: Integer);
132 procedure SetPageNo(NewPageNo: Integer);
133 procedure SetLowPage(NewPage: Integer);
134 procedure SetHighPage(NewPage: Integer);
135 procedure SetUpperPage(NewPage: TIndexPage);
136 procedure UpdateBounds(IsInnerNode: Boolean);
137
138 protected
GetEntrynull139 function GetEntry(AEntryNo: Integer): Pointer; virtual; abstract;
GetLowerPageNonull140 function GetLowerPageNo: Integer; virtual; abstract;
GetKeyDatanull141 function GetKeyData: PChar; virtual; abstract;
GetNumEntriesnull142 function GetNumEntries: Integer; virtual; abstract;
GetKeyDataFromEntrynull143 function GetKeyDataFromEntry(AEntry: Integer): PChar; virtual; abstract;
GetRecNonull144 function GetRecNo: Integer; virtual; abstract;
GetIsInnerNodenull145 function GetIsInnerNode: Boolean; virtual; abstract;
146 procedure IncNumEntries; virtual; abstract;
147 procedure SetNumEntries(NewNum: Integer); virtual; abstract;
148 procedure SetRecLowerPageNo(NewRecNo, NewPageNo: Integer); virtual; abstract;
149 procedure SetRecLowerPageNoOfEntry(AEntry, NewRecNo, NewPageNo: Integer); virtual; abstract;
150 {$ifdef TDBF_UPDATE_FIRST_LAST_NODE}
151 procedure SetPrevBlock(NewBlock: Integer); virtual;
152 {$endif}
153
154 public
155 constructor Create(Parent: TIndexFile);
156 destructor Destroy; override;
157
FindNearestnull158 function FindNearest(ARecNo: Integer): Integer;
PhysicalRecNonull159 function PhysicalRecNo: Integer;
MatchKeynull160 function MatchKey: Integer;
161 procedure GotoInsertEntry;
162
163 procedure Clear;
164 procedure GetNewPage;
165 procedure Modified;
166 procedure RecalcWeight;
167 procedure UpdateWeight;
168 procedure Flush;
169 procedure SaveBracket;
170 procedure RestoreBracket;
171
172 property Key: PChar read GetKeyData;
173 property Entry: Pointer read FEntry;
174 property EntryNo: Integer read FEntryNo write SetEntryNo;
175 property IndexFile: TIndexFile read FIndexFile;
176 property UpperPage: TIndexPage read FUpperPage write SetUpperPage;
177 property LowerPage: TIndexPage read FLowerPage;
178 // property LowerPageNo: Integer read GetLowerPageNo; // never used
179 property PageBuffer: Pointer read FPageBuffer;
180 property PageNo: Integer read FPageNo write SetPageNo;
181 property Weight: Integer read FWeight;
182
183 property NumEntries: Integer read GetNumEntries;
184 property HighBracket: Integer read FHighBracket write FHighBracket;
185 property HighIndex: Integer read FHighIndex;
186 property HighPage: Integer read FHighPage write SetHighPage;
187 property LowBracket: Integer read FLowBracket write FLowBracket;
188 property LowIndex: Integer read FLowIndex;
189 property LowPage: Integer read FLowPage write SetLowPage;
190 end;
191 //===========================================================================
192 TIndexTag = class(TObject)
193 private
194 FTag: Pointer;
195 protected
GetHeaderPageNonull196 function GetHeaderPageNo: Integer; virtual; abstract;
GetTagNamenull197 function GetTagName: string; virtual; abstract;
GetKeyFormatnull198 function GetKeyFormat: Byte; virtual; abstract;
GetForwardTag1null199 function GetForwardTag1: Byte; virtual; abstract;
GetForwardTag2null200 function GetForwardTag2: Byte; virtual; abstract;
GetBackwardTagnull201 function GetBackwardTag: Byte; virtual; abstract;
GetReservednull202 function GetReserved: Byte; virtual; abstract;
GetKeyTypenull203 function GetKeyType: Char; virtual; abstract;
204 procedure SetHeaderPageNo(NewPageNo: Integer); virtual; abstract;
205 procedure SetTagName(NewName: string); virtual; abstract;
206 procedure SetKeyFormat(NewFormat: Byte); virtual; abstract;
207 procedure SetForwardTag1(NewTag: Byte); virtual; abstract;
208 procedure SetForwardTag2(NewTag: Byte); virtual; abstract;
209 procedure SetBackwardTag(NewTag: Byte); virtual; abstract;
210 procedure SetReserved(NewReserved: Byte); virtual; abstract;
211 procedure SetKeyType(NewType: Char); virtual; abstract;
212 public
213 property HeaderPageNo: Integer read GetHeaderPageNo write SetHeaderPageNo;
214 property TagName: string read GetTagName write SetTagName;
215 property KeyFormat: Byte read GetKeyFormat write SetKeyFormat;
216 property ForwardTag1: Byte read GetForwardTag1 write SetForwardTag1;
217 property ForwardTag2: Byte read GetForwardTag2 write SetForwardTag2;
218 property BackwardTag: Byte read GetBackwardTag write SetBackwardTag;
219 property Reserved: Byte read GetReserved write SetReserved;
220 property KeyType: Char read GetKeyType write SetKeyType;
221 property Tag: Pointer read FTag write FTag;
222 end;
223 //===========================================================================
224 {$ifdef USE_CACHE}
225 TIndexFile = class(TCachedFile)
226 {$else}
227 TIndexFile = class(TPagedFile)
228 {$endif}
229 protected
230 FIndexName: string;
231 FLastError: string;
232 FParsers: array[0..MaxIndexes-1] of TDbfIndexParser;
233 FIndexHeaders: array[0..MaxIndexes-1] of Pointer;
234 FIndexHeaderModified: array[0..MaxIndexes-1] of Boolean;
235 FIndexHeader: Pointer;
236 FIndexVersion: TXBaseVersion;
237 FRoots: array[0..MaxIndexes-1] of TIndexPage;
238 FLeaves: array[0..MaxIndexes-1] of TIndexPage;
239 FCurrentParser: TDbfIndexParser;
240 FRoot: TIndexPage;
241 FLeaf: TIndexPage;
242 FMdxTag: TIndexTag;
243 FTempMdxTag: TIndexTag;
244 FEntryHeaderSize: Integer;
245 FPageHeaderSize: Integer;
246 FTagSize: Integer;
247 FTagOffset: Integer;
248 FHeaderPageNo: Integer;
249 FSelectedIndex: Integer;
250 FRangeIndex: Integer;
251 FIsDescending: Boolean;
252 FUniqueMode: TIndexUniqueType;
253 FModifyMode: TIndexModifyMode;
254 FHeaderLocked: Integer; // used to remember which header page we have locked
255 FKeyBuffer: array[0..100] of Char;
256 FLowBuffer: array[0..100] of Char;
257 FHighBuffer: array[0..100] of Char;
258 FEntryBof: Pointer;
259 FEntryEof: Pointer;
260 FDbfFile: Pointer;
261 FCanEdit: Boolean;
262 FOpened: Boolean;
263 FRangeActive: Boolean;
264 FUpdateMode: TIndexUpdateMode;
265 FUserKey: PChar; // find / insert key
266 FUserRecNo: Integer; // find / insert recno
267 FUserBCD: array[0..10] of Byte;
268 FUserNumeric: Double;
269 FForceClose: Boolean;
270 FForceReadOnly: Boolean;
271 FCodePage: Integer;
272 FCollation: PCollationTable;
273 FCompareKeys: TDbfCompareKeysEvent;
274 FOnLocaleError: TDbfLocaleErrorEvent;
275
GetNewPageNonull276 function GetNewPageNo: Integer;
277 procedure TouchHeader(AHeader: Pointer);
CreateTempFilenull278 function CreateTempFile(BaseName: string): TPagedFile;
279 procedure ConstructInsertErrorMsg;
280 procedure WriteIndexHeader(AIndex: Integer);
281 procedure SelectIndexVars(AIndex: Integer);
282 procedure CalcKeyProperties;
283 procedure UpdateIndexProperties;
284 procedure ClearRoots;
CalcTagOffsetnull285 function CalcTagOffset(AIndex: Integer): Pointer;
286
FindKeynull287 function FindKey(AInsert: boolean): Integer;
InsertKeynull288 function InsertKey(Buffer: TRecordBuffer): Boolean;
289 procedure DeleteKey(Buffer: TRecordBuffer);
InsertCurrentnull290 function InsertCurrent: Boolean;
291 procedure DeleteCurrent;
UpdateCurrentnull292 function UpdateCurrent(PrevBuffer, NewBuffer: TRecordBuffer): Boolean;
UpdateIndexnull293 function UpdateIndex(Index: Integer; PrevBuffer, NewBuffer: TRecordBuffer): Boolean;
294 procedure ReadIndexes;
295 procedure Resync(Relative: boolean);
296 procedure ResyncRoot;
297 procedure ResyncTree;
298 procedure ResyncRange(KeepPosition: boolean);
299 procedure ResetRange;
300 procedure SetBracketLow;
301 procedure SetBracketHigh;
302
303 procedure WalkFirst;
304 procedure WalkLast;
WalkPrevnull305 function WalkPrev: boolean;
WalkNextnull306 function WalkNext: boolean;
307
CompareKeysNumericNDXnull308 function CompareKeysNumericNDX(Key1, Key2: PChar): Integer;
CompareKeysNumericMDXnull309 function CompareKeysNumericMDX(Key1, Key2: PChar): Integer;
CompareKeysStringnull310 function CompareKeysString(Key1, Key2: PChar): Integer;
311
312 // property functions
GetNamenull313 function GetName: string;
GetDbfLanguageIdnull314 function GetDbfLanguageId: Byte;
GetKeyLennull315 function GetKeyLen: Integer;
GetKeyTypenull316 function GetKeyType: Char;
GetIndexCountnull317 // function GetIndexCount Integer;
318 function GetExpression: string;
GetPhysicalRecNonull319 function GetPhysicalRecNo: Integer;
GetSequentialRecNonull320 function GetSequentialRecNo: Integer;
GetSequentialRecordCountnull321 function GetSequentialRecordCount: Integer;
322 procedure SetSequentialRecNo(RecNo: Integer);
323 procedure SetPhysicalRecNo(RecNo: Integer);
324 procedure SetUpdateMode(NewMode: TIndexUpdateMode);
325 procedure SetIndexName(const AIndexName: string);
326
327 public
328 constructor Create(ADbfFile: Pointer);
329 destructor Destroy; override;
330
331 procedure Open;
332 procedure Close;
333
334 procedure Clear;
335 procedure Flush; override;
336 procedure ClearIndex;
337 procedure AddNewLevel;
338 procedure UnlockHeader;
339 procedure InsertError;
Insertnull340 function Insert(RecNo: Integer; Buffer:TRecordBuffer ): Boolean;
Updatenull341 function Update(RecNo: Integer; PrevBuffer, NewBuffer: TRecordBuffer): Boolean;
342 procedure Delete(RecNo: Integer; Buffer: TRecordBuffer);
CheckKeyViolationnull343 function CheckKeyViolation(Buffer: TRecordBuffer): Boolean;
344 procedure RecordDeleted(RecNo: Integer; Buffer: TRecordBuffer);
RecordRecallednull345 function RecordRecalled(RecNo: Integer; Buffer: TRecordBuffer): Boolean;
346 procedure DeleteIndex(const AIndexName: string);
347 procedure RepageFile;
348 procedure CompactFile;
349 procedure PrepareRename(NewFileName: string);
350
351 procedure CreateIndex(FieldDesc, TagName: string; Options: TIndexOptions);
ExtractKeyFromBuffernull352 function ExtractKeyFromBuffer(Buffer: TRecordBuffer): PChar;
SearchKeynull353 function SearchKey(Key: PChar; SearchType: TSearchKeyType): Boolean;
Findnull354 function Find(RecNo: Integer; Buffer: PChar): Integer;
IndexOfnull355 function IndexOf(const AIndexName: string): Integer;
356 procedure DisableRange;
357 procedure EnableRange;
358
359 procedure GetIndexNames(const AList: TStrings);
360 procedure GetIndexInfo(const AIndexName: string; IndexDef: TDbfIndexDef);
361 procedure WriteHeader; override;
362 procedure WriteFileHeader;
363
364 procedure First;
365 procedure Last;
Nextnull366 function Next: Boolean;
Prevnull367 function Prev: Boolean;
368
369 procedure SetRange(LowRange, HighRange: PChar);
370 procedure CancelRange;
MatchKeynull371 function MatchKey(UserKey: PChar): Integer;
CompareKeynull372 function CompareKey(Key: PChar): Integer;
CompareKeysnull373 function CompareKeys(Key1, Key2: PChar): Integer;
PrepareKeynull374 function PrepareKey(Buffer: TRecordBuffer; ResultType: TExpressionType): PChar;
375
376 property KeyLen: Integer read GetKeyLen;
377 property IndexVersion: TXBaseVersion read FIndexVersion;
378 property EntryHeaderSize: Integer read FEntryHeaderSize;
379 property KeyType: Char read GetKeyType;
380
381 property SequentialRecordCount: Integer read GetSequentialRecordCount;
382 property SequentialRecNo: Integer read GetSequentialRecNo write SetSequentialRecNo;
383 property PhysicalRecNo: Integer read GetPhysicalRecNo write SetPhysicalRecNo;
384 property HeaderPageNo: Integer read FHeaderPageNo;
385
386 property IndexHeader: Pointer read FIndexHeader;
387 property EntryBof: Pointer read FEntryBof;
388 property EntryEof: Pointer read FEntryEof;
389 property UniqueMode: TIndexUniqueType read FUniqueMode;
390 property IsDescending: Boolean read FIsDescending;
391
392 property UpdateMode: TIndexUpdateMode read FUpdateMode write SetUpdateMode;
393 property IndexName: string read FIndexName write SetIndexName;
394 property Expression: string read GetExpression;
395 // property Count: Integer read GetIndexCount;
396
397 property ForceClose: Boolean read FForceClose;
398 property ForceReadOnly: Boolean read FForceReadOnly;
399 property CodePage: Integer read FCodePage write FCodePage;
400
401 property OnLocaleError: TDbfLocaleErrorEvent read FOnLocaleError write FOnLocaleError;
402 end;
403
404 //------------------------------------------------------------------------------
405 implementation
406
407 uses
408 dbf_dbffile,
409 dbf_fields,
410 dbf_str,
411 dbf_prssupp,
412 dbf_prscore,
413 dbf_lang;
414
415 const
416 RecBOF = 0;
417 RecEOF = MaxInt;
418
419 lcidBinary = $0A03;
420
421 KeyFormat_Expression = $00;
422 KeyFormat_Data = $10;
423
424 KeyFormat_Descending = $08;
425 KeyFormat_String = $10;
426 KeyFormat_Distinct = $20;
427 KeyFormat_Unique = $40;
428
429 Unique_None = $00;
430 Unique_Unique = $01;
431 Unique_Distinct = $21;
432
433 type
434
435 TLCIDList = class(TList)
436 public
437 constructor Create;
438
439 procedure Enumerate;
440 end;
441
442 PMdxHdr = ^rMdxHdr;
443 rMdxHdr = record
444 MdxVersion : Byte; // 0
445 Year : Byte; // 1
446 Month : Byte; // 2
447 Day : Byte; // 3
448 FileName : array[0..15] of Char; // 4..19
449 BlockSize : Word; // 20..21
450 BlockAdder : Word; // 22..23
451 ProdFlag : Byte; // 24
452 NumTags : Byte; // 25
453 TagSize : Byte; // 26
454 Dummy1 : Byte; // 27
455 TagsUsed : Word; // 28..29
456 Dummy2 : Byte; // 30
457 Language : Byte; // 31
458 NumPages : Integer; // 32..35
459 FreePage : Integer; // 36..39
460 BlockFree : Integer; // 40..43
461 UpdYear : Byte; // 44
462 UpdMonth : Byte; // 45
463 UpdDay : Byte; // 46
464 Reserved : array[0..481] of Byte; // 47..528
465 TagFlag : Byte; // 529 // dunno what this means but it ought to be 1 :-)
466 end;
467
468 // Tags -> I don't know what to with them
469 // KeyType -> Variable position, db7 different from db4
470
471 PMdx4Tag = ^rMdx4Tag;
472 rMdx4Tag = record
473 HeaderPageNo : Integer; // 0..3
474 TagName : array [0..10] of Char; // 4..14 of Byte
475 KeyFormat : Byte; // 15 00h: Calculated
476 // 10h: Data Field
477 ForwardTag1 : Byte; // 16
478 ForwardTag2 : Byte; // 17
479 BackwardTag : Byte; // 18
480 Reserved : Byte; // 19
481 KeyType : Char; // 20 C : Character
482 // N : Numerical
483 // D : Date
484 end;
485
486 PMdx7Tag = ^rMdx7Tag;
487 rMdx7Tag = record
488 HeaderPageNo : Integer; // 0..3
489 TagName : array [0..32] of Char; // 4..36 of Byte
490 KeyFormat : Byte; // 37 00h: Calculated
491 // 10h: Data Field
492 ForwardTag1 : Byte; // 38
493 ForwardTag2 : Byte; // 39
494 BackwardTag : Byte; // 40
495 Reserved : Byte; // 41
496 KeyType : Char; // 42 C : Character
497 // N : Numerical
498 // D : Date
499 end;
500
501 PIndexHdr = ^rIndexHdr;
502 rIndexHdr = record
503 RootPage : Integer; // 0..3
504 NumPages : Integer; // 4..7
505 KeyFormat : Byte; // 8 00h: Right, Left, DTOC
506 // 08h: Descending order
507 // 10h: String
508 // 20h: Distinct
509 // 40h: Unique
510 KeyType : Char; // 9 C : Character
511 // N : Numerical
512 // D : Date
513 Dummy : Word; // 10..11
514 KeyLen : Word; // 12..13
515 NumKeys : Word; // 14..15
516 sKeyType : Word; // 16..17 00h: DB4: C/N; DB3: C
517 // 01h: DB4: D ; DB3: N/D
518 KeyRecLen : Word; // 18..19 Length of key entry in page
519 Version : Word; // 20..21
520 Dummy2 : Byte; // 22
521 Unique : Byte; // 23
522 KeyDesc : array [0..219] of Char; // 24..243
523 Dummy3 : Byte; // 244
524 ForExist : Byte; // 245
525 KeyExist : Byte; // 246
526 FirstNode : Longint; // 248..251 first node that contains data
527 LastNode : Longint; // 252..255 last node that contains data
528 // MDX Header has here a 506 byte block reserved
529 // and then the FILTER expression, which obviously doesn't
530 // fit in a NDX page, so we'll skip it
531 end;
532
533 PMdxEntry = ^rMdxEntry;
534 rMdxEntry = record
535 RecBlockNo: Longint; // 0..3 either recno or blockno
536 KeyData : Char; // 4.. first byte of data, context => length
537 end;
538
539 PMdxPage = ^rMdxPage;
540 rMdxPage = record
541 NumEntries : Integer;
542 PrevBlock : Integer;
543 FirstEntry : rMdxEntry;
544 end;
545
546 PNdxEntry = ^rNdxEntry;
547 rNdxEntry = record
548 LowerPageNo: Integer; // 0..3 lower page
549 RecNo : Integer; // 4..7 recno
550 KeyData : Char;
551 end;
552
553 PNdxPage = ^rNdxPage;
554 rNdxPage = record
555 NumEntries: Integer; // 0..3
556 FirstEntry: rNdxEntry;
557 end;
558
559 //---------------------------------------------------------------------------
560 TMdxPage = class(TIndexPage)
561 protected
562 function GetEntry(AEntryNo: Integer): Pointer; override;
563 function GetLowerPageNo: Integer; override;
564 function GetKeyData: PChar; override;
565 function GetNumEntries: Integer; override;
566 function GetKeyDataFromEntry(AEntry: Integer): PChar; override;
567 function GetRecNo: Integer; override;
568 function GetIsInnerNode: Boolean; override;
569 procedure IncNumEntries; override;
570 procedure SetNumEntries(NewNum: Integer); override;
571 procedure SetRecLowerPageNo(NewRecNo, NewPageNo: Integer); override;
572 procedure SetRecLowerPageNoOfEntry(AEntry, NewRecNo, NewPageNo: Integer); override;
573 {$ifdef TDBF_UPDATE_FIRST_LAST_NODE}
574 procedure SetPrevBlock(NewBlock: Integer); override;
575 {$endif}
576 end;
577 //---------------------------------------------------------------------------
578 TNdxPage = class(TIndexPage)
579 protected
580 function GetEntry(AEntryNo: Integer): Pointer; override;
581 function GetLowerPageNo: Integer; override;
582 function GetKeyData: PChar; override;
583 function GetNumEntries: Integer; override;
584 function GetKeyDataFromEntry(AEntry: Integer): PChar; override;
585 function GetRecNo: Integer; override;
586 function GetIsInnerNode: Boolean; override;
587 procedure IncNumEntries; override;
588 procedure SetNumEntries(NewNum: Integer); override;
589 procedure SetRecLowerPageNo(NewRecNo, NewPageNo: Integer); override;
590 procedure SetRecLowerPageNoOfEntry(AEntry, NewRecNo, NewPageNo: Integer); override;
591 end;
592 //---------------------------------------------------------------------------
593 TMdx4Tag = class(TIndexTag)
594 protected
595 function GetHeaderPageNo: Integer; override;
596 function GetTagName: string; override;
597 function GetKeyFormat: Byte; override;
598 function GetForwardTag1: Byte; override;
599 function GetForwardTag2: Byte; override;
600 function GetBackwardTag: Byte; override;
601 function GetReserved: Byte; override;
602 function GetKeyType: Char; override;
603 procedure SetHeaderPageNo(NewPageNo: Integer); override;
604 procedure SetTagName(NewName: string); override;
605 procedure SetKeyFormat(NewFormat: Byte); override;
606 procedure SetForwardTag1(NewTag: Byte); override;
607 procedure SetForwardTag2(NewTag: Byte); override;
608 procedure SetBackwardTag(NewTag: Byte); override;
609 procedure SetReserved(NewReserved: Byte); override;
610 procedure SetKeyType(NewType: Char); override;
611 end;
612 //---------------------------------------------------------------------------
613 TMdx7Tag = class(TIndexTag)
614 function GetHeaderPageNo: Integer; override;
615 function GetTagName: string; override;
616 function GetKeyFormat: Byte; override;
617 function GetForwardTag1: Byte; override;
618 function GetForwardTag2: Byte; override;
619 function GetBackwardTag: Byte; override;
620 function GetReserved: Byte; override;
621 function GetKeyType: Char; override;
622 procedure SetHeaderPageNo(NewPageNo: Integer); override;
623 procedure SetTagName(NewName: string); override;
624 procedure SetKeyFormat(NewFormat: Byte); override;
625 procedure SetForwardTag1(NewTag: Byte); override;
626 procedure SetForwardTag2(NewTag: Byte); override;
627 procedure SetBackwardTag(NewTag: Byte); override;
628 procedure SetReserved(NewReserved: Byte); override;
629 procedure SetKeyType(NewType: Char); override;
630 end;
631
632 var
633 Entry_Mdx_BOF: rMdxEntry; //(RecBOF, #0);
634 Entry_Mdx_EOF: rMdxEntry; //(RecBOF, #0);
635 Entry_Ndx_BOF: rNdxEntry; //(0, RecBOF, #0);
636 Entry_Ndx_EOF: rNdxEntry; //(0, RecEOF, #0);
637
638 LCIDList: TLCIDList;
639
640 procedure IncWordLE(var AVariable: Word; Amount: Integer);
641 begin
642 AVariable := SwapWordLE(SwapWordLE(AVariable) + Amount);
643 end;
644
645 procedure IncIntLE(var AVariable: Integer; Amount: Integer);
646 begin
647 AVariable := SwapIntLE(DWord(Integer(SwapIntLE(AVariable)) + Amount));
648 end;
649
650 //==========================================================
651 // Locale support for all versions of Delphi/C++Builder
652
653 function LocaleCallBack(LocaleString: PChar): Integer; stdcall;
654 begin
655 LCIDList.Add(Pointer(StrToInt('$'+LocaleString)));
656 Result := 1;
657 end;
658
659 constructor TLCIDList.Create;
660 begin
661 inherited;
662 end;
663
664 procedure TLCIDList.Enumerate;
665 begin
666 Clear;
667 EnumSystemLocales(@LocaleCallBack, LCID_SUPPORTED);
668 end;
669
670 { TIndexPage }
671
672 constructor TIndexPage.Create(Parent: TIndexFile);
673 begin
674 FIndexFile := Parent;
675 GetMem(FPageBuffer, FIndexFile.RecordSize);
676 FLowerPage := nil;
677 Clear;
678 end;
679
680 destructor TIndexPage.Destroy;
681 begin
682 // no locks anymore?
683 assert(FLockCount = 0);
684 if (FLowerPage<>nil) then
685 LowerPage.Free;
686 WritePage;
687 FreeMemAndNil(FPageBuffer);
688 inherited Destroy;
689 end;
690
691 procedure TIndexPage.Clear;
692 begin
693 FillChar(PChar(FPageBuffer)^, FIndexFile.RecordSize, 0);
694 FreeAndNil(FLowerPage);
695 FUpperPage := nil;
696 FPageNo := -1;
697 FEntryNo := -1;
698 FWeight := 1;
699 FModified := false;
700 FEntry := FIndexFile.EntryBof;
701 FLowPage := 0;
702 FHighPage := 0;
703 FLowIndex := 0;
704 FHighIndex := -1;
705 FLockCount := 0;
706 end;
707
708 procedure TIndexPage.GetNewPage;
709 begin
710 FPageNo := FIndexFile.GetNewPageNo;
711 end;
712
713 procedure TIndexPage.Modified;
714 begin
715 FModified := true;
716 end;
717
718 procedure TIndexPage.LockPage;
719 begin
720 // already locked?
721 if FLockCount = 0 then
722 FIndexFile.LockPage(FPageNo, true);
723 // increase count
724 inc(FLockCount);
725 end;
726
727 procedure TIndexPage.UnlockPage;
728 begin
729 // still in domain?
730 assert(FLockCount > 0);
731 dec(FLockCount);
732 // unlock?
733 if FLockCount = 0 then
734 begin
735 if FIndexFile.NeedLocks then
736 WritePage;
737 FIndexFile.UnlockPage(FPageNo);
738 end;
739 end;
740
741 procedure TIndexPage.LocalInsert(RecNo: Integer; Buffer: PChar; LowerPageNo: Integer);
742 // *) assumes there is at least one entry free
743 var
744 source, dest: Pointer;
745 size, lNumEntries, numKeysAvail: Integer;
746 begin
747 // lock page if needed; wait if not available, anyone else updating?
748 LockPage;
749 // check assertions
750 lNumEntries := GetNumEntries;
751 // if this is inner node, we can only store one less than max entries
752 numKeysAvail := SwapWordLE(PIndexHdr(FIndexFile.IndexHeader)^.NumKeys) - lNumEntries;
753 if FLowerPage <> nil then
754 dec(numKeysAvail);
755 // check if free space
756 assert(numKeysAvail > 0);
757 // first free up some space
758 source := FEntry;
759 dest := GetEntry(FEntryNo + 1);
760 size := (lNumEntries - EntryNo) * SwapWordLE(PIndexHdr(FIndexFile.IndexHeader)^.KeyRecLen);
761 // if 'rightmost' entry, copy pageno too
762 if (FLowerPage <> nil) or (numKeysAvail > 1) then
763 size := size + FIndexFile.EntryHeaderSize;
764 Move(source^, dest^, size);
765 // one entry added
766 Inc(FHighIndex);
767 IncNumEntries;
768 // lNumEntries not valid from here
769 SetEntry(RecNo, Buffer, LowerPageNo);
770 // done!
771 UnlockPage;
772 end;
773
774 procedure TIndexPage.LocalDelete;
775
776 function IsOnlyEntry(Page: TIndexPage): boolean;
777 begin
778 Result := true;
779 repeat
780 if Page.HighIndex > 0 then
781 Result := false;
782 Page := Page.UpperPage;
783 until not Result or (Page = nil);
784 end;
785
786 var
787 source, dest: Pointer;
788 size, lNumEntries: Integer;
789 begin
790 // get num entries
791 lNumEntries := GetNumEntries;
792 // is this last entry? if it's not move entries after current one
793 if EntryNo < FHighIndex then
794 begin
795 source := GetEntry(EntryNo + 1);
796 dest := FEntry;
797 size := (FHighIndex - EntryNo) * SwapWordLE(PIndexHdr(FIndexFile.IndexHeader)^.KeyRecLen);
798 Move(source^, dest^, size);
799 end else
800 // no need to update when we're about to remove the only entry
801 if (UpperPage <> nil) and (FHighIndex > FLowIndex) then
802 begin
803 // we are about to remove the last on this page, so update search
804 // key data of parent
805 EntryNo := FHighIndex - 1;
806 UpperPage.SetEntry(0, GetKeyData, FPageNo);
807 end;
808 // one entry less now
809 dec(lNumEntries);
810 dec(FHighIndex);
811 SetNumEntries(lNumEntries);
812 // zero last one out to not get confused about internal or leaf pages
813 // note: need to decrease lNumEntries and HighIndex first, otherwise
814 // check on page key consistency will fail
815 SetRecLowerPageNoOfEntry(FHighIndex+1, 0, 0);
816 // update bracket indexes
817 if FHighPage = FPageNo then
818 dec(FHighBracket);
819 // check if range violated
820 if EntryNo > FHighIndex then
821 EntryNo := FHighIndex;
822 // check if still entries left, otherwise remove page from parent
823 if FHighIndex = -1 then
824 begin
825 if UpperPage <> nil then
826 if not IsOnlyEntry(UpperPage) then
827 UpperPage.LocalDelete;
828 end;
829 // go to valid record in lowerpage
830 if FLowerPage <> nil then
831 SyncLowerPage;
832 // flag modified page
833 FModified := true;
834 // success!
835 end;
836
MatchKeynull837 function TIndexPage.MatchKey: Integer;
838 // assumes Buffer <> nil
839 var
840 keyData: PChar;
841 begin
842 // get key data
843 keyData := GetKeyData;
844 // use locale dependant compare
845 Result := FIndexFile.CompareKey(keyData);
846 end;
847
FindNearestnull848 function TIndexPage.FindNearest(ARecNo: Integer): Integer;
849 // pre:
850 // assumes Key <> nil
851 // assumes FLowIndex <= FHighIndex + 1
852 // ARecNo = -2 -> search first key matching Key
853 // ARecNo = -3 -> search first key greater than Key
854 // ARecNo > 0 -> search key matching Key and its recno = ARecNo
855 // post:
856 // Result < 0 -> key,recno smaller than current entry
857 // Result = 0 -> key,recno found, FEntryNo = found key entryno
858 // Result > 0 -> key,recno larger than current entry
859 var
860 low, high, current: Integer;
861 begin
862 // implement binary search, keys are sorted
863 low := FLowIndex;
864 high := GetNumEntries;
865 // always true: Entry(FEntryNo) = FEntry
866 // FHighIndex >= 0 because no-entry cases in leaves have been filtered out
867 // entry HighIndex may not be bigger than rest (in inner node)
868 // ARecNo = -3 -> search last recno matching key
869 // need to have: low <= high
870 // define low - 1 = neg.inf.
871 // define high = pos.inf
872 // inv1: (ARecNo<>-3) -> Entry(low-1).Key < Key <= Entry(high).Key
873 // inv2: (ARecNo =-3) -> Entry(low-1).Key <= Key < Entry(high).Key
874 // vf: high + 1 - low
875 while low < high do
876 begin
877 current := (low + high) div 2;
878 FEntry := GetEntry(current);
879 // calc diff
880 Result := MatchKey;
881 // test if we need to go lower or higher
882 // result < 0 implies key smaller than tested entry
883 // result = 0 implies key equal to tested entry
884 // result > 0 implies key greater than tested entry
885 if (Result < 0) or ((ARecNo<>-3) and (Result=0)) then
886 high := current
887 else
888 low := current+1;
889 end;
890 // high will contain first greater-or-equal key
891 // ARecNo <> -3 -> Entry(high).Key will contain first key that matches -> go to high
892 // ARecNo = -3 -> Entry(high).Key will contain first key that is greater -> go to high
893 FEntryNo := -1;
894 EntryNo := high;
895 // calc end result: can't inspect high if lowerpage <> nil
896 // if this is a leaf, we need to find specific recno
897 if (LowerPage = nil) then
898 begin
899 if high > FHighIndex then
900 begin
901 Result := 1;
902 end else begin
903 Result := MatchKey;
904 // test if we need to find a specific recno
905 // result < 0 -> current key greater -> nothing found -> don't search
906 if (ARecNo > 0) then
907 begin
908 // BLS to RecNo
909 high := FHighIndex + 1;
910 low := FEntryNo;
911 // inv: FLowIndex <= FEntryNo <= high <= FHighIndex + 1 /\
912 // (Ai: FLowIndex <= i < FEntryNo: Entry(i).RecNo <> ARecNo)
913 while FEntryNo <> high do
914 begin
915 // FEntryNo < high, get new entry
916 if low <> FEntryNo then
917 begin
918 FEntry := GetEntry(FEntryNo);
919 // check if entry key still ok
920 Result := MatchKey;
921 end;
922 // test if out of range or found recno
923 if (Result <> 0) or (GetRecNo = ARecNo) then
924 high := FEntryNo
925 else begin
926 // default to EOF
927 inc(FEntryNo);
928 Result := 1;
929 end;
930 end;
931 end;
932 end;
933 end else begin
934 // FLowerPage <> nil -> high contains entry, can not have empty range
935 Result := 0;
936 end;
937 end;
938
939 procedure TIndexPage.GotoInsertEntry;
940 // assures we really can insert here
941 begin
942 if FEntry = FIndexFile.EntryEof then
943 FEntry := GetEntry(FEntryNo);
944 end;
945
946 procedure TIndexPage.SetEntry(RecNo: Integer; AKey: PChar; LowerPageNo: Integer);
947 var
948 keyData: PChar;
949 {$ifdef TDBF_INDEX_CHECK}
950 prevKeyData, curKeyData, nextKeyData: PChar;
951 {$endif}
952 begin
953 // get num entries
954 keyData := GetKeyData;
955 // check valid entryno: we should be able to insert entries!
956 assert((EntryNo >= 0) and (EntryNo <= FHighIndex));
957 if (UpperPage <> nil) and (FEntryNo = FHighIndex) then
958 UpperPage.SetEntry(0, AKey, FPageNo);
959 { if PIndexHdr(FIndexFile.IndexHeader).KeyType = 'C' then }
960 if AKey <> nil then
961 Move(AKey^, keyData^, SwapWordLE(PIndexHdr(FIndexFile.IndexHeader)^.KeyLen))
962 else
963 PChar(keyData)^ := #0;
964 {
965 else
966 if AKey <> nil then
967 PDouble(keyData)^ := PDouble(AKey)^
968 else
969 PDouble(keyData)^ := 0.0;
970 }
971 // set entry info
972 SetRecLowerPageNo(RecNo, LowerPageNo);
973 // flag we modified the page
974 FModified := true;
975
976 {$ifdef TDBF_INDEX_CHECK}
977
978 // check sorted entry sequence
979 prevKeyData := GetKeyDataFromEntry(FEntryNo-1);
980 curKeyData := GetKeyDataFromEntry(FEntryNo+0);
981 nextKeyData := GetKeyDataFromEntry(FEntryNo+1);
982 // check if prior entry not greater, 'rightmost' key does not have to match
983 if (FEntryNo > 0) and ((FLowerPage = nil) or (FEntryNo < FHighIndex)) then
984 begin
985 if FIndexFile.CompareKeys(prevKeyData, curKeyData) > 0 then
986 assert(false);
987 end;
988 // check if next entry not smaller
989 if ((FLowerPage = nil) and (FEntryNo < FHighIndex)) or
990 ((FLowerPage <> nil) and (FEntryNo < (FHighIndex - 1))) then
991 begin
992 if FIndexFile.CompareKeys(curKeyData, nextKeyData) > 0 then
993 assert(false);
994 end;
995
996 {$endif}
997
998 end;
999
1000 {$ifdef TDBF_UPDATE_FIRST_LAST_NODE}
1001
1002 procedure TIndexPage.SetPrevBlock(NewBlock: Integer);
1003 begin
1004 end;
1005
1006 {$endif}
1007
1008 procedure TIndexPage.Split;
1009 // *) assumes this page is `nearly' full
1010 var
1011 NewPage: TIndexPage;
1012 source, dest: Pointer;
1013 paKeyData: PChar;
1014 size, oldEntryNo: Integer;
1015 splitRight, lNumEntries, numEntriesNew: Integer;
1016 saveLow, saveHigh: Integer;
1017 newRoot: Boolean;
1018 begin
1019 // assure parent exists, if not -> create & lock, else lock it
1020 newRoot := FUpperPage = nil;
1021 if newRoot then
1022 FIndexFile.AddNewLevel
1023 else
1024 FUpperPage.LockPage;
1025
1026 // lock this page for updates
1027 LockPage;
1028
1029 // get num entries
1030 lNumEntries := GetNumEntries;
1031
1032 // calc split pos: split in half
1033 splitRight := lNumEntries div 2;
1034 if (FLowerPage <> nil) and (lNumEntries mod 2 = 1) then
1035 inc(splitRight);
1036 numEntriesNew := lNumEntries - splitRight;
1037 // check if place to insert has least entries
1038 if (numEntriesNew > splitRight) and (EntryNo > splitRight) then
1039 begin
1040 inc(splitRight);
1041 dec(numEntriesNew);
1042 end else if (numEntriesNew < splitRight) and (EntryNo < splitRight) then
1043 begin
1044 dec(splitRight);
1045 inc(numEntriesNew);
1046 end;
1047 // save current entryno
1048 oldEntryNo := EntryNo;
1049 // check if we need to save high / low bound
1050 if FLowPage = FPageNo then
1051 saveLow := FLowIndex
1052 else
1053 saveLow := -1;
1054 if FHighPage = FPageNo then
1055 saveHigh := FHighIndex
1056 else
1057 saveHigh := -1;
1058
1059 // create new page
1060 NewPage := TIndexPageClass(ClassType).Create(FIndexFile);
1061 try
1062 // get page
1063 NewPage.GetNewPage;
1064 {$ifdef TDBF_UPDATE_FIRSTLAST_NODE}
1065 NewPage.SetPrevBlock(NewPage.PageNo - FIndexFile.PagesPerRecord);
1066 {$endif}
1067
1068 // set modified
1069 FModified := true;
1070 NewPage.FModified := true;
1071
1072 // compute source, dest
1073 dest := NewPage.GetEntry(0);
1074 source := GetEntry(splitRight);
1075 size := numEntriesNew * SwapWordLE(PIndexHdr(FIndexFile.IndexHeader)^.KeyRecLen);
1076 // if inner node, copy rightmost entry too
1077 if FLowerPage <> nil then
1078 size := size + FIndexFile.EntryHeaderSize;
1079 // copy bytes
1080 Move(source^, dest^, size);
1081 // if not inner node, clear possible 'rightmost' entry
1082 if (FLowerPage = nil) then
1083 SetRecLowerPageNoOfEntry(splitRight, 0, 0);
1084
1085 // calc new number of entries of this page
1086 lNumEntries := lNumEntries - numEntriesNew;
1087 // if lower level, then we need adjust for new 'rightmost' node
1088 if FLowerPage <> nil then
1089 begin
1090 // right split, so we need 'new' rightmost node
1091 dec(lNumEntries);
1092 end;
1093 // store new number of nodes
1094 // new page is right page, so update parent to point to new right page
1095 NewPage.SetNumEntries(numEntriesNew);
1096 SetNumEntries(lNumEntries);
1097 // update highindex
1098 FHighIndex := lNumEntries;
1099 if FLowerPage = nil then
1100 dec(FHighIndex);
1101
1102 // get data of last entry on this page
1103 paKeyData := GetKeyDataFromEntry(splitRight - 1);
1104
1105 // reinsert ourself into parent
1106 // FUpperPage.RecurInsert(0, paKeyData, FPageNo);
1107 // we can do this via a localinsert now: we know there is at least one entry
1108 // free in this page and higher up
1109 FUpperPage.LocalInsert(0, paKeyData, FPageNo);
1110
1111 // new page is right page, so update parent to point to new right page
1112 // we can't do this earlier: we will get lost in tree!
1113 FUpperPage.SetRecLowerPageNoOfEntry(FUpperPage.EntryNo+1, 0, NewPage.PageNo);
1114
1115 // NOTE: UpperPage.LowerPage = Self <= inserted FPageNo, not NewPage.PageNo
1116 finally
1117 NewPage.Free;
1118 end;
1119
1120 // done updating: unlock page
1121 UnlockPage;
1122 // save changes to parent
1123 FUpperPage.UnlockPage;
1124
1125 // unlock new root, unlock header too
1126 FIndexFile.UnlockHeader;
1127
1128 // go to entry we left on
1129 if oldEntryNo >= splitRight then
1130 begin
1131 // sync upperpage with right page
1132 FUpperPage.EntryNo := FUpperPage.EntryNo + 1;
1133 FEntryNo := oldEntryNo - splitRight;
1134 FEntry := GetEntry(FEntryNo);
1135 end else begin
1136 // in left page = this page
1137 EntryNo := oldEntryNo;
1138 end;
1139
1140 // check if we have to save high / low bound
1141 // seen the fact that FHighPage = FPageNo -> EntryNo <= FHighIndex, it can in
1142 // theory not happen that page is advanced to right page and high bound remains
1143 // on left page, but we won't check for that here
1144 if saveLow >= splitRight then
1145 begin
1146 FLowPage := FPageNo;
1147 FLowIndex := saveLow - splitRight;
1148 end;
1149 if saveHigh >= splitRight then
1150 begin
1151 FHighPage := FPageNo;
1152 FHighIndex := saveHigh - splitRight;
1153 end;
1154 end;
1155
1156 procedure TIndexPage.Delete;
1157 begin
1158 LocalDelete;
1159 end;
1160
1161 procedure TIndexPage.WritePage;
1162 begin
1163 // check if we modified current page
1164 if FModified and (FPageNo > 0) then
1165 begin
1166 FIndexFile.WriteRecord(FPageNo, FPageBuffer);
1167 FModified := false;
1168 end;
1169 end;
1170
1171 procedure TIndexPage.Flush;
1172 begin
1173 WritePage;
1174 if FLowerPage <> nil then
1175 FLowerPage.Flush;
1176 end;
1177
1178 procedure TIndexPage.RecalcWeight;
1179 begin
1180 if FLowerPage <> nil then
1181 begin
1182 FWeight := FLowerPage.Weight * SwapWordLE(PIndexHdr(FIndexFile.IndexHeader)^.NumKeys);
1183 end else begin
1184 FWeight := 1;
1185 end;
1186 if FUpperPage <> nil then
1187 FUpperPage.RecalcWeight;
1188 end;
1189
1190 procedure TIndexPage.UpdateWeight;
1191 begin
1192 if FLowerPage <> nil then
1193 FLowerPage.UpdateWeight
1194 else
1195 RecalcWeight;
1196 end;
1197
1198 procedure TIndexPage.SetUpperPage(NewPage: TIndexPage);
1199 begin
1200 if FUpperPage <> NewPage then
1201 begin
1202 // root height changed: update weights
1203 FUpperPage := NewPage;
1204 UpdateWeight;
1205 end;
1206 end;
1207
1208 procedure TIndexPage.SetLowPage(NewPage: Integer);
1209 begin
1210 if FLowPage <> NewPage then
1211 begin
1212 FLowPage := NewPage;
1213 UpdateBounds(FLowerPage <> nil);
1214 end;
1215 end;
1216
1217 procedure TIndexPage.SetHighPage(NewPage: Integer);
1218 begin
1219 if FHighPage <> NewPage then
1220 begin
1221 FHighPage := NewPage;
1222 UpdateBounds(FLowerPage <> nil);
1223 end;
1224 end;
1225
1226 procedure TIndexPage.UpdateBounds(IsInnerNode: Boolean);
1227 begin
1228 // update low / high index range
1229 if FPageNo = FLowPage then
1230 FLowIndex := FLowBracket
1231 else
1232 FLowIndex := 0;
1233 if FPageNo = FHighPage then
1234 FHighIndex := FHighBracket
1235 else begin
1236 FHighIndex := GetNumEntries;
1237 if not IsInnerNode then
1238 dec(FHighIndex);
1239 end;
1240 end;
1241
GetIsInnerNodenull1242 function TMdxPage.GetIsInnerNode: Boolean;
1243 begin
1244 Result := SwapIntLE(PMdxPage(FPageBuffer)^.NumEntries) < SwapWordLE(PIndexHdr(FIndexFile.IndexHeader)^.NumKeys);
1245 // if there is still an entry after the last one, this has to be an inner node
1246 if Result then
1247 Result := PMdxEntry(GetEntry(PMdxPage(FPageBuffer)^.NumEntries))^.RecBlockNo <> 0;
1248 end;
1249
TNdxPage.GetIsInnerNodenull1250 function TNdxPage.GetIsInnerNode: Boolean;
1251 begin
1252 Result := PNdxEntry(GetEntry(0))^.LowerPageNo <> 0;
1253 end;
1254
1255 procedure TIndexPage.SetPageNo(NewPageNo: Integer);
1256 var
1257 isInnerNode: Boolean;
1258 begin
1259 if (NewPageNo <> FPageNo) or FIndexFile.NeedLocks then
1260 begin
1261 // save changes
1262 WritePage;
1263 // no locks
1264 assert(FLockCount = 0);
1265
1266 // goto new page
1267 FPageNo := NewPageNo;
1268 // remind ourselves we need to load new entry when page loaded
1269 FEntryNo := -1;
1270 if (NewPageNo > 0) and (NewPageNo <= FIndexFile.RecordCount) then
1271 begin
1272 // read page from disk
1273 FIndexFile.ReadRecord(NewPageNo, FPageBuffer);
1274
1275 // fixup descending tree
1276 isInnerNode := GetIsInnerNode;
1277
1278 // update low / high index range
1279 UpdateBounds(isInnerNode);
1280
1281 // read inner node if any
1282 if isInnerNode then
1283 begin
1284 if FLowerPage = nil then
1285 begin
1286 FLowerPage := TIndexPageClass(ClassType).Create(FIndexFile);
1287 FLowerPage.UpperPage := Self;
1288 end;
1289 // read first entry, don't do this sooner, not created lowerpage yet
1290 // don't recursively resync all lower pages
1291 {$ifdef TDBF_INDEX_CHECK}
1292 end else if FLowerPage <> nil then
1293 begin
1294 // FLowerPage.Free;
1295 // FLowerPage := nil;
1296 assert(false);
1297 {$endif}
1298 end else begin
1299 // we don't have to check autoresync here because we're already at lowest level
1300 EntryNo := FLowIndex;
1301 end;
1302 end;
1303 end;
1304 end;
1305
1306 procedure TIndexPage.SyncLowerPage;
1307 // *) assumes FLowerPage <> nil!
1308 begin
1309 FLowerPage.PageNo := GetLowerPageNo;
1310 end;
1311
1312 procedure TIndexPage.SetEntryNo(value: Integer);
1313 begin
1314 // do not bother if no change
1315 if value <> FEntryNo then
1316 begin
1317 // check if out of range
1318 if (value < FLowIndex) then
1319 begin
1320 if FLowerPage = nil then
1321 FEntryNo := FLowIndex - 1;
1322 FEntry := FIndexFile.EntryBof;
1323 end else if value > FHighIndex then begin
1324 FEntryNo := FHighIndex + 1;
1325 FEntry := FIndexFile.EntryEof;
1326 end else begin
1327 FEntryNo := value;
1328 FEntry := GetEntry(value);
1329 // sync lowerpage with entry
1330 if (FLowerPage <> nil) then
1331 SyncLowerPage;
1332 end;
1333 end;
1334 end;
1335
TIndexPage.PhysicalRecNonull1336 function TIndexPage.PhysicalRecNo: Integer;
1337 var
1338 entryRec: Integer;
1339 begin
1340 // get num entries
1341 entryRec := GetRecNo;
1342 // check if in range
1343 if (FEntryNo >= FLowIndex) and (FEntryNo <= FHighIndex) then
1344 Result := entryRec
1345 else
1346 Result := -1;
1347 end;
1348
TIndexPage.RecurPrevnull1349 function TIndexPage.RecurPrev: Boolean;
1350 begin
1351 EntryNo := EntryNo - 1;
1352 Result := Entry <> FIndexFile.EntryBof;
1353 if Result then
1354 begin
1355 if FLowerPage <> nil then
1356 begin
1357 FLowerPage.RecurLast;
1358 end;
1359 end else begin
1360 if FUpperPage<>nil then
1361 begin
1362 Result := FUpperPage.RecurPrev;
1363 end;
1364 end;
1365 end;
1366
TIndexPage.RecurNextnull1367 function TIndexPage.RecurNext: Boolean;
1368 begin
1369 EntryNo := EntryNo + 1;
1370 Result := Entry <> FIndexFile.EntryEof;
1371 if Result then
1372 begin
1373 if FLowerPage <> nil then
1374 begin
1375 FLowerPage.RecurFirst;
1376 end;
1377 end else begin
1378 if FUpperPage<>nil then
1379 begin
1380 Result := FUpperPage.RecurNext;
1381 end;
1382 end;
1383 end;
1384
1385 procedure TIndexPage.RecurFirst;
1386 begin
1387 EntryNo := FLowIndex;
1388 if (FLowerPage<>nil) then
1389 FLowerPage.RecurFirst;
1390 end;
1391
1392 procedure TIndexPage.RecurLast;
1393 begin
1394 EntryNo := FHighIndex;
1395 if (FLowerPage<>nil) then
1396 FLowerPage.RecurLast;
1397 end;
1398
1399 procedure TIndexPage.SaveBracket;
1400 begin
1401 FLowPageTemp := FLowPage;
1402 FHighPageTemp := FHighPage;
1403 end;
1404
1405 procedure TIndexPage.RestoreBracket;
1406 begin
1407 FLowPage := FLowPageTemp;
1408 FHighPage := FHighPageTemp;
1409 end;
1410
1411 //==============================================================================
1412 //============ Mdx specific access routines
1413 //==============================================================================
1414
TMdxPage.GetEntrynull1415 function TMdxPage.GetEntry(AEntryNo: Integer): Pointer;
1416 begin
1417 // get base + offset
1418 Result := PChar(@PMdxPage(PageBuffer)^.FirstEntry) + (SwapWordLE(PIndexHdr(
1419 IndexFile.IndexHeader)^.KeyRecLen) * AEntryNo);
1420 end;
1421
GetLowerPageNonull1422 function TMdxPage.GetLowerPageNo: Integer;
1423 // *) assumes LowerPage <> nil
1424 begin
1425 // if LowerPage = nil then
1426 // Result := 0
1427 // else
1428 Result := SwapIntLE(PMdxEntry(Entry)^.RecBlockNo);
1429 end;
1430
TMdxPage.GetKeyDatanull1431 function TMdxPage.GetKeyData: PChar;
1432 begin
1433 Result := @PMdxEntry(Entry)^.KeyData;
1434 end;
1435
GetNumEntriesnull1436 function TMdxPage.GetNumEntries: Integer;
1437 begin
1438 Result := SwapWordLE(PMdxPage(PageBuffer)^.NumEntries);
1439 end;
1440
TMdxPage.GetKeyDataFromEntrynull1441 function TMdxPage.GetKeyDataFromEntry(AEntry: Integer): PChar;
1442 begin
1443 Result := @PMdxEntry(GetEntry(AEntry))^.KeyData;
1444 end;
1445
GetRecNonull1446 function TMdxPage.GetRecNo: Integer;
1447 begin
1448 Result := SwapIntLE(PMdxEntry(Entry)^.RecBlockNo);
1449 end;
1450
1451 procedure TMdxPage.SetNumEntries(NewNum: Integer);
1452 begin
1453 PMdxPage(PageBuffer)^.NumEntries := SwapIntLE(NewNum);
1454 end;
1455
1456 procedure TMdxPage.IncNumEntries;
1457 begin
1458 IncIntLE(PMdxPage(PageBuffer)^.NumEntries, 1);
1459 end;
1460
1461 procedure TMdxPage.SetRecLowerPageNo(NewRecNo, NewPageNo: Integer);
1462 begin
1463 if FLowerPage = nil then
1464 PMdxEntry(Entry)^.RecBlockNo := SwapIntLE(NewRecNo)
1465 else
1466 PMdxEntry(Entry)^.RecBlockNo := SwapIntLE(NewPageNo);
1467 end;
1468
1469 procedure TMdxPage.SetRecLowerPageNoOfEntry(AEntry, NewRecNo, NewPageNo: Integer);
1470 begin
1471 if FLowerPage = nil then
1472 PMdxEntry(GetEntry(AEntry))^.RecBlockNo := SwapIntLE(NewRecNo)
1473 else
1474 PMdxEntry(GetEntry(AEntry))^.RecBlockNo := SwapIntLE(NewPageNo);
1475 end;
1476
1477 {$ifdef TDBF_UPDATE_FIRST_LAST_NODE}
1478
1479 procedure TMdxPage.SetPrevBlock(NewBlock: Integer);
1480 begin
1481 PMdxPage(PageBuffer)^.PrevBlock := SwapIntLE(NewBlock);
1482 end;
1483
1484 {$endif}
1485
1486 //==============================================================================
1487 //============ Ndx specific access routines
1488 //==============================================================================
1489
GetEntrynull1490 function TNdxPage.GetEntry(AEntryNo: Integer): Pointer;
1491 begin
1492 // get base + offset
1493 Result := PChar(@PNdxPage(PageBuffer)^.FirstEntry) +
1494 (SwapWordLE(PIndexHdr(FIndexFile.IndexHeader)^.KeyRecLen) * AEntryNo);
1495 end;
1496
GetLowerPageNonull1497 function TNdxPage.GetLowerPageNo: Integer;
1498 // *) assumes LowerPage <> nil
1499 begin
1500 // if LowerPage = nil then
1501 // Result := 0
1502 // else
1503 Result := SwapIntLE(PNdxEntry(Entry)^.LowerPageNo)
1504 end;
1505
GetRecNonull1506 function TNdxPage.GetRecNo: Integer;
1507 begin
1508 Result := SwapIntLE(PNdxEntry(Entry)^.RecNo);
1509 end;
1510
TNdxPage.GetKeyDatanull1511 function TNdxPage.GetKeyData: PChar;
1512 begin
1513 Result := @PNdxEntry(Entry)^.KeyData;
1514 end;
1515
TNdxPage.GetKeyDataFromEntrynull1516 function TNdxPage.GetKeyDataFromEntry(AEntry: Integer): PChar;
1517 begin
1518 Result := @PNdxEntry(GetEntry(AEntry))^.KeyData;
1519 end;
1520
GetNumEntriesnull1521 function TNdxPage.GetNumEntries: Integer;
1522 begin
1523 Result := SwapIntLE(PNdxPage(PageBuffer)^.NumEntries);
1524 end;
1525
1526 procedure TNdxPage.IncNumEntries;
1527 begin
1528 IncIntLE(PNdxPage(PageBuffer)^.NumEntries, 1);
1529 end;
1530
1531 procedure TNdxPage.SetNumEntries(NewNum: Integer);
1532 begin
1533 PNdxPage(PageBuffer)^.NumEntries := SwapIntLE(NewNum);
1534 end;
1535
1536 procedure TNdxPage.SetRecLowerPageNo(NewRecNo, NewPageNo: Integer);
1537 begin
1538 PNdxEntry(Entry)^.RecNo := SwapIntLE(NewRecNo);
1539 PNdxEntry(Entry)^.LowerPageNo := SwapIntLE(NewPageNo);
1540 end;
1541
1542 procedure TNdxPage.SetRecLowerPageNoOfEntry(AEntry, NewRecNo, NewPageNo: Integer);
1543 begin
1544 PNdxEntry(GetEntry(AEntry))^.RecNo := SwapIntLE(NewRecNo);
1545 PNdxEntry(GetEntry(AEntry))^.LowerPageNo := SwapIntLE(NewPageNo);
1546 end;
1547
1548 //==============================================================================
1549 //============ MDX version 4 header access routines
1550 //==============================================================================
1551
GetHeaderPageNonull1552 function TMdx4Tag.GetHeaderPageNo: Integer;
1553 begin
1554 Result := SwapIntLE(Unaligned(PMdx4Tag(Tag)^.HeaderPageNo));
1555 end;
1556
TMdx4Tag.GetTagNamenull1557 function TMdx4Tag.GetTagName: string;
1558 begin
1559 Result := PMdx4Tag(Tag)^.TagName;
1560 end;
1561
GetKeyFormatnull1562 function TMdx4Tag.GetKeyFormat: Byte;
1563 begin
1564 Result := PMdx4Tag(Tag)^.KeyFormat;
1565 end;
1566
GetForwardTag1null1567 function TMdx4Tag.GetForwardTag1: Byte;
1568 begin
1569 Result := PMdx4Tag(Tag)^.ForwardTag1;
1570 end;
1571
GetForwardTag2null1572 function TMdx4Tag.GetForwardTag2: Byte;
1573 begin
1574 Result := PMdx4Tag(Tag)^.ForwardTag2;
1575 end;
1576
GetBackwardTagnull1577 function TMdx4Tag.GetBackwardTag: Byte;
1578 begin
1579 Result := PMdx4Tag(Tag)^.BackwardTag;
1580 end;
1581
TMdx4Tag.GetReservednull1582 function TMdx4Tag.GetReserved: Byte;
1583 begin
1584 Result := PMdx4Tag(Tag)^.Reserved;
1585 end;
1586
GetKeyTypenull1587 function TMdx4Tag.GetKeyType: Char;
1588 begin
1589 Result := PMdx4Tag(Tag)^.KeyType;
1590 end;
1591
1592 procedure TMdx4Tag.SetHeaderPageNo(NewPageNo: Integer);
1593 begin
1594 Unaligned(PMdx4Tag(Tag)^.HeaderPageNo) := SwapIntLE(NewPageNo);
1595 end;
1596
1597 procedure TMdx4Tag.SetTagName(NewName: string);
1598 begin
1599 StrPLCopy(PMdx4Tag(Tag)^.TagName, NewName, 10);
1600 PMdx4Tag(Tag)^.TagName[10] := #0;
1601 end;
1602
1603 procedure TMdx4Tag.SetKeyFormat(NewFormat: Byte);
1604 begin
1605 PMdx4Tag(Tag)^.KeyFormat := NewFormat;
1606 end;
1607
1608 procedure TMdx4Tag.SetForwardTag1(NewTag: Byte);
1609 begin
1610 PMdx4Tag(Tag)^.ForwardTag1 := NewTag;
1611 end;
1612
1613 procedure TMdx4Tag.SetForwardTag2(NewTag: Byte);
1614 begin
1615 PMdx4Tag(Tag)^.ForwardTag2 := NewTag;
1616 end;
1617
1618 procedure TMdx4Tag.SetBackwardTag(NewTag: Byte);
1619 begin
1620 PMdx4Tag(Tag)^.BackwardTag := NewTag;
1621 end;
1622
1623 procedure TMdx4Tag.SetReserved(NewReserved: Byte);
1624 begin
1625 PMdx4Tag(Tag)^.Reserved := NewReserved;
1626 end;
1627
1628 procedure TMdx4Tag.SetKeyType(NewType: Char);
1629 begin
1630 PMdx4Tag(Tag)^.KeyType := NewType;
1631 end;
1632
1633 //==============================================================================
1634 //============ MDX version 7 headertag access routines
1635 //==============================================================================
1636
GetHeaderPageNonull1637 function TMdx7Tag.GetHeaderPageNo: Integer;
1638 begin
1639 Result := SwapIntLE(Unaligned(PMdx7Tag(Tag)^.HeaderPageNo));
1640 end;
1641
TMdx7Tag.GetTagNamenull1642 function TMdx7Tag.GetTagName: string;
1643 begin
1644 Result := PMdx7Tag(Tag)^.TagName;
1645 end;
1646
GetKeyFormatnull1647 function TMdx7Tag.GetKeyFormat: Byte;
1648 begin
1649 Result := PMdx7Tag(Tag)^.KeyFormat;
1650 end;
1651
GetForwardTag1null1652 function TMdx7Tag.GetForwardTag1: Byte;
1653 begin
1654 Result := PMdx7Tag(Tag)^.ForwardTag1;
1655 end;
1656
GetForwardTag2null1657 function TMdx7Tag.GetForwardTag2: Byte;
1658 begin
1659 Result := PMdx7Tag(Tag)^.ForwardTag2;
1660 end;
1661
GetBackwardTagnull1662 function TMdx7Tag.GetBackwardTag: Byte;
1663 begin
1664 Result := PMdx7Tag(Tag)^.BackwardTag;
1665 end;
1666
TMdx7Tag.GetReservednull1667 function TMdx7Tag.GetReserved: Byte;
1668 begin
1669 Result := PMdx7Tag(Tag)^.Reserved;
1670 end;
1671
GetKeyTypenull1672 function TMdx7Tag.GetKeyType: Char;
1673 begin
1674 Result := PMdx7Tag(Tag)^.KeyType;
1675 end;
1676
1677 procedure TMdx7Tag.SetHeaderPageNo(NewPageNo: Integer);
1678 begin
1679 Unaligned(PMdx7Tag(Tag)^.HeaderPageNo) := SwapIntLE(NewPageNo);
1680 end;
1681
1682 procedure TMdx7Tag.SetTagName(NewName: string);
1683 begin
1684 StrPLCopy(PMdx7Tag(Tag)^.TagName, NewName, 32);
1685 PMdx7Tag(Tag)^.TagName[32] := #0;
1686 end;
1687
1688 procedure TMdx7Tag.SetKeyFormat(NewFormat: Byte);
1689 begin
1690 PMdx7Tag(Tag)^.KeyFormat := NewFormat;
1691 end;
1692
1693 procedure TMdx7Tag.SetForwardTag1(NewTag: Byte);
1694 begin
1695 PMdx7Tag(Tag)^.ForwardTag1 := NewTag;
1696 end;
1697
1698 procedure TMdx7Tag.SetForwardTag2(NewTag: Byte);
1699 begin
1700 PMdx7Tag(Tag)^.ForwardTag2 := NewTag;
1701 end;
1702
1703 procedure TMdx7Tag.SetBackwardTag(NewTag: Byte);
1704 begin
1705 PMdx7Tag(Tag)^.BackwardTag := NewTag;
1706 end;
1707
1708 procedure TMdx7Tag.SetReserved(NewReserved: Byte);
1709 begin
1710 PMdx7Tag(Tag)^.Reserved := NewReserved;
1711 end;
1712
1713 procedure TMdx7Tag.SetKeyType(NewType: Char);
1714 begin
1715 PMdx7Tag(Tag)^.KeyType := NewType;
1716 end;
1717
1718 { TDbfIndexParser }
1719
1720 procedure TDbfIndexParser.ValidateExpression(AExpression: string);
1721 const
1722 AnsiStrFuncs: array[0..13] of TExprFunc = (FuncUppercase, FuncLowercase, FuncStrI_EQ,
1723 FuncStrIP_EQ, FuncStrI_NEQ, FuncStrI_LT, FuncStrI_GT, FuncStrI_LTE, FuncStrI_GTE,
1724 FuncStrP_EQ, FuncStr_LT, FuncStr_GT, FuncStr_LTE, FuncStr_GTE);
1725 AnsiFuncsToMode: array[boolean] of TStringFieldMode = (smRaw, smAnsi);
1726 var
1727 TempRec: PExpressionRec;
1728 TempBuffer: TRecordBuffer;
1729 I: integer;
1730 hasAnsiFuncs: boolean;
1731 begin
1732 TempRec := CurrentRec;
1733 hasAnsiFuncs := false;
1734 while not hasAnsiFuncs and (TempRec <> nil) do
1735 begin
1736 for I := Low(AnsiStrFuncs) to High(AnsiStrFuncs) do
1737 if @TempRec^.Oper = @AnsiStrFuncs[I] then
1738 begin
1739 hasAnsiFuncs := true;
1740 break;
1741 end;
1742 TempRec := TempRec^.Next;
1743 end;
1744
1745 StringFieldMode := AnsiFuncsToMode[hasAnsiFuncs];
1746
1747 FResultLen := inherited ResultLen;
1748
1749 if FResultLen = -1 then
1750 begin
1751 // make empty record
1752 GetMem(TempBuffer, TDbfFile(DbfFile).RecordSize);
1753 try
1754 TDbfFile(DbfFile).InitRecord(TempBuffer);
1755 FResultLen := StrLen(ExtractFromBuffer(TempBuffer));
1756 finally
1757 FreeMem(TempBuffer);
1758 end;
1759 end;
1760
1761 // check if expression not too long
1762 if FResultLen > 100 then
1763 raise EDbfError.CreateFmt(STRING_INDEX_EXPRESSION_TOO_LONG, [AExpression, FResultLen]);
1764 end;
1765
1766 //==============================================================================
1767 //============ TIndexFile
1768 //==============================================================================
1769 constructor TIndexFile.Create(ADbfFile: Pointer);
1770 var
1771 I: Integer;
1772 begin
1773 inherited Create;
1774
1775 // clear variables
1776 FOpened := false;
1777 FRangeActive := false;
1778 FUpdateMode := umCurrent;
1779 FModifyMode := mmNormal;
1780 FTempMode := TDbfFile(ADbfFile).TempMode;
1781 FRangeIndex := -1;
1782 SelectIndexVars(-1);
1783 for I := 0 to MaxIndexes - 1 do
1784 begin
1785 FParsers[I] := nil;
1786 FRoots[I] := nil;
1787 FLeaves[I] := nil;
1788 FIndexHeaderModified[I] := false;
1789 end;
1790
1791 // store pointer to `parent' dbf file
1792 FDbfFile := ADbfFile;
1793 end;
1794
1795 destructor TIndexFile.Destroy;
1796 begin
1797 // close file
1798 Close;
1799
1800 // call ancestor
1801 inherited Destroy;
1802 end;
1803
1804 procedure TIndexFile.Open;
1805 var
1806 I: Integer;
1807 ext: string;
1808 localeError: TLocaleError;
1809 localeSolution: TLocaleSolution;
1810 DbfLangId: Byte;
1811 begin
1812 if not FOpened then
1813 begin
1814 // open physical file
1815 OpenFile;
1816
1817 // page offsets are not related to header length
1818 PageOffsetByHeader := false;
1819 // we need physical page locks
1820 VirtualLocks := false;
1821
1822 // not selected index expression => can't edit yet
1823 FCanEdit := false;
1824 FUserKey := nil;
1825 FUserRecNo := -1;
1826 FHeaderLocked := -1;
1827 FHeaderPageNo := 0;
1828 FForceClose := false;
1829 FForceReadOnly := false;
1830 FMdxTag := nil;
1831
1832 // get index type
1833 ext := UpperCase(ExtractFileExt(FileName));
1834 if (ext = '.MDX') then
1835 begin
1836 FEntryHeaderSize := 4;
1837 FPageHeaderSize := 8;
1838 FEntryBof := @Entry_Mdx_BOF;
1839 FEntryEof := @Entry_Mdx_EOF;
1840 HeaderSize := 2048;
1841 RecordSize := 1024;
1842 PageSize := 512;
1843 if FileCreated then
1844 begin
1845 FIndexVersion := TDbfFile(FDbfFile).DbfVersion;
1846 if FIndexVersion = xBaseIII then
1847 FIndexVersion := xBaseIV;
1848 end else begin
1849 case PMdxHdr(Header)^.MdxVersion of
1850 3: FIndexVersion := xBaseVII;
1851 else
1852 FIndexVersion := xBaseIV;
1853 end;
1854 end;
1855 case FIndexVersion of
1856 xBaseVII:
1857 begin
1858 FMdxTag := TMdx7Tag.Create;
1859 FTempMdxTag := TMdx7Tag.Create;
1860 end;
1861 else
1862 FMdxTag := TMdx4Tag.Create;
1863 FTempMdxTag := TMdx4Tag.Create;
1864 end;
1865 // get mem for all index headers..we're going to cache these
1866 for I := 0 to MaxIndexes - 1 do
1867 begin
1868 GetMem(FIndexHeaders[I], RecordSize);
1869 FillChar(FIndexHeaders[I]^, RecordSize, 0);
1870 end;
1871 // set pointers to first index
1872 FIndexHeader := FIndexHeaders[0];
1873 end else begin
1874 // don't waste memory on another header block: we can just use
1875 // the pagedfile one, there is only one index in this file
1876 FIndexVersion := xBaseIII;
1877 FEntryHeaderSize := 8;
1878 FPageHeaderSize := 4;
1879 FEntryBof := @Entry_Ndx_BOF;
1880 FEntryEof := @Entry_Ndx_EOF;
1881 HeaderSize := 512;
1882 RecordSize := 512;
1883 // have to read header first before we can assign following vars
1884 FIndexHeaders[0] := Header;
1885 FIndexHeader := Header;
1886 // create default root
1887 FParsers[0] := TDbfIndexParser.Create(FDbfFile);
1888 FRoots[0] := TNdxPage.Create(Self);
1889 FCurrentParser := FParsers[0];
1890 FRoot := FRoots[0];
1891 FSelectedIndex := 0;
1892 // parse index expression
1893 FCurrentParser.ParseExpression(PIndexHdr(FIndexHeader)^.KeyDesc);
1894 // set index locale
1895 FCollation := BINARY_COLLATION;
1896 end;
1897
1898 // determine how to open file
1899 if FileCreated then
1900 begin
1901 FillChar(Header^, HeaderSize, 0);
1902 Clear;
1903 end else begin
1904 // determine locale type
1905 localeError := leNone;
1906 if (FIndexVersion >= xBaseIV) then
1907 begin
1908 // get parent language id
1909 DbfLangId := GetDbfLanguageId;
1910 // no ID?
1911 if (DbfLangId = 0) { and (TDbfFile(FDbfFile).DbfVersion = xBaseIII)} then
1912 begin
1913 // if dbf is version 3, no language id, if no MDX language, use binary
1914 if PMdxHdr(Header)^.Language = 0 then
1915 FCollation := BINARY_COLLATION
1916 else
1917 FCollation := GetCollationTable(PMdxHdr(Header)^.Language);
1918 end else begin
1919 // check if MDX - DBF language id's match
1920 if (PMdxHdr(Header)^.Language = 0) or (PMdxHdr(Header)^.Language = DbfLangId) then
1921 FCollation := GetCollationTable(DbfLangId)
1922 else
1923 localeError := leTableIndexMismatch;
1924 end;
1925 // don't overwrite previous error
1926 if (FCollation = UNKNOWN_COLLATION) and (localeError = leNone) then
1927 localeError := leUnknown;
1928 end else begin
1929 // dbase III always binary?
1930 FCollation := BINARY_COLLATION;
1931 end;
1932 // check if selected locale is available, binary is always available...
1933 if (localeError <> leNone) and (FCollation <> BINARY_COLLATION) then
1934 begin
1935 if LCIDList.IndexOf(Pointer(FCollation)) < 0 then
1936 localeError := leNotAvailable;
1937 end;
1938 // check if locale error detected
1939 if localeError <> leNone then
1940 begin
1941 // provide solution, well, solution...
1942 localeSolution := lsNotOpen;
1943 // call error handler
1944 if Assigned(FOnLocaleError) then
1945 FOnLocaleError(localeError, localeSolution);
1946 // act to solution
1947 case localeSolution of
1948 lsNotOpen: FForceClose := true;
1949 lsNoEdit: FForceReadOnly := true;
1950 else
1951 { lsBinary }
1952 FCollation := BINARY_COLLATION;
1953 end;
1954 end;
1955 // now read info
1956 if not ForceClose then
1957 ReadIndexes;
1958 end;
1959 // default to update all
1960 UpdateMode := umAll;
1961 // flag open
1962 FOpened := true;
1963 end;
1964 end;
1965
1966 procedure TIndexFile.Close;
1967 var
1968 I: Integer;
1969 begin
1970 if FOpened then
1971 begin
1972 // save headers
1973 Flush;
1974
1975 // remove parser reference
1976 FCurrentParser := nil;
1977
1978 // free roots
1979 if FIndexVersion >= xBaseIV then
1980 begin
1981 for I := 0 to MaxIndexes - 1 do
1982 begin
1983 FreeMemAndNil(FIndexHeaders[I]);
1984 FreeAndNil(FParsers[I]);
1985 FreeAndNil(FRoots[I]);
1986 end;
1987 end else begin
1988 FreeAndNil(FRoot);
1989 end;
1990
1991 // free mem
1992 FMdxTag.Free;
1993 FTempMdxTag.Free;
1994
1995 // close physical file
1996 CloseFile;
1997
1998 // not opened any more
1999 FOpened := false;
2000 end;
2001 end;
2002
2003 procedure TIndexFile.ClearRoots;
2004 //
2005 // *) assumes FIndexVersion >= xBaseIV
2006 //
2007 var
2008 I, prevIndex: Integer;
2009 begin
2010 prevIndex := FSelectedIndex;
2011 for I := 0 to MaxIndexes - 1 do
2012 begin
2013 SelectIndexVars(I);
2014 if FRoot <> nil then
2015 begin
2016 // clear this entry
2017 ClearIndex;
2018 FLeaves[I] := FRoots[I];
2019 end;
2020 end;
2021 // reselect previously selected index
2022 SelectIndexVars(prevIndex);
2023 // deselect index
2024 end;
2025
2026 procedure WriteDBFileName(Header: PMdxHdr; HdrFileName: string);
2027 var
2028 HdrFileExt: string;
2029 lPos, lenFileName: integer;
2030 begin
2031 HdrFileName := ExtractFileName(HdrFileName);
2032 HdrFileExt := ExtractFileExt(HdrFileName);
2033 if Length(HdrFileExt) > 0 then
2034 begin
2035 lPos := System.Pos(HdrFileExt, HdrFileName);
2036 if lPos > 0 then
2037 SetLength(HdrFileName, lPos - 1);
2038 end;
2039 if Length(HdrFileName) > 15 then
2040 SetLength(HdrFileName, 15);
2041 lenFileName := Length(HdrFileName);
2042 Move(PChar(HdrFileName)^, PMdxHdr(Header)^.FileName[0], lenFileName);
2043 FillChar(PMdxHdr(Header)^.FileName[lenFileName], 15-lenFileName, 0);
2044 end;
2045
2046 procedure TIndexFile.Clear;
2047 var
2048 year, month, day: Word;
2049 pos, prevSelIndex, pageno: Integer;
2050 DbfLangId: Byte;
2051 begin
2052 // flush cache to prevent reading corrupted data
2053 Flush;
2054 // completely erase index
2055 if FIndexVersion >= xBaseIV then
2056 begin
2057 DecodeDate(Now, year, month, day);
2058 if FIndexVersion = xBaseVII then
2059 PMdxHdr(Header)^.MdxVersion := 3
2060 else
2061 PMdxHdr(Header)^.MdxVersion := 2;
2062 PMdxHdr(Header)^.Year := year - 1900;
2063 PMdxHdr(Header)^.Month := month;
2064 PMdxHdr(Header)^.Day := day;
2065 WriteDBFileName(PMdxHdr(Header), FileName);
2066 PMdxHdr(Header)^.BlockSize := SwapWordLE(2);
2067 PMdxHdr(Header)^.BlockAdder := SwapWordLE(1024);
2068 PMdxHdr(Header)^.ProdFlag := 1;
2069 PMdxHdr(Header)^.NumTags := 48;
2070 PMdxHdr(Header)^.TagSize := 32;
2071 PMdxHdr(Header)^.Dummy2 := 0;
2072 PMdxHdr(Header)^.Language := GetDbfLanguageID;
2073 PMdxHdr(Header)^.NumPages := SwapIntLE(HeaderSize div PageSize); // = 4
2074 TouchHeader(Header);
2075 PMdxHdr(Header)^.TagFlag := 1;
2076 // use locale id of parent
2077 DbfLangId := GetDbfLanguageId;
2078 if DbfLangId = 0 then
2079 FCollation := BINARY_COLLATION
2080 else
2081 FCollation := GetCollationTable(DbfLangId);
2082 // write index headers
2083 prevSelIndex := FSelectedIndex;
2084 for pos := 0 to SwapWordLE(PMdxHdr(Header)^.TagsUsed) - 1 do
2085 begin
2086 SelectIndexVars(pos);
2087 pageno := GetNewPageNo;
2088 FMdxTag.HeaderPageNo := SwapIntLE(pageno);
2089 WriteRecord(pageno, FIndexHeader);
2090 end;
2091 // reselect previously selected index
2092 SelectIndexVars(prevSelIndex);
2093 // file header done (tags are included in file header)
2094 WriteFileHeader;
2095 // clear roots
2096 ClearRoots;
2097 // init vars
2098 FTagSize := 32;
2099 FTagOffset := 544;
2100 // clear entries
2101 RecordCount := SwapIntLE(PMdxHdr(Header)^.NumPages);
2102 end else begin
2103 // clear single index entry
2104 ClearIndex;
2105 RecordCount := SwapIntLE(PIndexHdr(FIndexHeader)^.NumPages);
2106 end;
2107 end;
2108
2109 procedure TIndexFile.ClearIndex;
2110 var
2111 prevHeaderLocked: Integer;
2112 needHeaderLock: Boolean;
2113 begin
2114 // flush cache to prevent reading corrupted data
2115 Flush;
2116 // modifying header: lock page
2117 needHeaderLock := FHeaderLocked <> 0;
2118 prevHeaderLocked := FHeaderLocked;
2119 if needHeaderLock then
2120 begin
2121 LockPage(0, true);
2122 FHeaderLocked := 0;
2123 end;
2124 // initially, we have 1 page: header
2125 PIndexHdr(FIndexHeader)^.NumPages := SwapIntLE(HeaderSize div PageSize);
2126 // clear memory of root
2127 FRoot.Clear;
2128 // get new page for root
2129 FRoot.GetNewPage;
2130 // store new root page
2131 PIndexHdr(FIndexHeader)^.RootPage := SwapIntLE(FRoot.PageNo);
2132 {$ifdef TDBF_UPDATE_FIRSTLAST_NODE}
2133 PIndexHdr(FIndexHeader)^.FirstNode := SwapIntLE(FRoot.PageNo);
2134 {$endif}
2135 // update leaf pointers
2136 FLeaves[FSelectedIndex] := FRoot;
2137 FLeaf := FRoot;
2138 // write new header
2139 WriteHeader;
2140 FRoot.Modified;
2141 FRoot.WritePage;
2142 // done updating: unlock header
2143 if needHeaderLock then
2144 begin
2145 UnlockPage(0);
2146 FHeaderLocked := prevHeaderLocked;
2147 end;
2148 end;
2149
2150 procedure TIndexFile.CalcKeyProperties;
2151 // given KeyLen, this func calcs KeyRecLen and NumEntries
2152 begin
2153 // now adjust keylen to align on DWORD boundaries
2154 PIndexHdr(FIndexHeader)^.KeyRecLen := SwapWordLE((SwapWordLE(
2155 PIndexHdr(FIndexHeader)^.KeyLen) + FEntryHeaderSize + 3) and not 3);
2156 PIndexHdr(FIndexHeader)^.NumKeys := SwapWordLE((RecordSize - FPageHeaderSize) div
2157 SwapWordLE(PIndexHdr(FIndexHeader)^.KeyRecLen));
2158 end;
2159
TIndexFile.GetNamenull2160 function TIndexFile.GetName: string;
2161 begin
2162 // get suitable name of index: if tag name defined use that otherwise filename
2163 if FIndexVersion >= xBaseIV then
2164 Result := FIndexName
2165 else
2166 Result := FileName;
2167 end;
2168
2169 procedure TIndexFile.CreateIndex(FieldDesc, TagName: string; Options: TIndexOptions);
2170 var
2171 tagNo: Integer;
2172 fieldType: Char;
2173 TempParser: TDbfIndexParser;
2174 begin
2175 // check if we have exclusive access to table
2176 TDbfFile(FDbfFile).CheckExclusiveAccess;
2177 // parse index expression; if it cannot be parsed, why bother making index?
2178 TempParser := TDbfIndexParser.Create(FDbfFile);
2179 try
2180 TempParser.ParseExpression(FieldDesc);
2181 // check if result type is correct
2182 fieldType := 'C';
2183 case TempParser.ResultType of
2184 etString: ; { default set above to suppress delphi warning }
2185 etInteger, etLargeInt, etFloat: fieldType := 'N';
2186 else
2187 raise EDbfError.Create(STRING_INVALID_INDEX_TYPE);
2188 end;
2189 finally
2190 TempParser.Free;
2191 end;
2192 // select empty index
2193 if FIndexVersion >= xBaseIV then
2194 begin
2195 // get next entry no
2196 tagNo := SwapWordLE(PMdxHdr(Header)^.TagsUsed);
2197 // check if too many indexes
2198 if tagNo = MaxIndexes then
2199 raise EDbfError.Create(STRING_TOO_MANY_INDEXES);
2200 // get memory for root
2201 if FRoots[tagNo] = nil then
2202 begin
2203 FParsers[tagNo] := TDbfIndexParser.Create(FDbfFile);
2204 FRoots[tagNo] := TMdxPage.Create(Self)
2205 end else begin
2206 FreeAndNil(FRoots[tagNo].FLowerPage);
2207 end;
2208 // set leaves pointer
2209 FLeaves[tagNo] := FRoots[tagNo];
2210 // get pointer to index header
2211 FIndexHeader := FIndexHeaders[tagNo];
2212 // load root + leaf
2213 FCurrentParser := FParsers[tagNo];
2214 FRoot := FRoots[tagNo];
2215 FLeaf := FLeaves[tagNo];
2216 // create new tag
2217 FTempMdxTag.Tag := CalcTagOffset(tagNo);
2218 FTempMdxTag.TagName := UpperCase(TagName);
2219 // if expression then calculate
2220 FTempMdxTag.KeyFormat := KeyFormat_Data;
2221 if ixExpression in Options then
2222 FTempMdxTag.KeyFormat := KeyFormat_Expression;
2223 // what use have these reference tags?
2224 FTempMdxTag.ForwardTag1 := 0;
2225 FTempMdxTag.ForwardTag2 := 0;
2226 FTempMdxTag.BackwardTag := 0;
2227 FTempMdxTag.Reserved := 2;
2228 FTempMdxTag.KeyType := fieldType;
2229 // save this part of tag, need to save before GetNewPageNo,
2230 // it will reread header
2231 WriteFileHeader;
2232 // store selected index
2233 FSelectedIndex := tagNo;
2234 FIndexName := TagName;
2235 // store new headerno
2236 FHeaderPageNo := GetNewPageNo;
2237 FTempMdxTag.HeaderPageNo := FHeaderPageNo;
2238 // increase number of indexes active
2239 IncWordLE(PMdxHdr(Header)^.TagsUsed, 1);
2240 // update updatemode
2241 UpdateMode := umAll;
2242 // index header updated
2243 WriteFileHeader;
2244 end;
2245 // clear index
2246 ClearIndex;
2247
2248 // parse expression, we know it's parseable, we've checked that
2249 FCurrentParser.ParseExpression(FieldDesc);
2250
2251 // looked up index expression: now we can edit
2252 // FIsExpression := ixExpression in Options;
2253 FCanEdit := not FForceReadOnly;
2254
2255 // init key variables
2256 PIndexHdr(FIndexHeader)^.KeyFormat := 0;
2257 // descending
2258 if ixDescending in Options then
2259 PIndexHdr(FIndexHeader)^.KeyFormat := PIndexHdr(FIndexHeader)^.KeyFormat or KeyFormat_Descending;
2260 // key type
2261 if fieldType = 'C' then
2262 PIndexHdr(FIndexHeader)^.KeyFormat := PIndexHdr(FIndexHeader)^.KeyFormat or KeyFormat_String;
2263 PIndexHdr(FIndexHeader)^.KeyType := fieldType;
2264 // uniqueness
2265 PIndexHdr(FIndexHeader)^.Unique := Unique_None;
2266 if ixPrimary in Options then
2267 begin
2268 PIndexHdr(FIndexHeader)^.KeyFormat := PIndexHdr(FIndexHeader)^.KeyFormat or KeyFormat_Distinct or KeyFormat_Unique;
2269 PIndexHdr(FIndexHeader)^.Unique := Unique_Distinct;
2270 end else if ixUnique in Options then
2271 begin
2272 PIndexHdr(FIndexHeader)^.KeyFormat := PIndexHdr(FIndexHeader)^.KeyFormat or KeyFormat_Unique;
2273 PIndexHdr(FIndexHeader)^.Unique := Unique_Unique;
2274 end;
2275 // keylen is exact length of field
2276 if fieldType = 'C' then
2277 PIndexHdr(FIndexHeader)^.KeyLen := SwapWordLE(FCurrentParser.ResultLen)
2278 else if FIndexVersion >= xBaseIV then
2279 PIndexHdr(FIndexHeader)^.KeyLen := SwapWordLE(12)
2280 else
2281 PIndexHdr(FIndexHeader)^.KeyLen := SwapWordLE(8);
2282 CalcKeyProperties;
2283 // key desc
2284 StrPLCopy(PIndexHdr(FIndexHeader)^.KeyDesc, FieldDesc, 219);
2285 PIndexHdr(FIndexHeader)^.KeyDesc[219] := #0;
2286
2287 // init various
2288 if FIndexVersion >= xBaseIV then
2289 PIndexHdr(FIndexHeader)^.Dummy := 0 // MDX -> language driver
2290 else
2291 PIndexHdr(FIndexHeader)^.Dummy := SwapWordLE($5800); // NDX -> same ???
2292 case fieldType of
2293 'C':
2294 PIndexHdr(FIndexHeader)^.sKeyType := 0;
2295 'D':
2296 PIndexHdr(FIndexHeader)^.sKeyType := SwapWordLE(1);
2297 'N', 'F':
2298 if FIndexVersion >= xBaseIV then
2299 PIndexHdr(FIndexHeader)^.sKeyType := 0
2300 else
2301 PIndexHdr(FIndexHeader)^.sKeyType := SwapWordLE(1);
2302 else
2303 PIndexHdr(FIndexHeader)^.sKeyType := 0;
2304 end;
2305
2306 PIndexHdr(FIndexHeader)^.Version := SwapWordLE(2); // this is what DB4 writes into file
2307 PIndexHdr(FIndexHeader)^.Dummy2 := 0;
2308 PIndexHdr(FIndexHeader)^.Dummy3 := 0;
2309 PIndexHdr(FIndexHeader)^.ForExist := 0; // false
2310 PIndexHdr(FIndexHeader)^.KeyExist := 1; // true
2311 {$ifndef TDBF_UPDATE_FIRSTLAST_NODE}
2312 // if not defined, init to zero
2313 PIndexHdr(FIndexHeader)^.FirstNode := 0;
2314 PIndexHdr(FIndexHeader)^.LastNode := 0;
2315 {$endif}
2316 WriteHeader;
2317
2318 // update internal properties
2319 UpdateIndexProperties;
2320
2321 // for searches / inserts / deletes
2322 FKeyBuffer[SwapWordLE(PIndexHdr(FIndexHeader)^.KeyLen)] := #0;
2323 end;
2324
2325 procedure TIndexFile.ReadIndexes;
2326 var
2327 I: Integer;
2328
2329 procedure CheckHeaderIntegrity;
2330 begin
2331 if integer(SwapWordLE(PIndexHdr(FIndexHeader)^.NumKeys) *
2332 SwapWordLE(PIndexHdr(FIndexHeader)^.KeyRecLen)) > RecordSize then
2333 begin
2334 // adjust index header so that integrity is correct
2335 // WARNING: we can't be sure this gives a correct result, but at
2336 // least we won't AV (as easily). user will probably have to regenerate this index
2337 if SwapWordLE(PIndexHdr(FIndexHeader)^.KeyLen) > 100 then
2338 PIndexHdr(FIndexHeader)^.KeyLen := SwapWordLE(100);
2339 CalcKeyProperties;
2340 end;
2341 end;
2342
2343 begin
2344 // force header reread
2345 inherited ReadHeader;
2346 // examine all indexes
2347 if FIndexVersion >= xBaseIV then
2348 begin
2349 // clear all roots
2350 ClearRoots;
2351 // tags are extended at beginning? tagsize is byte sized
2352 FTagSize := PMdxHdr(Header)^.TagSize;
2353 FTagOffset := 544 + FTagSize - 32;
2354 for I := 0 to SwapWordLE(PMdxHdr(Header)^.TagsUsed) - 1 do
2355 begin
2356 // read page header
2357 FTempMdxTag.Tag := CalcTagOffset(I);
2358 ReadRecord(FTempMdxTag.HeaderPageNo, FIndexHeaders[I]);
2359 // select it
2360 FIndexHeader := FIndexHeaders[I];
2361 // create root if needed
2362 if FRoots[I] = nil then
2363 begin
2364 FParsers[I] := TDbfIndexParser.Create(FDbfFile);
2365 FRoots[I] := TMdxPage.Create(Self);
2366 end;
2367 // check header integrity
2368 CheckHeaderIntegrity;
2369 // read tree
2370 FRoots[I].PageNo := SwapIntLE(PIndexHdr(FIndexHeader)^.RootPage);
2371 // go to first record
2372 FRoots[I].RecurFirst;
2373 // store leaf
2374 FLeaves[I] := FRoots[I];
2375 while FLeaves[I].LowerPage <> nil do
2376 FLeaves[I] := FLeaves[I].LowerPage;
2377 // parse expression
2378 FParsers[I].ParseExpression(PIndexHdr(FIndexHeader)^.KeyDesc);
2379 end;
2380 end else begin
2381 // clear root
2382 FRoot.Clear;
2383 // check recordsize constraint
2384 CheckHeaderIntegrity;
2385 // just one index: read tree
2386 FRoot.PageNo := SwapIntLE(PIndexHdr(FIndexHeader)^.RootPage);
2387 // go to first valid record
2388 FRoot.RecurFirst;
2389 // get leaf page
2390 FLeaf := FRoot;
2391 while FLeaf.LowerPage <> nil do
2392 FLeaf := FLeaf.LowerPage;
2393 // write leaf pointer to first index
2394 FLeaves[0] := FLeaf;
2395 // get index properties -> internal props
2396 UpdateIndexProperties;
2397 end;
2398 end;
2399
2400 procedure TIndexFile.DeleteIndex(const AIndexName: string);
2401 var
2402 I, found, numTags, moveItems: Integer;
2403 tempHeader: Pointer;
2404 tempRoot, tempLeaf: TIndexPage;
2405 tempParser: TDbfIndexParser;
2406 begin
2407 // check if we have exclusive access to table
2408 TDbfFile(FDbfFile).CheckExclusiveAccess;
2409 if FIndexVersion = xBaseIII then
2410 begin
2411 Close;
2412 DeleteFile;
2413 end else if FIndexVersion >= xBaseIV then
2414 begin
2415 // find index
2416 found := IndexOf(AIndexName);
2417 if found >= 0 then
2418 begin
2419 // just remove this tag by copying memory over it
2420 numTags := SwapWordLE(PMdxHdr(Header)^.TagsUsed);
2421 moveItems := numTags - found - 1;
2422 // anything to move?
2423 if moveItems > 0 then
2424 begin
2425 // move entries after found one
2426 Move((Header + FTagOffset + (found+1) * FTagSize)^,
2427 (Header + FTagOffset + found * FTagSize)^, moveItems * FTagSize);
2428 // nullify last entry
2429 FillChar((Header + FTagOffset + numTags * FTagSize)^, FTagSize, 0);
2430 // index headers, roots, leaves
2431 tempHeader := FIndexHeaders[found];
2432 tempParser := FParsers[found];
2433 tempRoot := FRoots[found];
2434 tempLeaf := FLeaves[found];
2435 for I := 0 to moveItems - 1 do
2436 begin
2437 FIndexHeaders[found + I] := FIndexHeaders[found + I + 1];
2438 FParsers[found + I] := FParsers[found + I + 1];
2439 FRoots[found + I] := FRoots[found + I + 1];
2440 FLeaves[found + I] := FLeaves[found + I + 1];
2441 FIndexHeaderModified[found + I] := true;
2442 end;
2443 FIndexHeaders[found + moveItems] := tempHeader;
2444 FParsers[found + moveItems] := tempParser;
2445 FRoots[found + moveItems] := tempRoot;
2446 FLeaves[found + moveItems] := tempLeaf;
2447 FIndexHeaderModified[found + moveItems] := false; // non-existant header
2448 end;
2449 // one entry less left
2450 IncWordLE(PMdxHdr(Header)^.TagsUsed, -1);
2451 // ---*** numTags not valid from here ***---
2452 // file header changed
2453 WriteFileHeader;
2454 // repage index to free space used by deleted index
2455 // RepageFile;
2456 end;
2457 end;
2458 end;
2459
2460 procedure TIndexFile.TouchHeader(AHeader: Pointer);
2461 var
2462 year, month, day: Word;
2463 begin
2464 DecodeDate(Now, year, month, day);
2465 PMdxHdr(AHeader)^.UpdYear := year - 1900;
2466 PMdxHdr(AHeader)^.UpdMonth := month;
2467 PMdxHdr(AHeader)^.UpdDay := day;
2468 end;
2469
CreateTempFilenull2470 function TIndexFile.CreateTempFile(BaseName: string): TPagedFile;
2471 var
2472 lModifier: Integer;
2473 begin
2474 // create temporary in-memory index file
2475 lModifier := 0;
2476 FindNextName(BaseName, BaseName, lModifier);
2477 Result := TPagedFile.Create;
2478 Result.FileName := BaseName;
2479 Result.Mode := pfExclusiveCreate;
2480 Result.AutoCreate := true;
2481 Result.OpenFile;
2482 Result.HeaderSize := HeaderSize;
2483 Result.RecordSize := RecordSize;
2484 Result.PageSize := PageSize;
2485 Result.PageOffsetByHeader := false;
2486 end;
2487
2488 procedure TIndexFile.RepageFile;
2489 var
2490 TempFile: TPagedFile;
2491 TempIdxHeader: PIndexHdr;
2492 I, newPageNo: Integer;
2493 prevIndex: Integer;
2494
AllocNewPageNonull2495 function AllocNewPageNo: Integer;
2496 begin
2497 Result := newPageNo;
2498 Inc(newPageNo, PagesPerRecord);
2499 if FIndexVersion >= xBaseIV then
2500 IncIntLE(PMdxHdr(TempFile.Header)^.NumPages, PagesPerRecord);
2501 IncIntLE(TempIdxHeader^.NumPages, PagesPerRecord);
2502 end;
2503
WriteTreenull2504 function WriteTree(NewPage: TIndexPage): Integer;
2505 var
2506 J: Integer;
2507 begin
2508 // get us a page so that page no's are more logically ordered
2509 Result := AllocNewPageNo;
2510 // use postorder visiting, first do all children
2511 if NewPage.LowerPage <> nil then
2512 begin
2513 for J := 0 to NewPage.HighIndex do
2514 begin
2515 NewPage.EntryNo := J;
2516 WriteTree(NewPage.LowerPage);
2517 end;
2518 end;
2519 // now create new page for ourselves and write
2520 // update page pointer in parent
2521 if NewPage.UpperPage <> nil then
2522 begin
2523 if FIndexVersion >= xBaseIV then
2524 begin
2525 PMdxEntry(NewPage.UpperPage.Entry)^.RecBlockNo := SwapIntLE(Result);
2526 {$ifdef TDBF_UPDATE_FIRSTLAST_NODE}
2527 // write previous node
2528 if FRoot = NewPage then
2529 PMdxPage(NewPage.PageBuffer)^.PrevBlock := 0
2530 else
2531 PMdxPage(NewPage.PageBuffer)^.PrevBlock := SwapIntLE(Result - PagesPerRecord);
2532 {$endif}
2533 end else begin
2534 PNdxEntry(NewPage.UpperPage.Entry)^.LowerPageNo := SwapIntLE(Result);
2535 end;
2536 end;
2537 // store page
2538 TempFile.WriteRecord(Result, NewPage.PageBuffer);
2539 end;
2540
2541 procedure CopySelectedIndex;
2542 var
2543 hdrPageNo: Integer;
2544 begin
2545 // copy current index settings
2546 Move(FIndexHeader^, TempIdxHeader^, RecordSize);
2547 // clear number of pages
2548 TempIdxHeader^.NumPages := PagesPerRecord;
2549 // allocate a page no for header
2550 hdrPageNo := AllocNewPageNo;
2551 // use recursive function to write all pages
2552 TempIdxHeader^.RootPage := SwapIntLE(WriteTree(FRoot));
2553 {$ifdef TDBF_UPDATE_FIRSTLAST_NODE}
2554 TempIdxHeader^.FirstNode := TempIdxHeader^.RootPage;
2555 {$endif}
2556 // write index header now we know the root page
2557 TempFile.WriteRecord(hdrPageNo, TempIdxHeader);
2558 if FIndexVersion >= xBaseIV then
2559 begin
2560 // calculate tag offset in tempfile header
2561 FTempMdxTag.Tag := PChar(TempFile.Header) + (PChar(CalcTagOffset(I)) - Header);
2562 FTempMdxTag.HeaderPageNo := hdrPageNo;
2563 end;
2564 end;
2565
2566 begin
2567 CheckExclusiveAccess;
2568
2569 prevIndex := FSelectedIndex;
2570 newPageNo := HeaderSize div PageSize;
2571 TempFile := CreateTempFile(FileName);
2572 if FIndexVersion >= xBaseIV then
2573 begin
2574 // copy header
2575 Move(Header^, TempFile.Header^, HeaderSize);
2576 TouchHeader(TempFile.Header);
2577 // reset header
2578 PMdxHdr(TempFile.Header)^.NumPages := SwapIntLE(HeaderSize div PageSize);
2579 TempFile.WriteHeader;
2580 GetMem(TempIdxHeader, RecordSize);
2581 // now recreate indexes to that file
2582 for I := 0 to SwapWordLE(PMdxHdr(Header)^.TagsUsed - 1) do
2583 begin
2584 // select this index
2585 SelectIndexVars(I);
2586 CopySelectedIndex;
2587 end;
2588 FreeMem(TempIdxHeader);
2589 end else begin
2590 // indexversion = xBaseIII
2591 TempIdxHeader := PIndexHdr(TempFile.Header);
2592 CopySelectedIndex;
2593 end;
2594 TempFile.WriteHeader;
2595 TempFile.CloseFile;
2596 CloseFile;
2597
2598 // rename temporary file if all went successfull
2599 if not TempFile.WriteError then
2600 begin
2601 SysUtils.DeleteFile(FileName);
2602 SysUtils.RenameFile(TempFile.FileName, FileName);
2603 end;
2604
2605 TempFile.Free;
2606 DisableForceCreate;
2607 OpenFile;
2608 ReadIndexes;
2609 SelectIndexVars(prevIndex);
2610 end;
2611
2612 procedure TIndexFile.CompactFile;
2613 var
2614 TempFile: TPagedFile;
2615 TempIdxHeader: PIndexHdr;
2616 I, newPageNo: Integer;
2617 prevIndex: Integer;
2618
2619 function AllocNewPageNo: Integer;
2620 begin
2621 Result := newPageNo;
2622 Inc(newPageNo, PagesPerRecord);
2623 if FIndexVersion >= xBaseIV then
2624 IncIntLE(PMdxHdr(TempFile.Header)^.NumPages, PagesPerRecord);
2625 IncIntLE(TempIdxHeader^.NumPages, PagesPerRecord);
2626 end;
2627
2628 function CreateNewPage: TIndexPage;
2629 begin
2630 // create new page + space
2631 if FIndexVersion >= xBaseIV then
2632 Result := TMdxPage.Create(Self)
2633 else
2634 Result := TNdxPage.Create(Self);
2635 Result.FPageNo := AllocNewPageNo;
2636
2637 // set new page properties
2638 Result.SetNumEntries(0);
2639 end;
2640
2641 procedure GetNewEntry(APage: TIndexPage);
2642 // makes a new entry available and positions current 'pos' on it
2643 // NOTES: uses TIndexPage *very* carefully
2644 // - may not read from self (tindexfile)
2645 // - page.FLowerPage is assigned -> SyncLowerPage may *not* be called
2646 // - do not set PageNo (= SetPageNo)
2647 // - do not set EntryNo
2648 begin
2649 if APage.HighIndex >= SwapWordLE(PIndexHdr(FIndexHeader)^.NumKeys)-1 then
2650 begin
2651 if APage.UpperPage = nil then
2652 begin
2653 // add new upperlevel to page
2654 APage.FUpperPage := CreateNewPage;
2655 APage.UpperPage.FLowerPage := APage;
2656 APage.UpperPage.FEntryNo := 0;
2657 APage.UpperPage.FEntry := EntryEof;
2658 APage.UpperPage.GotoInsertEntry;
2659 APage.UpperPage.LocalInsert(0, APage.Key, APage.PageNo);
2660 // non-leaf pages need 'rightmost' key; numentries = real# - 1
2661 APage.UpperPage.SetNumEntries(0);
2662 end;
2663
2664 // page done, store
2665 TempFile.WriteRecord(APage.FPageNo, APage.PageBuffer);
2666
2667 // allocate new page
2668 APage.FPageNo := AllocNewPageNo;
2669 // clear
2670 APage.SetNumEntries(0);
2671 APage.FHighIndex := -1;
2672 APage.FLowIndex := 0;
2673 // clear 'right-most' blockno
2674 APage.SetRecLowerPageNoOfEntry(0, 0, 0);
2675
2676 // get new entry in upper page for current new apage
2677 GetNewEntry(APage.UpperPage);
2678 APage.UpperPage.LocalInsert(0, nil, 0);
2679 // non-leaf pages need 'rightmost' key; numentries = real# - 1
2680 if APage.UpperPage.EntryNo = 0 then
2681 APage.UpperPage.SetNumEntries(0);
2682 end;
2683 APage.FEntryNo := APage.HighIndex+1;
2684 APage.FEntry := EntryEof;
2685 APage.GotoInsertEntry;
2686 end;
2687
2688 procedure CopySelectedIndex;
2689 var
2690 APage: TIndexPage;
2691 hdrPageNo: Integer;
2692 begin
2693 // copy current index settings
2694 Move(FIndexHeader^, TempIdxHeader^, RecordSize);
2695 // clear number of pages
2696 TempIdxHeader^.NumPages := SwapIntLE(PagesPerRecord);
2697 // allocate a page no for header
2698 hdrPageNo := AllocNewPageNo;
2699
2700 // copy all records
2701 APage := CreateNewPage;
2702 FLeaf.RecurFirst;
2703 while not (FRoot.Entry = FEntryEof) do
2704 begin
2705 GetNewEntry(APage);
2706 APage.LocalInsert(FLeaf.PhysicalRecNo, FLeaf.Key, 0);
2707 FLeaf.RecurNext;
2708 end;
2709
2710 // flush remaining (partially filled) pages
2711 repeat
2712 TempFile.WriteRecord(APage.FPageNo, APage.PageBuffer);
2713 if APage.UpperPage <> nil then
2714 APage := APage.UpperPage
2715 else break;
2716 until false;
2717
2718 // copy index header + root page
2719 TempIdxHeader^.RootPage := SwapIntLE(APage.PageNo);
2720 {$ifdef TDBF_UPDATE_FIRSTLAST_NODE}
2721 TempIdxHeader^.FirstNode := SwapIntLE(APage.PageNo);
2722 {$endif}
2723 // write index header now we know the root page
2724 TempFile.WriteRecord(hdrPageNo, TempIdxHeader);
2725 if FIndexVersion >= xBaseIV then
2726 begin
2727 // calculate tag offset in tempfile header
2728 FTempMdxTag.Tag := PChar(TempFile.Header) + (PChar(CalcTagOffset(I)) - Header);
2729 FTempMdxTag.HeaderPageNo := hdrPageNo;
2730 end;
2731 end;
2732
2733 begin
2734 CheckExclusiveAccess;
2735
2736 prevIndex := FSelectedIndex;
2737 newPageNo := HeaderSize div PageSize;
2738 TempFile := CreateTempFile(FileName);
2739 if FIndexVersion >= xBaseIV then
2740 begin
2741 // copy header
2742 Move(Header^, TempFile.Header^, HeaderSize);
2743 TouchHeader(TempFile.Header);
2744 // reset header
2745 PMdxHdr(TempFile.Header)^.NumPages := SwapIntLE(HeaderSize div PageSize);
2746 TempFile.WriteHeader;
2747 GetMem(TempIdxHeader, RecordSize);
2748 // now recreate indexes to that file
2749 for I := 0 to SwapWordLE(PMdxHdr(Header)^.TagsUsed) - 1 do
2750 begin
2751 // select this index
2752 SelectIndexVars(I);
2753 CopySelectedIndex;
2754 end;
2755 FreeMem(TempIdxHeader);
2756 end else begin
2757 // indexversion = xBaseIII
2758 TempIdxHeader := PIndexHdr(TempFile.Header);
2759 CopySelectedIndex;
2760 end;
2761 TempFile.WriteHeader;
2762 TempFile.CloseFile;
2763 CloseFile;
2764
2765 // rename temporary file if all went successfull
2766 if not TempFile.WriteError then
2767 begin
2768 SysUtils.DeleteFile(FileName);
2769 SysUtils.RenameFile(TempFile.FileName, FileName);
2770 end;
2771
2772 TempFile.Free;
2773 DisableForceCreate;
2774 OpenFile;
2775 ReadIndexes;
2776 SelectIndexVars(prevIndex);
2777 end;
2778
2779 procedure TIndexFile.PrepareRename(NewFileName: string);
2780 begin
2781 if FIndexVersion >= xBaseIV then
2782 begin
2783 WriteDBFileName(PMdxHdr(Header), NewFileName);
2784 WriteFileHeader;
2785 end;
2786 end;
2787
GetNewPageNonull2788 function TIndexFile.GetNewPageNo: Integer;
2789 var
2790 needLockHeader: Boolean;
2791 begin
2792 // update header -> lock it if not already locked
2793 needLockHeader := FHeaderLocked <> 0;
2794 if needLockHeader then
2795 begin
2796 // lock header page
2797 LockPage(0, true);
2798 // someone else could be inserting records at the same moment
2799 if NeedLocks then
2800 inherited ReadHeader;
2801 end;
2802 if FIndexVersion >= xBaseIV then
2803 begin
2804 Result := SwapIntLE(PMdxHdr(Header)^.NumPages);
2805 IncIntLE(PMdxHdr(Header)^.NumPages, PagesPerRecord);
2806 {$ifdef TDBF_UPDATE_FIRSTLAST_NODE}
2807 // adjust high page
2808 PIndexHdr(FIndexHeader)^.LastNode := SwapIntLE(Result);
2809 {$endif}
2810 WriteFileHeader;
2811 end else begin
2812 Result := SwapIntLE(PIndexHdr(FIndexHeader)^.NumPages);
2813 end;
2814 IncIntLE(PIndexHdr(FIndexHeader)^.NumPages, PagesPerRecord);
2815 WriteHeader;
2816 // done updating header -> unlock if locked
2817 if needLockHeader then
2818 UnlockPage(0);
2819 end;
2820
Insertnull2821 function TIndexFile.Insert(RecNo: Integer; Buffer: TRecordBuffer): Boolean; {override;}
2822 var
2823 I, curSel, count: Integer;
2824 begin
2825 // check if updating all or only current
2826 FUserRecNo := RecNo;
2827 if (FUpdateMode = umAll) or (FSelectedIndex = -1) then
2828 begin
2829 // remember currently selected index
2830 curSel := FSelectedIndex;
2831 Result := true;
2832 I := 0;
2833 count := SwapWordLE(PMdxHdr(Header)^.TagsUsed);
2834 while I < count do
2835 begin
2836 SelectIndexVars(I);
2837 Result := InsertKey(Buffer);
2838 if not Result then
2839 begin
2840 while I > 0 do
2841 begin
2842 Dec(I);
2843 DeleteKey(Buffer);
2844 end;
2845 break;
2846 end;
2847 Inc(I);
2848 end;
2849 // restore previous selected index
2850 SelectIndexVars(curSel);
2851 end else begin
2852 Result := InsertKey(Buffer);
2853 end;
2854
2855 // check range, disabled by insert
2856 ResyncRange(true);
2857 end;
2858
CheckKeyViolationnull2859 function TIndexFile.CheckKeyViolation(Buffer: TRecordBuffer): Boolean;
2860 var
2861 I, curSel: Integer;
2862 begin
2863 Result := false;
2864 FUserRecNo := -2;
2865 if FIndexVersion = xBaseIV then
2866 begin
2867 curSel := FSelectedIndex;
2868 for I := 0 to SwapWordLE(PMdxHdr(Header)^.TagsUsed) - 1 do
2869 begin
2870 SelectIndexVars(I);
2871 if FUniqueMode = iuDistinct then
2872 begin
2873 FUserKey := ExtractKeyFromBuffer(Buffer);
2874 Result := FindKey(false) = 0;
2875 if Result then
2876 break;
2877 end;
2878 end;
2879 SelectIndexVars(curSel);
2880 end else begin
2881 if FUniqueMode = iuDistinct then
2882 begin
2883 FUserKey := ExtractKeyFromBuffer(Buffer);
2884 Result := FindKey(false) = 0;
2885 end;
2886 end;
2887 end;
2888
PrepareKeynull2889 function TIndexFile.PrepareKey(Buffer: TRecordBuffer; ResultType: TExpressionType): PChar;
2890 var
2891 FloatRec: TFloatRec;
2892 I, IntSrc, NumDecimals: Integer;
2893 ExtValue: Extended;
2894 BCDdigit: Byte;
2895 {$ifdef SUPPORT_INT64}
2896 Int64Src: Int64;
2897 {$endif}
2898
2899 begin
2900 // need to convert numeric?
2901 Result := PChar(Buffer);
2902 if PIndexHdr(FIndexHeader)^.KeyType in ['N', 'F'] then
2903 begin
2904 if FIndexVersion = xBaseIII then
2905 begin
2906 // DB3 -> index always 8 byte float, if original integer, convert to double
2907 case ResultType of
2908 etInteger:
2909 begin
2910 FUserNumeric := PInteger(Result)^;
2911 Result := PChar(@FUserNumeric);
2912 end;
2913 {$ifdef SUPPORT_INT64}
2914 etLargeInt:
2915 begin
2916 FUserNumeric := PLargeInt(Result)^;
2917 Result := PChar(@FUserNumeric);
2918 end;
2919 {$endif}
2920 end;
2921 end else begin
2922 // DB4 MDX
2923 NumDecimals := 0;
2924 case ResultType of
2925 etInteger:
2926 begin
2927 IntSrc := PInteger(Result)^;
2928 // handle zero differently: no decimals
2929 if IntSrc <> 0 then
2930 NumDecimals := GetStrFromInt(IntSrc, @FloatRec.Digits[0])
2931 else
2932 NumDecimals := 0;
2933 FloatRec.Negative := IntSrc < 0;
2934 end;
2935 {$ifdef SUPPORT_INT64}
2936 etLargeInt:
2937 begin
2938 Int64Src := PLargeInt(Result)^;
2939 if Int64Src <> 0 then
2940 NumDecimals := GetStrFromInt64(Int64Src, @FloatRec.Digits[0])
2941 else
2942 NumDecimals := 0;
2943 FloatRec.Negative := Int64Src < 0;
2944 end;
2945 {$endif}
2946 etFloat:
2947 begin
2948 ExtValue := PDouble(Result)^;
2949 FloatToDecimal(FloatRec, ExtValue, {$ifndef FPC_VERSION}fvExtended,{$endif} 9999, 15);
2950 if ExtValue <> 0.0 then
2951 NumDecimals := StrLen(@FloatRec.Digits[0])
2952 else
2953 NumDecimals := 0;
2954 // maximum number of decimals possible to encode in BCD is 16
2955 if NumDecimals > 16 then
2956 NumDecimals := 16;
2957 end;
2958 end;
2959
2960 case ResultType of
2961 etInteger {$ifdef SUPPORT_INT64}, etLargeInt{$endif}:
2962 begin
2963 FloatRec.Exponent := NumDecimals;
2964 // MDX-BCD does not count ending zeroes as `data' space length
2965 while (NumDecimals > 0) and (FloatRec.Digits[NumDecimals-1] = '0') do
2966 Dec(NumDecimals);
2967 // null-terminate string
2968 FloatRec.Digits[NumDecimals] := #0;
2969 end;
2970 end;
2971
2972 // write 'header', contains number of digits before decimal separator
2973 FUserBCD[0] := $34 + FloatRec.Exponent;
2974 // clear rest of BCD
2975 FillChar(FUserBCD[1], SizeOf(FUserBCD)-1, 0);
2976 // store number of bytes used (in number of bits + 1)
2977 FUserBCD[1] := (((NumDecimals+1) div 2) * 8) + 1;
2978 // where to store decimal dot position? now implicitly in first byte
2979 // store negative sign
2980 if FloatRec.Negative then
2981 FUserBCD[1] := FUserBCD[1] or $80;
2982 // convert string to BCD
2983 I := 0;
2984 while I < NumDecimals do
2985 begin
2986 // only one byte left?
2987 if FloatRec.Digits[I+1] = #0 then
2988 BCDdigit := 0
2989 else
2990 BCDdigit := Byte(FloatRec.Digits[I+1]) - Byte('0');
2991 // pack two bytes into bcd
2992 FUserBCD[2+(I div 2)] := ((Byte(FloatRec.Digits[I]) - Byte('0')) shl 4) or BCDdigit;
2993 // goto next 2 bytes
2994 Inc(I, 2);
2995 end;
2996
2997 // set result pointer to BCD
2998 Result := PChar(@FUserBCD[0]);
2999 end;
3000 end;
3001 end;
3002
TIndexFile.ExtractKeyFromBuffernull3003 function TIndexFile.ExtractKeyFromBuffer(Buffer: TRecordBuffer): PChar;
3004 begin
3005 // execute expression to get key
3006 Result := PrepareKey(TRecordBuffer(FCurrentParser.ExtractFromBuffer(Buffer)), FCurrentParser.ResultType);
3007 if FCurrentParser.StringFieldMode <> smRaw then
3008 TranslateString(GetACP, FCodePage, Result, Result, KeyLen);
3009 end;
3010
InsertKeynull3011 function TIndexFile.InsertKey(Buffer: TRecordBuffer): boolean;
3012 begin
3013 Result := true;
3014 // ignore deleted records
3015 if (FModifyMode = mmNormal) and (FUniqueMode = iuDistinct) and (AnsiChar(Buffer^) = '*') then
3016 exit;
3017 // check proper index and modifiability
3018 if FCanEdit and (PIndexHdr(FIndexHeader)^.KeyLen <> 0) then
3019 begin
3020 // get key from buffer
3021 FUserKey := ExtractKeyFromBuffer(Buffer);
3022 // patch through
3023 Result := InsertCurrent;
3024 end;
3025 end;
3026
TIndexFile.InsertCurrentnull3027 function TIndexFile.InsertCurrent: boolean;
3028 // insert in current index
3029 // assumes: FUserKey is an OEM key
3030 begin
3031 // only insert if not recalling or mode = distinct
3032 // modify = mmDeleteRecall /\ unique <> distinct -> key already present
3033 Result := true;
3034 if (FModifyMode <> mmDeleteRecall) or (FUniqueMode = iuDistinct) then
3035 begin
3036 // temporarily remove range to find correct location of key
3037 ResetRange;
3038 // find this record as closely as possible
3039 // if result = 0 then key already exists
3040 // if unique index, then don't insert key if already present
3041 if (FindKey(true) <> 0) or (FUniqueMode = iuNormal) then
3042 begin
3043 // if we found eof, write to pagebuffer
3044 FLeaf.GotoInsertEntry;
3045 // insert requested entry, we know there is an entry available
3046 FLeaf.LocalInsert(FUserRecNo, FUserKey, 0);
3047 end else begin
3048 // key already exists -> test possible key violation
3049 if FUniqueMode = iuDistinct then
3050 begin
3051 // raising -> reset modify mode
3052 FModifyMode := mmNormal;
3053 ConstructInsertErrorMsg;
3054 Result := false;
3055 end;
3056 end;
3057 end;
3058 end;
3059
3060 procedure TIndexFile.ConstructInsertErrorMsg;
3061 var
3062 InfoKey: string;
3063 begin
3064 if Length(FLastError) > 0 then exit;
3065 InfoKey := FUserKey;
3066 SetLength(InfoKey, KeyLen);
3067 FLastError := Format(STRING_KEY_VIOLATION, [GetName,
3068 PhysicalRecNo, TrimRight(InfoKey)]);
3069 end;
3070
3071 procedure TIndexFile.InsertError;
3072 var
3073 errorStr: string;
3074 begin
3075 errorStr := FLastError;
3076 FLastError := '';
3077 raise EDbfError.Create(errorStr);
3078 end;
3079
3080 procedure TIndexFile.Delete(RecNo: Integer; Buffer: TRecordBuffer);
3081 var
3082 I, curSel: Integer;
3083 begin
3084 // check if updating all or only current
3085 FUserRecNo := RecNo;
3086 if (FUpdateMode = umAll) or (FSelectedIndex = -1) then
3087 begin
3088 // remember currently selected index
3089 curSel := FSelectedIndex;
3090 for I := 0 to SwapWordLE(PMdxHdr(Header)^.TagsUsed) - 1 do
3091 begin
3092 SelectIndexVars(I);
3093 DeleteKey(Buffer);
3094 end;
3095 // restore previous selected index
3096 SelectIndexVars(curSel);
3097 end else begin
3098 DeleteKey(Buffer);
3099 end;
3100 // range may be changed
3101 ResyncRange(true);
3102 end;
3103
3104 procedure TIndexFile.DeleteKey(Buffer: TRecordBuffer);
3105 begin
3106 if FCanEdit and (PIndexHdr(FIndexHeader)^.KeyLen <> 0) then
3107 begin
3108 // get key from record buffer
3109 FUserKey := ExtractKeyFromBuffer(Buffer);
3110 // call function
3111 DeleteCurrent;
3112 end;
3113 end;
3114
3115 procedure TIndexFile.DeleteCurrent;
3116 // deletes from current index
3117 begin
3118 // only delete if not delete record or mode = distinct
3119 // modify = mmDeleteRecall /\ unique = distinct -> key needs to be deleted from index
3120 if (FModifyMode <> mmDeleteRecall) or (FUniqueMode = iuDistinct) then
3121 begin
3122 // prevent "confined" view of index while deleting
3123 ResetRange;
3124 // search correct entry to delete
3125 if FLeaf.PhysicalRecNo <> FUserRecNo then
3126 begin
3127 FindKey(false);
3128 end;
3129 // delete selected entry
3130 FLeaf.Delete;
3131 end;
3132 end;
3133
UpdateIndexnull3134 function TIndexFile.UpdateIndex(Index: Integer; PrevBuffer, NewBuffer: TRecordBuffer): Boolean;
3135 begin
3136 SelectIndexVars(Index);
3137 Result := UpdateCurrent(PrevBuffer, NewBuffer);
3138 end;
3139
Updatenull3140 function TIndexFile.Update(RecNo: Integer; PrevBuffer, NewBuffer: TRecordBuffer): Boolean;
3141 var
3142 I, curSel, count: Integer;
3143 begin
3144 // check if updating all or only current
3145 FUserRecNo := RecNo;
3146 if (FUpdateMode = umAll) or (FSelectedIndex = -1) then
3147 begin
3148 // remember currently selected index
3149 curSel := FSelectedIndex;
3150 Result := true;
3151 I := 0;
3152 count := SwapWordLE(PMdxHdr(Header)^.TagsUsed);
3153 while I < count do
3154 begin
3155 Result := UpdateIndex(I, PrevBuffer, NewBuffer);
3156 if not Result then
3157 begin
3158 // rollback updates to previous indexes
3159 while I > 0 do
3160 begin
3161 Dec(I);
3162 UpdateIndex(I, NewBuffer, PrevBuffer);
3163 end;
3164 break;
3165 end;
3166 Inc(I);
3167 end;
3168 // restore previous selected index
3169 SelectIndexVars(curSel);
3170 end else begin
3171 Result := UpdateCurrent(PrevBuffer, NewBuffer);
3172 end;
3173 // check range, disabled by delete/insert
3174 if (FRoot.LowPage = 0) and (FRoot.HighPage = 0) then
3175 ResyncRange(true);
3176 end;
3177
UpdateCurrentnull3178 function TIndexFile.UpdateCurrent(PrevBuffer, NewBuffer: TRecordBuffer): boolean;
3179 var
3180 InsertKey, DeleteKey: PChar;
3181 TempBuffer: array [0..100] of Char;
3182 begin
3183 Result := true;
3184 if FCanEdit and (PIndexHdr(FIndexHeader)^.KeyLen <> 0) then
3185 begin
3186 DeleteKey := ExtractKeyFromBuffer(PrevBuffer);
3187 Move(DeleteKey^, TempBuffer, SwapWordLE(PIndexHdr(FIndexHeader)^.KeyLen));
3188 DeleteKey := @TempBuffer[0];
3189 InsertKey := ExtractKeyFromBuffer(NewBuffer);
3190
3191 // compare to see if anything changed
3192 if CompareKeys(DeleteKey, InsertKey) <> 0 then
3193 begin
3194 FUserKey := DeleteKey;
3195 DeleteCurrent;
3196 FUserKey := InsertKey;
3197 Result := InsertCurrent;
3198 if not Result then
3199 begin
3200 FUserKey := DeleteKey;
3201 InsertCurrent;
3202 FUserKey := InsertKey;
3203 end;
3204 end;
3205 end;
3206 end;
3207
3208 procedure TIndexFile.AddNewLevel;
3209 var
3210 lNewPage: TIndexPage;
3211 pKeyData: PChar;
3212 begin
3213 // create new page + space
3214 if FIndexVersion >= xBaseIV then
3215 lNewPage := TMdxPage.Create(Self)
3216 else
3217 lNewPage := TNdxPage.Create(Self);
3218 lNewPage.GetNewPage;
3219
3220 // lock this new page; will be unlocked by caller
3221 lNewPage.LockPage;
3222 // lock index header; will be unlocked by caller
3223 LockPage(FHeaderPageNo, true);
3224 FHeaderLocked := FHeaderPageNo;
3225
3226 // modify header
3227 PIndexHdr(FIndexHeader)^.RootPage := SwapIntLE(lNewPage.PageNo);
3228
3229 // set new page properties
3230 lNewPage.SetNumEntries(0);
3231 lNewPage.EntryNo := 0;
3232 lNewPage.GotoInsertEntry;
3233 {$ifdef TDBF_UPDATE_FIRST_LAST_NODE}
3234 lNewPage.SetPrevBlock(lNewPage.PageNo - PagesPerRecord);
3235 {$endif}
3236 pKeyData := FRoot.GetKeyDataFromEntry(0);
3237 lNewPage.FLowerPage := FRoot;
3238 lNewPage.FHighIndex := 0;
3239 lNewPage.SetEntry(0, pKeyData, FRoot.PageNo);
3240
3241 // update root pointer
3242 FRoot.UpperPage := lNewPage;
3243 FRoots[FSelectedIndex] := lNewPage;
3244 FRoot := lNewPage;
3245
3246 // write new header
3247 WriteRecord(FHeaderPageNo, FIndexHeader);
3248 end;
3249
3250 procedure TIndexFile.UnlockHeader;
3251 begin
3252 if FHeaderLocked <> -1 then
3253 begin
3254 UnlockPage(FHeaderLocked);
3255 FHeaderLocked := -1;
3256 end;
3257 end;
3258
3259 procedure TIndexFile.ResyncRoot;
3260 begin
3261 if FIndexVersion >= xBaseIV then
3262 begin
3263 // read header page
3264 inherited ReadRecord(FHeaderPageNo, FIndexHeader);
3265 end else
3266 inherited ReadHeader;
3267 // reread tree
3268 FRoot.PageNo := SwapIntLE(PIndexHdr(FIndexHeader)^.RootPage);
3269 end;
3270
SearchKeynull3271 function TIndexFile.SearchKey(Key: PChar; SearchType: TSearchKeyType): Boolean;
3272 var
3273 findres, currRecNo: Integer;
3274 begin
3275 // save current position
3276 currRecNo := SequentialRecNo;
3277 // search, these are always from the root: no need for first
3278 findres := Find(-2, Key);
3279 // test result
3280 case SearchType of
3281 stEqual:
3282 Result := findres = 0;
3283 stGreaterEqual:
3284 Result := findres <= 0;
3285 stGreater:
3286 begin
3287 if findres = 0 then
3288 begin
3289 // find next record that is greater
3290 // NOTE: MatchKey assumes key to search for is already specified
3291 // in FUserKey, it is because we have called Find
3292 repeat
3293 Result := WalkNext;
3294 until not Result or (MatchKey(Key) <> 0);
3295 end else
3296 Result := findres < 0;
3297 end;
3298 else
3299 Result := false;
3300 end;
3301 // search failed -> restore previous position
3302 if not Result then
3303 SequentialRecNo := currRecNo;
3304 end;
3305
Findnull3306 function TIndexFile.Find(RecNo: Integer; Buffer: PChar): Integer;
3307 begin
3308 // execute find
3309 FUserRecNo := RecNo;
3310 FUserKey := Buffer;
3311 Result := FindKey(false);
3312 end;
3313
FindKeynull3314 function TIndexFile.FindKey(AInsert: boolean): Integer;
3315 //
3316 // if you set Insert = true, you need to re-enable range after insert!!
3317 //
3318 var
3319 TempPage, NextPage: TIndexPage;
3320 numEntries, numKeysAvail, done, searchRecNo: Integer;
3321 begin
3322 // reread index header (to discover whether root page changed)
3323 if NeedLocks then
3324 ResyncRoot;
3325 // if distinct or unique index -> every entry only occurs once ->
3326 // does not matter which recno we search -> search recno = -2 ->
3327 // extra info = recno
3328 if (FUniqueMode = iuNormal) then
3329 begin
3330 // if inserting, search last entry matching key
3331 if AInsert then
3332 searchRecNo := -3
3333 else
3334 searchRecNo := FUserRecNo
3335 end else begin
3336 searchRecNo := -2;
3337 end;
3338 // start from root
3339 TempPage := FRoot;
3340 repeat
3341 // find key
3342 done := 0;
3343 Result := TempPage.FindNearest(searchRecNo);
3344 if TempPage.LowerPage = nil then
3345 begin
3346 // if key greater than last, try next leaf
3347 if (Result > 0) and (searchRecNo > 0) then
3348 begin
3349 // find first parent in tree so we can advance to next item
3350 NextPage := TempPage;
3351 repeat
3352 NextPage := NextPage.UpperPage;
3353 until (NextPage = nil) or (NextPage.EntryNo < NextPage.HighIndex);
3354 // found page?
3355 if NextPage <> nil then
3356 begin
3357 // go to parent
3358 TempPage := NextPage;
3359 TempPage.EntryNo := TempPage.EntryNo + 1;
3360 // resync rest of tree
3361 TempPage.LowerPage.RecurFirst;
3362 // go to lower page to continue search
3363 TempPage := TempPage.LowerPage;
3364 // check if still more lowerpages
3365 if TempPage.LowerPage <> nil then
3366 begin
3367 // flag we need to traverse down further
3368 done := 2;
3369 end else begin
3370 // this is next child, we don't know if found
3371 done := 1;
3372 end;
3373 end;
3374 end;
3375 end else begin
3376 // need to traverse lower down
3377 done := 2;
3378 end;
3379
3380 // check if we need to split page
3381 // done = 1 -> not found entry on insert path yet
3382 if AInsert and (done <> 1) then
3383 begin
3384 // now we are on our path to destination where entry is to be inserted
3385 // check if this page is full, then split it
3386 numEntries := TempPage.NumEntries;
3387 // if this is inner node, we can only store one less than max entries
3388 numKeysAvail := SwapWordLE(PIndexHdr(FIndexHeader)^.NumKeys) - numEntries;
3389 if TempPage.LowerPage <> nil then
3390 dec(numKeysAvail);
3391 // too few available -> split
3392 if numKeysAvail = 0 then
3393 TempPage.Split;
3394 end;
3395
3396 // do we need to go lower down?
3397 if done = 2 then
3398 TempPage := TempPage.LowerPage;
3399 until done = 0;
3400 end;
3401
TIndexFile.MatchKeynull3402 function TIndexFile.MatchKey(UserKey: PChar): Integer;
3403 begin
3404 // BOF and EOF always false
3405 if FLeaf.Entry = FEntryBof then
3406 Result := 1
3407 else
3408 if FLeaf.Entry = FEntryEof then
3409 Result := -1
3410 else begin
3411 FUserKey := UserKey;
3412 Result := FLeaf.MatchKey;
3413 end;
3414 end;
3415
3416 procedure TIndexFile.SetRange(LowRange, HighRange: PChar);
3417 begin
3418 Move(LowRange^, FLowBuffer[0], KeyLen);
3419 Move(HighRange^, FHighBuffer[0], KeyLen);
3420 FRangeActive := true;
3421 ResyncRange(true);
3422 end;
3423
3424 procedure TIndexFile.RecordDeleted(RecNo: Integer; Buffer: TRecordBuffer);
3425 begin
3426 // are we distinct -> then delete record from index
3427 FModifyMode := mmDeleteRecall;
3428 Delete(RecNo, Buffer);
3429 FModifyMode := mmNormal;
3430 end;
3431
TIndexFile.RecordRecallednull3432 function TIndexFile.RecordRecalled(RecNo: Integer; Buffer: TRecordBuffer): Boolean;
3433 begin
3434 // are we distinct -> then reinsert record in index
3435 FModifyMode := mmDeleteRecall;
3436 Result := Insert(RecNo, Buffer);
3437 FModifyMode := mmNormal;
3438 end;
3439
3440 procedure TIndexFile.SetPhysicalRecNo(RecNo: Integer);
3441 begin
3442 // check if already at specified recno
3443 if FLeaf.PhysicalRecNo = RecNo then
3444 exit;
3445
3446 // check record actually exists
3447 if TDbfFile(FDbfFile).IsRecordPresent(RecNo) then
3448 begin
3449 // read buffer of this RecNo
3450 TDbfFile(FDbfFile).ReadRecord(RecNo, TDbfFile(FDbfFile).PrevBuffer);
3451 // extract key
3452 FUserKey := ExtractKeyFromBuffer(TDbfFile(FDbfFile).PrevBuffer);
3453 // find this key
3454 FUserRecNo := RecNo;
3455 FindKey(false);
3456 end;
3457 end;
3458
3459 procedure TIndexFile.SetUpdateMode(NewMode: TIndexUpdateMode);
3460 begin
3461 // if there is only one index, don't waste time and just set single
3462 if (FIndexVersion = xBaseIII) or (SwapWordLE(PMdxHdr(Header)^.TagsUsed) <= 1) then
3463 FUpdateMode := umCurrent
3464 else
3465 FUpdateMode := NewMode;
3466 end;
3467
3468 procedure TIndexFile.WalkFirst;
3469 begin
3470 // search first node
3471 FRoot.RecurFirst;
3472 // out of index - BOF
3473 FLeaf.EntryNo := FLeaf.EntryNo - 1;
3474 end;
3475
3476 procedure TIndexFile.WalkLast;
3477 begin
3478 // search last node
3479 FRoot.RecurLast;
3480 // out of index - EOF
3481 // we need to skip two entries to go out-of-bound
3482 FLeaf.EntryNo := FLeaf.EntryNo + 2;
3483 end;
3484
3485 procedure TIndexFile.First;
3486 begin
3487 // resync tree
3488 Resync(false);
3489 WalkFirst;
3490 end;
3491
3492 procedure TIndexFile.Last;
3493 begin
3494 // resync tree
3495 Resync(false);
3496 WalkLast;
3497 end;
3498
3499 procedure TIndexFile.ResyncRange(KeepPosition: boolean);
3500 var
3501 Result: Boolean;
3502 currRecNo: integer;
3503 begin
3504 if not FRangeActive then
3505 exit;
3506
3507 // disable current range if any
3508 // init to 0 to suppress delphi warning
3509 currRecNo := 0;
3510 if KeepPosition then
3511 currRecNo := SequentialRecNo;
3512 ResetRange;
3513 // search lower bound
3514 Result := SearchKey(FLowBuffer, stGreaterEqual);
3515 if not Result then
3516 begin
3517 // not found? -> make empty range
3518 WalkLast;
3519 end;
3520 // set lower bound
3521 SetBracketLow;
3522 // search upper bound
3523 Result := SearchKey(FHighBuffer, stGreater);
3524 // if result true, then need to get previous item <=>
3525 // last of equal/lower than key
3526 if Result then
3527 begin
3528 Result := WalkPrev;
3529 if not Result then
3530 begin
3531 // cannot go prev -> empty range
3532 WalkFirst;
3533 end;
3534 end else begin
3535 // not found -> EOF found, go EOF, then to last record
3536 WalkLast;
3537 WalkPrev;
3538 end;
3539 // set upper bound
3540 SetBracketHigh;
3541 if KeepPosition then
3542 SequentialRecNo := currRecNo;
3543 end;
3544
3545 procedure TIndexFile.Resync(Relative: boolean);
3546 begin
3547 if NeedLocks then
3548 begin
3549 if not Relative then
3550 begin
3551 ResyncRoot;
3552 ResyncRange(false);
3553 end else begin
3554 // resyncing tree implies resyncing range
3555 ResyncTree;
3556 end;
3557 end;
3558 end;
3559
3560 procedure TIndexFile.ResyncTree;
3561 var
3562 action, recno: integer;
3563 begin
3564 // if at BOF or EOF, then we need to resync by first or last
3565 // remember where the cursor was
3566 // init to 0 to suppress delphi warning
3567 recno := 0;
3568 if FLeaf.Entry = FEntryBof then
3569 begin
3570 action := 0;
3571 end else if FLeaf.Entry = FEntryEof then begin
3572 action := 1;
3573 end else begin
3574 // read current key into buffer
3575 Move(FLeaf.Key^, FKeyBuffer, SwapWordLE(PIndexHdr(FIndexHeader)^.KeyLen));
3576 recno := FLeaf.PhysicalRecNo;
3577 action := 2;
3578 end;
3579
3580 // we now know cursor position, resync possible range
3581 ResyncRange(false);
3582
3583 // go to cursor position
3584 case action of
3585 0: WalkFirst;
3586 1: WalkLast;
3587 2:
3588 begin
3589 // search current in-mem key on disk
3590 if (Find(recno, FKeyBuffer) <> 0) then
3591 begin
3592 // houston, we've got a problem!
3593 // our `current' record has gone. we need to find it
3594 // find it by using physical recno
3595 PhysicalRecNo := recno;
3596 end;
3597 end;
3598 end;
3599 end;
3600
WalkPrevnull3601 function TIndexFile.WalkPrev: boolean;
3602 var
3603 curRecNo: Integer;
3604 begin
3605 // save current recno, find different next!
3606 curRecNo := FLeaf.PhysicalRecNo;
3607 repeat
3608 // return false if we are at first entry
3609 Result := FLeaf.RecurPrev;
3610 until not Result or (curRecNo <> FLeaf.PhysicalRecNo);
3611 end;
3612
WalkNextnull3613 function TIndexFile.WalkNext: boolean;
3614 var
3615 curRecNo: Integer;
3616 begin
3617 // save current recno, find different prev!
3618 curRecNo := FLeaf.PhysicalRecNo;
3619 repeat
3620 // return false if we are at last entry
3621 Result := FLeaf.RecurNext;
3622 until not Result or (curRecNo <> FLeaf.PhysicalRecNo);
3623 end;
3624
Prevnull3625 function TIndexFile.Prev: Boolean;
3626 begin
3627 // resync in-mem tree with tree on disk
3628 Resync(true);
3629 Result := WalkPrev;
3630 end;
3631
Nextnull3632 function TIndexFile.Next: Boolean;
3633 begin
3634 // resync in-mem tree with tree on disk
3635 Resync(true);
3636 Result := WalkNext;
3637 end;
3638
GetKeyLennull3639 function TIndexFile.GetKeyLen: Integer;
3640 begin
3641 Result := SwapWordLE(PIndexHdr(FIndexHeader)^.KeyLen);
3642 end;
3643
GetKeyTypenull3644 function TIndexFile.GetKeyType: Char;
3645 begin
3646 Result := PIndexHdr(FIndexHeader)^.KeyType;
3647 end;
3648
GetPhysicalRecNonull3649 function TIndexFile.GetPhysicalRecNo: Integer;
3650 begin
3651 Result := FLeaf.PhysicalRecNo;
3652 end;
3653
GetSequentialRecordCountnull3654 function TIndexFile.GetSequentialRecordCount: Integer;
3655 begin
3656 Result := FRoot.Weight * (FRoot.HighIndex + 1);
3657 end;
3658
GetSequentialRecNonull3659 function TIndexFile.GetSequentialRecNo: Integer;
3660 var
3661 TempPage: TIndexPage;
3662 begin
3663 // check if at BOF or EOF, special values
3664 if FLeaf.EntryNo < FLeaf.LowIndex then begin
3665 Result := RecBOF;
3666 end else if FLeaf.EntryNo > FLeaf.HighIndex then begin
3667 Result := RecEOF;
3668 end else begin
3669 // first record is record 1
3670 Result := 1;
3671 TempPage := FRoot;
3672 repeat
3673 inc(Result, TempPage.EntryNo * TempPage.Weight);
3674 TempPage := TempPage.LowerPage;
3675 until TempPage = nil;
3676 end;
3677 end;
3678
3679 procedure TIndexFile.SetSequentialRecNo(RecNo: Integer);
3680 var
3681 TempPage: TIndexPage;
3682 gotoEntry: Integer;
3683 begin
3684 // use our weighting system to quickly go to a seq recno
3685 // recno starts at 1, entries at zero
3686 Dec(RecNo);
3687 TempPage := FRoot;
3688 repeat
3689 // don't div by zero
3690 assert(TempPage.Weight > 0);
3691 gotoEntry := RecNo div TempPage.Weight;
3692 RecNo := RecNo mod TempPage.Weight;
3693 // do we have this much entries?
3694 if (TempPage.HighIndex < gotoEntry) then
3695 begin
3696 // goto next entry in upper page if not
3697 // if recurnext fails, we have come at the end of the index
3698 if (TempPage.UpperPage <> nil) and TempPage.UpperPage.RecurNext then
3699 begin
3700 // lower recno to get because we skipped an entry
3701 TempPage.EntryNo := TempPage.LowIndex;
3702 RecNo := 0;
3703 end else begin
3704 // this can only happen if too big RecNo was entered, go to last
3705 TempPage.RecurLast;
3706 // terminate immediately
3707 TempPage := FLeaf;
3708 end;
3709 end else begin
3710 TempPage.EntryNo := gotoEntry;
3711 end;
3712 // get lower node
3713 TempPage := TempPage.LowerPage;
3714 until TempPage = nil;
3715 end;
3716
3717 procedure TIndexFile.SetBracketLow;
3718 var
3719 TempPage: TIndexPage;
3720 begin
3721 // set current record as lower bound
3722 TempPage := FRoot;
3723 repeat
3724 TempPage.LowBracket := TempPage.EntryNo;
3725 TempPage.LowPage := TempPage.PageNo;
3726 TempPage := TempPage.LowerPage;
3727 until TempPage = nil;
3728 end;
3729
3730 procedure TIndexFile.SetBracketHigh;
3731 var
3732 TempPage: TIndexPage;
3733 begin
3734 // set current record as lower bound
3735 TempPage := FRoot;
3736 repeat
3737 TempPage.HighBracket := TempPage.EntryNo;
3738 TempPage.HighPage := TempPage.PageNo;
3739 TempPage := TempPage.LowerPage;
3740 until TempPage = nil;
3741 end;
3742
3743 procedure TIndexFile.CancelRange;
3744 begin
3745 FRangeActive := false;
3746 ResetRange;
3747 end;
3748
3749 procedure TIndexFile.ResetRange;
3750 var
3751 TempPage: TIndexPage;
3752 begin
3753 // disable lower + upper bound
3754 TempPage := FRoot;
3755 repeat
3756 // set a page the index should never reach
3757 TempPage.LowPage := 0;
3758 TempPage.HighPage := 0;
3759 TempPage := TempPage.LowerPage;
3760 until TempPage = nil;
3761 end;
3762
3763 procedure TIndexFile.DisableRange;
3764 var
3765 TempPage: TIndexPage;
3766 begin
3767 TempPage := FRoot;
3768 repeat
3769 TempPage.SaveBracket;
3770 TempPage := TempPage.LowerPage;
3771 until TempPage = nil;
3772 CancelRange;
3773 end;
3774
3775 procedure TIndexFile.EnableRange;
3776 var
3777 TempPage: TIndexPage;
3778 begin
3779 TempPage := FRoot;
3780 repeat
3781 TempPage.RestoreBracket;
3782 TempPage := TempPage.LowerPage;
3783 until TempPage = nil;
3784 FRangeActive := true;
3785 end;
3786
MemCompnull3787 function MemComp(P1, P2: Pointer; const Length: Integer): Integer;
3788 var
3789 I: Integer;
3790 begin
3791 for I := 0 to Length - 1 do
3792 begin
3793 // still equal?
3794 if PByte(P1)^ <> PByte(P2)^ then
3795 begin
3796 Result := Integer(PByte(P1)^) - Integer(PByte(P2)^);
3797 exit;
3798 end;
3799 // go to next byte
3800 Inc(PChar(P1));
3801 Inc(PChar(P2));
3802 end;
3803
3804 // memory equal
3805 Result := 0;
3806 end;
3807
TIndexFile.CompareKeysnull3808 function TIndexFile.CompareKeys(Key1, Key2: PChar): Integer;
3809 begin
3810 // call compare routine
3811 Result := FCompareKeys(Key1, Key2);
3812
3813 // if descending then reverse order
3814 if FIsDescending then
3815 Result := -Result;
3816 end;
3817
CompareKeysNumericNDXnull3818 function TIndexFile.CompareKeysNumericNDX(Key1, Key2: PChar): Integer;
3819 var
3820 v1,v2: Double;
3821 begin
3822 v1 := PDouble(Key1)^;
3823 v2 := PDouble(Key2)^;
3824 if v1 > v2 then Result := 1
3825 else if v1 < v2 then Result := -1
3826 else Result := 0;
3827 end;
3828
CompareKeysNumericMDXnull3829 function TIndexFile.CompareKeysNumericMDX(Key1, Key2: PChar): Integer;
3830 var
3831 neg1, neg2: Boolean;
3832 begin
3833 // first byte - $34 contains dot position
3834 neg1 := (Byte(Key1[1]) and $80) <> 0;
3835 neg2 := (Byte(Key2[1]) and $80) <> 0;
3836 // check if both negative or both positive
3837 if neg1 = neg2 then
3838 begin
3839 // check alignment
3840 if Key1[0] = Key2[0] then
3841 begin
3842 // no alignment needed -> have same alignment
3843 Result := MemComp(Key1+2, Key2+2, 10-2);
3844 end else begin
3845 // greater 10-power implies bigger number except for zero
3846 if (Byte(Key1[0]) = $01) and (Byte(Key1[1]) = $34) then
3847 Result := -1
3848 else
3849 if (Byte(Key2[0]) = $01) and (Byte(Key2[1]) = $34) then
3850 Result := 1
3851 else
3852 Result := Byte(Key1[0]) - Byte(Key2[0]);
3853 end;
3854 // negate result if both negative
3855 if neg1 and neg2 then
3856 Result := -Result;
3857 end else if neg1 {-> not neg2} then
3858 Result := -1
3859 else { not neg1 and neg2 }
3860 Result := 1;
3861 end;
3862
TIndexFile.CompareKeysStringnull3863 function TIndexFile.CompareKeysString(Key1, Key2: PChar): Integer;
3864 begin
3865 Result := DbfCompareString(FCollation, Key1, KeyLen, Key2, KeyLen);
3866 if Result > 0 then
3867 Dec(Result, 2);
3868 end;
3869
CompareKeynull3870 function TIndexFile.CompareKey(Key: PChar): Integer;
3871 begin
3872 Result := CompareKeys(FUserKey, Key);
3873 end;
3874
IndexOfnull3875 function TIndexFile.IndexOf(const AIndexName: string): Integer;
3876 // *) assumes FIndexVersion >= xBaseIV
3877 var
3878 I: Integer;
3879 begin
3880 // get index of this index :-)
3881 Result := -1;
3882 for I := 0 to SwapWordLE(PMdxHdr(Header)^.TagsUsed) - 1 do
3883 begin
3884 FTempMdxTag.Tag := CalcTagOffset(I);
3885 if AnsiCompareText(AIndexName, FTempMdxTag.TagName) = 0 then
3886 begin
3887 Result := I;
3888 break;
3889 end;
3890 end;
3891 end;
3892
3893 procedure TIndexFile.SetIndexName(const AIndexName: string);
3894 var
3895 found: Integer;
3896 begin
3897 // we can only select a different index if we are MDX
3898 if FIndexVersion >= xBaseIV then
3899 begin
3900 // find index
3901 found := IndexOf(AIndexName);
3902 end else
3903 found := 0;
3904 // if changing index, range is N/A anymore
3905 if FRangeActive and (found <> FSelectedIndex) then
3906 begin
3907 FRangeIndex := FSelectedIndex;
3908 DisableRange;
3909 end;
3910 // we can now select by index
3911 if found >= 0 then
3912 begin
3913 SelectIndexVars(found);
3914 if found = FRangeIndex then
3915 begin
3916 EnableRange;
3917 FRangeIndex := -1;
3918 end;
3919 end;
3920 end;
3921
CalcTagOffsetnull3922 function TIndexFile.CalcTagOffset(AIndex: Integer): Pointer;
3923 begin
3924 Result := PChar(Header) + FTagOffset + AIndex * FTagSize;
3925 end;
3926
3927 procedure TIndexFile.SelectIndexVars(AIndex: Integer);
3928 // *) assumes index is in range
3929 begin
3930 if AIndex >= 0 then
3931 begin
3932 // get pointer to index header
3933 FIndexHeader := FIndexHeaders[AIndex];
3934 // load root + leaf
3935 FCurrentParser := FParsers[AIndex];
3936 FRoot := FRoots[AIndex];
3937 FLeaf := FLeaves[AIndex];
3938 // if xBaseIV then we need to store where pageno of current header
3939 if FIndexVersion >= xBaseIV then
3940 begin
3941 FMdxTag.Tag := CalcTagOffset(AIndex);
3942 FIndexName := FMdxTag.TagName;
3943 FHeaderPageNo := FMdxTag.HeaderPageNo;
3944 // does dBase actually use this flag?
3945 // FIsExpression := FMdxTag.KeyFormat = KeyFormat_Expression;
3946 end else begin
3947 // how does dBase III store whether it is expression?
3948 // FIsExpression := true;
3949 end;
3950 // retrieve properties
3951 UpdateIndexProperties;
3952 end else begin
3953 // not a valid index
3954 FIndexName := EmptyStr;
3955 end;
3956 // store selected index
3957 FSelectedIndex := AIndex;
3958 FCanEdit := not FForceReadOnly;
3959 end;
3960
3961 procedure TIndexFile.UpdateIndexProperties;
3962 begin
3963 // get properties
3964 FIsDescending := (PIndexHdr(FIndexHeader)^.KeyFormat and KeyFormat_Descending) <> 0;
3965 FUniqueMode := iuNormal;
3966 if (PIndexHdr(FIndexHeader)^.KeyFormat and KeyFormat_Unique) <> 0 then
3967 FUniqueMode := iuUnique;
3968 if (PIndexHdr(FIndexHeader)^.KeyFormat and KeyFormat_Distinct) <> 0 then
3969 FUniqueMode := iuDistinct;
3970 // select key compare routine
3971 if PIndexHdr(FIndexHeader)^.KeyType = 'C' then
3972 FCompareKeys := CompareKeysString
3973 else
3974 if FIndexVersion >= xBaseIV then
3975 FCompareKeys := CompareKeysNumericMDX
3976 else
3977 FCompareKeys := CompareKeysNumericNDX;
3978 end;
3979
3980 procedure TIndexFile.Flush;
3981 var
3982 I: Integer;
3983 begin
3984 // save changes to pages
3985 if FIndexVersion >= xBaseIV then
3986 begin
3987 for I := 0 to MaxIndexes - 1 do
3988 begin
3989 if FIndexHeaderModified[I] then
3990 WriteIndexHeader(I);
3991 if FRoots[I] <> nil then
3992 FRoots[I].Flush
3993 end;
3994 end else begin
3995 if FRoot <> nil then
3996 FRoot.Flush;
3997 end;
3998
3999 // save changes to header
4000 FlushHeader;
4001
4002 inherited;
4003 end;
4004
4005 (*
4006
GetIndexCountnull4007 function TIndexFile.GetIndexCount: Integer;
4008 begin
4009 if FIndexVersion = xBaseIII then
4010 Result := 1
4011 else
4012 if FIndexVersion = xBaseIV then
4013 Result := PMdxHdr(Header).TagsUsed;
4014 else
4015 Result := 0;
4016 end;
4017
4018 *)
4019
4020 procedure TIndexFile.GetIndexNames(const AList: TStrings);
4021 var
4022 I: Integer;
4023 begin
4024 // only applicable to MDX files
4025 if FIndexVersion >= xBaseIV then
4026 begin
4027 for I := 0 to SwapWordLE(PMdxHdr(Header)^.TagsUsed) - 1 do
4028 begin
4029 FTempMdxTag.Tag := CalcTagOffset(I);
4030 AList.AddObject(FTempMdxTag.TagName, Self);
4031 end;
4032 end;
4033 end;
4034
4035 procedure TIndexFile.GetIndexInfo(const AIndexName: string; IndexDef: TDbfIndexDef);
4036 var
4037 SaveIndexName: string;
4038 begin
4039 // remember current index
4040 SaveIndexName := IndexName;
4041 // select index
4042 IndexName := AIndexName;
4043 // copy properties
4044 IndexDef.IndexFile := AIndexName;
4045 IndexDef.Expression := PIndexHdr(FIndexHeader)^.KeyDesc;
4046 IndexDef.Options := [];
4047 IndexDef.Temporary := true;
4048 if FIsDescending then
4049 IndexDef.Options := IndexDef.Options + [ixDescending];
4050 IndexDef.Options := IndexDef.Options + [ixExpression];
4051 case FUniqueMode of
4052 iuUnique: IndexDef.Options := IndexDef.Options + [ixUnique];
4053 iuDistinct: IndexDef.Options := IndexDef.Options + [ixPrimary];
4054 end;
4055 // reselect previous index
4056 IndexName := SaveIndexName;
4057 end;
4058
GetExpressionnull4059 function TIndexFile.GetExpression: string;
4060 begin
4061 if FCurrentParser <> nil then
4062 Result := FCurrentParser.Expression
4063 else
4064 Result := EmptyStr;
4065 end;
4066
TIndexFile.GetDbfLanguageIdnull4067 function TIndexFile.GetDbfLanguageId: Byte;
4068 begin
4069 // check if parent DBF version 7, get language id
4070 if (TDbfFile(FDbfFile).DbfVersion = xBaseVII) then
4071 begin
4072 // get language id of parent dbf
4073 Result := GetLangId_From_LangName(TDbfFile(FDbfFile).LanguageStr);
4074 end else begin
4075 // dBase IV has language id in header
4076 Result := TDbfFile(FDbfFile).LanguageID;
4077 end;
4078 end;
4079
4080 procedure TIndexFile.WriteHeader; {override;}
4081 begin
4082 // if NDX, then this means file header
4083 if FIndexVersion >= xBaseIV then
4084 if NeedLocks then
4085 WriteIndexHeader(FSelectedIndex)
4086 else
4087 FIndexHeaderModified[FSelectedIndex] := true
4088 else
4089 WriteFileHeader;
4090 end;
4091
4092 procedure TIndexFile.WriteFileHeader;
4093 begin
4094 inherited WriteHeader;
4095 end;
4096
4097 procedure TIndexFile.WriteIndexHeader(AIndex: Integer);
4098 begin
4099 FTempMdxTag.Tag := CalcTagOffset(AIndex);
4100 WriteRecord(FTempMdxTag.HeaderPageNo, FIndexHeaders[AIndex]);
4101 FIndexHeaderModified[AIndex] := false;
4102 end;
4103
4104 //==========================================================
4105 //============ TDbfIndexDef
4106 //==========================================================
4107
4108 constructor TDbfIndexDef.Create(ACollection: TCollection); {override;}
4109 begin
4110 inherited Create(ACollection);
4111 FTemporary := false;
4112 end;
4113
4114 destructor TDbfIndexDef.Destroy; {override;}
4115 begin
4116 inherited Destroy;
4117 end;
4118
4119 procedure TDbfIndexDef.Assign(Source: TPersistent);
4120 begin
4121 // we can't do anything with it if not a TDbfIndexDef
4122 if Source is TDbfIndexDef then
4123 begin
4124 FIndexName := TDbfIndexDef(Source).IndexFile;
4125 FExpression := TDbfIndexDef(Source).Expression;
4126 FOptions := TDbfIndexDef(Source).Options;
4127 end else
4128 inherited;
4129 end;
4130
4131 procedure TDbfIndexDef.SetIndexName(NewName: string);
4132 begin
4133 FIndexName := AnsiUpperCase(Trim(NewName));
4134 end;
4135
4136 procedure TDbfIndexDef.SetExpression(NewField: string);
4137 begin
4138 FExpression := AnsiUpperCase(Trim(NewField));
4139 end;
4140
4141 initialization
4142
4143 {
4144 Entry_Mdx_BOF.RecBlockNo := RecBOF;
4145 Entry_Mdx_BOF.KeyData := #0;
4146
4147 Entry_Mdx_EOF.RecBlockNo := RecEOF;
4148 Entry_Mdx_EOF.KeyData := #0;
4149
4150 Entry_Ndx_BOF.LowerPageNo := 0;
4151 Entry_Ndx_BOF.RecNo := RecBOF;
4152 Entry_Ndx_BOF.KeyData := #0;
4153
4154 Entry_Ndx_EOF.LowerPageNo := 0;
4155 Entry_Ndx_EOF.RecNo := RecEOF;
4156 Entry_Ndx_EOF.KeyData := #0;
4157 }
4158
4159 LCIDList := TLCIDList.Create;
4160 LCIDList.Enumerate;
4161
4162 finalization
4163
4164 LCIDList.Free;
4165
4166 end.
4167
4168