简单的Delphi对象管理器

《掺和比试 》时得到的一个副产品。

原理很简单，就是创建的对象放到一个池里，暂时不释放，再分配的时候可以重用。对于需要反复大量创建删除同一个类的对象时，或是创建对象成本很高的情况下，这个东东有一定的作用。

使用方法：

uses objmngr; Type TDummy = Class(.... Function Init(...) : TDummy; ... End; Var DummyPool : TMObjPool; ... Function TDummy.Init(...) : TDummy; Begin ... Result := Self; End; ... Var om : IMObjManager; Begin om := TMObjManager.Create(DummyPool, 50); d1 := (om.New As TDummy).Init(...); // Create new dummy object ... End; // om and all new dummy objects will be released automatically Initialization DummyPool := TMObjPool.Create(TDummy, 5000); Finallization DummyPool.Free;

注意：因为自动创建对象时无法确定构造函数参数，所以只能调用无参数的构造函数，如需初始化对象，则需要再定义一个Init函数供调用。因为Init函数取代了构造函数的功能，所以还需要它返回Self给调用者。

管理单元objmngr.pas源码：

unit objmngr; {$IFDEF FPC}{$mode objfpc}{$H+}{$ENDIF} interface uses Classes, SysUtils; Type TMBucket = Record Key : TObject; Value : TObject; end; PMBucket = ^TMBucket; TMHashMap = Class(TObject) Private FSize : Integer; FItems : Array Of TMBucket; Protected Function HashFunc(Key : TObject) : Integer; Function FindKey(Key : TObject) : Integer; Function FindEmpty(Key : TObject) : Integer; Function GetItem(Key : TObject) : TObject; Public Constructor Create(ASize : Integer); Destructor Destroy; Override; Procedure AddItem(Key, Value : TObject); Procedure DelItem(Key : TObject); Function PopItem(Key : TObject) : TObject; Property Items[Key : TObject] : TObject Read GetItem; End; TMStack = Class(TObject) Private FData : Array Of TObject; FTop : Integer; Public Constructor Create(ASize : Integer); Destructor Destroy; Override; Procedure Push(AObj : TObject); Function Pop : TObject; Function IsEmpty : Boolean; End; TMObjPool = Class(TObject) Private FMeta : TClass; FPool : Array Of TObject; FIndex : Integer; FMap : TMHashMap; FFree : TMStack; Public Constructor Create(AMeta : TClass; ASize : Integer); Destructor Destroy; Override; Function NewObj : TObject; Procedure FreeObj(AObj : TObject); End; IMObjManager = Interface Function New : TObject; End; TMObjManager = Class(TInterfacedObject, IMObjManager) Private FPool : TMObjPool; FObjs : TMStack; Public Function New : TObject; Constructor Create(APool : TMObjPool; ASize : Integer = 1000); Destructor Destroy; Override; End; implementation { TMHashMap } Constructor TMHashMap.Create(ASize : Integer); Begin FSize := ASize; SetLength(FItems, FSize); FillChar(FItems[0], FSize * SizeOf(TMBucket), 0); End; Destructor TMHashMap.Destroy; Begin SetLength(FItems, 0); Inherited; End; Function TMHashMap.HashFunc(Key : TObject) : Integer; Begin Result := Integer(Key) Mod FSize; End; Function TMHashMap.FindKey(Key : TObject) : Integer; Var i, n : Integer; Begin n := HashFunc(Key); Result := -1; If FItems[n].Key = Key Then Result := n Else Begin i := n; Repeat i := (i + 1) Mod FSize; If FItems[i].Key = Key Then Begin Result := i; Break; End; Until i = n; End; End; Function TMHashMap.FindEmpty(Key : TObject) : Integer; Var i, n : Integer; Begin n := HashFunc(Key); If Integer(FItems[n].Key) = 0 Then Result := n Else Begin i := n; Repeat i := (i + 1) Mod FSize; If Integer(FItems[i].Key) = 0 Then Begin Result := i; Exit; End; Until i = n; Raise Exception.Create('Map is full!'); End; End; Function TMHashMap.GetItem(Key : TObject) : TObject; Var i : Integer; Begin i := FindKey(Key); If i >= 0 Then Result := FItems[i].Value Else Result := Nil; End; Procedure TMHashMap.AddItem(Key, Value : TObject); Var i : Integer; Begin i := FindEmpty(Key); FItems[i].Key := Key; FItems[i].Value := Value; End; Procedure TMHashMap.DelItem(Key : TObject); Var i : Integer; Begin i := FindKey(Key); If i >= 0 Then Begin FItems[i].Key := TObject(0); FItems[i].Value := Nil; End; End; Function TMHashMap.PopItem(Key : TObject) : TObject; Var i : Integer; Begin i := FindKey(Key); If i >= 0 Then Begin Result := FItems[i].Value; FItems[i].Key := TObject(0); FItems[i].Value := Nil; End Else Result := Nil; End; { TMStack } Constructor TMStack.Create(ASize : Integer); Begin SetLength(FData, ASize); FTop := 0; end; Destructor TMStack.Destroy; Begin SetLength(FData, 0); Inherited; end; Procedure TMStack.Push(AObj : TObject); Begin FData[FTop] := AObj; Inc(FTop); If FTop >= Length(FData) Then Raise Exception.Create('Queue is full!'); end; Function TMStack.Pop : TObject; Begin If FTop = 0 Then Raise Exception.Create('Queue is empty!'); Dec(FTop); Result := FData[FTop]; end; Function TMStack.IsEmpty : Boolean; Begin Result := (FTop = 0); end; { TMObjPool } Constructor TMObjPool.Create(AMeta : TClass; ASize : Integer); Begin FMeta := AMeta; SetLength(FPool, ASize); FIndex := 0; FMap := TMHashMap.Create(ASize * 4); FFree := TMStack.Create(ASize); End; Destructor TMObjPool.Destroy; Var i : Integer; Begin FFree.Free; FMap.Free; For i := 0 To FIndex - 1 Do FPool[i].Free; Inherited; End; Function TMObjPool.NewObj : TObject; Var i : Integer; Begin If FFree.IsEmpty Then Begin Result := FMeta.Create; FPool[FIndex] := Result; i := FIndex; Inc(FIndex); End Else Begin i := Integer(FFree.Pop); Result := FPool[i]; End; FMap.AddItem(Result, TObject(i)); End; Procedure TMObjPool.FreeObj(AObj : TObject); Var i : Integer; Begin i := Integer(FMap.PopItem(AObj)); FFree.Push(TObject(i)); End; { TMObjManager } Constructor TMObjManager.Create(APool : TMObjPool; ASize : Integer); Begin FPool := APool; FObjs := TMStack.Create(ASize); End; Destructor TMObjManager.Destroy; Begin While Not FObjs.IsEmpty Do FPool.FreeObj(FObjs.Pop); FObjs.Free; Inherited; end; Function TMObjManager.New : TObject; Begin Result := FPool.NewObj; FObjs.Push(Result); end; end.

 

草草写就，应该还有优化的余地。