sthash.pas

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

var
  P, T : TStHashNode;
begin
  if not(Assigned(FEqual) and Assigned(FHash)) then
    RaiseContainerError(stscNoCompare);

  Prev := nil;
  This := nil;
  H := FHash(V, HashSize);
  T := htHeads^[H];
  P := nil;
  while Assigned(T) do begin
    if FEqual(V, T.Value^) = 0 then begin
      Prev := P;
      This := T;
      Exit;
    end;
    P := T;
    T := T.hnNext;
  end;

  {not found}
  This := nil;
end;

procedure TStHashTable.htInsertNode(H : Integer; This : TStHashNode);
  {-Insert node This at front of hash bin H}
var
  P : TStHashNode;
begin
  P := htHeads^[H];
  htHeads^[H] := This;
  if not Assigned(htTails^[H]) then
    htTails^[H] := This;
  This.hnNext := P;
  htUpdateLRU(This);
  Inc(FCount);
  if FCount > FMaxNodes then
    htDeleteOldestNode;
end;

procedure TStHashTable.htIterate(Action : TIterateFunc; OtherData : Pointer;
                                 var H : Integer; var Prev, This : TStHashNode);
  {-Internal version of Iterate that returns more details}
var
  AHash :  Integer;
  P, T, N : TStHashNode;
begin
  if FCount <> 0 then begin
    for AHash := 0 to FHashSize-1 do begin
      T := htHeads^[AHash];
      P := nil;
      while Assigned(T) do begin
        N := T.hnNext;
        if Action(Self, T, OtherData) then begin
          P := T;
          T := N;
        end else begin
          H := AHash;
          Prev := P;
          This := T;
          Exit;
        end;
      end;
    end;
  end;
  This := nil;
end;

procedure TStHashTable.htMoveToFront(H : Integer; Prev, This : TStHashNode);
  {-Move This to front of list}
begin
  if Assigned(Prev) then begin
    Prev.hnNext := This.hnNext;
    This.hnNext := htHeads^[H];
    htHeads^[H] := This;
    if This = htTails^[H] then
      htTails^[H] := Prev;
  end;
end;

procedure TStHashTable.htSetEqual(E : TUntypedCompareFunc);
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if Count = 0 then
      FEqual := E;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStHashTable.htSetHash(H : THashFunc);
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if Count = 0 then
      FHash := H;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStHashTable.htSetHashSize(Size : Integer);
var
  HInx     : integer;
  TableSize: LongInt;
  Temp     : TStHashNode;
  Node     : TStHashNode;
  OldHeads : PHashArray;
  OldTails : PHashArray;
  OldSize  : Integer;
  OldCount : Integer;
  OldDisposeData : TDisposeDataProc;
  OldOnDisposeData : TStDisposeDataEvent;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    {calculate the new table size}
    TableSize := LongInt(Size) * sizeof(TStHashNode);
    if (Size <= 0) {or (TableSize > MaxBlockSize)} then
      RaiseContainerError(stscBadSize);

    {only do something if there's something to do}
    if (Size <> FHashSize) then begin

      {Notes: lots of things are going to be happening here: new
              allocations, nodes copied from the old table to the new,
              etc. Ideally if an exception is raised we would like to
              restore the hash table to the state it was in
              originally, before letting the exception escape}

      {save enough data about the current state of the table to
       allow restoring in case of an exception}
      OldHeads := htHeads;
      OldTails := htTails;
      OldSize := FHashSize;
      OldCount := FCount;
      OldDisposeData := DisposeData;
      OldOnDisposeData := OnDisposeData;

      {reset Self's data}
      htHeads := nil;
      htTails := nil;
      FHashSize := Size;
      FCount := 0;
      DisposeData := nil;
      OnDisposeData := nil;

      {from this point, exceptions can occur with impunity...}
      try
        {allocate the new head and tail tables}
        htHeads := AllocMem(TableSize);
        htTails := AllocMem(TableSize);

        {if there is data to transfer, do so}
        if (OldHeads <> nil) and (OldCount <> 0) then begin
          for HInx := 0 to pred(OldSize) do begin
            Node := OldHeads^[HInx];
            while Assigned(Node) do begin
              Add(Node.hnValue^, Node.Data);
              Node := Node.hnNext;
            end;
          end;
        end;

        {now all the data has been transferred, we can
         destroy the old table}
        if (OldHeads <> nil) then begin
          for HInx := 0 to pred(OldSize) do begin
            Node := OldHeads^[HInx];
            while Assigned(Node) do begin
              Temp := Node;
              Node := Node.hnNext;
              Temp.Free;
            end;
          end;
          FreeMem(OldHeads, OldSize * sizeof(TStHashNode));
        end;
        if (OldTails <> nil) then
          FreeMem(OldTails, OldSize * sizeof(TStHashNode));

        {restore the disposedata routines}
        DisposeData := OldDisposeData;
        OnDisposeData := OldOnDisposeData;

      except
        {destroy the new data}
        if (htHeads <> nil) then begin
          for HInx := 0 to pred(FHashSize) do begin
            Node := htHeads^[HInx];
            while Assigned(Node) do begin
              Temp := Node;
              Node := Node.hnNext;
              Temp.Free;
            end;
          end;
          FreeMem(htHeads, TableSize);
        end;
        if (htTails <> nil) then
          FreeMem(htTails, TableSize);
        {restore the old data}
        htHeads := OldHeads;
        htTails := OldTails;
        FHashSize := OldSize;
        FCount := OldCount;
        DisposeData := OldDisposeData;
        OnDisposeData := OldOnDisposeData;
        {reraise the exception}
        raise;
      end;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStHashTable.htSetMaxNodes(Nodes : LongInt);
begin
  if Nodes < 1 then
    RaiseContainerError(stscBadSize);
  FMaxNodes := Nodes;
  while FCount > FMaxNodes do
    htDeleteOldestNode;
end;

type
  TMinNode = record
    MLRU : LongInt;
    MNode : TStHashNode;
  end;
  PMinNode = ^TMinNode;

function FindMinPositiveNode(Container : TStContainer;
                             Node : TStNode;
                             OtherData : Pointer) : Boolean; far;
  {-Used to find the smallest non-negative LRU in the table}
begin
  with PMinNode(OtherData)^, TStHashNode(Node) do
    if (LRU >= 0) and (LRU <= MLRU) then begin
      MLRU := LRU;
      MNode := TStHashNode(Node);
    end;
  Result := True;
end;

function NegateNodeLRU(Container : TStContainer;
                       Node : TStNode;
                       OtherData : Pointer) : Boolean; far;
  {-Used to negate the LRU values of all nodes in the table}
begin
  with TStHashNode(Node) do
    LRU := -LRU;
  Result := True;
end;

procedure TStHashTable.htUpdateLRU(This : TStHashNode);
  {-Reassign all LRU values sequentially in their existing order}
var
  MinNode : TMinNode;
begin
  inc(htLRU);
  This.LRU := htLRU;
  if htLRU = MaxLongInt then begin
    {scan table and pack LRU values}
    htLRU := 0;
    repeat
      inc(htLRU);
      MinNode.MLRU := MaxLongInt;
      MinNode.MNode := nil;
      Iterate(FindMinPositiveNode, @MinNode);
      if not Assigned(MinNode.MNode) then
        break;
      {nodes already visited are set to a negative value}
      {depends on never having an LRU of zero}
      MinNode.MNode.LRU := -htLRU;
    until False;
    {negative values are made positive}
    Iterate(NegateNodeLRU, nil);
  end;
end;

function TStHashTable.Iterate(Action : TIterateFunc;
                              OtherData : Pointer) : TStHashNode;
var
  H :  Integer;
  P : TStHashNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    htIterate(Action, OtherData, H, P, Result);
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function JoinNode(Container : TStContainer;
                  Node : TStNode;
                  OtherData : Pointer) : Boolean; far;
  {-Used to add nodes from another table into this one}
var
  H : Integer;
  P, T : TStHashNode;
begin
  Result := True;
  with TStHashTable(OtherData) do begin
    htFindNode(TStHashNode(Node).Value^, H, P, T);
    if Assigned(T) then
      if htIgnoreDups then begin
        Node.Free;
        Exit;
      end else
        RaiseContainerError(stscDupNode);
    htInsertNode(H, TStHashNode(Node));
  end;
end;

procedure TStHashTable.Join(H : TStHashTable; IgnoreDups : Boolean);
begin
{$IFDEF ThreadSafe}
  EnterClassCS;
  EnterCS;
  H.EnterCS;
  try
{$ENDIF}
    htIgnoreDups := IgnoreDups;
    H.Iterate(JoinNode, Self);
    {dispose of D, but not its nodes}
    H.IncNodeProtection;
    H.Free;
{$IFDEF ThreadSafe}
  finally
    H.LeaveCS;
    LeaveCS;
    LeaveClassCS;
  end;
{$ENDIF}
end;

procedure TStHashTable.LoadFromStream(S : TStream);
var
  Data, Value : Pointer;
  AValSize : Cardinal;
  Reader : TReader;
  StreamedClass : TPersistentClass;
  StreamedNodeClass : TPersistentClass;
  StreamedClassName : string;
  StreamedNodeClassName : string;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    Clear;
    Reader := TReader.Create(S, 1024);
    try
      with Reader do begin
        StreamedClassName := ReadString;
        StreamedClass := GetClass(StreamedClassName);
        if not Assigned(StreamedClass) then
          RaiseContainerErrorFmt(stscUnknownClass, [StreamedClassName]);
        if (StreamedClass <> Self.ClassType) then
          RaiseContainerError(stscWrongClass);
        StreamedNodeClassName := ReadString;
        StreamedNodeClass := GetClass(StreamedNodeClassName);
        if not Assigned(StreamedNodeClass) then
          RaiseContainerErrorFmt(stscUnknownNodeClass, [StreamedNodeClassName]);
        if (StreamedNodeClass <> conNodeClass) then
          RaiseContainerError(stscWrongNodeClass);

        AValSize := ReadInteger;
        if AValSize <> FValSize then
          RaiseContainerError(stscBadSize);
        HashSize := ReadInteger;
        FMaxNodes := ReadInteger;
        GetMem(Value, FValSize);
        try
          ReadListBegin;
          while not EndOfList do begin
            ReadBoolean;
            Read(Value^, FValSize);
            Data := DoLoadData(Reader);
            Add(Value^, Data);
          end;
          ReadListEnd;
        finally
          FreeMem(Value, FValSize);
        end;
      end;
    finally
      Reader.Free;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStHashTable.NodeRemoved(const V; Data : Pointer);
begin
  {does nothing by default}
end;

procedure TStHashTable.StoreToStream(S : TStream);
var
  H : Integer;
  Walker : TStHashNode;
  Writer : TWriter;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    Writer := TWriter.Create(S, 1024);
    try
      with Writer do begin
        WriteString(Self.ClassName);
        WriteString(conNodeClass.ClassName);
        WriteInteger(FValSize);
        WriteInteger(FHashSize);
        WriteInteger(FMaxNodes);
        WriteListBegin;
        if Count <> 0 then
          for H := 0 to FHashSize-1 do begin
            Walker := htHeads^[H];
            while Assigned(Walker) do begin
              {writing the True boolean prevents false termination of the
               list if Value's first byte is zero when the stream is
               loaded into another hash table}
              WriteBoolean(True);
              Write(Walker.Value^, FValSize);
              DoStoreData(Writer, Walker.Data);
              Walker := Walker.hnNext;
            end;
          end;
        WriteListEnd;
      end;
    finally
      Writer.Free;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStHashTable.Update(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 begin
      htMoveToFront(H, P, T);
      htUpdateLRU(T);
      T.Data := Data;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

{$IFDEF ThreadSafe}
initialization
  Windows.InitializeCriticalSection(ClassCritSect);
finalization
  Windows.DeleteCriticalSection(ClassCritSect);
{$ENDIF}
end.