sthash.pas

条码控件： 一维条码控件 二维条码控件 PDF417Barcode MaxiCodeBarcode

(* ***** BEGIN LICENSE BLOCK *****
 * Version: MPL 1.1
 *
 * The contents of this file are subject to the Mozilla Public License Version
 * 1.1 (the "License"); you may not use this file except in compliance with
 * the License. You may obtain a copy of the License at
 * http://www.mozilla.org/MPL/
 *
 * Software distributed under the License is distributed on an "AS IS" basis,
 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
 * for the specific language governing rights and limitations under the
 * License.
 *
 * The Original Code is TurboPower SysTools
 *
 * The Initial Developer of the Original Code is
 * TurboPower Software
 *
 * Portions created by the Initial Developer are Copyright (C) 1996-2002
 * the Initial Developer. All Rights Reserved.
 *
 * Contributor(s):
 *
 * ***** END LICENSE BLOCK ***** *)

{*********************************************************}
{* SysTools: StHASH.PAS 4.03                             *}
{*********************************************************}
{* SysTools: Hash table class                            *}
{*********************************************************}

{$I StDefine.inc}

{Notes:
  - Generally the same as STDICT.PAS, but the hash table is
    keyed on elements of arbitrary type rather than just strings.

  - Also manages an LRU counter and updates each node's LRU when
    it is added or accessed. If the maximum allowed number of nodes
    in the table is exceeded, the least recently used node is
    automatically removed from the table. By default, MaxLongInt
    nodes can be in the table so the automatic removal logic does
    not come into play. When a node is automatically removed, the
    NodeRemoved virtual method is called to notify the program
    that the node is being removed.
}

unit StHASH;

interface

uses
  SysUtils,
  Classes,
 {$IFDEF ThreadSafe}
  Windows,
 {$ENDIF}
  StConst,
  StBase;

type
  TStHashNode = class(TStNode)
{.Z+}
    protected
      hnNext : TStHashNode;     {Next node in hash list}
      hnValue: Pointer;         {Pointer to value of element}
      hnValSize : Cardinal;     {Size of hnValue memory block}
      FLRU : LongInt;           {LRU counter of this node}

      function GetValue : Pointer;

{.Z-}
    public
      constructor CreateNode(const AValue; AValSize : Cardinal; AData : Pointer);
        virtual;
        {-Initialize node}
      destructor Destroy; override;
        {-Free name string and destroy node}

      property Value : Pointer
         read GetValue;
      property LRU : LongInt
         read FLRU
         write FLRU;
  end;

{.Z+}
  THashArray = array[0..(MaxInt div SizeOf(TStHashNode))-1] of TStHashNode;
  PHashArray = ^THashArray;
{.Z-}

  THashFunc = function (const V; Size : Integer) : Integer;

  TStHashTable = class(TStContainer)
{.Z+}
    protected
      {property instance variables}
      FValSize : Cardinal;          {Size of each element in table}
      FHashSize : Integer;          {Bins in hash array}
      FEqual : TUntypedCompareFunc; {Element compare function}
      FHash : THashFunc;            {Hash function}
      FMaxNodes : LongInt;          {Max nodes allowed in table}

      {private instance variables}
      htHeads : PHashArray;         {Pointer to head of node lists}
      htTails : PHashArray;         {Pointer to tail of node lists}
      htLRU : LongInt;              {LRU counter}
      htIgnoreDups : Boolean;       {Ignore duplicates during Join?}

      {protected undocumented methods}
      procedure htInsertNode(H : Integer; This : TStHashNode);
      procedure htIterate(Action : TIterateFunc; OtherData : Pointer;
                          var H : Integer; var Prev, This : TStHashNode);
      procedure htSetEqual(E : TUntypedCompareFunc);
      procedure htSetHash(H : THashFunc);
      procedure htSetHashSize(Size : Integer);
      procedure htSetMaxNodes(Nodes : LongInt);
      procedure htMoveToFront(H : Integer; Prev, This : TStHashNode);
      procedure htFindNode(const V; var H : Integer;
                           var Prev, This : TStHashNode);
      procedure htUpdateLRU(This : TStHashNode);
      procedure htDeleteOldestNode;

{.Z-}
    public
      constructor Create(AValSize : Cardinal; AHashSize : Integer); virtual;
        {-Initialize an empty hash table}
      destructor Destroy; override;
        {-Destroy a hash table}

      procedure LoadFromStream(S : TStream); override;
        {-Read a hash table and its data from a stream}
      procedure StoreToStream(S : TStream); override;
        {-Write a hash table and its data to a stream}

      procedure Clear; override;
        {-Remove all nodes from container but leave it instantiated}

      function Exists(const V; var Data : Pointer) : Boolean;
        {-Return True and the Data pointer if V is in the hash table}
      procedure Add(const V; Data : Pointer);
        {-Add new value and Data to the hash table}
      procedure Delete(const V);
        {-Delete a value from the hash table}
      procedure Update(const V; Data : Pointer);
        {-Update the data for an existing element}
      function Find(Data : Pointer; var V) : Boolean;
        {-Return True and the element value that matches Data}

      procedure Assign(Source: TPersistent); override;
        {-Assign another hash table's contents to this one}
      procedure Join(H : TStHashTable; IgnoreDups : Boolean);
        {-Add hash table H into this one and dispose H}

      function Iterate(Action : TIterateFunc;
                       OtherData : Pointer) : TStHashNode;
        {-Call Action for all the nodes, returning the last node visited}

      procedure NodeRemoved(const V; Data : Pointer); virtual;
        {-Called when a not recently used node is removed from the table}

      function BinCount(H : Integer) : LongInt;
        {-Return number of names in a hash bin (for testing)}

      property Equal : TUntypedCompareFunc
        {-Change the string compare function; only for an empty table}
        read FEqual
        write htSetEqual;

      property Hash : THashFunc
        {-Change the hash function; only for an empty table}
        read FHash
        write htSetHash;

      property HashSize : Integer
        {-Change the hash table size; preserves existing elements}
        read FHashSize
        write htSetHashSize;

      property ValSize : Cardinal
        {-Read the size of each element in the table}
        read FValSize;

      property MaxNodes : LongInt
        {-Change the maximum nodes in the table}
        read FMaxNodes
        write htSetMaxNodes;
  end;

{======================================================================}

implementation

{$IFDEF ThreadSafe}
var
  ClassCritSect : TRTLCriticalSection;
{$ENDIF}

procedure EnterClassCS;
begin
{$IFDEF ThreadSafe}
  EnterCriticalSection(ClassCritSect);
{$ENDIF}
end;

procedure LeaveClassCS;
begin
{$IFDEF ThreadSafe}
  LeaveCriticalSection(ClassCritSect);
{$ENDIF}
end;



{----------------------------------------------------------------------}

constructor TStHashNode.CreateNode(const AValue; AValSize : Cardinal;
                                   AData : Pointer);
begin
  Create(AData);
  hnValSize := AValSize;
  GetMem(hnValue, AValSize);
  Move(AValue, hnValue^, AValSize);
end;

destructor TStHashNode.Destroy;
begin
  if Assigned(hnValue) then
    FreeMem(hnValue, hnValSize);
  inherited Destroy;
end;

function TStHashNode.GetValue : Pointer;
begin
  Result := hnValue;
end;

{----------------------------------------------------------------------}

procedure TStHashTable.Add(const V; Data : Pointer);
var
  H : Integer;
  P, T : TStHashNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    htFindNode(V, H, P, T);
    if Assigned(T) then
      RaiseContainerError(stscDupNode);
    htInsertNode(H, TStHashNode.CreateNode(V, FValSize, Data));
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function AssignNode(Container : TStContainer;
                    Node : TStNode;
                    OtherData : Pointer) : Boolean; far;
var
  HashNode : TStHashNode absolute Node;
  OurHashTbl : TStHashTable absolute OtherData;
begin
  OurHashTbl.Add(HashNode.Value^, HashNode.Data);
  Result := true;
end;

procedure TStHashTable.Assign(Source: TPersistent);
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    {The only container that we allow to be assigned to a hash table
     is... another hash table}
    if (Source is TStHashTable) then begin
      Clear;
      FValSize := TStHashTable(Source).ValSize;
      TStHashTable(Source).Iterate(AssignNode, Self);
    end
    else
      inherited Assign(Source);
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;


function TStHashTable.BinCount(H : Integer) : LongInt;
var
  C : LongInt;
  T : TStHashNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    C := 0;
    T := htHeads^[H];
    while Assigned(T) do begin
      inc(C);
      T := T.hnNext;
    end;
    Result := C;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStHashTable.Clear;
var
  TableSize : Cardinal;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if FCount <> 0 then begin
      Iterate(DestroyNode, nil);
      FCount := 0;
      htLRU := 0;
      TableSize := FHashSize*SizeOf(TStHashNode);
      FillChar(htHeads^, TableSize, 0);
      FillChar(htTails^, TableSize, 0);
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

constructor TStHashTable.Create(AValSize : Cardinal; AHashSize : Integer);
begin
  if AValSize = 0 then
    RaiseContainerError(stscBadSize);

  CreateContainer(TStHashNode, 0);

  FValSize := AValSize;
  FMaxNodes := MaxLongInt;

  {allocate hash table by assigning to the HashSize property}
  HashSize := AHashSize;
end;

procedure TStHashTable.Delete(const V);
var
  H : Integer;
  P, T : TStHashNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    htFindNode(V, H, P, T);
    if Assigned(T) then begin
      if Assigned(P) then
        P.hnNext := T.hnNext
      else
        htHeads^[H] := T.hnNext;
      if T = htTails^[H] then
        htTails^[H] := P;
      DestroyNode(Self, T, nil);
      Dec(FCount);
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

destructor TStHashTable.Destroy;
var
  TableSize : Cardinal;
begin
  if conNodeProt = 0 then
    Clear;
  TableSize := FHashSize*SizeOf(TStHashNode);
  if Assigned(htHeads) then
    FreeMem(htHeads, TableSize);
  if Assigned(htTails) then
    FreeMem(htTails, TableSize);
  IncNodeProtection;
  inherited Destroy;
end;

function TStHashTable.Exists(const V; var Data : Pointer) : Boolean;
var
  H : Integer;
  P, T : TStHashNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    htFindNode(V, H, P, T);
    if Assigned(T) then begin
      htMoveToFront(H, P, T);
      htUpdateLRU(T);
      Result := True;
      Data := T.Data;
    end else
      Result := False;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function FindNodeData(Container : TStContainer; Node : TStNode;
                      OtherData : Pointer) : Boolean; far;
begin
  Result := (OtherData <> Node.Data);
end;

function TStHashTable.Find(Data : Pointer; var V) : Boolean;
var
  H : Integer;
  P, T : TStHashNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    htIterate(FindNodeData, Data, H, P, T);
    if Assigned(T) then begin
      htMoveToFront(H, P, T);
      htUpdateLRU(T);
      Result := True;
      Move(T.Value^, V, FValSize);
    end else
      Result := False;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStHashTable.htDeleteOldestNode;
  {-Find and delete the hash node with the smallest LRU counter}
var
  H, MinH :  Integer;
  MinLRU : LongInt;
  T, P : TStHashNode;
begin
  if FCount <> 0 then begin
    MinLRU := MaxLongInt;
    MinH := 0;
    for H := 0 to FHashSize-1 do
      if Assigned(htTails^[H]) and (htTails^[H].LRU <= MinLRU) then begin
        MinH := H;
        MinLRU := htTails^[H].LRU;
      end;

    {notify the application}
    with htTails^[MinH] do
      NodeRemoved(hnValue^, Data);

    {destroy the node}
    DestroyNode(Self, htTails^[MinH], nil);
    dec(FCount);

    {remove the node}
    if htTails^[MinH] = htHeads^[MinH] then begin
      {only node in this bin}
      htTails^[MinH] := nil;
      htHeads^[MinH] := nil;
    end else begin
      {at least two nodes in this bin}
      T := htHeads^[MinH];
      P := nil;
      while T <> htTails^[MinH] do begin
        P := T;
        T := T.hnNext;
      end;
      P.hnNext := nil;
      htTails^[MinH] := P;
    end;
  end;
end;

procedure TStHashTable.htFindNode(const V; var H : Integer;
                                  var Prev, This : TStHashNode);