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

原 理很简单，就是创建的对象放到一个池里，暂时不释放，再分配的时候可以重用。对于需要反复大量创建删除同一个类的对象时，或是创建对象成本很高的情况下， 这个东东有一定的作用。另外还弄了一个通用的对象管理，不提供POOL的缓冲，仅提供自动释放，纯粹是为了方便，这个可以不针对特定对象。

使用方法：

uses objmngr;
...
Type
  TDummy = Class(....
    Constructor Create(...);
    Function Init(...) : TDummy;
    ...
  End;
...
Var
  DummyPool : TMObjPool;
...
Function TDummy.Init(...) : TDummy;
Begin
  ...
  Result := Self;
End;
...
// Pool
Var
  om : IMObjPoolManager;
Begin
  om := TMObjPoolManager.Create(DummyPool, 50);
  d1 := (om.New As TDummy).Init(...);  //  Create new dummy object
  ...
End;  //  om and all new dummy objects will be released automatically
...
// Nopool
Var
  om : IMObjManager;
Begin
  om := TMObjManager.Create(50);
  d1 := om.New(TDummy.Create(...)) As TDummy;
  d2 := om.New(TOther.Create(...)) As TOther;
  ...
End; // om and all managed objects will be release 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;

IMObjPoolManager = Interface
    Function New : TObject;
End;

TMObjPoolManager = Class(TInterfacedObject, IMObjPoolManager)
Private
    FPool : TMObjPool;
    FObjs : TMStack;
Public
    Function New : TObject; Overload;

    Constructor Create(APool : TMObjPool; ASize : Integer = 1000);
    Destructor Destroy; Override;
End;

IMObjManager = Interface
    Function New(AObj : TObject) : TObject;
End;

TMObjManager = Class(TInterfacedObject, IMObjManager)
Private
    FObjs : TMStack;
Public
    Function New(AObj : TObject) : TObject; Overload;

    Constructor Create(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;

{ TMObjPoolManager }

Constructor TMObjPoolManager.Create(APool : TMObjPool; ASize : Integer);
Begin
    FPool := APool;
    FObjs := TMStack.Create(ASize);
End;

Destructor TMObjPoolManager.Destroy;
Begin
    While Not FObjs.IsEmpty Do
        FPool.FreeObj(FObjs.Pop);
    FObjs.Free;
    Inherited;
end;

Function TMObjPoolManager.New : TObject;
Begin
    Result := FPool.NewObj;
    FObjs.Push(Result);
end;

{ TMObjManager }

constructor TMObjManager.Create(ASize: Integer);
begin
    FObjs := TMStack.Create(ASize);
end;

destructor TMObjManager.Destroy;
begin
    While Not FObjs.IsEmpty Do
        FObjs.Pop.Free;
    FObjs.Free;
    Inherited;
end;

function TMObjManager.New(AObj: TObject): TObject;
begin
    FObjs.Push(AObj);
    Result := AObj;
end;

end.

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

推送到[go4pro.org]