jclstrhashmap.pas

East make Tray Icon in delphi

      { check for empty position after drilling left or right }
      if PPN^ = nil then
        Break;
    end;

  Result := PPN;
end;

function TStringHashMap.IterateNode(ANode: PHashNode; AUserData: Pointer;
  AIterateFunc: TIterateFunc): Boolean;
begin
  if ANode <> nil then
  begin
    Result := AIterateFunc(AUserData, ANode^.Str, ANode^.Ptr);
    if not Result then
      Exit;

    Result := IterateNode(ANode^.Left, AUserData, AIterateFunc);
    if not Result then
      Exit;

    Result := IterateNode(ANode^.Right, AUserData, AIterateFunc);
    if not Result then
      Exit;
  end
  else
    Result := True;
end;

function TStringHashMap.IterateMethodNode(ANode: PHashNode; AUserData: Pointer;
  AIterateMethod: TIterateMethod): Boolean;
begin
  if ANode <> nil then
  begin
    Result := AIterateMethod(AUserData, ANode^.Str, ANode^.Ptr);
    if not Result then
      Exit;

    Result := IterateMethodNode(ANode^.Left, AUserData, AIterateMethod);
    if not Result then
      Exit;

    Result := IterateMethodNode(ANode^.Right, AUserData, AIterateMethod);
    if not Result then
      Exit;
  end
  else
    Result := True;
end;

procedure TStringHashMap.NodeIterate(ANode: PPHashNode; AUserData: Pointer;
  AIterateFunc: TNodeIterateFunc);
begin
  if ANode^ <> nil then
  begin
    AIterateFunc(AUserData, ANode);
    NodeIterate(@ANode^.Left, AUserData, AIterateFunc);
    NodeIterate(@ANode^.Right, AUserData, AIterateFunc);
  end;
end;

procedure TStringHashMap.DeleteNode(var Q: PHashNode);
var
  T, R, S: PHashNode;
begin
  { we must delete node Q without destroying binary tree }
  { Knuth 6.2.2 D (pg 432 Vol 3 2nd ed) }

  { alternating between left / right delete to preserve decent
    performance over multiple insertion / deletion }
  FLeftDelete := not FLeftDelete;

  { T will be the node we delete }
  T := Q;

  if FLeftDelete then
  begin
    if T^.Right = nil then
      Q := T^.Left
    else
    begin
      R := T^.Right;
      if R^.Left = nil then
      begin
        R^.Left := T^.Left;
        Q := R;
      end
      else
      begin
        S := R^.Left;
        if S^.Left <> nil then
          repeat
            R := S;
            S := R^.Left;
          until S^.Left = nil;
        { now, S = symmetric successor of Q }
        S^.Left := T^.Left;
        R^.Left :=  S^.Right;
        S^.Right := T^.Right;
        Q := S;
      end;
    end;
  end
  else
  begin
    if T^.Left = nil then
      Q := T^.Right
    else
    begin
      R := T^.Left;
      if R^.Right = nil then
      begin
        R^.Right := T^.Right;
        Q := R;
      end
      else
      begin
        S := R^.Right;
        if S^.Right <> nil then
          repeat
            R := S;
            S := R^.Right;
          until S^.Right = nil;
        { now, S = symmetric predecessor of Q }
        S^.Right := T^.Right;
        R^.Right := S^.Left;
        S^.Left := T^.Left;
        Q := S;
      end;
    end;
  end;

  { we decrement before because the tree is already adjusted
    => any exception in FreeNode MUST be ignored.

    It's unlikely that FreeNode would raise an exception anyway. }
  Dec(FCount);
  FreeNode(T);
end;

procedure TStringHashMap.DeleteNodes(var Q: PHashNode);
begin
  if Q^.Left <> nil then
    DeleteNodes(Q^.Left);
  if Q^.Right <> nil then
    DeleteNodes(Q^.Right);
  FreeNode(Q);
  Q := nil;
end;

function TStringHashMap.AllocNode: PHashNode;
begin
  New(Result);
  Result^.Left := nil;
  Result^.Right := nil;
end;

procedure TStringHashMap.FreeNode(ANode: PHashNode);
begin
  Dispose(ANode);
end;

function TStringHashMap.GetData(const S: string): Pointer;
var
  PPN: PPHashNode;
begin
  PPN := FindNode(S);

  if PPN^ <> nil then
    Result := PPN^^.Ptr
  else
    Result := nil;
end;

procedure TStringHashMap.SetData(const S: string; P: Pointer);
var
  PPN: PPHashNode;
begin
  PPN := FindNode(S);

  if PPN^ <> nil then
    PPN^^.Ptr := P
  else
  begin
    { add }
    PPN^ := AllocNode;
    { we increment after in case of exception }
    Inc(FCount);
    PPN^^.Str := S;
    PPN^^.Ptr := P;
  end;
end;

procedure TStringHashMap.Add(const S: string; const P{: Pointer});
var
  PPN: PPHashNode;
begin
  PPN := FindNode(S);

  { if reordered from SetData because PPN^ = nil is more common for Add }
  if PPN^ = nil then
  begin
    { add }
    PPN^ := AllocNode;
    { we increment after in case of exception }
    Inc(FCount);
    PPN^^.Str := S;
    PPN^^.Ptr := Pointer(P);
  end
  else
    raise EJclStringHashMapError.CreateResFmt(@RsStringHashMapDuplicate, [S]);
end;

type
  PListNode = ^TListNode;
  TListNode = record
    Next: PListNode;
    NodeLoc: PPHashNode;
  end;

  PDataParam = ^TDataParam;
  TDataParam = record
    Head: PListNode;
    Data: Pointer;
  end;

procedure NodeIterate_BuildDataList(AUserData: Pointer; ANode: PPHashNode);
var
  DP: PDataParam;
  T: PListNode;
begin
  DP := PDataParam(AUserData);
  if DP.Data = ANode^^.Ptr then
  begin
    New(T);
    T^.Next := DP.Head;
    T^.NodeLoc := ANode;
    DP.Head := T;
  end;
end;

procedure TStringHashMap.RemoveData(const P{: Pointer});
var
  DP: TDataParam;
  I: Integer;
  N, T: PListNode;
begin
  DP.Data := Pointer(P);
  DP.Head := nil;

  for I := 0 to FHashSize - 1 do
    NodeIterate(@FList^[I], @DP, NodeIterate_BuildDataList);

  N := DP.Head;
  while N <> nil do
  begin
    DeleteNode(N^.NodeLoc^);
    T := N;
    N := N^.Next;
    Dispose(T);
  end;
end;

function TStringHashMap.Remove(const S: string): Pointer;
var
  PPN: PPHashNode;
begin
  PPN := FindNode(S);

  if PPN^ <> nil then
  begin
    Result := PPN^^.Ptr;
    DeleteNode(PPN^);
  end
  else
    raise EJclStringHashMapError.CreateResFmt(@RsStringHashMapInvalidNode, [S]);
end;

procedure TStringHashMap.IterateMethod(AUserData: Pointer;
  AIterateMethod: TIterateMethod);
var
  I: Integer;
begin
  for I := 0 to FHashSize - 1 do
    if not IterateMethodNode(FList^[I], AUserData, AIterateMethod) then
      Break;
end;

procedure TStringHashMap.Iterate(AUserData: Pointer; AIterateFunc: TIterateFunc);
var
  I: Integer;
begin
  for I := 0 to FHashSize - 1 do
    if not IterateNode(FList^[I], AUserData, AIterateFunc) then
      Break;
end;

function TStringHashMap.Has(const S: string): Boolean;
var
  PPN: PPHashNode;
begin
  PPN := FindNode(S);
  Result := PPN^ <> nil;
end;

function TStringHashMap.Find(const S: string; var P{: Pointer}): Boolean;
var
  PPN: PPHashNode;
begin
  PPN := FindNode(S);
  Result := PPN^ <> nil;
  if Result then
    Pointer(P) := PPN^^.Ptr;
end;

type
  PFindDataResult = ^TFindDataResult;
  TFindDataResult = record
    Found: Boolean;
    ValueToFind: Pointer;
    Key: string;
  end;

function Iterate_FindData(AUserData: Pointer; const AStr: string;
  var APtr: Pointer): Boolean;
var
  PFdr: PFindDataResult;
begin
  PFdr := PFindDataResult(AUserData);
  PFdr^.Found := (APtr = PFdr^.ValueToFind);
  Result := not PFdr^.Found;
  if PFdr^.Found then
    PFdr^.Key := AStr;
end;

function TStringHashMap.FindData(const P{: Pointer}; var S: string): Boolean;
var
  PFdr: PFindDataResult;
begin
  New(PFdr);
  try
    PFdr^.Found := False;
    PFdr^.ValueToFind := Pointer(P);
    Iterate(PFdr, Iterate_FindData);
    Result := PFdr^.Found;
    if Result then
      S := PFdr^.Key;
  finally
    Dispose(PFdr);
  end;
end;

procedure TStringHashMap.Clear;
var
  I: Integer;
  PPN: PPHashNode;
begin
  for I := 0 to FHashSize - 1 do
  begin
    PPN := @FList^[I];
    if PPN^ <> nil then
      DeleteNodes(PPN^);
  end;
  FCount := 0;
end;

initialization

finalization
  FreeAndNil(GlobalCaseInsensitiveTraits);
  FreeAndNil(GlobalCaseSensitiveTraits);

// History:

// $Log: JclStrHashMap.pas,v $
// Revision 1.13  2005/03/08 08:33:17  marquardt
// overhaul of exceptions and resourcestrings, minor style cleaning
//
// Revision 1.12  2005/02/24 16:34:40  marquardt
// remove divider lines, add section lines (unfinished)
//
// Revision 1.11  2004/10/13 06:58:20  marquardt
// normal style cleaning
//
// Revision 1.10  2004/10/12 18:29:52  rrossmair
// cleanup
//
// Revision 1.9  2004/09/16 19:47:32  rrossmair
// check-in in preparation for release 1.92
//
// Revision 1.8  2004/08/03 07:22:37  marquardt
// resourcestring cleanup
//
// Revision 1.7  2004/07/31 06:21:01  marquardt
// fixing TStringLists, adding BeginUpdate/EndUpdate, finalization improved
//
// Revision 1.6  2004/07/28 18:00:51  marquardt
// various style cleanings, some minor fixes
//
// Revision 1.5  2004/05/18 18:58:04  rrossmair
// documentation extracted to StrHashMap.dtx
//
// Revision 1.4  2004/05/05 00:11:24  mthoma
// Updated headers: Added donors as contributors, adjusted the initial authors, added cvs names when they were not obvious. Changed $data to $date where necessary,
//

end.