修正 THashedStringList 在插入和 PutObject 时的速度缺陷

建议用 TFastHashedStringListMini ,更安全(版本安全),不过TFastHashedStringList 更清晰完整.

--------------------------------------------------

unit uFastHashedStringList;

//修正 THashedStringList 在插入和 PutObject 时的速度缺陷
//THashedStringList 主要的问题是重写了   ,而插入和 PutObject 等修改内容的操作都会触发这个事件,
//而这个事件是要表明更新索引的,所以第次都更新索引引起了性能的急剧下降

interface
uses
  IniFiles,SysUtils, Classes;

type
  TFastHashedStringListMini = class(THashedStringList)
  private
    FChangeTag:Boolean;
  protected
    procedure Changed; override;

  public
    //在为屏蔽了 Changed ,所以在需要更新索引时一定要调用这个函数
    //procedure SetChangeTag();
    //更新索引
    procedure UpdateIndex();

  end;


//直接来自 TFastHashedString
type
  TFastHashedStringList = class(TStringList)
  private
    FValueHash: TStringHash;
    FNameHash: TStringHash;
    FValueHashValid: Boolean;
    FNameHashValid: Boolean;
    procedure UpdateValueHash;
    procedure UpdateNameHash;
  protected
    //procedure Changed; override;
  public
    FList: PStringItemList;
    destructor Destroy; override;
    function IndexOf(const S: string): Integer; override;
    function IndexOfName(const Name: string): Integer; override;
    procedure PutObject2(Index: Integer; AObject: TObject);//test
    //在为屏蔽了 Changed ,所以在需要更新索引时一定要调用这个函数
    procedure SetChangeTag();
    //更新索引
    procedure UpdateIndex();
  end;

implementation

{ TFastHashedStringList }

//procedure TFastHashedStringList.Changed;
//begin
//  //inherited;
//  //恢复为 procedure TStringList.Changed; 的内容
//
//  //if (FUpdateCount = 0) and Assigned(FOnChange) then
//  //  FOnChange(Self);
//
//  Self.FValueHashValid := True;
//end;

{ THashedStringList }

//procedure THashedStringList.Changed;
//begin
//  inherited Changed;
//  FValueHashValid := False;
//  FNameHashValid := False;
//end;

destructor TFastHashedStringList.Destroy;
begin
  FValueHash.Free;
  FNameHash.Free;
  inherited Destroy;
end;

function TFastHashedStringList.IndexOf(const S: string): Integer;
begin
  UpdateValueHash;
  if not CaseSensitive then
    Result :=  FValueHash.ValueOf(AnsiUpperCase(S))
  else
    Result :=  FValueHash.ValueOf(S);
end;

function TFastHashedStringList.IndexOfName(const Name: string): Integer;
begin
  UpdateNameHash;
  if not CaseSensitive then
    Result := FNameHash.ValueOf(AnsiUpperCase(Name))
  else
    Result := FNameHash.ValueOf(Name);
end;

//--------------------------------------------------
procedure TFastHashedStringList.PutObject2(Index: Integer; AObject: TObject);
begin
//  if (Index < 0) or (Index >= FCount) then Error(@SListIndexError, Index);
//  Changing;
  if FList= nil then
  ReallocMem(FList, 20000 * 2000 * SizeOf(TStringItem));

  FList^[Index].FObject := AObject;
  Changed;//是这一个造成特别的慢//clq
end;
//--------------------------------------------------

procedure TFastHashedStringList.SetChangeTag;
begin
  FValueHashValid := False;
  FNameHashValid := False;
end;

procedure TFastHashedStringList.UpdateIndex;
begin
  SetChangeTag();
  UpdateValueHash;
  UpdateNameHash;
 
end;

procedure TFastHashedStringList.UpdateNameHash;
var
  I: Integer;
  P: Integer;
  Key: string;
begin
  if FNameHashValid then Exit;
 
  if FNameHash = nil then
    FNameHash := TStringHash.Create
  else
    FNameHash.Clear;
  for I := 0 to Count - 1 do
  begin
    Key := Get(I);
    P := AnsiPos('=', Key);
    if P <> 0 then
    begin
      if not CaseSensitive then
        Key := AnsiUpperCase(Copy(Key, 1, P - 1))
      else
        Key := Copy(Key, 1, P - 1);
      FNameHash.Add(Key, I);
    end;
  end;
  FNameHashValid := True;
end;

procedure TFastHashedStringList.UpdateValueHash;
var
  I: Integer;
begin
  if FValueHashValid then Exit;
 
  if FValueHash = nil then
    FValueHash := TStringHash.Create
  else
    FValueHash.Clear;
  for I := 0 to Count - 1 do
    if not CaseSensitive then
      FValueHash.Add(AnsiUpperCase(Self[I]), I)
    else
      FValueHash.Add(Self[I], I);
  FValueHashValid := True;
end;


{ TFastHashedStringListTmp }

procedure TFastHashedStringListMini.Changed;
begin
  //inherited;
  //恢复为 procedure TStringList.Changed; 的内容

  //if (FUpdateCount = 0) and Assigned(FOnChange) then
  //  FOnChange(Self);

  //这样修改不太安全,不过比全部重写要好
  if (UpdateCount = 0) and Assigned(OnChange) then
    OnChange(Self);

  //--------------------------------------------------
  if FChangeTag then inherited;
  FChangeTag := False;

end;

procedure TFastHashedStringListMini.UpdateIndex;
begin
  FChangeTag := True;
  Changed;
end;

end.