home *** CD-ROM | disk | FTP | other *** search
/ Chip 1999 January / Chip_1999-01_cd.bin / zkuste / delphi / QDB / QDB.ZIP / QDB.pas next >
Pascal/Delphi Source File  |  1998-07-29  |  144KB  |  5,468 lines
  1.  
  2. {*****************************************************************************}
  3. {                                                                             }
  4. {            QDB v2.11 Visual Components for Delphi 1, 2, & 3                 }
  5. {                                                                             }
  6. {       Copyright (c) 1995, 1996, 1997, 1998 Robert R. Marsh, S.J.            }
  7. {             & the British Province of the Society of Jesus                  }
  8. {                                                                             }
  9. {              This source code may *not* be redistributed                    }
  10. {              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~                    }
  11. {                                                                             }
  12. {       If you like QDB and find yourself using it please consider            }
  13. {       making a donation to your favorite charity. I would also be           }
  14. {       pleased if you would acknowledge QDB in any projects that             }
  15. {       make use of it.                                                       }
  16. {                                                                             }
  17. {       QDB is supplied as is. The author disclaims all warranties,           }
  18. {       expressed or implied, including, without limitation, the              }
  19. {       warranties of merchantability and of fitness for any purpose.         }
  20. {       The author assumes no liability for damages, direct or                }
  21. {       consequential, which may result from the use of QDB.                  }
  22. {                                                                             }
  23. {                           rrm@sprynet.com                                   }
  24. {                  http://home.sprynet.com/sprynet/rrm                        }
  25. {                                                                             }
  26. {*****************************************************************************}
  27.  
  28. (*
  29.   Portions of the code are based on the work of others:
  30.  
  31.   TQDBNavigator is based on TDBNavigator Copyright (c) 1995-1997
  32.     Borland International. All Rights Reserved.
  33.  
  34.   The vertical orientation of TQDBNavigator is modeled after
  35.     DBVNav97 by Bourmad Mehdi(Mehdi.Bourmad@de.edfgdf.fr).
  36.  
  37.   The Secure Hash Algorithm (SHA-1) used in the password routines is based
  38.     on the implementation by Koos Lodewijkx (J.P.Lodewijkx@inter.nl.net).
  39.  
  40.   The grep-style pattern matching routine is based on the code of Gerald Nunn
  41.     and comes from GEXperts his excellent suite of Delphi add-ins at
  42.     http://www.amano-blick.com/~gnunn/GExperts.htm.
  43.  
  44.   The buffered stream class was based on *someone's* source but the code
  45.     has no name attached, I can't remember where I downloaded it, and no
  46.     amount of web-searching has turned it up. If you recognize it, do
  47.     please let me know, so that I can properly acknowledge the author's
  48.     work.
  49.  
  50.   Thanks to Bob Stammers for fixing a problem when TQDBNavigator is
  51.     created and destroyed at run-time.
  52.  
  53. *)
  54.  
  55. (*
  56.   Watch out for compiler warnings after try ... except blocks. The compiler
  57.   doesn't know that the various error functions raise exceptions of their
  58.   own which prevents the following code from ever being executed uninitialized.
  59. *)
  60.  
  61. unit QDB;
  62.  
  63. interface
  64.  
  65. uses
  66. {$IFDEF WIN32}Windows, {$ELSE}WinTypes, WinProcs, {$ENDIF}
  67.   SysUtils, Classes, Messages, Controls, Forms,
  68.   ExtCtrls, Buttons, Graphics;
  69.  
  70. type
  71.   string40 = string[40];
  72.   string05 = string[5];
  73.  
  74. const
  75.   FileVersion: string05 = '2.11';
  76.   AuthorInfo: string40 = 'Robert R. Marsh, SJ -- rrm@sprynet.com';
  77.  
  78. var
  79.   QDBTempFileLocation: string;
  80.  
  81. type
  82.   { basic types that your application needs to know about }
  83.   TKey = string[255]; { QDB key }
  84.   TItemIndex = longint; { pointer into index }
  85.   TDataIndex = longint; { pointer into item of data }
  86.  
  87. type
  88.   { other simple types used internally }
  89.   TQDBFileName = string;
  90.   TFileHandle = integer;
  91.   TFilePos = longint; { pointer into disk file }
  92.  
  93. type
  94.   { event used to signal progress of lengthy process }
  95.   TPercentage = 0..100;
  96.   TProgressOrigin = (prStart, prFinish, prSave, prPack, prKeyList, prCompress);
  97.   TProgressEvent = procedure(Sender: TObject;
  98.     Percent: TPercentage;
  99.     Kind: TProgressOrigin) of object;
  100.  
  101. type
  102.   { event used to get confirmation from user }
  103.   TConfirmEvent = procedure(Sender: TObject; var OK: boolean) of object;
  104.  
  105. type
  106.   { event used to give warning to the user }
  107.   TWarningEvent = TNotifyEvent;
  108.  
  109. type
  110.   { event used to elicit password }
  111.   TPassword = string[255];
  112.   TPasswordEvent = procedure(Sender: TObject; var Password: TPassword) of
  113.     object;
  114.  
  115. type
  116.   { QDB-specific exceptions }
  117.   EQDBError = class(Exception);
  118.   EQDBListError = class(EQDBError);
  119.   EQDBFileError = class(EQDBError);
  120.   EQDBIndexError = class(EQDBError);
  121.   EQDBInvalidPW = class(EQDBError);
  122.   EQDBNoCompress = class(EQDBError);
  123.   EQDBBadKey = class(EQDBError);
  124.   EQDBOutOfBounds = class(EQDBIndexError);
  125.   EQDBNoData = class(EQDBIndexError);
  126.   EQDBReadOnly = class(EQDBIndexError);
  127.   EQDBNoFile = class(EQDBIndexError);
  128.  
  129.   { TQDBList }
  130.  
  131. const
  132.   MaxBranchSize = 65532 div SizeOf(pointer);
  133.   MaxListSize = MaxBranchSize * MaxBranchSize;
  134.  
  135. type
  136.   PLeafList = ^TLeafList;
  137.   TLeafList = array[0..MaxBranchSize - 1] of pointer;
  138.   PTopList = ^TTopList;
  139.   TTopList = array[0..MaxBranchSize - 1] of PLeafList;
  140.  
  141. type
  142.   TQDBList = class(TObject)
  143.   private
  144.     FCapacity: longint;
  145.     FCount: longint;
  146.     FList: PTopList;
  147.     LeafMask: longint; { used to find the index into a leaf }
  148.     LeafLength: longint; { the length of the Leaf array }
  149.     LeafSize: longint; { the memory-size of the Leaf }
  150.     TopSize: longint; { the memory-size of the Top array }
  151.     Power: longint; { the power of two giving the length }
  152.     TopUsed: longint; { the number of active leaves }
  153.     procedure AddLeaf;
  154.     procedure SetPower(p: longint);
  155.   protected
  156.     function Get(Index: longint): pointer;
  157.     procedure Grow;
  158.     procedure Put(Index: longint; Item: pointer);
  159.     procedure SetCapacity(NewCapacity: longint);
  160.     procedure SetCount(NewCount: longint);
  161.   public
  162.     constructor Create;
  163.     destructor Destroy; override;
  164.     procedure Clear;
  165.     procedure Delete(Index: longint);
  166.     procedure Error(const ErrMsg: string; Data: longint);
  167.     procedure Exchange(Index1, Index2: longint);
  168.     procedure Insert(Index: longint; Item: pointer);
  169.     property Capacity: longint read FCapacity write SetCapacity;
  170.     property Count: longint read FCount write SetCount;
  171.     property Items[Index: longint]: pointer read Get write Put;
  172.     default;
  173.   end;
  174.  
  175.   { TQDBStringList }
  176.  
  177.   TQDBStringList = class(TPersistent)
  178.   private
  179.     FCaseSensitive: boolean;
  180.     FList: TQDBList;
  181.     FSorted: boolean;
  182.     procedure SetCaseSensitive(Value: boolean);
  183.     procedure SetSorted(Value: boolean);
  184.   protected
  185.     function Get(Index: longint): string;
  186.     function GetCapacity: longint;
  187.     function GetCount: longint;
  188.     function GetObject(Index: longint): TObject;
  189.     procedure Put(Index: longint; const S: string);
  190.     procedure PutObject(Index: longint; AObject: TObject);
  191.     procedure SetCapacity(NewCapacity: longint);
  192.   public
  193.     constructor Create;
  194.     destructor Destroy; override;
  195.     function Add(const S: string): longint;
  196.     function AddObject(const S: string; AObject: TObject): longint;
  197.     procedure Clear;
  198.     procedure Delete(Index: longint);
  199.     procedure Error(const ErrMsg: string; Data: longint);
  200.     procedure Exchange(Index1, Index2: longint);
  201.     function Find(const S: string; var Index: longint): boolean;
  202.     procedure Reverse;
  203.     property CaseSensitive: boolean read FCaseSensitive write SetCaseSensitive;
  204.     property Count: longint read GetCount;
  205.     property Sorted: boolean read FSorted write SetSorted;
  206.     property Objects[Index: longint]: TObject read GetObject write
  207.       PutObject;
  208.     property Strings[Index: longint]: string read Get write Put;
  209.     default;
  210.   end;
  211.  
  212.   { TIndexList }
  213.  
  214. type
  215.   TIndexList = class(TQDBStringList)
  216.     destructor Destroy; override;
  217.     procedure EmptyAndClear;
  218.   end;
  219.  
  220.   { TCacheList }
  221.  
  222.   TCacheList = class(TQDBStringList)
  223.   private
  224.     FAttempts: longint; { number of cache hits and failures }
  225.     FCurrentSize: longint; { ... in bytes }
  226.     FDisposals: longint; { number of scans for LRU item }
  227.     FMaximumSize: longint; { upper limit on size of cache }
  228.     FOldest: longint;
  229.     FSuccesses: longint; { number of cache hits }
  230.   protected
  231.     function GetFrequency: integer;
  232.     procedure SetFrequency(Value: integer);
  233.     procedure SetSize(Value: longint);
  234.   public
  235.     constructor Create;
  236.     destructor Destroy; override;
  237.     procedure Fetch(Stream: TStream; Place: longint);
  238.     procedure Flush;
  239.     procedure MakeSpace;
  240.     procedure Remove(Key: TKey);
  241.     procedure Statistics(var MaxSize, CurSize, CurLen, HitRatio, DropRatio:
  242.       longint);
  243.     procedure Store(Stream: TStream; Key: TKey);
  244.   end;
  245.  
  246.   { TBFStream }
  247.  
  248. type
  249.   TBFStream = class(TFileStream)
  250.   private
  251.     Buffer: pchar;
  252.     BufLen: longint;
  253.     BufferPos: pchar;
  254.     BytesRead: longint;
  255.     IsDirty: boolean;
  256.   public
  257.     constructor Create(const FileName: string; Mode: word; BufferSize:
  258.       longint);
  259.     destructor Destroy; override;
  260.     procedure AdjustBuffer;
  261.     function GetKey(var k: TKey): boolean;
  262.     function GetLongint(var L: longint): boolean;
  263.     procedure PutKey(const k: TKey);
  264.     procedure PutLongint(const L: longint);
  265.     procedure ResetBuffer;
  266.     function Seek(Offset: longint; Origin: word): longint; override;
  267.   end;
  268.  
  269.   { TTempBFStream }
  270.  
  271. type
  272.   TTempBFStream = class(TBFStream)
  273.   private
  274.     FOldFileName: string;
  275.     TmpFileName: string;
  276.   public
  277.     constructor Create(const OldFileName: string);
  278.     destructor Destroy; override;
  279.   end;
  280.  
  281.   { TQDB }
  282.  
  283. type
  284.   TMatchProc = function(Key: TKey; Pattern: TKey): boolean of object;
  285.  
  286. type
  287.   TQDBNavigator = class; {forward declaration }
  288.  
  289.   TQDB = class(TComponent)
  290.   private
  291.     Admin: TIndexList; { in-memory index to administrative items }
  292.     Cache: TCacheList; { in-memory item cache }
  293.     FAfterCancel: TNotifyEvent;
  294.     FAfterDelete: TNotifyEvent;
  295.     FAfterEdit: TNotifyEvent;
  296.     FAfterInsert: TNotifyEvent;
  297.     FAfterPost: TNotifyEvent;
  298.     FAdminIndex: TItemIndex; { current position in admin index }
  299.     FAggressiveUpdate: boolean; { }
  300.     FAuthor: string40; { my name! }
  301.     FAutoEdit: boolean;
  302.     FBackWild: char; { wildcard stands for any chars at back of key }
  303.     FBeforeCancel: TNotifyEvent;
  304.     FBeforeDelete: TNotifyEvent;
  305.     FBeforeEdit: TNotifyEvent;
  306.     FBeforeInsert: TNotifyEvent;
  307.     FBeforePost: TNotifyEvent;
  308.     FBoF: boolean; { at beginning of file ? }
  309.     FCompression: boolean; { compress changes ? }
  310.     FCount: TItemIndex; { number of items in Index }
  311.     FEditing: boolean;
  312.     FEoF: boolean; { at end of file ? }
  313.     FFileAge: longint; { age of the QDB file when opened }
  314.     FFileName: string; { name of QDB file }
  315.     FFilter: TKey;
  316.     FForceOverwrite: boolean; { restricts access to certain keys }
  317.     FFrontWild: char; { wildcard stands for any chars at front of key }
  318.     Filtered: boolean; { is FFilter = '' ? }
  319.     FGrepMatch: boolean; { use grep-style match }
  320.     FInserting: boolean;
  321.     FItemIndex: TItemIndex; { current position in Index }
  322.     FKey: TKey; { key of current item }
  323.     Matches: TMatchProc; { the matching procedure to use }
  324.     FMatchWholeWord: boolean; { in patetrn matching and filtering }
  325.     FOnAdded: TNotifyEvent;
  326.     FOnChanged: TNotifyEvent;
  327.     FOnDeleted: TNotifyEvent;
  328.     FOnDemandPassWord: TPasswordEvent;
  329.     FOnFileAssigned: TNotifyEvent;
  330.     FOnFound: TNotifyEvent;
  331.     FOnKilled: TNotifyEvent;
  332.     FOnNavigate: TNotifyEvent;
  333.     FPassWord: TPassword; { up to 255 chars }
  334.     FProgressUpdate: TProgressEvent;
  335.     FQDBNavigator: TQDBNavigator;
  336.     FReadOnly: boolean; { governs file access }
  337.     FReady: boolean; { true iff a file is open and ready for access }
  338.     FSaveOnClose: boolean; { if true closing the file saves it , def true }
  339.     FExpandedFileNames: boolean; { if true FileName is made absolute , def true }
  340.     FUpdating: longint; { count Begin/End Update calls }
  341.     FVersion: string05; { QDB version e.g. '1.00' }
  342.     index: TIndexList; { in-memory index to file }
  343.     IsDirty: boolean; { has the file been changed ? }
  344.     MonitorKind: TProgressOrigin;
  345.     MonitorInterval: longint; { how often to update progress monitor }
  346.     QIXFile: TBFStream; { working index-file stream }
  347.     QIXFileName: string; { name of the working index-file }
  348.     FBeforeKill: TConfirmEvent;
  349.     FBeforeOverWrite: TConfirmEvent;
  350.     FWarnNoData: TWarningEvent;
  351.     FWarnOutOfBounds: TWarningEvent;
  352.     FWarnReadOnly: TWarningEvent;
  353.     procedure AdminAddItem(ItemPtr: pointer; ItemLen: TDataIndex; Key: TKey);
  354.     procedure AdminChangeItem(ItemPtr: pointer; ItemLen: TDataIndex);
  355.     function AdminExactMatch(Key: TKey): boolean;
  356.     function AdminGetBoolean(Key: TKey): boolean;
  357.     function AdminGetInteger(Key: TKey): longint;
  358.     procedure AdminGetItem(ItemPtr: pointer);
  359.     function AdminGetString(Key: TKey): string;
  360.     function AdminItemSize: TDataIndex;
  361.     procedure AdminSetBoolean(Key: TKey; b: boolean);
  362.     procedure AdminSetInteger(Key: TKey; n: longint);
  363.     procedure AdminSetString(Key: TKey; const S: string);
  364.     procedure CloseQDB;
  365.     procedure CreateQDB;
  366.     procedure FileError(ErrCode: integer; SDefault: string);
  367.     function GetCacheFrequency: integer;
  368.     function GetCacheSize: longint;
  369.     function GetFileName: TQDBFileName;
  370.     function GetFilteredCount: TItemIndex;
  371.     function GetItemSize(Value: TItemIndex): TDataIndex;
  372.     function GetKey(Value: TItemIndex): TKey;
  373.     function GetKeyCase: boolean;
  374.     function GetStr(n: TItemIndex): string;
  375.     function GetStrByKey(Key: TKey): string;
  376.     function GetThisItemSize: TDataIndex;
  377.     function GetThisStr: string;
  378.     procedure IndexError(ErrMsg: string);
  379.     function ItemIsCompressed(Value: TItemIndex): boolean;
  380.     procedure LoadIndex;
  381.     procedure MonitorSetup(const Max: longint; const Kind: TProgressOrigin);
  382.     procedure MonitorUpdate(const n: longint);
  383.     procedure MonitorZero;
  384.     procedure OpenQDB;
  385.     procedure SaveIndex;
  386.     procedure SetCacheFrequency(Value: integer);
  387.     procedure SetCacheSize(Value: longint);
  388.     procedure SetDummyAuthor(Value: string40);
  389.     procedure SetDummyVersion(Value: string05);
  390.     procedure SetFilter(Value: TKey);
  391.     procedure SetItemIndex(Value: TItemIndex);
  392.     procedure SetKeyCase(Value: boolean);
  393.     procedure SetReadOnly(Value: boolean);
  394.     procedure SetReady(Value: boolean);
  395.     procedure SetStr(n: TItemIndex; const Value: string);
  396.     procedure SetStrByKey(Key: TKey; const Value: string);
  397.     procedure SetThisStr(const Value: string);
  398.     procedure Splice;
  399.     procedure Split;
  400.   protected
  401.     QDBFile: TFileStream; { working item-file stream }
  402.     QDBFileName: string; { name of the working data-file }
  403.     Restructuring: boolean;
  404.     procedure AboutToKill(var OK: boolean);
  405.     procedure AboutToOverWrite(var OK: boolean);
  406.     procedure Added;
  407.     procedure CannotChange;
  408.     procedure Changed;
  409.     procedure Deleted;
  410.     procedure DemandPassword;
  411.     procedure DoCancel; virtual;
  412.     procedure DoDelete; virtual;
  413.     procedure DoEdit; virtual;
  414.     procedure DoInsert; virtual;
  415.     procedure DoPost; virtual;
  416.     procedure FileAssigned;
  417.     function FileToRecover: string;
  418.     procedure ForceOverwrite(Value: boolean);
  419.     procedure Found;
  420.     function GrepMatches(Key: TKey; Pattern: TKey): boolean;
  421.     procedure Killed;
  422.     function Live: boolean;
  423.     procedure Navigate;
  424.     procedure NoData;
  425.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  426.     procedure OutOfBounds;
  427.     procedure SetFileName(Value: TQDBFileName); virtual;
  428.     procedure SetGrepMatch(Value: boolean);
  429.     procedure SetLinkToNavigator(Value: TQDBNavigator);
  430.     procedure SignalProgress(Percent: TPercentage; Kind: TProgressOrigin);
  431.     function SimpleMatches(Key: TKey; Pattern: TKey): boolean;
  432.     property AutoEdit: boolean read FAutoEdit write FAutoEdit;
  433.     property Editing: boolean read FEditing;
  434.     property Inserting: boolean read Finserting;
  435.   public
  436.     constructor Create(AOwner: TComponent); override;
  437.     destructor Destroy; override;
  438.     procedure Add(Stream: TStream; Key: TKey);
  439.     procedure AddItem(ItemPtr: pointer; ItemLen: TDataIndex; Key: TKey);
  440.     procedure AddStreamItem(Stream: TStream; Key: TKey);
  441.     procedure AdminClear(StartOfKey: TKey);
  442.     function AdminCount: TItemIndex;
  443.     procedure AdminDelete(Key: TKey);
  444.     function AdminKeyExists(Key: TKey): boolean;
  445.     function AdminKeys(Keys: TStrings; StartOfKey: TKey): longint;
  446.     procedure AssignKeyList(Keys: TStrings);
  447.     procedure BeginUpdate;
  448.     procedure Cancel;
  449.     procedure CacheFlush;
  450.     procedure CacheStatistics(var MaxSize, CurSize, CurLen, HitRatio, DropRatio: longint);
  451.     procedure Change(Stream: TStream);
  452.     procedure ChangeItem(ItemPtr: pointer; ItemLen: TDataIndex);
  453. {// Alex      procedure ChangeKey(key: TKey);}
  454.     procedure ChangeStreamItem(Stream: TStream);
  455.     function CloseMatch(Partialkey: TKey): boolean;
  456.     procedure Compress;
  457.     procedure Delete;
  458.     procedure DeleteItem;
  459.     procedure Edit;
  460.     procedure EndUpdate;
  461.     function ExactMatch(Key: TKey): boolean;
  462.     procedure Expand;
  463.     procedure FirstItem; virtual;
  464.     procedure Get(Stream: TStream);
  465.     procedure GetItem(ItemPtr: pointer);
  466.     procedure GetStreamItem(Stream: TStream);
  467.     procedure Insert;
  468.     function KeyExists(Key: TKey): boolean;
  469.     procedure Kill;
  470.     procedure LastItem; virtual;
  471.     procedure NextItem; virtual;
  472.     function OrphanToRecover: boolean;
  473.     procedure Pack;
  474.     function PartialMatch(StartOfKey: TKey): boolean;
  475.     procedure PartialMatchInit;
  476.     function PatternMatch(Pattern: TKey): boolean;
  477.     procedure PatternMatchInit;
  478.     procedure Post;
  479.     procedure PrepareToAdd(numberofitems: TItemIndex);
  480.     procedure PrevItem; virtual;
  481.     procedure Recover(NewFileName: string);
  482.     procedure Refresh; virtual;
  483.     procedure Save;
  484.     procedure SaveAs(NewName: string);
  485.     procedure SetMatchChars(Front: char; back: char);
  486.     procedure UpdateNavigator;
  487.     property AdminAsBoolean[Key: TKey]: boolean read AdminGetBoolean write AdminSetBoolean;
  488.     property AdminAsInteger[Key: TKey]: longint read AdminGetInteger write AdminSetInteger;
  489.     property AdminAsString[Key: TKey]: string read AdminGetString write AdminSetString;
  490.     property BoF: boolean read FBoF;
  491.     property Count: TItemIndex read FCount;
  492.     property EoF: boolean read FEoF;
  493.     property FilteredCount: TItemIndex read GetFilteredCount;
  494.     property Key: TKey read FKey;
  495.     property KeyCaseSensitive: boolean read GetKeyCase write SetKeyCase;
  496.     property CurrentItem: string read GetThisStr write SetThisStr;
  497.     property ItemIndex: TItemIndex read FItemIndex write SetItemIndex;
  498.     property Items[n: TItemIndex]: string read GetStr write SetStr;
  499.     property ItemsByKey[Key: TKey]: string read GetStrByKey write SetStrByKey;
  500.     default;
  501.     property ItemSize: TDataIndex read GetThisItemSize;
  502.     property MatchWholeWord: boolean read FMatchWholeWord write FMatchWholeWord;
  503.     property Password: TPassword read FPassWord write FPassWord stored false;
  504.     property Ready: boolean read FReady;
  505.   published
  506.     property AboutAuthor: string40 read FAuthor write SetDummyAuthor;
  507.     property AboutVersion: string05 read FVersion write SetDummyVersion;
  508.     property AfterCancel: TNotifyEvent read FAfterCancel write FAfterCancel;
  509.     property AfterDelete: TNotifyEvent read FAfterDelete write FAfterDelete;
  510.     property AfterEdit: TNotifyEvent read FAfterEdit write FAfterEdit;
  511.     property AfterInsert: TNotifyEvent read FAfterInsert write FAfterInsert;
  512.     property AfterPost: TNotifyEvent read FAfterPost write FAfterPost;
  513.     property AggressiveUpdate: boolean read FAggressiveUpdate write FAggressiveUpdate;
  514.     property BeforeCancel: TNotifyEvent read FBeforeCancel write FBeforeCancel;
  515.     property BeforeDelete: TNotifyEvent read FBeforeDelete write FBeforeDelete;
  516.     property BeforeEdit: TNotifyEvent read FBeforeEdit write FBeforeEdit;
  517.     property BeforeInsert: TNotifyEvent read FBeforeInsert write FBeforeInsert;
  518.     property BeforeKill: TConfirmEvent read FBeforeKill write FBeforeKill;
  519.     property BeforePost: TNotifyEvent read FBeforePost write FBeforePost;
  520.     property BeforeOverWrite: TConfirmEvent read FBeforeOverWrite write FBeforeOverWrite;
  521.     property CacheFrequency: integer read GetCacheFrequency write SetCacheFrequency;
  522.     property CacheSize: longint read GetCacheSize write SetCacheSize;
  523.     property Compression: boolean read FCompression write FCompression;
  524.     property FileName: TQDBFileName read GetFileName write SetFileName;
  525.     property Filter: TKey read FFilter write SetFilter;
  526.     property ProgressUpdate: TProgressEvent read FProgressUpdate write FProgressUpdate;
  527.     property ReadOnly: boolean read FReadOnly write SetReadOnly;
  528.     property SaveOnClose: boolean read FSaveOnClose write FSaveOnClose;
  529.     property ExpandedFileNames: boolean read FExpandedFileNames write FExpandedFileNames;
  530.     property UseGrepMatch: boolean read FGrepMatch write SetGrepMatch;
  531.     property WarnNoData: TWarningEvent read FWarnNoData write FWarnNoData;
  532.     property WarnOutOfBounds: TWarningEvent read FWarnOutOfBounds write FWarnOutOfBounds;
  533.     property WarnReadOnly: TWarningEvent read FWarnReadOnly write FWarnReadOnly;
  534.     property OnAdded: TNotifyEvent read FOnAdded write FOnAdded;
  535.     property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;
  536.     property OnDeleted: TNotifyEvent read FOnDeleted write FOnDeleted;
  537.     property OnDemandPassword: TPasswordEvent read FOnDemandPassWord write FOnDemandPassWord;
  538.     property OnFileAssigned: TNotifyEvent read FOnFileAssigned write FOnFileAssigned;
  539.     property OnFound: TNotifyEvent read FOnFound write FOnFound;
  540.     property OnKilled: TNotifyEvent read FOnKilled write FOnKilled;
  541.     property OnNavigate: TNotifyEvent read FOnNavigate write FOnNavigate;
  542.   end;
  543.  
  544.   { TQDBNavigator }
  545.  
  546.   { This is a modified version of DBNavigator. Code from the VCL library }
  547.   { is copyright Borland. }
  548.   { Copyright (c) 1995-1997 Borland International. All Rights Reserved. }
  549.  
  550.   {type}
  551.   TNavButton = class;
  552.  
  553.   TNavGlyph = (ngEnabled, ngDisabled);
  554.   TNavOrientation = (noAuto, noHoriz, noVert);
  555.   TNavigateBtn = (nbFirst, nbPrev, nbNext, nbLast,
  556.     nbInsert, nbDelete, nbEdit, nbPost, nbCancel, nbRefresh);
  557.   TButtonSet = set of TNavigateBtn;
  558.   TNavButtonStyle = set of (nsAllowTimer, nsFocusRect);
  559.  
  560.   TNavClickEvent = procedure(Sender: TObject; Button: TNavigateBtn) of object;
  561.   TBtnPressEvent = procedure(Sender: TObject; Q: TQDB) of object;
  562.  
  563.   TQDBNavigator = class(TCustomPanel)
  564.   private
  565.     ButtonHeight: integer;
  566.     ButtonWidth: integer;
  567.     FBeforeAction: TNavClickEvent;
  568.     FFlat: boolean;
  569.     FHints: TStrings;
  570.     FocusedButton: TNavigateBtn;
  571.     FOnCancel: TBtnPressEvent;
  572.     FOnDelete: TBtnPressEvent;
  573.     FOnEdit: TBtnPressEvent;
  574.     FOnFirst: TBtnPressEvent;
  575.     FOnInsert: TBtnPressEvent;
  576.     FOnLast: TBtnPressEvent;
  577.     FOnNavClick: TNavClickEvent;
  578.     FOnNext: TBtnPressEvent;
  579.     FOnPost: TBtnPressEvent;
  580.     FOnPrev: TBtnPressEvent;
  581.     FOnRefresh: TBtnPressEvent;
  582.     FOrientation: TNavOrientation;
  583.     FQDB: TQDB;
  584.     FVisibleButtons: TButtonSet;
  585.     MinBtnSize: TPoint;
  586.     procedure _Click(Sender: TObject);
  587.     procedure AdjustSize(var W: integer; var H: integer);
  588.     procedure BtnMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: integer);
  589.     function GetEnabled: boolean;
  590.     function GetGlyph(Btn: TNavigateBtn): Graphics.TBitmap;
  591.     procedure HintsChanged(Sender: TObject);
  592.     procedure InitButtons;
  593.     procedure InitHints;
  594.     procedure SetEnabled(Value: boolean);
  595.     procedure SetFlat(Value: boolean);
  596.     procedure SetGlyph(Btn: TNavigateBtn; Value: Graphics.TBitmap);
  597.     procedure SetHints(Value: TStrings);
  598.     procedure SetOrientation(Value: TNavOrientation);
  599.     procedure SetVisible(Value: TButtonSet);
  600.     procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
  601.     procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
  602.     procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
  603.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  604.   protected
  605.     Buttons: array[TNavigateBtn] of TNavButton;
  606.     procedure Cancel;
  607.     procedure Delete;
  608.     procedure Edit;
  609.     procedure First;
  610.     procedure Insert;
  611.     procedure KeyDown(var Key: word; Shift: TShiftState); override;
  612.     procedure Last;
  613.     procedure Loaded; override;
  614.     procedure Next;
  615.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  616.     procedure Post;
  617.     procedure Prev;
  618.     procedure QDBStateChanged;
  619.     procedure Refresh;
  620.     procedure SetQDB(Value: TQDB); virtual;
  621.   public
  622.     constructor Create(AOwner: TComponent); override;
  623.     destructor Destroy; override;
  624.     procedure BtnClick(Index: TNavigateBtn); virtual;
  625.     procedure SetBounds(ALeft, ATop, AWidth, AHeight: integer); override;
  626.     property Glyphs[Btn: TNavigateBtn]: Graphics.TBitmap read GetGlyph write SetGlyph;
  627.   published
  628.     property Align;
  629.     property BeforeAction: TNavClickEvent read FBeforeAction write FBeforeAction;
  630.     property Ctl3D;
  631.     property DragCursor;
  632.     property DragMode;
  633.     property Enabled read GetEnabled write SetEnabled;
  634.     property Flat: boolean read FFlat write SetFlat default false;
  635.     property Hints: TStrings read FHints write SetHints;
  636.     property Orientation: TNavOrientation read FOrientation write SetOrientation default noAuto;
  637.     property ParentCtl3D;
  638.     property ParentShowHint;
  639.     property QDB: TQDB read FQDB write SetQDB;
  640.     property ShowHint;
  641.     property TabOrder;
  642.     property TabStop;
  643.     property Visible;
  644.     property VisibleButtons: TButtonSet read FVisibleButtons write SetVisible
  645.       default [nbFirst, nbPrev, nbNext, nbLast, nbInsert, nbDelete, nbEdit, nbPost, nbCancel, nbRefresh];
  646.     property OnCancel: TBtnPressEvent read FOnCancel write FOnCancel;
  647.     property OnClick: TNavClickEvent read FOnNavClick write FOnNavClick;
  648.     property OnDblClick;
  649.     property OnDelete: TBtnPressEvent read FOnDelete write FOnDelete;
  650.     property OnDragDrop;
  651.     property OnDragOver;
  652.     property OnEdit: TBtnPressEvent read FOnEdit write FOnEdit;
  653.     property OnEndDrag;
  654.     property OnEnter;
  655.     property OnExit;
  656.     property OnFirst: TBtnPressEvent read FOnFirst write FOnFirst;
  657.     property OnInsert: TBtnPressEvent read FOnInsert write FOnInsert;
  658.     property OnLast: TBtnPressEvent read FOnLast write FOnLast;
  659.     property OnNext: TBtnPressEvent read FOnNext write FOnNext;
  660.     property OnPost: TBtnPressEvent read FOnPost write FOnPost;
  661.     property OnPrev: TBtnPressEvent read FOnPrev write FOnPrev;
  662.     property OnRefresh: TBtnPressEvent read FOnRefresh write FOnRefresh;
  663.     property OnResize;
  664.   end;
  665.  
  666.   {type}
  667.   TNavButton = class(TSpeedButton)
  668.   private
  669.     FIndex: TNavigateBtn;
  670.     FNavStyle: TNavButtonStyle;
  671.     FRepeatTimer: TTimer;
  672.     procedure TimerExpired(Sender: TObject);
  673.   protected
  674.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override;
  675.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override;
  676.     procedure Paint; override;
  677.   public
  678.     destructor Destroy; override;
  679.     property Index: TNavigateBtn read FIndex write FIndex;
  680.     property NavStyle: TNavButtonStyle read FNavStyle write FNavStyle;
  681.   end;
  682.  
  683. function TempFileName(Prefix: string): string;
  684. procedure RenameOrMoveFile(const SrcFileName, DstFileName: string);
  685.  
  686. implementation
  687.  
  688. uses
  689.   qdbu;
  690.  
  691. {$IFDEF WIN32}
  692. {$R QDB.R32}
  693. {$ELSE}
  694. {$R QDB.R16}
  695. {$ENDIF}
  696.  
  697. { the codes for the messages in QDB.R16 or QDB.R32}
  698. const
  699.   SMissing = 'Could not find the file %s';
  700.   SCorrupt = 'The file %s is not a valid QDB file';
  701.   SDoorOpen = 'The drive you are trying to access is not ready';
  702.   SReadOnly = '%s is marked as read-only';
  703.   STooMany = 'No more file handles are available';
  704.   SShareError = 'The file %s seems to be in use by another program';
  705.   SDiskFull = 'The drive is full';
  706.   SUnknownError = 'Unidentified problem -  %s';
  707.   SIndexAdd = 'Not enough memory to extend the index to %s';
  708.   SCannotCopy = 'Unable to copy %s';
  709.   SDataAdd = 'Unable to extend the file %s';
  710.   SDuplicateKey = 'Duplicate keys are not allowed';
  711.   SSortedListError = 'Cannot insert into a sorted list';
  712.   SOutOfBounds = 'The list index is out of bounds';
  713.   STempFile = 'Could not create a necessary temporary file';
  714.   SNoFile = 'Illegal operation - no file assigned';
  715.   SNoMemory = 'Insufficient memory to compress or expand';
  716.   SBadKey = 'The key ''%s'' does not exist';
  717.   SBadPassword = 'The password you have provided is invalid';
  718.   SNoData = 'File %s is empty';
  719.  
  720.   { Flags in the TIndex.Ext field }
  721.  
  722. type
  723.   TFlags = 0..31;
  724.   TFlagSet = set of TFlags;
  725.  
  726. const
  727.   IsAdminItem: TFlags = 0; {Admin items}
  728.   IsCompressed: TFlags = 1; {Compressed items}
  729.  
  730.   { ******* Utility routines ******* }
  731.  
  732.   { Allocates memory for a buffer -- first tries to get the }
  733.   { RequestedSize but if not available keeps halving the size }
  734.   { until a block can be allocated. The actual amount allocated }
  735.   { is returned as Result. }
  736.  
  737. function GetBuffer(var Buffer: pointer; RequestedSize: longint): longint;
  738. var
  739.   AllocatedOK: boolean;
  740.   AllocatedSize: longint;
  741. begin
  742.   AllocatedSize := 0;
  743.   { make sure request is in range }
  744.   if RequestedSize < 1024 then
  745.     RequestedSize := 1024;
  746. {$IFNDEF WIN32}
  747.   if RequestedSize > (1024 * 63) then
  748.     RequestedSize := (1024 * 63);
  749. {$ELSE}
  750.   if RequestedSize > (1024 * 512) then
  751.     RequestedSize := (1024 * 512);
  752. {$ENDIF}
  753.   AllocatedOK := false;
  754.   while not AllocatedOK do
  755.   begin
  756.     try
  757.       GetMem(Buffer, RequestedSize);
  758.       AllocatedSize := RequestedSize;
  759.       AllocatedOK := true;
  760.     except
  761.       { keep halving the request until successful }
  762.       on EOutOfMemory do
  763.         RequestedSize := RequestedSize div 2;
  764.     end;
  765.   end;
  766.   Result := AllocatedSize;
  767. end;
  768.  
  769. {*******************************************************************
  770. *
  771. *                      Stream Compression
  772. *
  773. *    based on the LZRW1/KH compression algorithm posted by Kurt Haenen
  774. *    to SWAG as 'lzrw1' and modified for Delphi by D. Heijl
  775. *    (Danny.Heijl@cevi.be)
  776. *
  777. *    Haenen states, 'The algoritm is not as good as LZH, but can compete
  778. *    with Lempel-Ziff. It's the fastest one I've encountered up to now.'
  779. *
  780. *    The procedures below are the ones actually used in QDB
  781. *
  782. *    function squashstream(src, dst: tstream): longint;
  783. *      compresses the whole of the src stream to the current place in
  784. *      dst and returns the number of bytes written to dst
  785. *
  786. *    procedure unsquashstream(src, dst: tstream; bytes: longint);
  787. *      expands the requested number of bytes from the current place in
  788. *      the src stream to dst (which should be empty)
  789. *
  790. *    The procedures GetMatch, Squash, and Unsquash do the actual work.
  791. *
  792. ******************************************************************************}
  793.  
  794. { we want to turn off range checking temporarily }
  795. {$IFOPT R+}
  796. {$DEFINE RON}
  797. {$R-}
  798. {$ENDIF}
  799.  
  800. {$IFDEF WIN32}
  801. type
  802.   int16 = smallint;
  803. {$ELSE}
  804. type
  805.   int16 = integer;
  806. {$ENDIF}
  807.  
  808. const
  809.   BufferMaxSize = 32768;
  810.   BufferMax = BufferMaxSize - 1;
  811.   flag_copied = $80;
  812.   flag_compress = $40;
  813.  
  814. type
  815.   BufferIndex = 0..BufferMax + 15;
  816.   BufferSize = 0..BufferMaxSize;
  817.   BufferArray = array[BufferIndex] of Byte;
  818.   Bufferptr = ^BufferArray;
  819.   HashTable = array[0..4095] of int16;
  820.   HashTabPtr = ^HashTable;
  821.  
  822.   { turn off overflow testing temporarily }
  823. {$IFOPT Q+}
  824. {$DEFINE QON}
  825. {$Q-}
  826. {$ENDIF}
  827.  
  828.   {check if this string has already been seen in the current 4 KB window }
  829.  
  830. function GetMatch(Source: Bufferptr; X: BufferIndex; SourceSize: BufferSize;
  831.   Hash: HashTabPtr; var size: word; var Pos: BufferIndex): boolean;
  832. var
  833.   HashValue: word;
  834.   TmpHash: int16;
  835. begin
  836.   HashValue := (40543 * ((((Source^[X] shl 4) xor Source^[X + 1]) shl
  837.     4) xor
  838.     Source^[X + 2]) shr 4) and $0FFF;
  839.   Result := false;
  840.   TmpHash := Hash^[HashValue];
  841.   if (TmpHash <> -1) and (X - TmpHash < 4096) then
  842.   begin
  843.     Pos := TmpHash;
  844.     size := 0;
  845.     while ((size < 18) and (Source^[X + size] = Source^[Pos + size])
  846.       and (X + size < SourceSize)) do
  847.     begin
  848.       inc(size);
  849.     end;
  850.     Result := (size >= 3)
  851.   end;
  852.   Hash^[HashValue] := X;
  853. end;
  854. {$IFDEF QON}
  855. {$UNDEF QON}
  856. {$Q+}
  857. {$ENDIF}
  858.  
  859. { compress a buffer of max. 32 KB }
  860.  
  861. function Squash(Source, Dest: Bufferptr; SourceSize: BufferSize; Hash:
  862.   HashTabPtr): BufferSize;
  863. var
  864.   bit, command, size: word;
  865.   Key: word;
  866.   X, Y, Z, Pos: BufferIndex;
  867. begin
  868.   FillChar(Hash^, SizeOf(HashTable), $FF);
  869.   Dest^[0] := flag_compress;
  870.   X := 0;
  871.   Y := 3;
  872.   Z := 1;
  873.   bit := 0;
  874.   command := 0;
  875.   while (X < SourceSize) and (Y <= SourceSize) do
  876.   begin
  877.     if (bit > 15) then
  878.     begin
  879.       Dest^[Z] := Hi(command);
  880.       Dest^[Z + 1] := Lo(command);
  881.       Z := Y;
  882.       bit := 0;
  883.       inc(Y, 2)
  884.     end;
  885.     size := 1;
  886.     while ((Source^[X] = Source^[X + size]) and (size < $FFF)
  887.       and (X + size < SourceSize)) do
  888.     begin
  889.       inc(size);
  890.     end;
  891.     if (size >= 16) then
  892.     begin
  893.       Dest^[Y] := 0;
  894.       Dest^[Y + 1] := Hi(size - 16);
  895.       Dest^[Y + 2] := Lo(size - 16);
  896.       Dest^[Y + 3] := Source^[X];
  897.       inc(Y, 4);
  898.       inc(X, size);
  899.       command := (command shl 1) + 1;
  900.     end
  901.     else
  902.     begin { not size >= 16 }
  903.       if (GetMatch(Source, X, SourceSize, Hash, size, Pos)) then
  904.       begin
  905.         Key := ((X - Pos) shl 4) + (size - 3);
  906.         Dest^[Y] := Hi(Key);
  907.         Dest^[Y + 1] := Lo(Key);
  908.         inc(Y, 2);
  909.         inc(X, size);
  910.         command := (command shl 1) + 1
  911.       end
  912.       else
  913.       begin
  914.         Dest^[Y] := Source^[X];
  915.         inc(Y);
  916.         inc(X);
  917.         command := command shl 1
  918.       end;
  919.     end; { size <= 16 }
  920.     inc(bit);
  921.   end; { while x < sourcesize ... }
  922.   command := command shl (16 - bit);
  923.   Dest^[Z] := Hi(command);
  924.   Dest^[Z + 1] := Lo(command);
  925.   if (Y > SourceSize) then
  926.   begin
  927.     Move(Source^[0], Dest^[1], SourceSize);
  928.     Dest^[0] := flag_copied;
  929.     Y := succ(SourceSize)
  930.   end;
  931.   Result := Y
  932. end;
  933.  
  934. { decompress a buffer of max 32 KB }
  935.  
  936. function Unsquash(Source, Dest: Bufferptr; SourceSize: BufferSize):
  937.   BufferSize;
  938. var
  939.   X, Y, Pos: BufferIndex;
  940.   command, size, k: word;
  941.   bit: Byte;
  942.   Savey: BufferIndex; { unsafe for-loop variable Y -- dh --}
  943. begin
  944.   if (SourceSize <= 1) then
  945.   begin { correction of a bug found by Dominique Willems <Domus@compuserve.com>}
  946.     Result := 0;
  947.     exit;
  948.   end;
  949.   if (Source^[0] = flag_copied) then
  950.   begin
  951.     for Y := 1 to pred(SourceSize) do
  952.     begin
  953.       Dest^[pred(Y)] := Source^[Y];
  954.       Savey := Y;
  955.     end;
  956.     Y := Savey;
  957.   end
  958.   else
  959.   begin
  960.     Y := 0;
  961.     X := 3;
  962.     command := (Source^[1] shl 8) + Source^[2];
  963.     bit := 16;
  964.     while (X < SourceSize) do
  965.     begin
  966.       if (bit = 0) then
  967.       begin
  968.         command := (Source^[X] shl 8) + Source^[X + 1];
  969.         bit := 16;
  970.         inc(X, 2)
  971.       end;
  972.       if ((command and $8000) = 0) then
  973.       begin
  974.         Dest^[Y] := Source^[X];
  975.         inc(X);
  976.         inc(Y)
  977.       end
  978.       else
  979.       begin { command and $8000 }
  980.         Pos := ((Source^[X] shl 4) + (Source^[X + 1] shr 4));
  981.         if (Pos = 0) then
  982.         begin
  983.           size := (Source^[X + 1] shl 8) + Source^[X + 2] + 15;
  984.           for k := 0 to size do
  985.           begin
  986.             Dest^[Y + k] := Source^[X + 3];
  987.           end;
  988.           inc(X, 4);
  989.           inc(Y, size + 1)
  990.         end
  991.         else
  992.         begin { pos = 0 }
  993.           size := (Source^[X + 1] and $0F) + 2;
  994.           for k := 0 to size do
  995.             Dest^[Y + k] := Dest^[Y - Pos + k];
  996.           inc(X, 2);
  997.           inc(Y, size + 1)
  998.         end; { pos = 0 }
  999.       end; { command and $8000 }
  1000.       command := command shl 1;
  1001.       dec(bit);
  1002.     end; { while x < sourcesize }
  1003.   end;
  1004.   Result := Y;
  1005. end; { Unsquash }
  1006.  
  1007. function SquashStream(Src, Dst: TStream): longint;
  1008. var
  1009.   inp,
  1010.     outp: Bufferptr;
  1011.   ins,
  1012.     outs: word;
  1013.   Hash: HashTabPtr;
  1014. begin
  1015.   Result := 0;
  1016.   Src.Seek(0, 0);
  1017.   try
  1018.     GetMem(inp, BufferMaxSize);
  1019.   except
  1020.     raise EQDBNoCompress.Create(SNoMemory);
  1021.   end;
  1022.   try
  1023.     try
  1024.       GetMem(outp, BufferMaxSize);
  1025.     except
  1026.       raise EQDBNoCompress.Create(SNoMemory);
  1027.     end;
  1028.     try
  1029.       try
  1030.         GetMem(Hash, SizeOf(HashTable));
  1031.       except
  1032.         raise EQDBNoCompress.Create(SNoMemory);
  1033.       end;
  1034.       try
  1035.         while Src.Position < Src.size do
  1036.         begin
  1037.           ins := Src.Read(inp^, BufferMaxSize);
  1038.           outs := Squash(inp, outp, ins, Hash);
  1039.           inc(Result, Dst.Write(outs, SizeOf(outs)));
  1040.           inc(Result, Dst.Write(outp^, outs));
  1041.         end;
  1042.       finally
  1043.         FreeMem(Hash, SizeOf(HashTable));
  1044.       end;
  1045.     finally
  1046.       FreeMem(outp, BufferMaxSize);
  1047.     end;
  1048.   finally
  1049.     FreeMem(inp, BufferMaxSize);
  1050.   end;
  1051. end;
  1052.  
  1053. procedure UnSquashStream(Src, Dst: TStream; Bytes: longint);
  1054. var
  1055.   inp,
  1056.     outp: Bufferptr;
  1057.   ins,
  1058.     outs: word;
  1059.   Tot: longint;
  1060. begin
  1061.   Dst.Seek(0, 0);
  1062.   Tot := 0;
  1063.   try
  1064.     GetMem(inp, BufferMaxSize);
  1065.   except
  1066.     raise EQDBNoCompress.Create(SNoMemory);
  1067.   end;
  1068.   try
  1069.     try
  1070.       GetMem(outp, BufferMaxSize);
  1071.     except
  1072.       raise EQDBNoCompress.Create(SNoMemory);
  1073.     end;
  1074.     try
  1075.       while Tot < Bytes do
  1076.       begin
  1077.         inc(Tot, Src.Read(ins, SizeOf(ins)));
  1078.         ins := Src.Read(inp^, ins);
  1079.         inc(Tot, ins);
  1080.         outs := Unsquash(inp, outp, ins);
  1081.         Dst.Write(outp^, outs);
  1082.       end;
  1083.     finally
  1084.       FreeMem(outp, BufferMaxSize);
  1085.     end;
  1086.   finally
  1087.     FreeMem(inp, BufferMaxSize);
  1088.   end;
  1089.   Dst.Seek(0, 0);
  1090. end;
  1091.  
  1092. { restore the previous range checking state }
  1093. {$IFDEF RON}
  1094. {$UNDEF RON}
  1095. {$R+}
  1096. {$ENDIF}
  1097.  
  1098. { TQDBList }
  1099.  
  1100. const
  1101.   PowerMin = 1; { governs the minimum capacity of the list }
  1102.   { i.e.. 2^(2*PowerMin) = 4 }
  1103.  
  1104. constructor TQDBList.Create;
  1105. begin
  1106.   inherited Create;
  1107.   FCount := 0;
  1108.   FList := nil;
  1109.   TopUsed := 0;
  1110.   SetPower(PowerMin);
  1111.   FCapacity := 0;
  1112.   SetCapacity(0);
  1113. end;
  1114.  
  1115. destructor TQDBList.Destroy;
  1116. begin
  1117.   while TopUsed > 0 do
  1118.   begin
  1119.     FreeMem(FList^[TopUsed - 1], LeafSize);
  1120.     dec(TopUsed);
  1121.   end;
  1122.   if FList <> nil then
  1123.   begin
  1124.     FreeMem(FList, TopSize);
  1125.     FList := nil;
  1126.   end;
  1127.   inherited Destroy;
  1128. end;
  1129.  
  1130. procedure TQDBList.AddLeaf;
  1131. var
  1132.   NewLeaf: PLeafList;
  1133. begin
  1134.   try
  1135.     GetMem(NewLeaf, LeafSize);
  1136.     FList^[TopUsed] := NewLeaf;
  1137.     inc(TopUsed);
  1138.   except
  1139.     on EOutOfMemory do
  1140.       Error(SNoMemory, 0)
  1141.   else
  1142.     raise;
  1143.   end;
  1144. end;
  1145.  
  1146. procedure TQDBList.Clear;
  1147. begin
  1148.   while TopUsed > 0 do
  1149.   begin
  1150.     FreeMem(FList^[TopUsed - 1], LeafSize);
  1151.     dec(TopUsed);
  1152.   end;
  1153.   FCount := 0;
  1154.   SetCapacity(0);
  1155. end;
  1156.  
  1157. procedure TQDBList.Delete(Index: longint);
  1158. { messy ... we have to move items from one leaf to the next }
  1159. var
  1160.   i: longint;
  1161.   amount: longint;
  1162. begin
  1163.   { how many elements do we have to shift in the first leaf }
  1164.   amount := LeafLength - 1 - (Index and LeafMask);
  1165.   { move the first chunk left }
  1166.   if amount > 0 then
  1167.     System.Move(FList^[(Index shr Power)]^[(Index + 1) and LeafMask],
  1168.       FList^[(Index shr Power)]^[Index and LeafMask], amount * SizeOf(
  1169.       pointer));
  1170.   { then for each leaf on up }
  1171.   for i := (Index shr Power) to TopUsed - 2 do
  1172.   begin
  1173.     { bring one item down from the end to the front }
  1174.     FList^[i]^[LeafLength - 1] := FList^[i + 1]^[0];
  1175.     { shift the rest left one place }
  1176.     System.Move(FList^[i + 1]^[1], FList^[i + 1]^[0], LeafSize -
  1177.       SizeOf(pointer));
  1178.   end;
  1179.   dec(FCount);
  1180.   { if we've emptied a leaf we can free the space }
  1181.   if (FCount = 0) or (((FCount - 1) shr Power) < (TopUsed - 1)) then
  1182.   begin
  1183.     FreeMem(FList^[TopUsed - 1], LeafSize);
  1184.     dec(TopUsed);
  1185.   end;
  1186. end;
  1187.  
  1188. procedure TQDBList.Error(const ErrMsg: string; Data: longint);
  1189. var
  1190.   StackTop: record
  1191.   end;
  1192.   Stack: record
  1193.     BPorEBP: integer; { 16 bit: BP, 32 bit: EBP }
  1194.     ReturnAddress: pointer;
  1195.   end absolute StackTop;
  1196. begin
  1197.   raise EQDBListError.CreateFmt(ErrMsg, [Data])at Stack.ReturnAddress;
  1198. end;
  1199.  
  1200. procedure TQDBList.Exchange(Index1, Index2: longint);
  1201. var
  1202.   Item: pointer;
  1203. begin
  1204.   Item := FList^[(Index1 shr Power)]^[(Index1 and LeafMask)];
  1205.   FList^[(Index1 shr Power)]^[(Index1 and LeafMask)] := FList^[(Index2
  1206.     shr Power)]^[(Index2 and LeafMask)];
  1207.   FList^[(Index2 shr Power)]^[(Index2 and LeafMask)] := Item;
  1208. end;
  1209.  
  1210. function TQDBList.Get(Index: longint): pointer;
  1211. begin
  1212.   Result := FList^[(Index shr Power)]^[(Index and LeafMask)];
  1213. end;
  1214.  
  1215. procedure TQDBList.Grow;
  1216. begin
  1217.   { SetCapacity will choose a suitable new value -- the list }
  1218.   { capacity grows by powers of two }
  1219.   SetCapacity(FCapacity + 1);
  1220. end;
  1221.  
  1222. procedure TQDBList.Insert(Index: longint; Item: pointer);
  1223. { messy ... we have to move elements from leaf to leaf }
  1224. var
  1225.   i: longint;
  1226.   amount: longint;
  1227. begin
  1228.   { make room if necessary }
  1229.   if FCount = FCapacity then
  1230.     Grow;
  1231.   { add another leaf if needed }
  1232.   if (FCount and LeafMask) = 0 then
  1233.     AddLeaf;
  1234.   { for each leaf from the top down to the place of insertion }
  1235.   for i := TopUsed - 1 downto ((Index shr Power) + 1) do
  1236.   begin
  1237.     { shift everything one place right }
  1238.     System.Move(FList^[i]^[0], FList^[i]^[1], LeafSize - SizeOf(pointer
  1239.       ));
  1240.     { bring one item up from the end of the previous leaf }
  1241.     FList^[i]^[0] := FList^[i - 1]^[LeafLength - 1];
  1242.   end;
  1243.   { how many elements to shift along }
  1244.   amount := LeafLength - 1 - (Index and LeafMask);
  1245.   { shift right to make room for new item }
  1246.   System.Move(FList^[Index shr Power]^[(Index and LeafMask)],
  1247.     FList^[Index shr Power]^[(Index and LeafMask) + 1], amount * SizeOf(
  1248.     pointer));
  1249.   { insert the item itself }
  1250.   FList^[(Index shr Power)]^[(Index and LeafMask)] := Item;
  1251.   inc(FCount);
  1252. end;
  1253.  
  1254. procedure TQDBList.Put(Index: longint; Item: pointer);
  1255. begin
  1256.   FList^[(Index shr Power)]^[(Index and LeafMask)] := Item;
  1257. end;
  1258.  
  1259. procedure TQDBList.SetCapacity(NewCapacity: longint);
  1260. { a lot of business goes on in here ... }
  1261. var
  1262.   NewPower: longint;
  1263.   NewSize: longint;
  1264.   NewList: PTopList;
  1265.   NewLeaf: PLeafList;
  1266.   NewTopUsed: longint;
  1267.   Ratio: longint;
  1268.   i, j: longint;
  1269.  
  1270.   function RecommendedPower(NewCapacity: longint): longint;
  1271.   begin
  1272.     { compute the root of s to the nearest greater power of 2 }
  1273.     Result := PowerMin;
  1274.     while NewCapacity >= (1 shl (Result shl 1)) do
  1275.       inc(Result);
  1276.   end;
  1277.  
  1278. begin
  1279.   { calculate the parameters of the 'new' qlist }
  1280.   NewPower := RecommendedPower(NewCapacity);
  1281.   NewSize := (1 shl NewPower) * SizeOf(pointer);
  1282.   NewCapacity := (1 shl (NewPower shl 1));
  1283.   if (NewCapacity < FCount) or (NewCapacity > MaxListSize) then
  1284.     Error(SOutOfBounds, NewCapacity);
  1285.   if NewCapacity <> FCapacity then
  1286.   begin
  1287.     { begin to build a new qlist }
  1288.     try
  1289.       GetMem(NewList, NewSize);
  1290.     except
  1291.       on EOutOfMemory do
  1292.         Error(SNoMemory, 0)
  1293.     else
  1294.       raise
  1295.     end;
  1296.     if FCount > 0 then
  1297.     begin
  1298.       { only relevant if the list is not empty }
  1299.       NewTopUsed := ((FCount - 1) shr NewPower) + 1;
  1300.       { how many old leaves fit into a new one }
  1301.       Ratio := (NewSize div LeafSize);
  1302.       { for each old leaf }
  1303.       for i := 0 to TopUsed - 1 do
  1304.       begin
  1305.         { if a new leaf is needed }
  1306.         if i mod Ratio = 0 then
  1307.         begin
  1308.           try
  1309.             { add a new leaf }
  1310.             GetMem(NewLeaf, NewSize);
  1311.           except
  1312.             on EOutOfMemory do
  1313.               { get rid of the partly built qlist }
  1314.             begin
  1315.               j := i;
  1316.               dec(j, Ratio);
  1317.               while j >= 0 do
  1318.                 FreeMem(NewList^[j], NewSize);
  1319.               FreeMem(NewList, NewSize);
  1320.               Error(SNoMemory, 0);
  1321.             end
  1322.           else
  1323.             raise;
  1324.           end;
  1325.           { put the leaf into the tree }
  1326.           NewList^[i div Ratio] := NewLeaf;
  1327.         end;
  1328.         { move the old leaf to its place in the new }
  1329.         System.Move(FList^[i]^[0], NewList^[i div Ratio]^[(LeafLength *
  1330.             (i mod Ratio))], LeafSize);
  1331.         { get rid of the old leaf }
  1332.         FreeMem(FList^[i], LeafSize);
  1333.       end;
  1334.       TopUsed := NewTopUsed;
  1335.     end;
  1336.     { get rid of the now empty old qlist }
  1337.     if FList <> nil then
  1338.       FreeMem(FList, TopSize);
  1339.     { assign the new qlist instead }
  1340.     FList := NewList;
  1341.     { adjust the qlist parameters }
  1342.     SetPower(NewPower);
  1343.     FCapacity := NewCapacity;
  1344.   end;
  1345. end;
  1346.  
  1347. procedure TQDBList.SetCount(NewCount: longint);
  1348. var
  1349.   i: longint;
  1350. begin
  1351.   if (NewCount < 0) or (NewCount > MaxListSize) then
  1352.     Error(SOutOfBounds, NewCount);
  1353.   if NewCount > FCapacity then
  1354.     SetCapacity(NewCount);
  1355.   { if we are shrinking the list we blank out the unwanted }
  1356.   { items -- if they point to anything there'll be a leak }
  1357.   if NewCount > FCount then
  1358.     for i := FCount to NewCount do
  1359.       FList^[(i shr Power)]^[(i and LeafMask)] := nil;
  1360.   FCount := NewCount;
  1361. end;
  1362.  
  1363. procedure TQDBList.SetPower(p: longint);
  1364. begin
  1365.   Power := p;
  1366.   LeafLength := (1 shl Power);
  1367.   LeafSize := LeafLength * SizeOf(pointer);
  1368.   LeafMask := LeafLength - 1;
  1369.   TopSize := LeafSize;
  1370. end;
  1371.  
  1372. { TQDBStringList }
  1373.  
  1374. type
  1375.   PStrItem = ^TStrItem;
  1376.   TStrItem = record
  1377.     FString: pchar;
  1378.     FObject: TObject;
  1379.   end;
  1380.  
  1381. constructor TQDBStringList.Create;
  1382. begin
  1383.   inherited Create;
  1384.   FList := TQDBList.Create;
  1385. end;
  1386.  
  1387. destructor TQDBStringList.Destroy;
  1388. begin
  1389.   Clear;
  1390.   FList.Free;
  1391.   inherited Destroy;
  1392. end;
  1393.  
  1394. procedure DisposeStrItem(p: PStrItem);
  1395. begin
  1396.   FreeMem(p^.FString, StrLen(p^.FString) + 1);
  1397.   FreeMem(p, SizeOf(TStrItem));
  1398. end;
  1399.  
  1400. function NewStrItem(const AString: string; AObject: TObject): PStrItem;
  1401. var
  1402.   p: PStrItem;
  1403.   c: pchar;
  1404. begin
  1405.   GetMem(p, SizeOf(TStrItem));
  1406.   GetMem(c, Length(AString) + 1);
  1407.   StrPCopy(c, AString);
  1408.   p^.FObject := AObject;
  1409.   p^.FString := c;
  1410.   Result := p;
  1411. end;
  1412.  
  1413. function TQDBStringList.Add(const S: string): longint;
  1414. begin
  1415.   if not Sorted then
  1416.     Result := FList.Count
  1417.   else
  1418.     if Find(S, Result) then
  1419.       Error(SDuplicateKey, 0);
  1420.   FList.Insert(Result, NewStrItem(S, nil));
  1421. end;
  1422.  
  1423. function TQDBStringList.AddObject(const S: string; AObject: TObject):
  1424.   longint;
  1425. begin
  1426.   if not Sorted then
  1427.     Result := FList.Count
  1428.   else
  1429.     if Find(S, Result) then
  1430.       Error(SDuplicateKey, 0);
  1431.   FList.Insert(Result, NewStrItem(S, AObject));
  1432. end;
  1433.  
  1434. procedure TQDBStringList.Clear;
  1435. var
  1436.   i: longint;
  1437. begin
  1438.   for i := 1 to FList.Count do
  1439.   begin
  1440.     DisposeStrItem(FList[i - 1]);
  1441.     FList[i - 1] := nil;
  1442.   end;
  1443.   FList.Clear;
  1444. end;
  1445.  
  1446. procedure TQDBStringList.Delete(Index: longint);
  1447. begin
  1448.   DisposeStrItem(FList[Index]);
  1449.   FList.Delete(Index);
  1450. end;
  1451.  
  1452. procedure TQDBStringList.Error(const ErrMsg: string; Data: longint);
  1453. var
  1454.   StackTop: record
  1455.   end;
  1456.   Stack: record
  1457.     BPorEBP: integer; { 16 bit: BP, 32 bit: EBP }
  1458.     ReturnAddress: pointer;
  1459.   end absolute StackTop;
  1460. begin
  1461.   raise EQDBListError.CreateFmt(ErrMsg, [Data])at Stack.ReturnAddress;
  1462. end;
  1463.  
  1464. procedure TQDBStringList.Exchange(Index1, Index2: longint);
  1465. begin
  1466.   FList.Exchange(Index1, Index2);
  1467. end;
  1468.  
  1469. function TQDBStringList.Find(const S: string; var Index: longint): boolean;
  1470. var
  1471.   L, H, i, c: longint;
  1472. begin
  1473.   Result := false;
  1474.   L := 0;
  1475.   H := FList.Count - 1;
  1476.   while L <= H do
  1477.   begin
  1478.     i := (L + H) shr 1;
  1479.     if CaseSensitive then
  1480.       c := AnsiCompareStr(StrPas(PStrItem(FList[i])^.FString), S)
  1481.     else
  1482.       c := AnsiCompareText(StrPas(PStrItem(FList[i])^.FString), S);
  1483.     if c < 0 then
  1484.       L := i + 1
  1485.     else
  1486.     begin
  1487.       H := i - 1;
  1488.       if c = 0 then
  1489.       begin
  1490.         Result := true;
  1491.         L := i;
  1492.       end;
  1493.     end;
  1494.   end;
  1495.   Index := L;
  1496. end;
  1497.  
  1498. function TQDBStringList.Get(Index: longint): string;
  1499. begin
  1500.   Result := StrPas(PStrItem(FList[Index])^.FString);
  1501. end;
  1502.  
  1503. function TQDBStringList.GetCapacity: longint;
  1504. begin
  1505.   Result := FList.Capacity;
  1506. end;
  1507.  
  1508. function TQDBStringList.GetCount: longint;
  1509. begin
  1510.   Result := FList.Count;
  1511. end;
  1512.  
  1513. function TQDBStringList.GetObject(Index: longint): TObject;
  1514. begin
  1515.   Result := PStrItem(FList[Index])^.FObject;
  1516. end;
  1517.  
  1518. procedure TQDBStringList.Put(Index: longint; const S: string);
  1519. var
  1520.   p: PStrItem;
  1521. begin
  1522.   { get the old str item }
  1523.   p := FList[Index];
  1524.   { create and assign the new str item }
  1525.   FList[Index] := NewStrItem(S, p^.FObject);
  1526.   { get rid of the old one }
  1527.   DisposeStrItem(p);
  1528. end;
  1529.  
  1530. procedure TQDBStringList.PutObject(Index: longint; AObject: TObject);
  1531. var
  1532.   p: PStrItem;
  1533. begin
  1534.   p := FList[Index];
  1535.   FList[Index] := NewStrItem(Strings[Index], AObject);
  1536.   DisposeStrItem(p);
  1537. end;
  1538.  
  1539. procedure TQDBStringList.Reverse;
  1540. { the QDB index gets read in in reverse order ... this just reverses that }
  1541. { since it leaves the items in sorted order it is safe to set sorted to true }
  1542. var
  1543.   n, m: longint;
  1544. begin
  1545.   if Sorted then
  1546.     exit;
  1547.   n := 1;
  1548.   m := FList.Count;
  1549.   while n < m do
  1550.   begin
  1551.     FList.Exchange(n - 1, m - 1);
  1552.     inc(n);
  1553.     dec(m);
  1554.   end;
  1555.   FSorted := true;
  1556. end;
  1557.  
  1558. procedure TQDBStringList.SetCapacity(NewCapacity: longint);
  1559. begin
  1560.   FList.Capacity := NewCapacity;
  1561. end;
  1562.  
  1563. procedure TQDBStringList.SetCaseSensitive(Value: boolean);
  1564. var
  1565.   n: longint;
  1566. begin
  1567.   { if the list is empty it's easy ...}
  1568.   if Count = 0 then
  1569.     FCaseSensitive := Value
  1570.   else
  1571.   begin
  1572.     if FCaseSensitive <> Value then
  1573.     begin
  1574.       FCaseSensitive := Value;
  1575.       { if we are going from sensitive to insensitive we have extra work }
  1576.       if not FCaseSensitive then
  1577.       begin
  1578.         {check for duplicates and delete them }
  1579.         n := Count - 1;
  1580.         while n > 0 do
  1581.         begin
  1582.           if AnsiCompareText(Get(n - 1), Get(n)) = 0 then
  1583.             Delete(n);
  1584.           dec(n);
  1585.         end;
  1586.       end;
  1587.     end;
  1588.   end;
  1589. end;
  1590.  
  1591. procedure TQDBStringList.SetSorted(Value: boolean);
  1592. begin
  1593.   if FSorted <> Value then
  1594.     FSorted := Value;
  1595. end;
  1596.  
  1597. { ******* Index and cache records ******* }
  1598.  
  1599. type
  1600.   TIndex = class { each index object points to variable length data... }
  1601.     Pos: TFilePos; { it's location in the data file }
  1602.     Len: TDataIndex; { and it's length }
  1603.     Ext: TFlagSet; { additional flags }
  1604.   end;
  1605.  
  1606. type
  1607.   TCache = class
  1608.     FAge: longint;
  1609.     Stream: TMemoryStream; { the stream holds the data }
  1610.   public
  1611.     constructor Create(Data: TStream; Age: longint);
  1612.     destructor Destroy; override;
  1613.   end;
  1614.  
  1615.   { TCache }
  1616.  
  1617. constructor TCache.Create(Data: TStream; Age: longint);
  1618. begin
  1619.   inherited Create;
  1620.   FAge := Age;
  1621.   Stream := TMemoryStream.Create;
  1622.   Stream.LoadFromStream(Data);
  1623.   Data.Seek(0, 0);
  1624.   Stream.Seek(0, 0);
  1625. end;
  1626.  
  1627. destructor TCache.Destroy;
  1628. begin
  1629.   Stream.Free;
  1630.   inherited Destroy;
  1631. end;
  1632.  
  1633. { TIndexList }
  1634.  
  1635. destructor TIndexList.Destroy;
  1636. begin
  1637.   EmptyAndClear;
  1638.   inherited Destroy;
  1639. end;
  1640.  
  1641. procedure TIndexList.EmptyAndClear;
  1642. begin
  1643.   while Count > 0 do
  1644.   begin
  1645.     TIndex(Objects[Count - 1]).Free;
  1646.     Delete(Count - 1);
  1647.   end;
  1648. end;
  1649.  
  1650. { TCacheList }
  1651.  
  1652. constructor TCacheList.Create;
  1653. begin
  1654.   inherited Create;
  1655.   CaseSensitive := true;
  1656.   Sorted := true;
  1657.   FCurrentSize := 0;
  1658.   FMaximumSize := 64 * 1024; { default cache size 64K }
  1659.   FSuccesses := 0;
  1660.   FAttempts := 0;
  1661.   FDisposals := 0;
  1662.   FOldest := 0;
  1663. end;
  1664.  
  1665. destructor TCacheList.Destroy;
  1666. begin
  1667.   Flush;
  1668.   inherited Destroy;
  1669. end;
  1670.  
  1671. procedure TCacheList.Fetch(Stream: TStream; Place: longint);
  1672. var
  1673.   CacheRec: TCache;
  1674. begin
  1675.   CacheRec := TCache(Objects[Place]);
  1676.   CacheRec.Stream.SaveToStream(Stream);
  1677.   CacheRec.Stream.Seek(0, 0);
  1678.   { promote item in age list }
  1679.   inc(FOldest);
  1680.   CacheRec.FAge := FOldest;
  1681.   { update statistics }
  1682.   inc(FSuccesses);
  1683.   inc(FAttempts);
  1684. end;
  1685.  
  1686. procedure TCacheList.Flush;
  1687. { clear the item cache }
  1688. begin
  1689.   while Count > 0 do
  1690.   begin
  1691.     TCache(Objects[Count - 1]).Free;
  1692.     Delete(Count - 1);
  1693.   end;
  1694.   FCurrentSize := 0;
  1695.   FSuccesses := 0;
  1696.   FAttempts := 0;
  1697.   FDisposals := 0;
  1698.   FOldest := 0;
  1699. end;
  1700.  
  1701. function TCacheList.GetFrequency: integer;
  1702. { superceded by Statistics }
  1703. begin
  1704.   if FAttempts <> 0 then
  1705.     Result := Round((100.0 * FSuccesses) / FAttempts)
  1706.   else
  1707.     Result := 0;
  1708. end;
  1709.  
  1710. procedure TCacheList.MakeSpace;
  1711. { remove the oldest item from the cache ... }
  1712. var
  1713.   oldest: longint;
  1714.   oldestindex: longint;
  1715.   n: longint;
  1716.   oldestcache: TCache;
  1717. begin
  1718.   if Count < 1 then
  1719.     exit;
  1720.   oldest := maxint;
  1721.   oldestindex := 0;
  1722.   for n := 0 to Count - 1 do
  1723.   begin
  1724.     oldestcache := TCache(Objects[n]);
  1725.     if oldestcache.FAge < oldest then
  1726.     begin
  1727.       oldest := oldestcache.FAge;
  1728.       oldestindex := n;
  1729.     end;
  1730.   end;
  1731.   oldestcache := TCache(Objects[oldestindex]);
  1732.   dec(FCurrentSize, oldestcache.Stream.size);
  1733.   oldestcache.Free;
  1734.   Delete(oldestindex);
  1735.   inc(FDisposals);
  1736. end;
  1737.  
  1738. procedure TCacheList.Remove(Key: TKey);
  1739. { remove the specified item from the cache }
  1740. var
  1741.   CacheN: longint;
  1742. begin
  1743.   if Find(Key, CacheN) then
  1744.   begin
  1745.     dec(FCurrentSize, TCache(Objects[CacheN]).Stream.size);
  1746.     TCache(Objects[CacheN]).Free;
  1747.     Delete(CacheN);
  1748.   end
  1749. end;
  1750.  
  1751. procedure TCacheList.SetFrequency(Value: integer);
  1752. begin
  1753.   FSuccesses := 0;
  1754.   FAttempts := 0;
  1755.   FDisposals := 0;
  1756. end;
  1757.  
  1758. procedure TCacheList.SetSize(Value: longint);
  1759. { note: changing the cache size empties it }
  1760. begin
  1761.   Flush;
  1762.   FMaximumSize := Value;
  1763. end;
  1764.  
  1765. procedure TCacheList.Statistics(var MaxSize, CurSize, CurLen, HitRatio,
  1766.   DropRatio: longint);
  1767. begin
  1768.   if FAttempts = 0 then
  1769.   begin
  1770.     MaxSize := FMaximumSize;
  1771.     CurSize := 0;
  1772.     CurLen := 0;
  1773.     HitRatio := 0;
  1774.     DropRatio := 0;
  1775.   end
  1776.   else
  1777.   begin
  1778.     MaxSize := FMaximumSize;
  1779.     CurSize := FCurrentSize;
  1780.     CurLen := Count;
  1781.     HitRatio := (FSuccesses * 100) div FAttempts;
  1782.     DropRatio := (FDisposals * 100) div FAttempts;
  1783.   end;
  1784. end;
  1785.  
  1786. procedure TCacheList.Store(Stream: TStream; Key: TKey);
  1787. { add an item to the cache, making space if needed via MakeSpace }
  1788. var
  1789.   CacheRec: TCache;
  1790. begin
  1791.   { we don't try to cache items bigger than the limit }
  1792.   if Stream.size >= FMaximumSize then
  1793.     exit;
  1794.   { make room for the new entry by removing as many old ones as needed }
  1795.   while FCurrentSize + Stream.size > FMaximumSize do
  1796.     MakeSpace;
  1797.   inc(FOldest);
  1798.   try
  1799.     CacheRec := TCache.Create(Stream, FOldest);
  1800.   except
  1801.     exit;
  1802.   end;
  1803.   try
  1804.     AddObject(Key, CacheRec);
  1805.   except
  1806.     CacheRec.Free;
  1807.     exit;
  1808.   end;
  1809.   inc(FCurrentSize, CacheRec.Stream.size);
  1810.   inc(FAttempts);
  1811. end;
  1812.  
  1813. { TBFStream }
  1814.  
  1815. constructor TBFStream.Create(const FileName: string; Mode: word; BufferSize:
  1816.   longint);
  1817. { if BufferSize is -1 we try to get a buffer big enough for the whole file }
  1818. begin
  1819.   inherited Create(FileName, Mode);
  1820.   if BufferSize = -1 then
  1821.   begin
  1822.     BufferSize := inherited Seek(0, 2);
  1823.     inherited Seek(0, 0);
  1824.   end;
  1825.   {need to make sure we have zero byte at the end of the buffer}
  1826.   BufLen := GetBuffer(pointer(Buffer), BufferSize) - 1;
  1827.   IsDirty := false;
  1828.   ResetBuffer;
  1829. end;
  1830.  
  1831. destructor TBFStream.Destroy;
  1832. begin
  1833.   ResetBuffer;
  1834.   FreeMem(Buffer, BufLen + 1);
  1835.   inherited Destroy;
  1836. end;
  1837.  
  1838. procedure TBFStream.AdjustBuffer;
  1839. begin
  1840.   if IsDirty then
  1841.   begin
  1842.     Write(Buffer^, BufferPos - Buffer);
  1843.     IsDirty := false;
  1844.   end;
  1845.   FillChar(Buffer^, BufLen + 1, #0);
  1846.   inherited Seek(BufferPos - Buffer - BytesRead, 1);
  1847. end;
  1848.  
  1849. function TBFStream.GetKey(var k: TKey): boolean;
  1850. begin
  1851.   Result := false;
  1852.   if (BufferPos - Buffer + StrLen(BufferPos) + 1 > BytesRead) then
  1853.   begin
  1854.     if (BytesRead < BufLen) then
  1855.       exit
  1856.     else
  1857.     begin
  1858.       AdjustBuffer;
  1859.       BufferPos := Buffer;
  1860.       BytesRead := Read(Buffer^, BufLen);
  1861.       Result := GetKey(k);
  1862.     end;
  1863.   end
  1864.   else
  1865.   begin
  1866.     k := StrPas(BufferPos);
  1867.     inc(BufferPos, Length(k) + 1);
  1868.     Result := true;
  1869.   end;
  1870. end;
  1871.  
  1872. function TBFStream.GetLongint(var L: longint): boolean;
  1873. begin
  1874.   Result := false;
  1875.   if (BufferPos - Buffer + SizeOf(L) > BytesRead) then
  1876.   begin
  1877.     if (BytesRead < BufLen) then
  1878.       exit
  1879.     else
  1880.     begin
  1881.       AdjustBuffer;
  1882.       BufferPos := Buffer;
  1883.       BytesRead := Read(Buffer^, BufLen);
  1884.       Result := GetLongint(L);
  1885.     end;
  1886.   end
  1887.   else
  1888.   begin
  1889.     Move(BufferPos^, L, SizeOf(L));
  1890.     inc(BufferPos, SizeOf(L));
  1891.     Result := true;
  1892.   end;
  1893. end;
  1894.  
  1895. procedure TBFStream.PutKey(const k: TKey);
  1896. begin
  1897.   if (BufferPos - Buffer + Length(k) + 1 > BufLen) then
  1898.   begin
  1899.     ResetBuffer;
  1900.     BufferPos := Buffer;
  1901.   end;
  1902.   StrPCopy(BufferPos, k);
  1903.   inc(BufferPos, Length(k) + 1);
  1904.   IsDirty := true;
  1905. end;
  1906.  
  1907. procedure TBFStream.PutLongint(const L: longint);
  1908. begin
  1909.   if (BufferPos - Buffer + SizeOf(L) > BufLen) then
  1910.   begin
  1911.     ResetBuffer;
  1912.     BufferPos := Buffer;
  1913.   end;
  1914.   Move(L, BufferPos^, SizeOf(L));
  1915.   inc(BufferPos, SizeOf(L));
  1916.   IsDirty := true;
  1917. end;
  1918.  
  1919. procedure TBFStream.ResetBuffer;
  1920. begin
  1921.   if IsDirty then
  1922.   begin
  1923.     Write(Buffer^, BufferPos - Buffer);
  1924.     IsDirty := false;
  1925.   end;
  1926.   FillChar(Buffer^, BufLen + 1, #0);
  1927.   BufferPos := Buffer + BufLen;
  1928.   BytesRead := BufLen;
  1929. end;
  1930.  
  1931. function TBFStream.Seek(Offset: longint; Origin: word): longint;
  1932. begin
  1933.   ResetBuffer;
  1934.   Result := inherited Seek(Offset, Origin);
  1935. end;
  1936.  
  1937. { ******* Utility routine ******* }
  1938.  
  1939. function TempLocationValid: boolean;
  1940. var
  1941.   tfl: string;
  1942.   L: integer;
  1943. begin
  1944.   tfl := QDBTempFileLocation;
  1945.   Result := false;
  1946.   if tfl <> '' then
  1947.   begin
  1948.     tfl := ExpandFileName(tfl);
  1949.     L := Length(tfl);
  1950.     if tfl[L] = '\' then
  1951.     begin
  1952.       if tfl[L - 1] <> ':' then
  1953.         Delete(QDBTempFileLocation, Length(QDBTempFileLocation), 1);
  1954.       tfl := tfl + 'nul';
  1955.     end
  1956.     else
  1957.       tfl := tfl + '\nul';
  1958.     Result := FileExists(tfl);
  1959.   end;
  1960. end;
  1961.  
  1962. {$IFNDEF WIN32}
  1963. const
  1964.   MAX_PATH = 255;
  1965. {$ENDIF}
  1966.  
  1967. function TempFileName(Prefix: string): string;
  1968. { returns a unique name for a temp file }
  1969. const
  1970.   TmpStrLen = MAX_PATH;
  1971. var
  1972.   TmpName: pchar;
  1973.   TmpPath: pchar;
  1974. {$IFNDEF WIN32}
  1975.   Dummy: pchar;
  1976. {$ENDIF}
  1977. begin
  1978.   Result := '';
  1979.   GetMem(TmpName, TmpStrLen);
  1980.   try
  1981.     FillChar(TmpName^, TmpStrLen, #0);
  1982. {$IFDEF WIN32}
  1983.     GetMem(TmpPath, TmpStrLen);
  1984.     try
  1985.       FillChar(TmpPath^, TmpStrLen, #0);
  1986.       if TempLocationValid then
  1987.         StrPCopy(TmpPath, ExpandFileName(QDBTempFileLocation))
  1988.       else
  1989.         GetTempPath(TmpStrLen, TmpPath);
  1990.       GetTempFileName(TmpPath, pchar(Prefix), 0, TmpName);
  1991.       Result := TmpName;
  1992.     finally
  1993.       FreeMem(TmpPath, TmpStrLen);
  1994.     end;
  1995. {$ELSE}
  1996.     GetMem(Dummy, Length(Prefix) + 1);
  1997.     try
  1998.       GetTempFileName(#0, StrPCopy(Dummy, Prefix), 0, TmpName);
  1999.       Result := StrPas(TmpName);
  2000.     finally
  2001.       FreeMem(Dummy, Length(Prefix) + 1);
  2002.     end;
  2003. {$ENDIF}
  2004.   finally
  2005.     FreeMem(TmpName, TmpStrLen);
  2006.   end;
  2007. end;
  2008.  
  2009. procedure RenameOrMoveFile(const SrcFileName, DstFileName: string);
  2010. { if src and dst are on the same drive rename will work }
  2011. { if not we have to pysically move the file }
  2012. var
  2013.   FSrc: TFileStream;
  2014.   FDst: TFileStream;
  2015. begin
  2016.   {first get rid of the dst file }
  2017.   SysUtils.DeleteFile(DstFileName);
  2018.   { if a rename doesn't work we have to copy }
  2019.   if not RenameFile(SrcFileName, DstFileName) then
  2020.   begin
  2021.     FDst := TFileStream.Create(DstFileName, fmCreate);
  2022.     try
  2023.       FSrc := TFileStream.Create(SrcFileName, fmOpenRead);
  2024.       try
  2025.         FDst.CopyFrom(FSrc, FSrc.size);
  2026.       finally
  2027.         FSrc.Free;
  2028.       end;
  2029.     finally
  2030.       FDst.Free;
  2031.     end;
  2032.     SysUtils.DeleteFile(SrcFileName);
  2033.   end;
  2034. end;
  2035.  
  2036. { TTempBFStream }
  2037.  
  2038. const
  2039.   TmpFilePrefix = 'QDT';
  2040.  
  2041. constructor TTempBFStream.Create(const OldFileName: string);
  2042. begin
  2043.   TmpFileName := TempFileName(TmpFilePrefix);
  2044.   if TmpFileName = '' then
  2045.     raise EQDBIndexError.CreateFmt(STempFile, [FOldFileName]);
  2046.   inherited Create(TmpFileName, fmCreate or fmShareExclusive, 32 * 1024);
  2047.   FOldFileName := OldFileName;
  2048. end;
  2049.  
  2050. destructor TTempBFStream.Destroy;
  2051. begin
  2052.   inherited Destroy;
  2053.   if TmpFileName <> '' then
  2054.     RenameOrMoveFile(TmpFileName, FOldFileName);
  2055.   TmpFileName := '';
  2056.   FOldFileName := '';
  2057. end;
  2058.  
  2059. { GREP code ... a cut-down version of code graciously supplied by
  2060.   Gerald Nunn ... from his GExperts Delphi add-in
  2061.   (http://www.amano-blick.com/~gnunn/GExperts.htm). Any problems
  2062.   with this code are mine rather than his. }
  2063.  
  2064. const
  2065.   opCHAR = 1;
  2066.   opBOL = 2;
  2067.   opEOL = 3;
  2068.   opANY = 4;
  2069.   opCLASS = 5;
  2070.   opNCLASS = 6;
  2071.   opSTAR = 7;
  2072.   opBOW = 8; {opPLUS = 8;}
  2073.   opEOW = 9; {opMINUS = 9;}
  2074.   opALPHA = 10;
  2075.   opDIGIT = 11;
  2076.   opNALPHA = 12;
  2077.   opPUNCT = 13;
  2078.   opRANGE = 14;
  2079.   opENDPAT = 15;
  2080.  
  2081. function LoCase(ch: char): char;
  2082. begin
  2083.   if (ch >= 'A') and (ch <= 'Z') then
  2084.     inc(ch, 32);
  2085.   Result := ch;
  2086. end;
  2087.  
  2088. function GrepMatch(const S, Pattern: string; CaseSensitive, WholeWord: boolean
  2089.   ): boolean;
  2090. var
  2091.   L: integer;
  2092.   FixBOL: boolean; { beginning of line }
  2093.   FixBOW: boolean; { beginning of word }
  2094.   FString: pchar;
  2095.   FStrLen: integer;
  2096.   FPattern: pchar;
  2097.   PatternOK: boolean;
  2098.  
  2099.   procedure CompilePattern(Source: string);
  2100.   var
  2101.     lp: integer; {Last Pattern Pointer}
  2102.     c: integer; {Current Character}
  2103.  
  2104.     procedure Store(ch: char);
  2105.     begin
  2106.       if not CaseSensitive then
  2107.         FPattern[lp] := LoCase(ch)
  2108.       else
  2109.         FPattern[lp] := ch;
  2110.       inc(lp);
  2111.     end;
  2112.  
  2113.     procedure cclass;
  2114.     var
  2115.       cstart: integer;
  2116.     begin
  2117.       cstart := c;
  2118.       inc(c);
  2119.       if Source[c] = '^' then
  2120.         Store(char(opNCLASS))
  2121.       else
  2122.         Store(char(opCLASS));
  2123.  
  2124.       while (c <= Length(Source)) and (Source[c] <> ']') do
  2125.       begin
  2126.         if (Source[c] = '\') and (c < Length(Source)) and (Source[c + 1
  2127.           ] = '\') then
  2128.         begin
  2129.           Store(Source[c + 2]);
  2130.           inc(c, 3);
  2131.         end
  2132.         else
  2133.           if (Source[c] = '-') and (c - cstart > 1) and (Source[c + 1]
  2134.             <>
  2135.             ']') and (c < Length(Source)) then
  2136.           begin
  2137.             dec(lp, 2);
  2138.             Store(char(opRANGE));
  2139.             Store(Source[c - 1]);
  2140.             Store(Source[c + 1]);
  2141.             inc(c, 2);
  2142.           end
  2143.           else
  2144.           begin
  2145.             Store(Source[c]);
  2146.             inc(c);
  2147.           end;
  2148.       end;
  2149.       if (Source[c] <> ']') or (c > Length(Source)) then
  2150.       begin
  2151.         PatternOK := false;
  2152.         exit;
  2153.       end;
  2154.       inc(c);
  2155.     end;
  2156.  
  2157.   begin
  2158.     try
  2159.       c := 1;
  2160.       lp := 0;
  2161.       while c <= Length(Source) do
  2162.       begin
  2163.         case Source[c] of
  2164.           '^': { beginning of line }
  2165.             begin
  2166.               if c = 1 then
  2167.                 FixBOL := true
  2168.               else
  2169.               begin
  2170.                 PatternOK := false;
  2171.                 exit;
  2172.               end;
  2173.               inc(c);
  2174.             end;
  2175.           '%': { beginning of word }
  2176.             begin
  2177.               if c = 1 then
  2178.                 FixBOW := true
  2179.               else
  2180.               begin
  2181.                 PatternOK := false;
  2182.                 exit;
  2183.               end;
  2184.               inc(c);
  2185.             end;
  2186.           '$': { end of line }
  2187.             begin
  2188.               if c <> Length(Source) then
  2189.               begin
  2190.                 PatternOK := false;
  2191.                 exit;
  2192.               end;
  2193.               Store(char(opEOL));
  2194.               inc(c);
  2195.             end;
  2196.           '&': { end of word }
  2197.             begin
  2198.               if c <> Length(Source) then
  2199.               begin
  2200.                 PatternOK := false;
  2201.                 exit;
  2202.               end;
  2203.               Store(char(opEOW));
  2204.               inc(c);
  2205.             end;
  2206.           '.':
  2207.             begin
  2208.               Store(char(opANY));
  2209.               inc(c);
  2210.             end;
  2211.           '[':
  2212.             cclass;
  2213.           ':':
  2214.             begin
  2215.               if c < Length(Source) then
  2216.               begin
  2217.                 case UpCase(Source[c + 1]) of
  2218.                   'A':
  2219.                     Store(char(opALPHA));
  2220.                   'D':
  2221.                     Store(char(opDIGIT));
  2222.                   'N':
  2223.                     Store(char(opNALPHA));
  2224.                   ' ':
  2225.                     Store(char(opPUNCT));
  2226.                 else
  2227.                   begin
  2228.                     Store(char(opENDPAT));
  2229.                     PatternOK := false;
  2230.                     exit;
  2231.                   end;
  2232.                 end;
  2233.                 inc(c, 2);
  2234.               end;
  2235.             end;
  2236.           '\':
  2237.             begin
  2238.               if c < Length(Source) then
  2239.                 if Source[c + 1] = '\' then
  2240.                 begin
  2241.                   Store(char(opCHAR));
  2242.                   Store(Source[c + 2]);
  2243.                   inc(c, 3);
  2244.                 end
  2245.                 else
  2246.                 begin
  2247.                   Store(char(opCHAR));
  2248.                   Store(Source[c]);
  2249.                   inc(c);
  2250.                 end
  2251.               else
  2252.               begin
  2253.                 Store(char(opCHAR));
  2254.                 Store(Source[c]);
  2255.                 inc(c);
  2256.               end;
  2257.             end;
  2258.         else
  2259.           begin
  2260.             Store(char(opCHAR));
  2261.             Store(Source[c]);
  2262.             inc(c);
  2263.           end;
  2264.         end;
  2265.       end;
  2266.     finally
  2267.       Store(char(opENDPAT));
  2268.       Store(#0);
  2269.     end;
  2270.   end;
  2271.  
  2272.   function PatternMatch: boolean;
  2273.   var
  2274.     L, p: integer; {line and pattern pointers}
  2275.     op: integer; {Pattern operation}
  2276.     LinePos: integer;
  2277.  
  2278.     function IsFound: boolean;
  2279.     var
  2280.       S, E: integer;
  2281.     begin
  2282.       Result := false;
  2283.       if WholeWord then
  2284.       begin
  2285.         S := LinePos - 2;
  2286.         E := L;
  2287.         if (S > 0) then
  2288.           if (LoCase(FString[S]) >= 'a') and (LoCase(FString[S]) <=
  2289.             'z') then
  2290.             exit;
  2291.         if (FString[E] <> #0) then
  2292.           if (LoCase(FString[E]) >= 'a') and (LoCase(FString[E]) <=
  2293.             'z') then
  2294.             exit;
  2295.       end;
  2296.       if FixBOL and (LinePos <> 1) then
  2297.         exit;
  2298.       if (FixBOW) and not ((LinePos = 1) or (FString[LinePos - 2] = ' ')
  2299.         or (FString[LinePos - 2] <= #64)) then
  2300.         exit;
  2301.       Result := true;
  2302.     end;
  2303.  
  2304.   begin
  2305.     Result := false;
  2306.     if not PatternOK then
  2307.       exit;
  2308.     if FString[0] = #0 then
  2309.       exit;
  2310.     if integer(FPattern[0]) = opENDPAT then
  2311.       exit;
  2312.     if not CaseSensitive then
  2313.       StrLower(FString);
  2314.  
  2315.     LinePos := 0;
  2316.  
  2317.     {Don't bother pattern matching if first search is opCHAR, just go to first match directly}
  2318.     {Results in about a 5% to 10% speed increase}
  2319.     if (integer(FPattern[0]) = opCHAR) and not CaseSensitive then
  2320.       while (FPattern[1] <> FString[LinePos]) and (FString[LinePos] <>
  2321.         #0) do
  2322.         inc(LinePos);
  2323.  
  2324.     while FString[LinePos] <> #0 do
  2325.     begin
  2326.       L := LinePos;
  2327.       p := 0;
  2328.       op := integer(FPattern[p]);
  2329.       while (op <> opENDPAT) do
  2330.       begin
  2331.         case op of
  2332.           opCHAR:
  2333.             begin
  2334.               if not (FString[L] = FPattern[p + 1]) then
  2335.                 Break;
  2336.               inc(p, 2);
  2337.             end;
  2338.           opEOL:
  2339.             begin
  2340.               if L = FStrLen then
  2341.               begin
  2342.                 inc(LinePos);
  2343.                 Result := IsFound;
  2344.               end;
  2345.               exit;
  2346.             end;
  2347.           opEOW:
  2348.             begin
  2349.               if (L = FStrLen) or (FString[L] = ' ') or (FString[L] <
  2350.                 #64) then
  2351.               begin
  2352.                 inc(LinePos);
  2353.                 Result := IsFound;
  2354.               end;
  2355.               exit;
  2356.             end;
  2357.           opANY:
  2358.             begin
  2359.               if (FString[L] = #13) or (FString[L] = #10) or (FString[L
  2360.                 ] = #0) then
  2361.                 Break;
  2362.               inc(p);
  2363.             end;
  2364.           opCLASS:
  2365.             begin
  2366.               inc(p);
  2367.               {Compare letters to find a match}
  2368.               while (FPattern[p] > #15) and (FPattern[p] <> FString[L]) do
  2369.                 inc(p);
  2370.               {Was a match found?}
  2371.               if (FPattern[p] <= #15) then
  2372.                 Break;
  2373.               {move FPattern pointer to next opcode}
  2374.               while (FPattern[p] > #15) do
  2375.                 inc(p);
  2376.             end;
  2377.           opNCLASS:
  2378.             begin
  2379.               inc(p);
  2380.               {Compare letters to find a match}
  2381.               while (FPattern[p] > #15) and (FPattern[p] <> FString[L]) do
  2382.                 inc(p);
  2383.               if (FPattern[p] > #15) then
  2384.                 Break;
  2385.             end;
  2386.           opALPHA:
  2387.             begin
  2388.               if (LoCase(FString[L]) < 'a') or (LoCase(FString[L]) >
  2389.                 'z') then
  2390.                 Break;
  2391.               inc(p);
  2392.             end;
  2393.           opDIGIT:
  2394.             begin
  2395.               if (FString[L] < '0') or (FString[L] > '9') then
  2396.                 Break;
  2397.               inc(p);
  2398.             end;
  2399.           opNALPHA:
  2400.             begin
  2401.               if (LoCase(FString[L]) > 'a') or (LoCase(FString[L]) <
  2402.                 'z') then
  2403.                 Break;
  2404.               inc(p);
  2405.             end;
  2406.           opPUNCT:
  2407.             begin
  2408.               if (FString[L] = ' ') or (FString[L] > #64) then
  2409.                 Break;
  2410.               inc(p);
  2411.             end;
  2412.           opRANGE:
  2413.             begin
  2414.               if (FString[L] < FPattern[p + 1]) or (FString[L] >
  2415.                 FPattern[p + 2]) then
  2416.                 Break;
  2417.               inc(p, 3);
  2418.             end;
  2419.         else
  2420.           inc(p);
  2421.         end; {End Case}
  2422.         op := integer(FPattern[p]);
  2423.         inc(L);
  2424.       end; {End While op<>opENDPAT}
  2425.       inc(LinePos);
  2426.       if op = opENDPAT then
  2427.         Result := IsFound;
  2428.     end; {While FString[LinePos]<>#0}
  2429.   end;
  2430.  
  2431. begin
  2432.   L := Length(S) + 1;
  2433.   FString := StrAlloc(L);
  2434.   FillChar(FString^, L, #0);
  2435.   FString := StrPCopy(FString, S);
  2436.   FStrLen := StrLen(FString);
  2437.   FPattern := StrAlloc(512);
  2438.   FixBOL := false;
  2439.   FixBOW := false;
  2440.   PatternOK := true;
  2441.  
  2442.   CompilePattern(Pattern);
  2443.   if PatternOK then
  2444.     Result := PatternMatch
  2445.   else
  2446.     Result := true;
  2447.  
  2448.   StrDispose(FString);
  2449.   StrDispose(FPattern);
  2450. end;
  2451.  
  2452. { TQDB }
  2453.  
  2454. constructor TQDB.Create(AOwner: TComponent);
  2455. begin
  2456.   inherited Create(AOwner);
  2457.   try
  2458.     Index := TIndexList.Create;
  2459.     Index.Sorted := true;
  2460.     Cache := TCacheList.Create;
  2461.     Admin := TIndexList.Create;
  2462.     Admin.Sorted := true;
  2463.     SetReady(false);
  2464.     FItemIndex := 0;
  2465.     FAdminIndex := 0;
  2466.     FKey := '';
  2467.     FCount := Index.Count;
  2468.     FReadOnly := false;
  2469.     FFrontWild := '<';
  2470.     FBackWild := '>';
  2471.     FVersion := FileVersion;
  2472.     FAuthor := AuthorInfo;
  2473.     FUpdating := 0;
  2474.     FSaveOnClose := true;
  2475.     FExpandedFileNames := true;
  2476.     UseGrepMatch := false;
  2477.     Restructuring := false;
  2478.   except
  2479.     Index.Free;
  2480.     Cache.Free;
  2481.     Admin.Free;
  2482.     raise;
  2483.   end;
  2484. end;
  2485.  
  2486. destructor TQDB.Destroy;
  2487. begin
  2488.   if Live and (FFileName <> '') then
  2489.     CloseQDB;
  2490.   Index.Free;
  2491.   Cache.Free;
  2492.   Admin.Free;
  2493.   FItemIndex := 0;
  2494.   inherited Destroy;
  2495. end;
  2496.  
  2497. procedure TQDB.AboutToKill(var OK: boolean);
  2498. begin
  2499.   if Assigned(FBeforeKill) then
  2500.     FBeforeKill(Self, OK);
  2501. end;
  2502.  
  2503. procedure TQDB.AboutToOverWrite(var OK: boolean);
  2504. begin
  2505.   if Assigned(FBeforeOverWrite) then
  2506.     FBeforeOverWrite(Self, OK);
  2507. end;
  2508.  
  2509. procedure TQDB.Add(Stream: TStream; Key: TKey);
  2510. { add an item to the file -- this is now the method of choice }
  2511. var
  2512.   IndRec: TIndex;
  2513. begin
  2514.   if not FReady then
  2515.     raise EQDBNoFile.Create(SNoFile);
  2516.   Stream.Seek(0, 0);
  2517.   if ReadOnly then
  2518.     CannotChange
  2519.   else
  2520.   begin
  2521.     try
  2522.       IndRec := TIndex.Create;
  2523.     except
  2524.       IndexError(SIndexAdd);
  2525.     end;
  2526.     IndRec.Pos := QDBFile.Seek(0, 2);
  2527.     if IndRec.Pos < 0 then
  2528.       FileError(-1, SCorrupt);
  2529.     try
  2530.       FItemIndex := Index.AddObject(Key, IndRec);
  2531.     except
  2532.       IndRec.Free;
  2533.       IndexError(SDuplicateKey);
  2534.     end;
  2535.     FKey := GetKey(FItemIndex);
  2536.     Cache.Store(Stream, Index.Strings[FItemIndex]);
  2537.     if Compression then
  2538.     begin
  2539.       TIndex(Index.Objects[FItemIndex]).Len := SquashStream(Stream, QDBFile
  2540.         );
  2541.       TIndex(Index.Objects[FItemIndex]).Ext := TIndex(Index.Objects[
  2542.         FItemIndex]).Ext + [IsCompressed];
  2543.     end
  2544.     else
  2545.     begin
  2546.       TIndex(Index.Objects[FItemIndex]).Len := QDBFile.CopyFrom(Stream,
  2547.         Stream.size);
  2548.       TIndex(Index.Objects[FItemIndex]).Ext := TIndex(Index.Objects[
  2549.         FItemIndex]).Ext - [IsCompressed];
  2550.     end;
  2551.     FCount := Index.Count;
  2552.     IsDirty := true;
  2553.     Added;
  2554.     if (FUpdating = 0) then
  2555.       Navigate;
  2556.   end;
  2557.   Stream.Seek(0, 0);
  2558. end;
  2559.  
  2560. procedure TQDB.Added;
  2561. begin
  2562.   if Assigned(FOnAdded) then
  2563.     FOnAdded(Self);
  2564. end;
  2565.  
  2566. procedure TQDB.AddItem(ItemPtr: pointer; ItemLen: TDataIndex; Key: TKey);
  2567. { add an item to the file -- if you can, use Add instead }
  2568. var
  2569.   TmpStream: TMemoryStream;
  2570. begin
  2571.   TmpStream := TMemoryStream.Create;
  2572.   try
  2573.     TmpStream.Write(ItemPtr^, ItemLen);
  2574.     Add(TmpStream, Key);
  2575.   finally
  2576.     TmpStream.Free;
  2577.   end;
  2578. end;
  2579.  
  2580. procedure TQDB.AddStreamItem(Stream: TStream; Key: TKey);
  2581. { add an item to the file -- provided for compatibility }
  2582. { -- use Add instead }
  2583. begin
  2584.   Add(Stream, Key);
  2585. end;
  2586.  
  2587. procedure TQDB.AdminAddItem(ItemPtr: pointer; ItemLen: TDataIndex; Key: TKey
  2588.   );
  2589. var
  2590.   IndRec: TIndex;
  2591. begin
  2592.   if not FReady then
  2593.     raise EQDBNoFile.Create(SNoFile);
  2594.   if ReadOnly then
  2595.     CannotChange
  2596.   else
  2597.   begin
  2598.     try
  2599.       IndRec := TIndex.Create;
  2600.     except
  2601.       IndexError(SIndexAdd);
  2602.     end;
  2603.     IndRec.Pos := QDBFile.Seek(0, 2);
  2604.     if IndRec.Pos < 0 then
  2605.       FileError(-1, SCorrupt);
  2606.     IndRec.Len := ItemLen;
  2607.     IndRec.Ext := IndRec.Ext + [IsAdminItem];
  2608.     try
  2609.       FAdminIndex := Admin.AddObject(Key, IndRec);
  2610.     except
  2611.       IndRec.Free;
  2612.       IndexError(SDuplicateKey);
  2613.     end;
  2614.     if QDBFile.Write(ItemPtr^, ItemLen) <> ItemLen then
  2615.       IndexError(SDataAdd);
  2616.     IsDirty := true;
  2617.   end;
  2618. end;
  2619.  
  2620. procedure TQDB.AdminChangeItem(ItemPtr: pointer; ItemLen: TDataIndex);
  2621. var
  2622.   ThisKey: TKey;
  2623.   IndRec: TIndex;
  2624. begin
  2625.   if not FReady then
  2626.     raise EQDBNoFile.Create(SNoFile);
  2627.   if Admin.Count < 1 then
  2628.     NoData
  2629.   else
  2630.     if ReadOnly then
  2631.       CannotChange
  2632.     else
  2633.     begin
  2634.       ThisKey := Admin.Strings[FAdminIndex];
  2635.       if ItemLen <= AdminItemSize then
  2636.       begin {just write on top of the old}
  2637.         with TIndex(Admin.Objects[FAdminIndex]) do
  2638.         begin
  2639.           QDBFile.Seek(Pos, 0);
  2640.           Len := ItemLen;
  2641.         end;
  2642.       end
  2643.       else
  2644.       begin
  2645.         TIndex(Admin.Objects[FAdminIndex]).Free;
  2646.         Admin.Delete(FAdminIndex);
  2647.         try
  2648.           IndRec := TIndex.Create;
  2649.         except
  2650.           IndexError(SIndexAdd);
  2651.         end;
  2652.         IndRec.Pos := QDBFile.Seek(0, 2);
  2653.         if IndRec.Pos < 0 then
  2654.           FileError(-1, SDataAdd);
  2655.         IndRec.Len := ItemLen;
  2656.         IndRec.Ext := IndRec.Ext + [IsAdminItem];
  2657.         try
  2658.           FAdminIndex := Admin.AddObject(ThisKey, IndRec);
  2659.         except
  2660.           IndRec.Free;
  2661.           raise
  2662.         end;
  2663.       end;
  2664.       if QDBFile.Write(ItemPtr^, ItemLen) <> ItemLen then
  2665.         FileError(-1, SDataAdd);
  2666.       IsDirty := true;
  2667.     end;
  2668. end;
  2669.  
  2670. procedure TQDB.AdminClear(StartOfKey: TKey);
  2671. var
  2672.   TmpList: TStringList;
  2673.   i: integer;
  2674. begin
  2675.   if StartOfKey = '' then
  2676.   begin
  2677.     Admin.EmptyAndClear;
  2678.     FAdminIndex := 0;
  2679.   end
  2680.   else
  2681.   begin
  2682.     TmpList := TStringList.Create;
  2683.     try
  2684.       AdminKeys(TmpList, StartOfKey);
  2685.       for i := 0 to TmpList.Count - 1 do
  2686.         AdminDelete(TmpList[i]);
  2687.     finally
  2688.       TmpList.Free;
  2689.     end;
  2690.   end;
  2691. end;
  2692.  
  2693. function TQDB.AdminCount: TItemIndex;
  2694. { nb not a property like TQDB.Count }
  2695. begin
  2696.   Result := Admin.Count;
  2697. end;
  2698.  
  2699. procedure TQDB.AdminDelete(Key: TKey);
  2700. begin
  2701.   if not FReady then
  2702.     raise EQDBNoFile.Create(SNoFile);
  2703.   if ReadOnly then
  2704.     CannotChange
  2705.   else
  2706.     if not AdminExactMatch(Key) then
  2707.       raise EQDBBadKey.Create(SBadKey)
  2708.     else
  2709.     begin
  2710.       TIndex(Admin.Objects[FAdminIndex]).Free;
  2711.       Admin.Delete(FAdminIndex);
  2712.       if FAdminIndex > 0 then
  2713.         FAdminIndex := FAdminIndex - 1;
  2714.       IsDirty := true;
  2715.     end;
  2716. end;
  2717.  
  2718. function TQDB.AdminExactMatch(Key: TKey): boolean;
  2719. { generally you will know what items are stored -- use }
  2720. { this function to locate the key you want }
  2721. var
  2722.   n: TItemIndex;
  2723. begin
  2724.   Result := Admin.Find(Key, n);
  2725.   if Result then
  2726.     FAdminIndex := n;
  2727. end;
  2728.  
  2729. function TQDB.AdminGetBoolean(Key: TKey): boolean;
  2730. var
  2731.   Buffer: pointer;
  2732.   BufLen: longint;
  2733. begin
  2734.   Result := false;
  2735.   if AdminExactMatch(Key) then
  2736.   begin
  2737.     BufLen := AdminItemSize;
  2738.     if BufLen = SizeOf(boolean) then
  2739.     begin
  2740.       GetMem(Buffer, BufLen);
  2741.       try
  2742.         AdminGetItem(Buffer);
  2743.         Result := Byte(Buffer^) = 1;
  2744.       finally
  2745.         FreeMem(Buffer, BufLen);
  2746.       end;
  2747.     end;
  2748.   end
  2749.   else
  2750.     raise EQDBBadKey.CreateFmt(SBadKey, [Key]);
  2751. end;
  2752.  
  2753. function TQDB.AdminGetInteger(Key: TKey): longint;
  2754. var
  2755.   Buffer: pointer;
  2756.   BufLen: longint;
  2757. begin
  2758.   Result := 0;
  2759.   if AdminExactMatch(Key) then
  2760.   begin
  2761.     BufLen := AdminItemSize;
  2762.     if BufLen = SizeOf(longint) then
  2763.     begin
  2764.       GetMem(Buffer, BufLen);
  2765.       try
  2766.         AdminGetItem(Buffer);
  2767.         Result := longint(Buffer^);
  2768.       finally
  2769.         FreeMem(Buffer, BufLen);
  2770.       end;
  2771.     end;
  2772.   end
  2773.   else
  2774.     raise EQDBBadKey.CreateFmt(SBadKey, [Key]);
  2775. end;
  2776.  
  2777. procedure TQDB.AdminGetItem(ItemPtr: pointer);
  2778. begin
  2779.   if not FReady then
  2780.     raise EQDBNoFile.Create(SNoFile);
  2781.   if Admin.Count > 0 then
  2782.   begin
  2783.     try
  2784.       QDBFile.Seek(TIndex(Admin.Objects[FAdminIndex]).Pos, 0);
  2785.       QDBFile.Read(ItemPtr^, TIndex(Admin.Objects[FAdminIndex]).Len);
  2786.     except
  2787.       IndexError(SCorrupt);
  2788.     end;
  2789.   end
  2790.   else
  2791.     NoData;
  2792. end;
  2793.  
  2794. function TQDB.AdminGetString(Key: TKey): string;
  2795. var
  2796.   Buffer: pointer;
  2797.   BufLen: longint;
  2798. begin
  2799.   Result := '';
  2800.   if AdminExactMatch(Key) then
  2801.   begin
  2802.     BufLen := AdminItemSize;
  2803. {$IFNDEF WIN32}
  2804.     if BufLen > 255 then
  2805.       BufLen := 255;
  2806. {$ENDIF}
  2807.     if BufLen > 0 then
  2808.     begin
  2809.       GetMem(Buffer, BufLen);
  2810.       try
  2811.         AdminGetItem(Buffer);
  2812.         Result := StrPas(pchar(Buffer));
  2813.       finally
  2814.         FreeMem(Buffer, BufLen);
  2815.       end;
  2816.     end;
  2817.   end
  2818.   else
  2819.     raise EQDBBadKey.CreateFmt(SBadKey, [Key]);
  2820. end;
  2821.  
  2822. function TQDB.AdminItemSize: TDataIndex;
  2823. begin
  2824.   if Admin.Count < 1 then
  2825.   begin
  2826.     Result := 0;
  2827.     NoData;
  2828.   end
  2829.   else
  2830.     Result := TIndex(Admin.Objects[FAdminIndex]).Len;
  2831. end;
  2832.  
  2833. function TQDB.AdminKeyExists(Key: TKey): boolean;
  2834. begin
  2835.   Result := AdminExactMatch(Key);
  2836. end;
  2837.  
  2838. function TQDB.AdminKeys(Keys: TStrings; StartOfKey: TKey): longint;
  2839. { makes a list of all the Admin keys }
  2840. var
  2841.   ThisItem: TItemIndex;
  2842.   ThisKey: TKey;
  2843.   Len: longint;
  2844. begin
  2845.   TStringList(Keys).Clear;
  2846.   for ThisItem := 1 to Admin.Count do
  2847.   begin
  2848.     ThisKey := Admin.Strings[ThisItem - 1];
  2849.     Len := Length(StartOfKey);
  2850.     if Copy(ThisKey, 1, Len) = StartOfKey then
  2851.       Keys.Add(ThisKey);
  2852.   end;
  2853.   Result := Keys.Count;
  2854. end;
  2855.  
  2856. procedure TQDB.AdminSetBoolean(Key: TKey; b: boolean);
  2857. begin
  2858.   if AdminExactMatch(Key) then
  2859.     AdminChangeItem(@b, SizeOf(b))
  2860.   else
  2861.     AdminAddItem(@b, SizeOf(b), Key);
  2862. end;
  2863.  
  2864. procedure TQDB.AdminSetInteger(Key: TKey; n: longint);
  2865. begin
  2866.   if AdminExactMatch(Key) then
  2867.     AdminChangeItem(@n, SizeOf(n))
  2868.   else
  2869.     AdminAddItem(@n, SizeOf(n), Key);
  2870. end;
  2871.  
  2872. procedure TQDB.AdminSetString(Key: TKey; const S: string);
  2873. var
  2874.   p: pchar;
  2875. begin
  2876.   p := StrAlloc(Length(S) + 1);
  2877.   try
  2878.     StrPCopy(p, S);
  2879.     if AdminExactMatch(Key) then
  2880.       AdminChangeItem(p, Length(S) + 1)
  2881.     else
  2882.       AdminAddItem(p, Length(S) + 1, Key);
  2883.   finally
  2884.     StrDispose(p);
  2885.   end;
  2886. end;
  2887.  
  2888. procedure TQDB.AssignKeyList(Keys: TStrings);
  2889. { Copies the in-memory list of keys to the Keys parameter. }
  2890. { Items that are filtered out are not included. }
  2891. var
  2892.   ThisItem: TItemIndex;
  2893.   ThisKey: TKey;
  2894.   WasSorted: boolean;
  2895. begin
  2896.   TStringList(Keys).Clear;
  2897.   { TStrings has no sort method but TStringList does }
  2898.   if Keys is TStringList then
  2899.   begin
  2900.     WasSorted := TStringList(Keys).Sorted;
  2901.     TStringList(Keys).Sorted := false;
  2902.   end;
  2903.   MonitorSetup(Index.Count, prKeyList);
  2904.   for ThisItem := 1 to Index.Count do
  2905.   begin
  2906.     MonitorUpdate(ThisItem);
  2907.     if Filtered then
  2908.     begin
  2909.       ThisKey := GetKey(ThisItem - 1);
  2910.       if Matches(ThisKey, FFilter) then
  2911.         TStringList(Keys).Add(ThisKey);
  2912.     end
  2913.     else
  2914.       TStringList(Keys).Add(GetKey(ThisItem - 1));
  2915.   end;
  2916.   if Keys is TStringList then
  2917.     TStringList(Keys).Sorted := WasSorted;
  2918.   MonitorZero;
  2919. end;
  2920.  
  2921. procedure TQDB.BeginUpdate;
  2922. begin
  2923.   inc(FUpdating);
  2924. end;
  2925.  
  2926. procedure TQDB.CacheFlush;
  2927. begin
  2928.   Cache.Flush;
  2929. end;
  2930.  
  2931. procedure TQDB.CacheStatistics(var MaxSize, CurSize, CurLen, HitRatio, DropRatio
  2932.   : longint);
  2933. begin
  2934.   Cache.Statistics(MaxSize, CurSize, CurLen, HitRatio, DropRatio);
  2935. end;
  2936.  
  2937. procedure TQDB.DoCancel;
  2938. begin
  2939.   if not AutoEdit then
  2940.     FEditing := false;
  2941.   FInserting := false;
  2942.   UpdateNavigator;
  2943. end;
  2944.  
  2945. procedure TQDB.Cancel;
  2946. begin
  2947.   if Assigned(FBeforeCancel) then
  2948.     FBeforeCancel(Self);
  2949.   DoCancel;
  2950.   if Assigned(FAfterCancel) then
  2951.     FAfterCancel(Self);
  2952. end;
  2953.  
  2954. procedure TQDB.CannotChange;
  2955. { If a warning handler has not been assigned an exception is raised }
  2956. { To silence exceptions assign at least an empty handler }
  2957. begin
  2958.   if Assigned(FWarnReadOnly) then
  2959.     FWarnReadOnly(Self)
  2960.   else
  2961.     raise EQDBReadOnly.CreateFmt(SReadOnly, [FFileName]);
  2962. end;
  2963.  
  2964. procedure TQDB.Change(Stream: TStream);
  2965. { Change the contents of the current stream item }
  2966. { This is the change method of choice -- use it }
  2967. var
  2968.   ThisKey: TKey;
  2969.   IndRec: TIndex;
  2970.   TmpStream: TMemoryStream;
  2971. begin
  2972.   if not FReady then
  2973.     raise EQDBNoFile.Create(SNoFile);
  2974.   if Index.Count < 1 then
  2975.     NoData
  2976.   else
  2977.     if ReadOnly then
  2978.       CannotChange
  2979.     else
  2980.     begin
  2981.       Stream.Seek(0, 0);
  2982.       Cache.Remove(Index.Strings[FItemIndex]);
  2983.       ThisKey := GetKey(FItemIndex);
  2984.       TmpStream := TMemoryStream.Create;
  2985.       if Compression then
  2986.         SquashStream(Stream, TmpStream)
  2987.       else
  2988.         TmpStream.LoadFromStream(Stream);
  2989.       TmpStream.Seek(0, 0);
  2990.       if TmpStream.size <= TIndex(Index.Objects[FItemIndex]).Len then
  2991.       begin {just write on top of the old}
  2992.         with TIndex(Index.Objects[FItemIndex]) do
  2993.         begin
  2994.           QDBFile.Seek(Pos, 0);
  2995.           Len := TmpStream.size;
  2996.           if Compression then
  2997.             Ext := Ext + [IsCompressed]
  2998.           else
  2999.             Ext := Ext - [IsCompressed];
  3000.         end;
  3001.       end
  3002.       else
  3003.       begin
  3004.         TIndex(Index.Objects[FItemIndex]).Free;
  3005.         Index.Delete(FItemIndex);
  3006.         try
  3007.           IndRec := TIndex.Create;
  3008.         except
  3009.           IndexError(SIndexAdd);
  3010.         end;
  3011.         IndRec.Pos := QDBFile.Seek(0, 2);
  3012.         if IndRec.Pos < 0 then
  3013.           FileError(-1, SDataAdd);
  3014.         IndRec.Len := TmpStream.size;
  3015.         if Compression then
  3016.           IndRec.Ext := IndRec.Ext + [IsCompressed]
  3017.         else
  3018.           IndRec.Ext := IndRec.Ext - [IsCompressed];
  3019.         try
  3020.           FItemIndex := Index.AddObject(ThisKey, IndRec);
  3021.         except
  3022.           IndRec.Free;
  3023.           raise
  3024.         end;
  3025.       end;
  3026.       QDBFile.CopyFrom(TmpStream, TmpStream.size);
  3027.       TmpStream.Free;
  3028.       Cache.Store(Stream, Index.Strings[FItemIndex]);
  3029.       FCount := Index.Count;
  3030.       IsDirty := true;
  3031.       Stream.Seek(0, 0);
  3032.       Changed;
  3033.     end;
  3034. end;
  3035.  
  3036. procedure TQDB.Changed;
  3037. begin
  3038.   if Assigned(FOnChanged) then
  3039.     FOnChanged(Self);
  3040. end;
  3041.  
  3042. procedure TQDB.ChangeItem(ItemPtr: pointer; ItemLen: TDataIndex);
  3043. { Change the contents of the current item }
  3044. { If you can, use the Change method instead }
  3045. var
  3046.   TmpStream: TMemoryStream;
  3047. begin
  3048.   TmpStream := TMemoryStream.Create;
  3049.   try
  3050.     TmpStream.Write(ItemPtr^, ItemLen);
  3051.     Change(TmpStream);
  3052.   finally
  3053.     TmpStream.Free;
  3054.   end;
  3055. end;
  3056.  
  3057. (*// Alex
  3058. procedure TQDB.ChangeKey(key: TKey);
  3059. var
  3060.    IndRec: TIndex;
  3061. begin
  3062.     IndRec := TIndex.Create;
  3063.     IndRec.pos := TIndex(Index.Objects[FItemIndex]).pos;
  3064.     IndRec.len := TIndex(Index.Objects[FItemIndex]).len;
  3065.     IndRec.ext := TIndex(Index.Objects[FItemIndex]).ext;
  3066.  
  3067.     Index.beginupdate;
  3068.     TIndex(Index.Objects[FItemIndex]).Free;
  3069.     Index.Delete(FItemIndex);
  3070.     FItemindex := Index.addobject(key, IndRec);
  3071.     Index.endupdate;
  3072. end;
  3073. *)
  3074. procedure TQDB.ChangeStreamItem(Stream: TStream);
  3075. { provided for backwards compatibility -- use Change instead }
  3076. begin
  3077.   Change(Stream);
  3078. end;
  3079.  
  3080. function TQDB.CloseMatch(Partialkey: TKey): boolean;
  3081. { looking for a near match -- stops where a full match would be }
  3082. var
  3083.   n: TItemIndex;
  3084.   IsFound: boolean;
  3085. begin
  3086.   Result := Index.Find(Partialkey, n);
  3087.   IsFound := Result;
  3088.   if (not Result) and (n >= 0) and (n < Index.Count) then
  3089.   begin
  3090.     if KeyCaseSensitive then
  3091.       IsFound := (Copy(Index[n], 1, Length(Partialkey)) = Partialkey)
  3092.     else
  3093.       IsFound := (LowerCase(Copy(Index[n], 1, Length(Partialkey))) = LowerCase(Partialkey));
  3094.   end;
  3095.   if IsFound then
  3096.   begin
  3097.     ItemIndex := n;
  3098.     Found;
  3099.   end;
  3100. end;
  3101.  
  3102. procedure TQDB.CloseQDB;
  3103. { close up a QDB file }
  3104. begin
  3105.   SaveIndex;
  3106.   FItemIndex := 0;
  3107.   FKey := '';
  3108.   FCount := 0;
  3109.   IsDirty := false;
  3110.   SetReady(false);
  3111.   Password := '';
  3112. end;
  3113.  
  3114. procedure TQDB.Compress;
  3115. { compresses every item in the file -- not quick! }
  3116. var
  3117.   m: TMemoryStream;
  3118.   n: TItemIndex;
  3119. begin
  3120.   if not FReady then
  3121.     raise EQDBNoFile.Create(SNoFile);
  3122.   if ReadOnly then
  3123.   begin
  3124.     CannotChange;
  3125.     exit;
  3126.   end;
  3127.   Compression := true;
  3128.   BeginUpdate;
  3129.   MonitorSetup(Index.Count, prCompress);
  3130.   for n := 1 to Index.Count do
  3131.   begin
  3132.     MonitorUpdate(n);
  3133.     if not ItemIsCompressed(n - 1) then
  3134.     begin
  3135.       m := TMemoryStream.Create;
  3136.       try
  3137.         FItemIndex := n - 1;
  3138.         Get(m);
  3139.         Change(m);
  3140.       finally
  3141.         m.Free;
  3142.       end;
  3143.     end;
  3144.   end;
  3145.   MonitorZero;
  3146.   Pack;
  3147.   EndUpdate;
  3148. end;
  3149.  
  3150. procedure TQDB.CreateQDB;
  3151. { makes a new empty QDB file on disk ... }
  3152. const
  3153.   Sig1: array[0..3] of char = ('Q', 'D', 'B', #0);
  3154.   Sig2: array[0..3] of char = ('Q', 'I', 'X', #0);
  3155. var
  3156.   f: TFileHandle;
  3157.   sz1,
  3158.     sz2: longint;
  3159.   zero: Byte;
  3160.   bigzero: longint;
  3161. begin
  3162.   zero := 0; { to null-terminate the index block }
  3163.   bigzero := 0; { number of items in the index = 0 }
  3164.   f := FileCreate(FileName);
  3165.   if f < 0 then
  3166.     FileError(f, '');
  3167.   try { protect file f }
  3168.     FileWrite(f, Sig1, SizeOf(Sig1));
  3169.     sz1 := 0;
  3170.     FileWrite(f, sz1, SizeOf(sz1));
  3171.     FileWrite(f, Sig2, SizeOf(Sig2));
  3172.     sz2 := SizeOf(bigzero) + SizeOf(zero);
  3173.     FileWrite(f, sz2, SizeOf(sz2));
  3174.     FileWrite(f, bigzero, SizeOf(bigzero));
  3175.     FileWrite(f, zero, SizeOf(zero));
  3176.   finally
  3177.     FileClose(f);
  3178.   end;
  3179. end;
  3180.  
  3181. procedure TQDB.DoDelete;
  3182. { delete an item from the index -- need to Pack to get it }
  3183. { out of the item file }
  3184. begin
  3185.   if not FReady then
  3186.     raise EQDBNoFile.Create(SNoFile);
  3187.   if ReadOnly then
  3188.     CannotChange
  3189.   else
  3190.     if Index.Count < 1 then
  3191.       NoData
  3192.     else
  3193.     begin
  3194.       if not AutoEdit then
  3195.         FEditing := false;
  3196.       FInserting := false;
  3197.       Cache.Remove(Index.Strings[FItemIndex]);
  3198.       TIndex(Index.Objects[FItemIndex]).Free;
  3199.       Index.Delete(FItemIndex);
  3200.       if FItemIndex > 0 then
  3201.         ItemIndex := FItemIndex - 1
  3202.       else
  3203.         FKey := '';
  3204.       FCount := Index.Count;
  3205.       IsDirty := true;
  3206.       Deleted;
  3207.       UpdateNavigator;
  3208.     end;
  3209. end;
  3210.  
  3211. procedure TQDB.Delete;
  3212. begin
  3213.   if Assigned(FBeforeDelete) then
  3214.     FBeforeDelete(Self);
  3215.   DoDelete;
  3216.   if Assigned(FAfterDelete) then
  3217.     FAfterDelete(Self);
  3218. end;
  3219.  
  3220. procedure TQDB.Deleted;
  3221. begin
  3222.   if Assigned(FOnDeleted) then
  3223.     FOnDeleted(Self);
  3224. end;
  3225.  
  3226. procedure TQDB.DeleteItem;
  3227. { provided for backward compatibility -- use Delete }
  3228. begin
  3229.   Delete;
  3230. end;
  3231.  
  3232. procedure TQDB.DemandPassword;
  3233. var
  3234.   NewPassword: TPassword;
  3235. begin
  3236.   NewPassword := '';
  3237.   if Assigned(FOnDemandPassWord) then
  3238.     FOnDemandPassWord(Self, NewPassword);
  3239.   Password := NewPassword;
  3240. end;
  3241.  
  3242. procedure TQDB.DoEdit;
  3243. begin
  3244.   FEditing := true;
  3245.   UpdateNavigator;
  3246. end;
  3247.  
  3248. procedure TQDB.Edit;
  3249. begin
  3250.   if Assigned(FBeforeEdit) then
  3251.     FBeforeEdit(Self);
  3252.   DoEdit;
  3253.   if Assigned(FAfterEdit) then
  3254.     FAfterEdit(Self);
  3255. end;
  3256.  
  3257. procedure TQDB.EndUpdate;
  3258. begin
  3259.   dec(FUpdating);
  3260.   if (FUpdating = 0) then
  3261.     Navigate;
  3262. end;
  3263.  
  3264. function TQDB.ExactMatch(Key: TKey): boolean;
  3265. { simple stringlist find }
  3266. var
  3267.   n: TItemIndex;
  3268. begin
  3269.   Result := Index.Find(Key, n);
  3270.   if Result then
  3271.   begin
  3272.     ItemIndex := n;
  3273.     Found;
  3274.   end;
  3275. end;
  3276.  
  3277. procedure TQDB.Expand;
  3278. { decompresses every item in the file -- not quick! }
  3279. var
  3280.   m: TMemoryStream;
  3281.   n: TItemIndex;
  3282. begin
  3283.   if not FReady then
  3284.     raise EQDBNoFile.Create(SNoFile);
  3285.   if ReadOnly then
  3286.   begin
  3287.     CannotChange;
  3288.     exit;
  3289.   end;
  3290.   Compression := false;
  3291.   BeginUpdate;
  3292.   MonitorSetup(Index.Count, prCompress);
  3293.   for n := 1 to Index.Count do
  3294.   begin
  3295.     MonitorUpdate(n);
  3296.     if ItemIsCompressed(n - 1) then
  3297.     begin
  3298.       m := TMemoryStream.Create;
  3299.       try
  3300.         FItemIndex := n - 1;
  3301.         Get(m);
  3302.         Change(m);
  3303.       finally
  3304.         m.Free;
  3305.       end;
  3306.     end;
  3307.   end;
  3308.   MonitorZero;
  3309.   Pack;
  3310.   EndUpdate;
  3311. end;
  3312.  
  3313. procedure TQDB.FileAssigned;
  3314. begin
  3315.   if Assigned(FOnFileAssigned) then
  3316.     FOnFileAssigned(Self);
  3317. end;
  3318.  
  3319. procedure TQDB.FileError(ErrCode: integer; SDefault: string);
  3320. { report errors concerning file resources }
  3321. var
  3322.   SErr: string;
  3323. begin
  3324.   case ErrCode of
  3325.     - 1:
  3326.       SErr := SDefault;
  3327.     - 2:
  3328.       SErr := SMissing;
  3329.     - 3:
  3330.       SErr := SDoorOpen;
  3331.     - 4:
  3332.       SErr := STooMany;
  3333.     - 5:
  3334.       SErr := SShareError;
  3335.     - 101:
  3336.       SErr := SDiskFull;
  3337.   else
  3338.     raise EQDBFileError.CreateFmt(SUnknownError, [IntToStr(ErrCode)]);
  3339.   end;
  3340.   raise EQDBFileError.CreateFmt(SErr, [FFileName]);
  3341. end;
  3342.  
  3343. function TQDB.FileToRecover: string;
  3344. { returns the name of an orphaned working file }
  3345. var
  3346.   TmpPath: pchar;
  3347.   PlaceToLook: string;
  3348.   f: TSearchRec;
  3349.   OldQDBFileName: string;
  3350.   Handle: integer;
  3351. begin
  3352.   Result := '';
  3353.   GetMem(TmpPath, MAX_PATH);
  3354.   try
  3355.     FillChar(TmpPath^, MAX_PATH, #0);
  3356. {$IFDEF WIN32}
  3357.     GetTempPath(MAX_PATH, TmpPath);
  3358.     PlaceToLook := TmpPath;
  3359. {$ELSE}
  3360.     GetTempFileName(#0, 'RRM', 0, TmpPath);
  3361.     PlaceToLook := ExtractFilePath(StrPas(TmpPath));
  3362. {$ENDIF}
  3363.   finally
  3364.     FreeMem(TmpPath, MAX_PATH);
  3365.   end;
  3366.   if FindFirst(PlaceToLook + 'QDB*.tmp', 0, f) = 0 then
  3367.   begin
  3368.     OldQDBFileName := PlaceToLook + f.Name;
  3369.     SysUtils.FindClose(f);
  3370.     { check if in use at the moment or if genuine orphan ... }
  3371.     Handle := FileOpen(OldQDBFileName, fmShareExclusive);
  3372.     if Handle < 0 then
  3373.       exit;
  3374.     FileClose(Handle);
  3375.     Result := OldQDBFileName;
  3376.   end;
  3377. end;
  3378.  
  3379. procedure TQDB.FirstItem;
  3380. var
  3381.   This: TItemIndex;
  3382. begin
  3383.   FBoF := true;
  3384.   FEoF := false;
  3385.   if Filtered then
  3386.   begin
  3387.     { the filter slows things down ... }
  3388.     This := 0;
  3389.     while (This < Index.Count) and not Matches(GetKey(This), FFilter) do
  3390.       inc(This);
  3391.     ItemIndex := This;
  3392.   end
  3393.   else
  3394.     ItemIndex := 0;
  3395.   { if there is one, tell the navigator we've moved }
  3396.   UpdateNavigator;
  3397. end;
  3398.  
  3399. procedure TQDB.ForceOverwrite(Value: boolean);
  3400. begin
  3401.   FForceOverwrite := Value;
  3402. end;
  3403.  
  3404.  
  3405. procedure TQDB.Found;
  3406. begin
  3407.   if Assigned(FOnFound) then
  3408.     FOnFound(Self);
  3409. end;
  3410.  
  3411. procedure TQDB.Get(Stream: TStream);
  3412. { retrieve an item from the file as a stream }
  3413. var
  3414.   CacheN: longint;
  3415. begin
  3416.   if not FReady then
  3417.     raise EQDBNoFile.Create(SNoFile);
  3418.   if Index.Count > 0 then
  3419.   begin
  3420.     try
  3421.       Stream.Seek(0, 0);
  3422.       { first check if in cache }
  3423.       if Cache.Find(Index.Strings[FItemIndex], CacheN) then
  3424.       begin
  3425.         Cache.Fetch(Stream, CacheN);
  3426.       end
  3427.       else
  3428.       begin
  3429.         QDBFile.Seek(TIndex(Index.Objects[FItemIndex]).Pos, 0);
  3430.         Stream.Seek(0, 0);
  3431.         if ItemIsCompressed(FItemIndex) then
  3432.           UnSquashStream(QDBFile, Stream, TIndex(Index.Objects[FItemIndex]).Len)
  3433.         else
  3434.           Stream.CopyFrom(QDBFile, TIndex(Index.Objects[FItemIndex]).Len);
  3435.         Stream.Seek(0, 0);
  3436.         Cache.Store(Stream, Index.Strings[FItemIndex]);
  3437.       end;
  3438.       Stream.Seek(0, 0);
  3439.     except
  3440.       IndexError(SCorrupt);
  3441.     end;
  3442.   end
  3443.   else
  3444.     NoData;
  3445. end;
  3446.  
  3447. function TQDB.GetCacheFrequency: integer;
  3448. { gets the percentage of accesses that hit the cache }
  3449. begin
  3450.   Result := Cache.GetFrequency;
  3451. end;
  3452.  
  3453. function TQDB.GetCacheSize: longint;
  3454. begin
  3455.   Result := Cache.FMaximumSize;
  3456. end;
  3457.  
  3458. function TQDB.GetFileName: TQDBFileName;
  3459. begin
  3460.   Result := FFileName;
  3461. end;
  3462.  
  3463. function TQDB.GetFilteredCount: TItemIndex;
  3464. { how many keys match the current filter? }
  3465. var
  3466.   This: TItemIndex;
  3467.   i: TItemIndex;
  3468. begin
  3469.   if Filtered then
  3470.   begin
  3471.     { not quick ... }
  3472.     i := 0;
  3473.     for This := 1 to Index.Count do
  3474.       if Matches(GetKey(This - 1), FFilter) then
  3475.         inc(i);
  3476.     Result := i;
  3477.   end
  3478.   else
  3479.     Result := FCount;
  3480. end;
  3481.  
  3482. procedure TQDB.GetItem(ItemPtr: pointer);
  3483. { retrieve the current item -- try to use Get instead }
  3484. var
  3485.   TmpStream: TMemoryStream;
  3486. begin
  3487.   TmpStream := TMemoryStream.Create;
  3488.   try
  3489.     GetStreamItem(TmpStream);
  3490.     TmpStream.Read(ItemPtr^, TmpStream.size);
  3491.   finally
  3492.     TmpStream.Free;
  3493.   end;
  3494. end;
  3495.  
  3496. function TQDB.GetItemSize(Value: TItemIndex): TDataIndex;
  3497. { returns the number of bytes an item occupies on the disk }
  3498. begin
  3499.   Result := TIndex(Index.Objects[Value]).Len;
  3500. end;
  3501.  
  3502. function TQDB.GetKey(Value: TItemIndex): TKey;
  3503. { fetches the key for the given item }
  3504. begin
  3505.   if Index.Count < 1 then
  3506.   begin
  3507.     Result := '';
  3508.     NoData;
  3509.   end
  3510.   else
  3511.     Result := Index.Strings[Value];
  3512. end;
  3513.  
  3514. function TQDB.GetKeyCase: boolean;
  3515. { is the index case-sensitive ? }
  3516. begin
  3517.   Result := Index.CaseSensitive;
  3518. end;
  3519.  
  3520. function TQDB.GetStr(n: TItemIndex): string;
  3521. { gets item n as a string }
  3522. begin
  3523.   Result := '';
  3524.   ItemIndex := n;
  3525.   Result := GetThisStr;
  3526. end;
  3527.  
  3528. function TQDB.GetStrByKey(Key: TKey): string;
  3529. { if key exists gets item as string }
  3530. begin
  3531.   if ExactMatch(Key) then
  3532.     Result := GetThisStr
  3533.   else
  3534.     raise EQDBBadKey.CreateFmt(SBadKey, [Key]);
  3535. end;
  3536.  
  3537. procedure TQDB.GetStreamItem(Stream: TStream);
  3538. { provided for compatibility -- use Get }
  3539. begin
  3540.   Get(Stream);
  3541. end;
  3542.  
  3543. function TQDB.GetThisItemSize: TDataIndex;
  3544. { returns the number of bytes the current item occupies }
  3545. { in memory -- may have to uncompress an item to tell }
  3546. var
  3547.   m: TMemoryStream;
  3548.   n: TDataIndex;
  3549. begin
  3550.   if Index.Count < 1 then
  3551.   begin
  3552.     Result := 0;
  3553.     NoData;
  3554.   end
  3555.   else
  3556.     if ItemIsCompressed(FItemIndex) then
  3557.     begin
  3558.       { look in Cache }
  3559.       if Cache.Find(Key, n) then
  3560.       begin
  3561.         Result := TCache(Cache.Objects[n]).Stream.size;
  3562.       end
  3563.       else
  3564.       begin
  3565.         m := TMemoryStream.Create;
  3566.         try
  3567.           Get(m);
  3568.           Result := m.size;
  3569.         finally
  3570.           m.Free;
  3571.         end;
  3572.       end;
  3573.     end
  3574.     else
  3575.       Result := GetItemSize(FItemIndex);
  3576. end;
  3577.  
  3578. function TQDB.GetThisStr: string;
  3579. { gets the current item as a string -- truncates D1 }
  3580. { strings if needed }
  3581. var
  3582.   m: TMemoryStream;
  3583.   size: longint;
  3584. begin
  3585.   m := TMemoryStream.Create;
  3586.   try
  3587.     Get(m);
  3588.     size := m.size;
  3589. {$IFNDEF WIN32}
  3590.     if size > 255 then
  3591.       size := 255;
  3592.     Result[0] := chr(size);
  3593. {$ELSE}
  3594.     SetLength(Result, size);
  3595. {$ENDIF}
  3596.     m.Read(Result[1], size);
  3597.   finally
  3598.     m.Free;
  3599.   end;
  3600. end;
  3601.  
  3602. function TQDB.GrepMatches(Key: TKey; Pattern: TKey): boolean;
  3603. begin
  3604.   Result := GrepMatch(Key, Pattern, KeyCaseSensitive, FMatchWholeWord);
  3605. end;
  3606.  
  3607. procedure TQDB.IndexError(ErrMsg: string);
  3608. { reports errors to do with the Index }
  3609. begin
  3610.   raise EQDBIndexError.CreateFmt(ErrMsg, [FFileName]);
  3611. end;
  3612.  
  3613. procedure TQDB.DoInsert;
  3614. begin
  3615.   FInserting := true;
  3616.   UpdateNavigator;
  3617. end;
  3618.  
  3619. procedure TQDB.Insert;
  3620. begin
  3621.   if Assigned(FBeforeInsert) then
  3622.     FBeforeInsert(Self);
  3623.   DoInsert;
  3624.   if Assigned(FAfterInsert) then
  3625.     FAfterInsert(Self);
  3626. end;
  3627.  
  3628. function TQDB.ItemIsCompressed(Value: TItemIndex): boolean;
  3629. { is the item compressed? }
  3630. begin
  3631.   Result := IsCompressed in TIndex(Index.Objects[Value]).Ext;
  3632. end;
  3633.  
  3634. function TQDB.KeyExists(Key: TKey): boolean;
  3635. var
  3636.   n: TItemIndex;
  3637. begin
  3638.   Result := Index.Find(Key, n);
  3639. end;
  3640.  
  3641. procedure TQDB.Kill;
  3642. { Erases a QDB file after asking confirmation }
  3643. var
  3644.   OK: boolean;
  3645.   FileToDel: string;
  3646. begin
  3647.   if not FReady then
  3648.     raise EQDBNoFile.Create(SNoFile);
  3649.   OK := false;
  3650.   AboutToKill(OK);
  3651.   if not OK then
  3652.     exit;
  3653.   if ReadOnly then
  3654.   begin
  3655.     CannotChange;
  3656.     exit;
  3657.   end;
  3658.   if FFileName <> '' then
  3659.   begin
  3660.     FileToDel := FileName;
  3661.     FileName := '';
  3662.     SysUtils.DeleteFile(FileToDel);
  3663.     Killed;
  3664.   end;
  3665. end;
  3666.  
  3667. procedure TQDB.Killed;
  3668. begin
  3669.   if Assigned(FOnKilled) then
  3670.     FOnKilled(Self);
  3671. end;
  3672.  
  3673. procedure TQDB.LastItem;
  3674. var
  3675.   This: TItemIndex;
  3676. begin
  3677.   FBoF := false;
  3678.   FEoF := true;
  3679.   if Filtered then
  3680.   begin
  3681.     This := Index.Count - 1;
  3682.     while (This >= 0) and not Matches(GetKey(This), FFilter) do
  3683.       dec(This);
  3684.     ItemIndex := This;
  3685.   end
  3686.   else
  3687.     ItemIndex := Index.Count - 1;
  3688.   { if there is one, tell the navigator we've moved }
  3689.   UpdateNavigator;
  3690. end;
  3691.  
  3692. function TQDB.Live: boolean;
  3693. begin
  3694.   Result := Restructuring or not (csDesigning in ComponentState);
  3695. end;
  3696.  
  3697. procedure TQDB.LoadIndex;
  3698. { Loading and saving the index are the most complex tasks in the unit }
  3699. { Some words about the working file formats is in order: }
  3700. { The item file (QDBFile) consists of contiguous, variable-length, }
  3701. { blocks of data. Where one ends and the next begins is known only }
  3702. { to the index file (QIXFile). LoadIndex reads this data into }
  3703. { its Index list. The index file format is as follows: }
  3704. { }
  3705. { 4 bytes -- longint(n) = number of items in the file }
  3706. { n variable length blocks of the following structure }
  3707. {    null terminated string data = the key to an item }
  3708. {    4 bytes -- longint(n1) = the place in the item file }
  3709. {    4 bytes -- longint(n2) = the size of the item }
  3710. {    4 bytes -- longint(n3) = binary attribute flags }
  3711. { }
  3712. var
  3713.   Key: TKey;
  3714.   Rec: TIndex;
  3715.   NumItems: TItemIndex;
  3716.   n: TItemIndex;
  3717. begin
  3718.   try { except any error }
  3719.     Split;
  3720.     QDBFile := TFileStream.Create(QDBFileName, fmOpenReadWrite or
  3721.       fmShareExclusive);
  3722.     QIXFile := TBFStream.Create(QIXFileName, fmOpenReadWrite or
  3723.       fmShareExclusive, -1);
  3724.     try { protect file QIXFile }
  3725.       QIXFile.GetLongint(NumItems);
  3726.       MonitorSetup(NumItems, prStart);
  3727.       Index.SetCapacity(NumItems);
  3728.       Index.Sorted := false; { quicker to sort later than add to a sorted list }
  3729.       for n := 1 to NumItems do
  3730.       begin
  3731.         QIXFile.GetKey(Key);
  3732.         try
  3733.           Rec := TIndex.Create;
  3734.         except
  3735.           IndexError(SIndexAdd);
  3736.         end;
  3737.         QIXFile.GetLongint(Rec.Pos);
  3738.         QIXFile.GetLongint(Rec.Len);
  3739.         QIXFile.GetLongint(longint(Rec.Ext));
  3740.         try
  3741.           if IsAdminItem in Rec.Ext then
  3742.             FAdminIndex := Admin.AddObject(Key, Rec)
  3743.           else
  3744.           begin
  3745.             FItemIndex := Index.AddObject(Key, Rec);
  3746.           end;
  3747.         except
  3748.           Rec.Free;
  3749.           Index.EmptyAndClear;
  3750.           Index.Sorted := true;
  3751.           Admin.EmptyAndClear;
  3752.           IndexError(SIndexAdd);
  3753.         end;
  3754.         MonitorUpdate(n);
  3755.       end;
  3756.       FItemIndex := 0;
  3757.       FAdminIndex := 0;
  3758.       FCount := Index.Count;
  3759.       IsDirty := false;
  3760.       Index.Reverse;
  3761.       MonitorZero;
  3762.       if FCount > 0 then
  3763.       begin
  3764.         FKey := GetKey(FItemIndex);
  3765.       end
  3766.       else
  3767.       begin
  3768.         FKey := '';
  3769.       end;
  3770.     finally
  3771.       QIXFile.Destroy;
  3772.     end;
  3773.   except
  3774.     on EOutOfMemory do
  3775.       IndexError(SCorrupt);
  3776.     on ERangeError do
  3777.       IndexError(SCorrupt);
  3778.     on EQDBListError do
  3779.       IndexError(SCorrupt);
  3780.   else
  3781.     raise;
  3782.   end;
  3783. end;
  3784.  
  3785. procedure TQDB.MonitorSetup(const Max: longint; const Kind: TProgressOrigin
  3786.   );
  3787. { start monitoring the progress of a lengthy process }
  3788. begin
  3789.   MonitorInterval := (Max div 10) + 1;
  3790.   MonitorKind := Kind;
  3791. end;
  3792.  
  3793. procedure TQDB.MonitorUpdate(const n: longint);
  3794. { update the progress monitor }
  3795. begin
  3796.   if n mod MonitorInterval = 0 then
  3797.   begin
  3798.     Application.ProcessMessages;
  3799.     SignalProgress((10 * n) div MonitorInterval, MonitorKind);
  3800.   end;
  3801. end;
  3802.  
  3803. procedure TQDB.MonitorZero;
  3804. begin
  3805.   SignalProgress(0, MonitorKind);
  3806. end;
  3807.  
  3808. procedure TQDB.Navigate;
  3809. { whenever the ItemIndex is changed }
  3810. begin
  3811.   if Assigned(FOnNavigate) then
  3812.     FOnNavigate(Self);
  3813. end;
  3814.  
  3815. procedure TQDB.NextItem;
  3816. var
  3817.   This: TItemIndex;
  3818. begin
  3819.   FEoF := false;
  3820.   FBoF := false;
  3821.   This := FItemIndex;
  3822.   if Filtered then
  3823.   begin
  3824.     while (This + 1 < Index.Count) and not Matches(GetKey(This + 1), FFilter
  3825.       ) do
  3826.     begin
  3827.       inc(This);
  3828.     end;
  3829.   end;
  3830.   inc(This);
  3831.   if This >= Index.Count then
  3832.   begin
  3833.     FBoF := false;
  3834.     FEoF := true;
  3835.   end
  3836.   else
  3837.   begin
  3838.     ItemIndex := This;
  3839.   end;
  3840.   { if there is one tell the navigator we've moved }
  3841.   UpdateNavigator;
  3842. end;
  3843.  
  3844. procedure TQDB.NoData;
  3845. { If a warning handler has not been assigned an exception is raised }
  3846. { To silence exceptions assign at least an empty handler }
  3847. begin
  3848.   if Assigned(FWarnNoData) then
  3849.     FWarnNoData(Self)
  3850.   else
  3851.     raise EQDBNoData.CreateFmt(SNoData, [FileName]);
  3852. end;
  3853.  
  3854. procedure TQDB.Notification(AComponent: TComponent; Operation: TOperation);
  3855. { if the link to a navigator is broken we must respond }
  3856. begin
  3857.   inherited Notification(AComponent, Operation);
  3858.   if (FQDBNavigator <> nil) and
  3859.     (AComponent = FQDBNavigator) and
  3860.     (Operation = opRemove) then
  3861.     FQDBNavigator := nil;
  3862. end;
  3863.  
  3864. procedure TQDB.OpenQDB;
  3865. { open a QDB file with the current filename }
  3866. begin
  3867.   try
  3868.     if not FileExists(FFileName) then
  3869.       CreateQDB;
  3870.     LoadIndex;
  3871.     SetReady(true);
  3872.     if AdminKeyExists('QDBCaseSensitive') then
  3873.       Index.CaseSensitive := AdminAsBoolean['QDBCaseSensitive'];
  3874.   except
  3875.     raise
  3876.   end;
  3877. end;
  3878.  
  3879. function TQDB.OrphanToRecover: boolean;
  3880. { is there at least one orphaned file... }
  3881. begin
  3882.   Result := (FileToRecover <> '');
  3883. end;
  3884.  
  3885. procedure TQDB.OutOfBounds;
  3886. { If a warning handler has not been assigned an exception is raised }
  3887. { To silence exceptions assign at least an empty handler }
  3888.  
  3889. begin
  3890.   if Assigned(FWarnOutOfBounds) then
  3891.     FWarnOutOfBounds(Self)
  3892.   else
  3893.     raise EQDBOutOfBounds.CreateFmt(SOutOfBounds, [FFileName]);
  3894. end;
  3895.  
  3896. procedure TQDB.Pack;
  3897. { Re-organizes the working item file into index order }
  3898. { eliminating any unreferenced items. }
  3899. var
  3900.   TmpFile: TFileStream;
  3901.   DatBuf: pchar;
  3902.   QLen: TDataIndex;
  3903.   QPos: TFilePos;
  3904.   TmpFileName: string;
  3905.   This, Init: TItemIndex;
  3906. begin
  3907.   if not FReady then
  3908.     raise EQDBNoFile.Create(SNoFile);
  3909.   if ReadOnly then
  3910.   begin
  3911.     CannotChange;
  3912.     exit;
  3913.   end;
  3914.   Init := FItemIndex;
  3915.   TmpFileName := TempFileName('QDB');
  3916.   if TmpFileName = '' then
  3917.     IndexError(STempFile);
  3918.   TmpFile := TFileStream.Create(TmpFileName, fmCreate);
  3919.   try { protect file tmpfile }
  3920.     MonitorSetup(Index.Count, prPack);
  3921.     for This := 1 to Admin.Count do
  3922.     begin
  3923.       QLen := TIndex(Admin.Objects[This - 1]).Len;
  3924.       QPos := TIndex(Admin.Objects[This - 1]).Pos;
  3925.       GetMem(DatBuf, QLen);
  3926.       try { protect memory DatBuf }
  3927.         try { catch file errors }
  3928.           TIndex(Admin.Objects[This - 1]).Pos := TmpFile.Seek(0, 2);
  3929.           QDBFile.Seek(QPos, 0);
  3930.           QDBFile.Read(DatBuf^, QLen);
  3931.         except
  3932.           IndexError(SCorrupt);
  3933.         end;
  3934.         TmpFile.Write(DatBuf^, QLen);
  3935.       finally
  3936.         FreeMem(DatBuf, QLen);
  3937.       end;
  3938.     end;
  3939.     for This := 1 to Index.Count do
  3940.     begin
  3941.       MonitorUpdate(This);
  3942.       QLen := TIndex(Index.Objects[This - 1]).Len;
  3943.       QPos := TIndex(Index.Objects[This - 1]).Pos;
  3944.       GetMem(DatBuf, QLen);
  3945.       try { protect memory DatBuf }
  3946.         try { catch file errors }
  3947.           TIndex(Index.Objects[This - 1]).Pos := TmpFile.Seek(0, 2);
  3948.           QDBFile.Seek(QPos, 0);
  3949.           QDBFile.Read(DatBuf^, QLen);
  3950.         except
  3951.           IndexError(SCorrupt);
  3952.         end;
  3953.         TmpFile.Write(DatBuf^, QLen);
  3954.       finally
  3955.         FreeMem(DatBuf, QLen);
  3956.       end;
  3957.     end;
  3958.   finally
  3959.     TmpFile.Free;
  3960.   end;
  3961.   QDBFile.Free;
  3962.   RenameOrMoveFile(TmpFileName, QDBFileName);
  3963.   QDBFile := TFileStream.Create(QDBFileName, fmOpenReadWrite or fmShareExclusive);
  3964.   if Init > 0 then
  3965.     ItemIndex := Init;
  3966.   MonitorZero;
  3967. end;
  3968.  
  3969. function TQDB.PartialMatch(StartOfKey: TKey): boolean;
  3970. { finds the next key which begins with the right chars -- if }
  3971. { you want to include the first item call PartialMatchInit first }
  3972. var
  3973.   n: TItemIndex;
  3974.   k: TKey;
  3975.   T: TItemIndex;
  3976. begin
  3977.   Result := false;
  3978.   if not KeyCaseSensitive then
  3979.     StartOfKey := LowerCase(StartOfKey);
  3980.   begin
  3981.     T := FItemIndex;
  3982.     if KeyCaseSensitive then
  3983.     begin
  3984.       for n := T + 2 to Count do
  3985.       begin
  3986.         k := Index.Strings[n - 1];
  3987.         if Copy(k, 1, Length(StartOfKey)) = StartOfKey then
  3988.         begin
  3989.           Result := true;
  3990.           Break;
  3991.         end;
  3992.       end;
  3993.     end
  3994.     else
  3995.     begin
  3996.       for n := T + 2 to Count do
  3997.       begin
  3998.         k := Index.Strings[n - 1];
  3999.         if LowerCase(Copy(k, 1, Length(StartOfKey))) = StartOfKey then
  4000.         begin
  4001.           Result := true;
  4002.           Break;
  4003.         end;
  4004.       end;
  4005.     end;
  4006.     if Result and (T <> n - 1) then
  4007.     begin
  4008.       ItemIndex := n - 1;
  4009.       Found;
  4010.     end;
  4011.   end;
  4012. end;
  4013.  
  4014. procedure TQDB.PartialMatchInit;
  4015. begin
  4016.   FItemIndex := -1;
  4017. end;
  4018.  
  4019. function TQDB.PatternMatch(Pattern: TKey): boolean;
  4020. { brute force search for a pattern -- not quick! }
  4021. var
  4022.   n: TItemIndex;
  4023.   k: TKey;
  4024.   T: TItemIndex;
  4025. begin
  4026.   T := FItemIndex;
  4027.   Result := false;
  4028.   for n := T + 1 to Count do
  4029.   begin
  4030.     k := GetKey(n - 1);
  4031.     if Matches(k, Pattern) then
  4032.     begin
  4033.       Result := true;
  4034.       Break;
  4035.     end;
  4036.   end;
  4037.   if Result and (T <> n - 1) then
  4038.   begin
  4039.     ItemIndex := n - 1;
  4040.     Found;
  4041.   end;
  4042. end;
  4043.  
  4044. procedure TQDB.PatternMatchInit;
  4045. begin
  4046.   FItemIndex := -1;
  4047. end;
  4048.  
  4049. procedure TQDB.DoPost;
  4050. begin
  4051.   if not AutoEdit then
  4052.     FEditing := false;
  4053.   FInserting := false;
  4054.   UpdateNavigator;
  4055. end;
  4056.  
  4057. procedure TQDB.Post;
  4058. begin
  4059.   if Assigned(FBeforePost) then
  4060.     FBeforePost(Self);
  4061.   DoPost;
  4062.   if Assigned(FAfterPost) then
  4063.     FAfterPost(Self);
  4064. end;
  4065.  
  4066. procedure TQDB.PrepareToAdd(numberofitems: longint);
  4067. { Usually the memory allocated for the index grows whenever needed, }
  4068. { which can be time-consuming with all the moving of memory blocks, }
  4069. { etc. Instead PrepareToAdd allocates all the memory required in }
  4070. { go which is much quicker and reduces memory fragmentation. }
  4071. begin
  4072.   Index.SetCapacity(Index.Count + numberofitems);
  4073. end;
  4074.  
  4075. procedure TQDB.PrevItem;
  4076. var
  4077.   This: TItemIndex;
  4078. begin
  4079.   FBoF := false;
  4080.   FEoF := false;
  4081.   This := FItemIndex;
  4082.   if Filtered then
  4083.   begin
  4084.     while (This - 1 >= 0) and not Matches(GetKey(This - 1), FFilter) do
  4085.     begin
  4086.       dec(This);
  4087.     end;
  4088.   end;
  4089.   dec(This);
  4090.   if This < 0 then
  4091.   begin
  4092.     FBoF := true;
  4093.     FEoF := false;
  4094.   end
  4095.   else
  4096.   begin
  4097.     ItemIndex := This;
  4098.   end;
  4099.   { if there is one, tell the navigator we've moved }
  4100.   UpdateNavigator;
  4101. end;
  4102.  
  4103. procedure TQDB.Recover(NewFileName: string);
  4104. { Checks to see if there are temp working files still around }
  4105. { that are not in use. }
  4106. var
  4107.   Remnant: string;
  4108. begin
  4109.   if FFileName <> '' then
  4110.     exit; { only use if nothing open }
  4111.   Remnant := FileToRecover;
  4112.   if Remnant = '' then
  4113.     exit; { and there is an orphan }
  4114.   { prepare to splice the working files together }
  4115.   QDBFileName := Remnant;
  4116.   QIXFileName := ExtractFilePath(Remnant) + 'QIX' + Copy(ExtractFileName(
  4117.     Remnant), 4, MAX_PATH);
  4118.   FFileAge := 0;
  4119.   FFileName := NewFileName;
  4120.   Splice;
  4121.   FFileName := '';
  4122.   SysUtils.DeleteFile(QDBFileName);
  4123.   SysUtils.DeleteFile(QIXFileName);
  4124.   { then open it up again }
  4125.   FileName := NewFileName;
  4126. end;
  4127.  
  4128. procedure TQDB.Refresh;
  4129. begin
  4130. end;
  4131.  
  4132. procedure TQDB.Save;
  4133. { Save commits the in-memory index to the working file }
  4134. var
  4135.   T: TIndex;
  4136.   i, n: longint;
  4137.   NumItems: longint;
  4138.   TmpFile: TTempBFStream;
  4139. begin
  4140.   if not FReady then
  4141.     raise EQDBNoFile.Create(SNoFile);
  4142.   if ReadOnly or not IsDirty then
  4143.     exit;
  4144.   MonitorSetup(Index.Count, prSave);
  4145.   TmpFile := TTempBFStream.Create(QIXFileName);
  4146.   try { protect file tmpfile }
  4147.     NumItems := Index.Count + Admin.Count;
  4148.     TmpFile.PutLongint(NumItems);
  4149.     i := Admin.Count;
  4150.     while i > 0 do
  4151.     begin
  4152.       TmpFile.PutKey(Admin.Strings[i - 1]);
  4153.       T := TIndex(Admin.Objects[i - 1]);
  4154.       TmpFile.PutLongint(T.Pos);
  4155.       TmpFile.PutLongint(T.Len);
  4156.       TmpFile.PutLongint(longint(T.Ext));
  4157.       dec(i);
  4158.     end;
  4159.     i := Index.Count;
  4160.     n := 0;
  4161.     while i > 0 do
  4162.     begin
  4163.       MonitorUpdate(n);
  4164.       inc(n);
  4165.       TmpFile.PutKey(Index.Strings[i - 1]);
  4166.       T := TIndex(Index.Objects[i - 1]);
  4167.       TmpFile.PutLongint(T.Pos);
  4168.       TmpFile.PutLongint(T.Len);
  4169.       TmpFile.PutLongint(longint(T.Ext));
  4170.       dec(i);
  4171.     end;
  4172.   finally
  4173.     TmpFile.Destroy;
  4174.   end;
  4175.   QDBFile.Free;
  4176.   IsDirty := false;
  4177.   QDBFile := TFileStream.Create(QDBFileName, fmOpenReadWrite or fmShareExclusive
  4178.     );
  4179.   MonitorZero;
  4180. end;
  4181.  
  4182. procedure TQDB.SaveAs(NewName: string);
  4183. { SaveAs first commits the in-memory index to the working file }
  4184. { before writing a copy of index and items to a new QDB file }
  4185. begin
  4186.   Save;
  4187.   QDBFile.Free;
  4188.   FFileName := ExpandFileName(NewName);
  4189.   if ExtractFileExt(FFileName) = '' then
  4190.     FFileName := ChangeFileExt(FFileName, '.QDB');
  4191.   FFileAge := 0;
  4192.   Splice;
  4193.   FFileAge := FileAge(FFileName);
  4194.   QDBFile := TFileStream.Create(QDBFileName, fmOpenReadWrite or fmShareExclusive
  4195.     );
  4196.   IsDirty := false;
  4197. end;
  4198.  
  4199. procedure TQDB.SaveIndex;
  4200. { Saving the index is just as messy as loading it ... }
  4201. var
  4202.   T: TIndex;
  4203.   n: TItemIndex;
  4204.   NumItems: TItemIndex;
  4205.   TmpFile: TTempBFStream;
  4206. begin
  4207.   MonitorSetup(Index.Count, prFinish);
  4208.   if ReadOnly or not SaveOnClose then
  4209.   begin
  4210.     while Admin.Count > 0 do
  4211.     begin
  4212.       TIndex(Admin.Objects[Admin.Count - 1]).Free;
  4213.       Admin.Delete(Admin.Count - 1);
  4214.     end;
  4215.     n := 0;
  4216.     while Index.Count > 0 do
  4217.     begin
  4218.       MonitorUpdate(n);
  4219.       inc(n);
  4220.       TIndex(Index.Objects[Index.Count - 1]).Free;
  4221.       Index.Delete(Index.Count - 1);
  4222.     end;
  4223.   end
  4224.   else
  4225.   begin
  4226.     TmpFile := TTempBFStream.Create(QIXFileName);
  4227.     try { protect file tmpfile }
  4228.       NumItems := Index.Count + Admin.Count;
  4229.       TmpFile.PutLongint(NumItems);
  4230.       while Admin.Count > 0 do
  4231.       begin
  4232.         TmpFile.PutKey(Admin.Strings[Admin.Count - 1]);
  4233.         T := TIndex(Admin.Objects[Admin.Count - 1]);
  4234.         TmpFile.PutLongint(T.Pos);
  4235.         TmpFile.PutLongint(T.Len);
  4236.         TmpFile.PutLongint(longint(T.Ext));
  4237.         T.Free;
  4238.         Admin.Delete(Admin.Count - 1);
  4239.       end;
  4240.       n := 0;
  4241.       while Index.Count > 0 do
  4242.       begin
  4243.         MonitorUpdate(n);
  4244.         inc(n);
  4245.         TmpFile.PutKey(Index.Strings[Index.Count - 1]);
  4246.         T := TIndex(Index.Objects[Index.Count - 1]);
  4247.         TmpFile.PutLongint(T.Pos);
  4248.         TmpFile.PutLongint(T.Len);
  4249.         TmpFile.PutLongint(longint(T.Ext));
  4250.         T.Free;
  4251.         Index.Delete(Index.Count - 1);
  4252.       end;
  4253.     finally
  4254.       TmpFile.Destroy;
  4255.     end;
  4256.   end;
  4257.   Cache.Flush;
  4258.   QDBFile.Free;
  4259.   IsDirty := false;
  4260.   Splice;
  4261.   SysUtils.DeleteFile(QDBFileName);
  4262.   SysUtils.DeleteFile(QIXFileName);
  4263.   MonitorZero;
  4264. end;
  4265.  
  4266. procedure TQDB.SetCacheFrequency(Value: integer);
  4267. { resets cache-hit counting -- notice that whatever the }
  4268. { value the result is the same. }
  4269. begin
  4270.   Cache.SetFrequency(Value);
  4271. end;
  4272.  
  4273. procedure TQDB.SetCacheSize(Value: longint);
  4274. { sets the upper limit on the cache's size -- flushing }
  4275. { the cache in the process }
  4276. begin
  4277.   Cache.SetSize(Value);
  4278. end;
  4279.  
  4280. procedure TQDB.SetDummyAuthor(Value: string40);
  4281. begin
  4282.   { does nothing but make a read-only property visible in Object Inspector }
  4283. end;
  4284.  
  4285. procedure TQDB.SetDummyVersion(Value: string05);
  4286. begin
  4287.   { does nothing but make a read-only property visible in Object Inspector }
  4288. end;
  4289.  
  4290. procedure TQDB.SetFileName(Value: string);
  4291. { setting the FileName property loads and unloads QDB files }
  4292. begin
  4293.   try
  4294.     if FExpandedFileNames and (Value <> '') then
  4295.       Value := ExpandFileName(Value);
  4296.     if ExpandFileName(FFileName) <> ExpandFileName(Value) then
  4297.     begin
  4298.       if Live and (FFileName <> '') then
  4299.         CloseQDB;
  4300.       if Value = '' then
  4301.         FFileName := ''
  4302.       else
  4303.       begin
  4304.         FFileName := Value;
  4305.         if ExtractFileExt(FFileName) = '' then
  4306.           FFileName := ChangeFileExt(FFileName, '.QDB');
  4307.       end;
  4308.       if Live and (FFileName <> '') then
  4309.         OpenQDB;
  4310.       FileAssigned; { trigger event }
  4311.     end;
  4312.   except
  4313.     FFileName := ''; { if anything goes wrong ... }
  4314.     raise;
  4315.   end;
  4316. end;
  4317.  
  4318. procedure TQDB.SetFilter(Value: TKey);
  4319. { sets a filter to restrict navigation }
  4320. begin
  4321.   Filtered := (Value <> ''); { we use this flag a lot elsewhere }
  4322.   FFilter := Value;
  4323. end;
  4324.  
  4325. procedure TQDB.SetGrepMatch(Value: boolean);
  4326. begin
  4327.   if Value then
  4328.     Matches := GrepMatches
  4329.   else
  4330.     Matches := SimpleMatches;
  4331.   FGrepMatch := Value;
  4332. end;
  4333.  
  4334. procedure TQDB.SetItemIndex(Value: TItemIndex);
  4335. { does all the work of moving about the index }
  4336. begin
  4337.   if Index.Count = 0 then
  4338.     NoData { trigger event if empty }
  4339.   else
  4340.     if (Value < 0) or (Value > Index.Count - 1) then
  4341.       OutOfBounds { trigger event if illegal move }
  4342.     else
  4343.     begin
  4344.       FItemIndex := Value; { new index position }
  4345.       FKey := GetKey(FItemIndex); { updated properties }
  4346.       if (FUpdating = 0) then
  4347.         Navigate; { trigger event when index pos changes }
  4348.     end
  4349. end;
  4350.  
  4351. procedure TQDB.SetKeyCase(Value: boolean);
  4352. { sets the case-sensitivity of the index }
  4353. begin
  4354.   { if value is false the index is checked and any duplicates purged }
  4355.   Index.CaseSensitive := Value;
  4356.   {the case-sensitivity is stored in the QDB file }
  4357.   AdminAsBoolean['QDBCaseSensitive'] := Value;
  4358. end;
  4359.  
  4360. procedure TQDB.SetLinkToNavigator(Value: TQDBNavigator);
  4361. { note which navigator (if any) is using this QDB }
  4362. begin
  4363.   FQDBNavigator := Value;
  4364.   UpdateNavigator;
  4365. end;
  4366.  
  4367. procedure TQDB.SetMatchChars(Front: char; back: char);
  4368. { defines the wild card chars for the simple pattern matching }
  4369. begin
  4370.   if Front <> #0 then
  4371.     FFrontWild := Front;
  4372.   if back <> #0 then
  4373.     FBackWild := back;
  4374. end;
  4375.  
  4376. procedure TQDB.SetReadOnly(Value: boolean);
  4377. { sets the ReadOnly state of the QDB and notifies the navigator }
  4378. begin
  4379.   if Value <> FReadOnly then
  4380.   begin
  4381.     FReadOnly := Value;
  4382.     UpdateNavigator;
  4383.   end;
  4384. end;
  4385.  
  4386. procedure TQDB.SetReady(Value: boolean);
  4387. { sets the Ready state of the QDB and notifies the navigator }
  4388. begin
  4389.   if Value <> FReady then
  4390.   begin
  4391.     FReady := Value;
  4392.     UpdateNavigator;
  4393.   end;
  4394. end;
  4395.  
  4396. procedure TQDB.SetStr(n: TItemIndex; const Value: string);
  4397. { sets the item n as a string }
  4398. begin
  4399.   ItemIndex := n;
  4400.   SetThisStr(Value);
  4401. end;
  4402.  
  4403. procedure TQDB.SetStrByKey(Key: TKey; const Value: string);
  4404. { look up key and add or change item as string }
  4405. var
  4406.   m: TMemoryStream;
  4407. begin
  4408.   if ExactMatch(Key) then
  4409.     SetThisStr(Value)
  4410.   else
  4411.   begin
  4412.     m := TMemoryStream.Create;
  4413.     try
  4414.       m.Write(Value[1], Length(Value));
  4415.       m.Seek(0, 0);
  4416.       Add(m, Key);
  4417.     finally
  4418.       m.Free;
  4419.     end;
  4420.   end;
  4421. end;
  4422.  
  4423. procedure TQDB.SetThisStr(const Value: string);
  4424. { sets -- adds or changes -- current item as string }
  4425. var
  4426.   m: TMemoryStream;
  4427. begin
  4428.   m := TMemoryStream.Create;
  4429.   try
  4430.     m.Write(Value[1], Length(Value));
  4431.     m.Seek(0, 0);
  4432.     Change(m);
  4433.   finally
  4434.     m.Free;
  4435.   end;
  4436. end;
  4437.  
  4438. procedure TQDB.SignalProgress(Percent: TPercentage; Kind: TProgressOrigin);
  4439. begin
  4440.   if Assigned(FProgressUpdate) then
  4441.     FProgressUpdate(Self, Percent, Kind);
  4442. end;
  4443.  
  4444. function TQDB.SimpleMatches(Key: TKey; Pattern: TKey): boolean;
  4445. { used by the filtering system  -- if you wanted a more }
  4446. { sophisticated match you would override this function. }
  4447. var
  4448.   IsMatch: boolean;
  4449.   LeftPos,
  4450.     RightPos,
  4451.     PatternPosF,
  4452.     PatternPosL,
  4453.     LenP,
  4454.     LastPos: Byte;
  4455. begin
  4456.   if not KeyCaseSensitive then
  4457.   begin
  4458.     Key := UpperCase(Key);
  4459.     Pattern := UpperCase(Pattern);
  4460.   end;
  4461.   LenP := Length(Pattern);
  4462.   LeftPos := Pos(FFrontWild, Pattern);
  4463.   if LeftPos = 1 then
  4464.   begin
  4465.     dec(LenP);
  4466.     Pattern := Copy(Pattern, 2, LenP);
  4467.   end;
  4468.   RightPos := Pos(FBackWild, Pattern);
  4469.   if (RightPos = LenP) and (LenP <> 0) then
  4470.   begin
  4471.     dec(LenP);
  4472.     Pattern := Copy(Pattern, 1, LenP);
  4473.   end
  4474.   else
  4475.   begin
  4476.     if LenP = 0 then { Clester Keaton }
  4477.     begin
  4478.       Result := true;
  4479.       exit;
  4480.     end;
  4481.   end;
  4482.   if LenP = 0 then
  4483.   begin
  4484.     PatternPosF := 1;
  4485.     PatternPosL := 1;
  4486.   end
  4487.   else
  4488.   begin
  4489.     PatternPosF := Pos(Pattern, Key);
  4490.     PatternPosL := PatternPosF;
  4491.     if PatternPosL <> 0 then
  4492.     begin
  4493.       LastPos := PatternPosL;
  4494.       while LastPos <> 0 do
  4495.       begin
  4496.         LastPos := Pos(Pattern, Copy(Key, PatternPosL + 1, Length(Key)));
  4497.         PatternPosL := PatternPosL + LastPos;
  4498.       end;
  4499.     end;
  4500.   end;
  4501.   IsMatch := PatternPosF <> 0;
  4502.   if IsMatch and (LeftPos = 0) and (PatternPosF <> 1) then
  4503.   begin
  4504.     IsMatch := false;
  4505.   end;
  4506.   if IsMatch and (RightPos = 0) and (PatternPosL <> (Length(Key) - LenP + 1
  4507.     )) then
  4508.   begin
  4509.     IsMatch := false;
  4510.   end;
  4511.   Result := IsMatch;
  4512. end;
  4513.  
  4514. procedure TQDB.Splice;
  4515. { Splices the two working files back into a single QDB file, }
  4516. { takingcare not to overwrite the original if it has been used }
  4517. { by another program. }
  4518. const
  4519.   Sig1: array[0..3] of char = ('Q', 'D', 'B', #0);
  4520.   Sig2: array[0..3] of char = ('Q', 'I', 'X', #0);
  4521.   Sig3: array[0..3] of char = ('Q', 'P', 'W', #0);
  4522. var
  4523.   n: longint;
  4524.   TmpFileName: string;
  4525.   f, f1, f2: TFileHandle;
  4526.   Buffer: pointer;
  4527.   sz1, sz2: longint;
  4528.   BytesRead: TFilePos;
  4529.   BufLen: longint;
  4530.   CanOverWrite: boolean;
  4531.   PassHash: THash;
  4532.   WriteHash: THash;
  4533.   Encrypt: boolean;
  4534. begin
  4535.   if ReadOnly then
  4536.     exit;
  4537.   { check if the file has been used since we opened it -- }
  4538.   { if FFileAge = 0 it means we are doing a SaveAs... }
  4539.   if (FFileAge <> 0) and (FileAge(FFileName) <> FFileAge) then
  4540.   begin
  4541.     { it has so we need to ask if we can save our stuff over it }
  4542.     CanOverWrite := FForceOverwrite; { be conservative }
  4543.     AboutToOverWrite(CanOverWrite);
  4544.     if not CanOverWrite then
  4545.       repeat
  4546.         { since we can't overwrite the original we have }
  4547.         { to look for a unique derivative of the filename }
  4548.         FFileName := ExtractFilePath(FFileName) + '1.' + ExtractFileName(
  4549.           FFileName);
  4550.       until not FileExists(FileName);
  4551.     { then we can go ahead as normal }
  4552.   end;
  4553.   Encrypt := false;
  4554.   TmpFileName := TempFileName('QDD');
  4555.   f := FileCreate(TmpFileName);
  4556.   if f < 0 then
  4557.     FileError(f, '');
  4558.   try { protect file f }
  4559.     FileWrite(f, Sig1, SizeOf(Sig1));
  4560.     if Password <> '' then
  4561.     begin
  4562.       FileWrite(f, Sig3, SizeOf(Sig3));
  4563.       WriteHash := Hash(Password);
  4564.       PassHash := Hash(WriteHash);
  4565.       FileWrite(f, PassHash, SizeOf(THash));
  4566.       Encrypt := true;
  4567.     end;
  4568.     f1 := FileOpen(QDBFileName, fmOpenRead or fmShareExclusive);
  4569.     if f1 < 0 then
  4570.       FileError(f1, '');
  4571.     try { protect file f1 }
  4572.       sz1 := FileSeek(f1, 0, 2);
  4573.       FileWrite(f, sz1, SizeOf(sz1));
  4574.       FileSeek(f1, 0, 0);
  4575.       BufLen := GetBuffer(Buffer, sz1);
  4576.       try { protect memory buffer }
  4577.         for n := 1 to (sz1 div BufLen) do
  4578.         begin
  4579.           BytesRead := FileRead(f1, Buffer^, BufLen);
  4580.           if Encrypt then
  4581.             Shroud(Buffer^, BytesRead, WriteHash);
  4582.           FileWrite(f, Buffer^, BytesRead);
  4583.         end;
  4584.         BytesRead := FileRead(f1, Buffer^, sz1 mod BufLen);
  4585.         if Encrypt then
  4586.           Shroud(Buffer^, BytesRead, WriteHash);
  4587.         FileWrite(f, Buffer^, BytesRead);
  4588.       finally
  4589.         FreeMem(Buffer, BufLen);
  4590.       end;
  4591.     finally
  4592.       FileClose(f1);
  4593.     end;
  4594.     FileWrite(f, Sig2, SizeOf(Sig2));
  4595.     f2 := FileOpen(QIXFileName, fmOpenRead or fmShareExclusive);
  4596.     if f2 < 0 then
  4597.       FileError(f2, '');
  4598.     try { protect file f2 }
  4599.       sz2 := FileSeek(f2, 0, 2);
  4600.       FileWrite(f, sz2, SizeOf(sz2));
  4601.       FileSeek(f2, 0, 0);
  4602.       BufLen := GetBuffer(Buffer, sz2);
  4603.       try { protect memory buffer }
  4604.         for n := 1 to (sz2 div BufLen) do
  4605.         begin
  4606.           BytesRead := FileRead(f2, Buffer^, BufLen);
  4607.           if Encrypt then
  4608.             Shroud(Buffer^, BytesRead, WriteHash);
  4609.           FileWrite(f, Buffer^, BytesRead);
  4610.         end;
  4611.         BytesRead := FileRead(f2, Buffer^, sz2 mod BufLen);
  4612.         if Encrypt then
  4613.           Shroud(Buffer^, BytesRead, WriteHash);
  4614.         FileWrite(f, Buffer^, BytesRead);
  4615.       finally
  4616.         FreeMem(Buffer, BufLen);
  4617.       end;
  4618.     finally
  4619.       FileClose(f2);
  4620.     end;
  4621.   finally
  4622.     FileClose(f);
  4623.     RenameOrMoveFile(TmpFileName, FFileName);
  4624.     FFileAge := FileAge(FFileName);
  4625.   end;
  4626. end;
  4627.  
  4628. procedure TQDB.Split;
  4629. { This seems like a good place to document the QDB file format ... }
  4630. { }
  4631. {  4 bytes -- 'Q','D','B',#0 }
  4632. {(24 bytes -- optional password block present if file is encrypted }
  4633. {             'Q','P','W',#0 indicates encryption }
  4634. {             20 bytes of encrypted password ) }
  4635. {  4 bytes -- longint(n1) = size of data block }
  4636. { n1 bytes of data }
  4637. {  4 bytes -- 'Q','I','X',#0 }
  4638. {  4 bytes -- longint(n2) = size of index block }
  4639.  
  4640. { Split takes a QDB file and, testing it for integrity, }
  4641. { splits it into two working files, one the item data, }
  4642. { the other the index data. These are the files that the }
  4643. { QDB component uses internally. The original QDB file }
  4644. { doesn't get reconstituted until the Splice method. }
  4645. var
  4646.   n: longint;
  4647.   f, f1, f2: TFileHandle;
  4648.   Buffer: pointer;
  4649.   Sig: array[0..3] of char;
  4650.   sz1, sz2: longint;
  4651.   BytesRead: TFilePos;
  4652.   BufLen: longint;
  4653.   PassHash: THash;
  4654.   ReadHash: THash;
  4655.   ReadHash2: THash;
  4656.   Decrypt: boolean;
  4657. begin
  4658.   Decrypt := false;
  4659.   { we get the age of the file when it was opened }
  4660.   FFileAge := FileAge(FFileName);
  4661.   if (faReadOnly and FileGetAttr(FFileName)) <> 0 then
  4662.     ReadOnly := true;
  4663.   f := FileOpen(FFileName, fmOpenRead);
  4664.   if f < 0 then
  4665.     FileError(f, '');
  4666.   try { protect file f }
  4667.     FileRead(f, Sig, SizeOf(Sig));
  4668.     if StrPas(Sig) <> 'QDB' then
  4669.       FileError(-1, SCorrupt);
  4670.     BytesRead := FileRead(f, Sig, SizeOf(Sig));
  4671.     if StrPas(Sig) = 'QPW' then
  4672.     begin
  4673.       { process password }
  4674.       FileRead(f, PassHash, SizeOf(THash));
  4675.       if Password = '' then
  4676.         DemandPassword;
  4677.       ReadHash := Hash(Password);
  4678.       ReadHash2 := Hash(ReadHash);
  4679.       if Hash(ReadHash) = PassHash then
  4680.       begin
  4681.         { we have a match }
  4682.         Decrypt := true;
  4683.       end
  4684.       else
  4685.       begin
  4686.         { file demands a password and we can't deliver }
  4687.         raise EQDBInvalidPW.Create(SBadPassword);
  4688.       end;
  4689.     end
  4690.     else
  4691.     begin
  4692.       { rewind and continue }
  4693.       FileSeek(f, -BytesRead, 1)
  4694.     end;
  4695.     FileRead(f, sz1, SizeOf(sz1));
  4696.     BufLen := GetBuffer(Buffer, sz1);
  4697.     try { protect memory buffer }
  4698.       QDBFileName := TempFileName('QDB');
  4699.       f1 := FileCreate(QDBFileName);
  4700.       if f1 < 0 then
  4701.         FileError(f1, '');
  4702.       try { protect file f1 }
  4703.         for n := 1 to (sz1 div BufLen) do
  4704.         begin
  4705.           BytesRead := FileRead(f, Buffer^, BufLen);
  4706.           if Decrypt then
  4707.             UnShroud(Buffer^, BytesRead, ReadHash);
  4708.           FileWrite(f1, Buffer^, BytesRead);
  4709.         end;
  4710.         BytesRead := FileRead(f, Buffer^, sz1 mod BufLen);
  4711.         if Decrypt then
  4712.           UnShroud(Buffer^, BytesRead, ReadHash);
  4713.         FileWrite(f1, Buffer^, BytesRead);
  4714.       finally
  4715.         FileClose(f1);
  4716.       end;
  4717.     finally
  4718.       FreeMem(Buffer, BufLen);
  4719.     end;
  4720.     FileRead(f, Sig, SizeOf(Sig));
  4721.     if StrPas(Sig) <> 'QIX' then
  4722.       FileError(-1, SCorrupt);
  4723.     FileRead(f, sz2, SizeOf(sz2));
  4724.     BufLen := GetBuffer(Buffer, sz2);
  4725.     try { protect memory buffer }
  4726.       { use same 'random' name as for QDBFileName }
  4727.       QIXFileName := ExtractFilePath(QDBFileName) + 'QIX' + Copy(
  4728.         ExtractFileName(QDBFileName), 4, MAX_PATH);
  4729.       f2 := FileCreate(QIXFileName);
  4730.       if f2 < 0 then
  4731.         FileError(f2, '');
  4732.       try { protect file f2 }
  4733.         for n := 1 to (sz2 div BufLen) do
  4734.         begin
  4735.           BytesRead := FileRead(f, Buffer^, BufLen);
  4736.           if Decrypt then
  4737.             UnShroud(Buffer^, BytesRead, ReadHash);
  4738.           FileWrite(f2, Buffer^, BytesRead);
  4739.         end;
  4740.         BytesRead := FileRead(f, Buffer^, sz2 mod BufLen);
  4741.         if Decrypt then
  4742.           UnShroud(Buffer^, BytesRead, ReadHash);
  4743.         FileWrite(f2, Buffer^, BytesRead);
  4744.       finally
  4745.         FileClose(f2);
  4746.       end;
  4747.     finally
  4748.       FreeMem(Buffer, BufLen);
  4749.     end;
  4750.   finally
  4751.     FileClose(f);
  4752.   end;
  4753. end;
  4754.  
  4755. procedure TQDB.UpdateNavigator;
  4756. { recalcs BoF and EoF and then prompts the navigator (if there is }
  4757. { one assigned) to update its buttons }
  4758. var
  4759.   This: TItemIndex;
  4760. begin
  4761.   if Filtered then
  4762.   begin
  4763.     if AggressiveUpdate then
  4764.     begin
  4765.       This := FItemIndex - 1;
  4766.       while (This >= 0) and not Matches(GetKey(This), FFilter) do
  4767.       begin
  4768.         dec(This);
  4769.       end;
  4770.       if This < 0 then
  4771.       begin
  4772.         FBoF := true;
  4773.       end;
  4774.       This := FItemIndex + 1;
  4775.       while (This < FCount) and not Matches(GetKey(This), FFilter) do
  4776.       begin
  4777.         inc(This);
  4778.       end;
  4779.       if This >= FCount then
  4780.       begin
  4781.         FEoF := true;
  4782.       end;
  4783.     end;
  4784.   end
  4785.   else
  4786.   begin
  4787.     FBoF := (FCount > 0) and (FItemIndex = 0);
  4788.     FEoF := (FCount > 0) and (FItemIndex + 1 = FCount);
  4789.   end;
  4790.   if Assigned(FQDBNavigator) then
  4791.   begin
  4792.     FQDBNavigator.QDBStateChanged;
  4793.   end;
  4794. end;
  4795.  
  4796. { Basically -- the TQDBNavigator component from DBCtrls but with }
  4797. { all the BDE stuff torn out and replaced with QDB stuff instead. }
  4798. { Portions of this code are Copyright Borland. }
  4799. { Copyright (c) 1995-1997 Borland International. All Rights Reserved. }
  4800.  
  4801. { TQDBNavigator }
  4802.  
  4803. const
  4804.   InitRepeatPause = 400; { pause before repeat timer (ms) }
  4805.   RepeatPause = 100; { pause before hint window displays (ms)}
  4806.   SpaceSize = 5; { size of space between special buttons }
  4807.  
  4808. const
  4809.   SFirstRecord = 119;
  4810.   SPrevRecord = 120;
  4811.   SNextRecord = 121;
  4812.   SLastRecord = 122;
  4813.   SInsertRecord = 123;
  4814.   SDeleteRecord = 124;
  4815.   SEditRecord = 125;
  4816.   SPostEdit = 126;
  4817.   SCancelEdit = 127;
  4818.   SRefreshRecord = 128;
  4819.   BtnTypeName: array[TNavigateBtn] of pchar = ('FIRST', 'PREV', 'NEXT',
  4820.     'LAST', 'INSERT', 'DELETE', 'EDIT', 'POST', 'CANCEL', 'REFRESH');
  4821.   BtnHintId: array[TNavigateBtn] of word = (SFirstRecord, SPrevRecord,
  4822.     SNextRecord, SLastRecord, SInsertRecord, SDeleteRecord, SEditRecord,
  4823.     SPostEdit, SCancelEdit, SRefreshRecord);
  4824.  
  4825. constructor TQDBNavigator.Create(AOwner: TComponent);
  4826. begin
  4827.   inherited Create(AOwner);
  4828.   ControlStyle := ControlStyle - [csAcceptsControls, csSetCaption] + [csOpaque
  4829.     ];
  4830. {$IFDEF VER100}
  4831.   if not NewStyleControls then
  4832.     ControlStyle := ControlStyle + [csFramed];
  4833. {$ELSE}
  4834.   ControlStyle := ControlStyle + [csFramed];
  4835. {$ENDIF}
  4836.   FVisibleButtons := [nbFirst, nbPrev, nbNext, nbLast, nbInsert, nbDelete, nbEdit, nbPost,
  4837.     nbCancel, nbRefresh];
  4838.   FHints := TStringList.Create;
  4839.   TStringList(FHints).OnChange := HintsChanged;
  4840.   InitButtons;
  4841.   BevelOuter := bvNone;
  4842.   BevelInner := bvNone;
  4843.   Width := 241;
  4844.   Height := 25;
  4845.   ButtonHeight := 0;
  4846.   ButtonWidth := 0;
  4847.   FocusedButton := nbFirst;
  4848. end;
  4849.  
  4850. destructor TQDBNavigator.Destroy;
  4851. var
  4852.   i: TNavigateBtn;
  4853. begin
  4854.   if FQDB <> nil then             {BS}
  4855.     FQDB.SetLinkToNavigator(nil); {BS}
  4856.   FHints.Free;
  4857.   for i := Low(Buttons) to High(Buttons) do
  4858.     Buttons[i].Free;
  4859.   inherited Destroy;
  4860. end;
  4861.  
  4862. procedure TQDBNavigator._Click(Sender: TObject);
  4863. begin
  4864.   BtnClick(TNavButton(Sender).Index);
  4865. end;
  4866.  
  4867. procedure TQDBNavigator.AdjustSize(var W: integer; var H: integer);
  4868. var
  4869.   Count: integer;
  4870.   MinW: integer;
  4871.   MinH: integer;
  4872.   i: TNavigateBtn;
  4873.   Space, Temp, Remain: integer;
  4874.   X: integer;
  4875.   Y: integer;
  4876. begin
  4877.   if (csLoading in ComponentState) then
  4878.     exit;
  4879.   if Buttons[nbFirst] = nil then
  4880.     exit;
  4881.   Count := 0;
  4882.   for i := Low(Buttons) to High(Buttons) do
  4883.   begin
  4884.     if Buttons[i].Visible then
  4885.     begin
  4886.       inc(Count);
  4887.     end;
  4888.   end;
  4889.   if Count = 0 then
  4890.     inc(Count);
  4891.  
  4892.   {horizontal}
  4893.   if ((FOrientation = noAuto) and (W >= H)) or (FOrientation = noHoriz) then
  4894.   begin
  4895.     MinW := Count * (MinBtnSize.X);
  4896.     if W < MinW then
  4897.       W := MinW;
  4898.     if H < MinBtnSize.Y then
  4899.       H := MinBtnSize.Y;
  4900.     ButtonWidth := ((W) div Count);
  4901.     Temp := Count * (ButtonWidth);
  4902.     if Align = alNone then
  4903.       W := Temp;
  4904.     X := 0;
  4905.     Remain := W - Temp;
  4906.     Temp := Count div 2;
  4907.     for i := Low(Buttons) to High(Buttons) do
  4908.     begin
  4909.       if Buttons[i].Visible then
  4910.       begin
  4911.         Space := 0;
  4912.         if Remain <> 0 then
  4913.         begin
  4914.           dec(Temp, Remain);
  4915.           if Temp < 0 then
  4916.           begin
  4917.             inc(Temp, Count);
  4918.             Space := 1;
  4919.           end;
  4920.         end;
  4921.         Buttons[i].SetBounds(X, 0, ButtonWidth + Space, Height);
  4922.         inc(X, ButtonWidth + Space);
  4923.       end
  4924.       else
  4925.         Buttons[i].SetBounds(Width, 0, ButtonWidth, Height);
  4926.     end;
  4927.   end {vertical: ((FDirection=dirAuto) and (W < H)) or (FDirection=dirVertical)}
  4928.   else
  4929.   begin
  4930.     MinH := Count * (MinBtnSize.Y);
  4931.     if H < MinH then
  4932.       H := MinH;
  4933.     if W < MinBtnSize.X then
  4934.       W := MinBtnSize.X;
  4935.     ButtonHeight := (H div Count);
  4936.     Temp := Count * (ButtonHeight);
  4937.     if Align = alNone then
  4938.       H := Temp;
  4939.     Y := 0;
  4940.     Remain := H - Temp;
  4941.     Temp := Count div 2;
  4942.     for i := Low(Buttons) to High(Buttons) do
  4943.     begin
  4944.       if Buttons[i].Visible then
  4945.       begin
  4946.         Space := 0;
  4947.         if Remain <> 0 then
  4948.         begin
  4949.           dec(Temp, Remain);
  4950.           if Temp < 0 then
  4951.           begin
  4952.             inc(Temp, Count);
  4953.             Space := 1;
  4954.           end;
  4955.         end;
  4956.         Buttons[i].SetBounds(0, Y, Width, ButtonHeight + Space);
  4957.         inc(Y, ButtonHeight + Space);
  4958.       end
  4959.       else
  4960.         Buttons[i].SetBounds(0, Height, ButtonHeight, Width);
  4961.     end;
  4962.   end;
  4963. end;
  4964.  
  4965. procedure TQDBNavigator.BtnClick(Index: TNavigateBtn);
  4966. begin
  4967.   if (FQDB <> nil) then
  4968.   begin
  4969.     if not (csDesigning in ComponentState) and Assigned(FBeforeAction) then
  4970.       FBeforeAction(Self, Index);
  4971.     case Index of
  4972.       nbPrev:
  4973.         Prev;
  4974.       nbNext:
  4975.         Next;
  4976.       nbFirst:
  4977.         First;
  4978.       nbLast:
  4979.         Last;
  4980.       nbInsert:
  4981.         Insert;
  4982.       nbEdit:
  4983.         Edit;
  4984.       nbCancel:
  4985.         Cancel;
  4986.       nbPost:
  4987.         Post;
  4988.       nbRefresh:
  4989.         Refresh;
  4990.       nbDelete:
  4991.         Delete;
  4992.     end;
  4993.   end;
  4994.   if not (csDesigning in ComponentState) and Assigned(FOnNavClick) then
  4995.     FOnNavClick(Self, Index);
  4996. end;
  4997.  
  4998. procedure TQDBNavigator.BtnMouseDown(Sender: TObject; Button: TMouseButton;
  4999.   Shift: TShiftState; X, Y: integer);
  5000. var
  5001.   OldFocus: TNavigateBtn;
  5002. begin
  5003.   OldFocus := FocusedButton;
  5004.   FocusedButton := TNavButton(Sender).Index;
  5005.   if TabStop and (GetFocus <> Handle) and CanFocus then
  5006.   begin
  5007.     SetFocus;
  5008.     if (GetFocus <> Handle) then
  5009.       exit;
  5010.   end
  5011.   else
  5012.     if TabStop and (GetFocus = Handle) and (OldFocus <> FocusedButton) then
  5013.     begin
  5014.       Buttons[OldFocus].Invalidate;
  5015.       Buttons[FocusedButton].Invalidate;
  5016.     end;
  5017. end;
  5018.  
  5019. procedure TQDBNavigator.Cancel;
  5020. begin
  5021.   if Assigned(FQDB) then
  5022.     if Assigned(FOnCancel) then
  5023.       FOnCancel(Self, FQDB)
  5024.     else
  5025.       FQDB.Cancel;
  5026. end;
  5027.  
  5028. procedure TQDBNavigator.Delete;
  5029. begin
  5030.   if Assigned(FQDB) then
  5031.     if Assigned(FOnDelete) then
  5032.       FOnDelete(Self, FQDB)
  5033.     else
  5034.       FQDB.Delete;
  5035. end;
  5036.  
  5037. procedure TQDBNavigator.Edit;
  5038. begin
  5039.   if Assigned(FQDB) then
  5040.     if Assigned(FOnEdit) then
  5041.       FOnEdit(Self, FQDB)
  5042.     else
  5043.       FQDB.Edit;
  5044. end;
  5045.  
  5046. procedure TQDBNavigator.First;
  5047. begin
  5048.   if Assigned(FQDB) then
  5049.     if Assigned(FOnFirst) then
  5050.       FOnFirst(Self, FQDB)
  5051.     else
  5052.       FQDB.FirstItem;
  5053. end;
  5054.  
  5055. function TQDBNavigator.GetEnabled: boolean;
  5056. begin
  5057.   Result := inherited Enabled;
  5058. end;
  5059.  
  5060. function TQDBNavigator.GetGlyph(Btn: TNavigateBtn): Graphics.TBitmap;
  5061. begin
  5062.   Result := Buttons[Btn].Glyph;
  5063. end;
  5064.  
  5065. procedure TQDBNavigator.HintsChanged(Sender: TObject);
  5066. begin
  5067.   InitHints;
  5068. end;
  5069.  
  5070. procedure TQDBNavigator.InitButtons;
  5071. var
  5072.   i: TNavigateBtn;
  5073.   Btn: TNavButton;
  5074.   X: integer;
  5075.   ResName: array[0..40] of char;
  5076. begin
  5077.   MinBtnSize := Point(20, 18);
  5078.   X := 0;
  5079.   for i := Low(Buttons) to High(Buttons) do
  5080.   begin
  5081.     Btn := TNavButton.Create(Self);
  5082. {$IFDEF VER100}
  5083.     Btn.Flat := Flat;
  5084. {$ENDIF}
  5085.     Btn.Index := i;
  5086.     Btn.Visible := i in FVisibleButtons;
  5087.     Btn.Enabled := true;
  5088.     Btn.SetBounds(X, 0, MinBtnSize.X, MinBtnSize.Y);
  5089.     StrFmt(ResName, 'qdb_%s', [BtnTypeName[i]]);
  5090.     Btn.Glyph.Handle := LoadBitmap(HInstance, ResName);
  5091.     Btn.NumGlyphs := 2;
  5092.     Btn.Enabled := false;
  5093.     Btn.Enabled := true;
  5094.     Btn.OnClick := _Click;
  5095.     Btn.OnMouseDown := BtnMouseDown;
  5096.     Btn.Parent := Self;
  5097.     Buttons[i] := Btn;
  5098.     X := X + MinBtnSize.X;
  5099.   end;
  5100.   InitHints;
  5101.   Buttons[nbPrev].NavStyle := Buttons[nbPrev].NavStyle + [nsAllowTimer];
  5102.   Buttons[nbNext].NavStyle := Buttons[nbNext].NavStyle + [nsAllowTimer];
  5103. end;
  5104.  
  5105. procedure TQDBNavigator.InitHints;
  5106. var
  5107.   i: integer;
  5108.   j: TNavigateBtn;
  5109. begin
  5110.   for j := Low(Buttons) to High(Buttons) do
  5111.     Buttons[j].Hint := LoadStr(BtnHintId[j]);
  5112.   j := Low(Buttons);
  5113.   for i := 0 to (FHints.Count - 1) do
  5114.   begin
  5115.     if FHints.Strings[i] <> '' then
  5116.       Buttons[j].Hint := FHints.Strings[i];
  5117.     if j = High(Buttons) then
  5118.       exit;
  5119.     inc(j);
  5120.   end;
  5121. end;
  5122.  
  5123. procedure TQDBNavigator.Insert;
  5124. begin
  5125.   if Assigned(FQDB) then
  5126.     if Assigned(FOnInsert) then
  5127.       FOnInsert(Self, FQDB)
  5128.     else
  5129.       FQDB.Insert;
  5130. end;
  5131.  
  5132. procedure TQDBNavigator.KeyDown(var Key: word; Shift: TShiftState);
  5133. var
  5134.   NewFocus: TNavigateBtn;
  5135.   OldFocus: TNavigateBtn;
  5136. begin
  5137.   OldFocus := FocusedButton;
  5138.   case Key of
  5139.     VK_RIGHT:
  5140.       begin
  5141.         NewFocus := FocusedButton;
  5142.         repeat
  5143.           if NewFocus < High(Buttons) then
  5144.             NewFocus := succ(NewFocus);
  5145.         until (NewFocus = High(Buttons)) or (Buttons[NewFocus].Visible);
  5146.         if NewFocus <> FocusedButton then
  5147.         begin
  5148.           FocusedButton := NewFocus;
  5149.           Buttons[OldFocus].Invalidate;
  5150.           Buttons[FocusedButton].Invalidate;
  5151.         end;
  5152.       end;
  5153.     VK_LEFT:
  5154.       begin
  5155.         NewFocus := FocusedButton;
  5156.         repeat
  5157.           if NewFocus > Low(Buttons) then
  5158.             NewFocus := pred(NewFocus);
  5159.         until (NewFocus = Low(Buttons)) or (Buttons[NewFocus].Visible);
  5160.         if NewFocus <> FocusedButton then
  5161.         begin
  5162.           FocusedButton := NewFocus;
  5163.           Buttons[OldFocus].Invalidate;
  5164.           Buttons[FocusedButton].Invalidate;
  5165.         end;
  5166.       end;
  5167.     VK_SPACE:
  5168.       begin
  5169.         if Buttons[FocusedButton].Enabled then
  5170.           Buttons[FocusedButton].Click;
  5171.       end;
  5172.   end;
  5173. end;
  5174.  
  5175. procedure TQDBNavigator.Last;
  5176. begin
  5177.   if Assigned(FQDB) then
  5178.     if Assigned(FOnLast) then
  5179.       FOnLast(Self, FQDB)
  5180.     else
  5181.       FQDB.LastItem;
  5182. end;
  5183.  
  5184. procedure TQDBNavigator.Loaded;
  5185. var
  5186.   W, H: integer;
  5187. begin
  5188.   inherited Loaded;
  5189.   W := Width;
  5190.   H := Height;
  5191.   AdjustSize(W, H);
  5192.   if (W <> Width) or (H <> Height) then
  5193.     inherited SetBounds(Left, Top, W, H);
  5194.   InitHints;
  5195. end;
  5196.  
  5197. procedure TQDBNavigator.Next;
  5198. begin
  5199.   if Assigned(FQDB) then
  5200.     if Assigned(FOnNext) then
  5201.       FOnNext(Self, FQDB)
  5202.     else
  5203.       FQDB.NextItem;
  5204. end;
  5205.  
  5206. procedure TQDBNavigator.Notification(AComponent: TComponent; Operation:
  5207.   TOperation);
  5208. { if the link to a data file is broken we must respond }
  5209. begin
  5210.   inherited Notification(AComponent, Operation);
  5211.   if (FQDB <> nil) and
  5212.     (AComponent = FQDB) and
  5213.     (Operation = opRemove) then
  5214.     FQDB := nil;
  5215. end;
  5216.  
  5217. procedure TQDBNavigator.Post;
  5218. begin
  5219.   if Assigned(FQDB) then
  5220.     if Assigned(FOnPost) then
  5221.       FOnPost(Self, FQDB)
  5222.     else
  5223.       FQDB.Post;
  5224. end;
  5225.  
  5226. procedure TQDBNavigator.Prev;
  5227. begin
  5228.   if Assigned(FQDB) then
  5229.     if Assigned(FOnPrev) then
  5230.       FOnPrev(Self, FQDB)
  5231.     else
  5232.       FQDB.PrevItem;
  5233. end;
  5234.  
  5235. procedure TQDBNavigator.QDBStateChanged;
  5236. { update the buttons to reflect the state of the QDB }
  5237. var
  5238.   Btn: TNavigateBtn;
  5239. begin
  5240.   if not Assigned(FQDB) then
  5241.     exit;
  5242.   with FQDB do
  5243.     if not Ready then
  5244.       for Btn := Low(Buttons) to High(Buttons) do
  5245.         Buttons[Btn].Enabled := false
  5246.     else
  5247.     begin
  5248.       Buttons[nbFirst].Enabled := not BoF;
  5249.       Buttons[nbPrev].Enabled := not BoF;
  5250.       Buttons[nbNext].Enabled := not EoF;
  5251.       Buttons[nbLast].Enabled := not EoF;
  5252.       Buttons[nbInsert].Enabled := not (ReadOnly or FInserting);
  5253.       Buttons[nbDelete].Enabled := not (ReadOnly or (Count < 1));
  5254.       Buttons[nbEdit].Enabled := not (ReadOnly or FEditing or FInserting or (Count < 1));
  5255.       Buttons[nbPost].Enabled := FEditing or FInserting;
  5256.       Buttons[nbCancel].Enabled := FEditing or FInserting;
  5257.       Buttons[nbRefresh].Enabled := true;
  5258.     end;
  5259. end;
  5260.  
  5261. procedure TQDBNavigator.Refresh;
  5262. begin
  5263.   if Assigned(FQDB) then
  5264.     if Assigned(FOnRefresh) then
  5265.       FOnRefresh(Self, FQDB)
  5266.     else
  5267.       FQDB.Refresh;
  5268. end;
  5269.  
  5270. procedure TQDBNavigator.SetBounds(ALeft, ATop, AWidth, AHeight: integer);
  5271. var
  5272.   W, H: integer;
  5273. begin
  5274.   W := AWidth;
  5275.   H := AHeight;
  5276.   if not HandleAllocated then
  5277.     AdjustSize(W, H);
  5278.   inherited SetBounds(ALeft, ATop, W, H);
  5279. end;
  5280.  
  5281. procedure TQDBNavigator.SetEnabled(Value: boolean);
  5282. { en/disable the buttons as well }
  5283. var
  5284.   Btn: TNavigateBtn;
  5285. begin
  5286.   if Value and not (csDesigning in ComponentState) then
  5287.     QDBStateChanged
  5288.   else
  5289.     for Btn := Low(Buttons) to High(Buttons) do
  5290.       Buttons[Btn].Enabled := Value;
  5291.   inherited Enabled := Value;
  5292. end;
  5293.  
  5294. procedure TQDBNavigator.SetFlat(Value: boolean);
  5295. var
  5296.   i: TNavigateBtn;
  5297. begin
  5298. {$IFDEF VER100}
  5299.   if FFlat <> Value then
  5300.   begin
  5301.     FFlat := Value;
  5302.     for i := Low(Buttons) to High(Buttons) do
  5303.       Buttons[i].Flat := Value;
  5304.   end;
  5305. {$ELSE}
  5306.   FFlat := false;
  5307. {$ENDIF}
  5308. end;
  5309.  
  5310. procedure TQDBNavigator.SetGlyph(Btn: TNavigateBtn; Value: Graphics.TBitmap
  5311.   );
  5312. begin
  5313.   Buttons[Btn].Glyph := Value;
  5314. end;
  5315.  
  5316. procedure TQDBNavigator.SetHints(Value: TStrings);
  5317. begin
  5318.   FHints.Assign(Value);
  5319.   InitHints;
  5320. end;
  5321.  
  5322. procedure TQDBNavigator.SetOrientation(Value: TNavOrientation);
  5323. var
  5324.   W, H: integer;
  5325. begin
  5326.   W := Width;
  5327.   H := Height;
  5328.   if ((((FOrientation = noAuto) and (W >= H)) or (FOrientation = noHoriz
  5329.     )) and (Value = noVert)) or
  5330.     ((((FOrientation = noAuto) and (W < H)) or (FOrientation = noVert)
  5331.     ) and (Value = noHoriz)) then
  5332.   begin
  5333.     W := Height;
  5334.     H := Width;
  5335.   end;
  5336.   FOrientation := Value;
  5337.   AdjustSize(W, H);
  5338.   if (W <> Width) or (H <> Height) then
  5339.     inherited SetBounds(Left, Top, W, H);
  5340.   Invalidate;
  5341. end;
  5342.  
  5343. procedure TQDBNavigator.SetQDB(Value: TQDB);
  5344. begin
  5345.   if Value <> FQDB then
  5346.   begin
  5347.     if FQDB <> nil then             {BS}
  5348.       FQDB.SetLinkToNavigator(nil); {BS}
  5349.     FQDB := Value;
  5350.     if FQDB <> nil then {BS}
  5351.       FQDB.SetLinkToNavigator(TQDBNavigator(Self));
  5352.   end;
  5353. end;
  5354.  
  5355. procedure TQDBNavigator.SetVisible(Value: TButtonSet);
  5356. var
  5357.   i: TNavigateBtn;
  5358.   W, H: integer;
  5359. begin
  5360.   W := Width;
  5361.   H := Height;
  5362.   FVisibleButtons := Value;
  5363.   for i := Low(Buttons) to High(Buttons) do
  5364.     Buttons[i].Visible := i in FVisibleButtons;
  5365.   AdjustSize(W, H);
  5366.   if (W <> Width) or (H <> Height) then
  5367.     inherited SetBounds(Left, Top, W, H);
  5368.   Invalidate;
  5369. end;
  5370.  
  5371. procedure TQDBNavigator.WMGetDlgCode(var Message: TWMGetDlgCode);
  5372. begin
  5373.   Message.Result := DLGC_WANTARROWS;
  5374. end;
  5375.  
  5376. procedure TQDBNavigator.WMKillFocus(var Message: TWMKillFocus);
  5377. begin
  5378.   Buttons[FocusedButton].Invalidate;
  5379. end;
  5380.  
  5381. procedure TQDBNavigator.WMSetFocus(var Message: TWMSetFocus);
  5382. begin
  5383.   Buttons[FocusedButton].Invalidate;
  5384. end;
  5385.  
  5386. procedure TQDBNavigator.WMSize(var Message: TWMSize);
  5387. var
  5388.   W, H: integer;
  5389. begin
  5390.   inherited;
  5391.   { check for minimum size }
  5392.   W := Width;
  5393.   H := Height;
  5394.   AdjustSize(W, H);
  5395.   if (W <> Width) or (H <> Height) then
  5396.     inherited SetBounds(Left, Top, W, H);
  5397.   Message.Result := 0;
  5398. end;
  5399.  
  5400. { TNavButton }
  5401.  
  5402. destructor TNavButton.Destroy;
  5403. begin
  5404.   if FRepeatTimer <> nil then
  5405.     FRepeatTimer.Free;
  5406.   inherited Destroy;
  5407. end;
  5408.  
  5409. procedure TNavButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  5410.   X, Y: integer);
  5411. begin
  5412.   inherited MouseDown(Button, Shift, X, Y);
  5413.   if nsAllowTimer in FNavStyle then
  5414.   begin
  5415.     if FRepeatTimer = nil then
  5416.       FRepeatTimer := TTimer.Create(Self);
  5417.  
  5418.     FRepeatTimer.OnTimer := TimerExpired;
  5419.     FRepeatTimer.Interval := InitRepeatPause;
  5420.     FRepeatTimer.Enabled := true;
  5421.   end;
  5422. end;
  5423.  
  5424. procedure TNavButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  5425.   X, Y: integer);
  5426. begin
  5427.   inherited MouseUp(Button, Shift, X, Y);
  5428.   if FRepeatTimer <> nil then
  5429.     FRepeatTimer.Enabled := false;
  5430. end;
  5431.  
  5432. procedure TNavButton.Paint;
  5433. var
  5434.   R: TRect;
  5435. begin
  5436.   inherited Paint;
  5437.   if (GetFocus = Parent.Handle) and
  5438.     (FIndex = TQDBNavigator(Parent).FocusedButton) then
  5439.   begin
  5440.     R := Bounds(0, 0, Width, Height);
  5441.     InflateRect(R, -3, -3);
  5442.     if FState = bsDown then
  5443.       OffsetRect(R, 1, 1);
  5444.     DrawFocusRect(Canvas.Handle, R);
  5445.   end;
  5446. end;
  5447.  
  5448. procedure TNavButton.TimerExpired(Sender: TObject);
  5449. begin
  5450.   FRepeatTimer.Interval := RepeatPause;
  5451.   if (FState = bsDown) and MouseCapture then
  5452.   begin
  5453.     try
  5454.       Click;
  5455.     except
  5456.       FRepeatTimer.Enabled := false;
  5457.       raise;
  5458.     end;
  5459.   end;
  5460. end;
  5461.  
  5462. initialization
  5463.  
  5464.   QDBTempFileLocation := '';
  5465.  
  5466. end.
  5467.  
  5468.