Delphi对象池

<span style="font-family: Arial, Helvetica, sans-serif;">//</span><span style="font-family: Arial, Helvetica, sans-serif;">http://www.cnblogs.com/DKSoft/p/3564983.html</span>

unit uMyObjectPool;

interface

uses
  SyncObjs, Classes, Windows, SysUtils;

type
  TObjectBlock = record
  private
    FObject:TObject;
    FUsing:Boolean;
    FBorrowTime:Cardinal;   //借出时间
    FRelaseTime:Cardinal;   //归还时间
  end;

  PObjectBlock = ^TObjectBlock;

  TMyObjectPool = class(TObject)
  private
    FObjectClass:TClass;

    FLocker: TCriticalSection;

    //全部归还信号
    FReleaseSingle: THandle;

    //有可用的对象信号灯
    FUsableSingle: THandle;

    FMaxNum: Integer;

    /// <summary>
    ///   正在使用的对象列表
    /// </summary>
    FBusyList:TList;

    /// <summary>
    ///   可以使用的对象列表
    /// </summary>
    FUsableList:TList;

    FName: String;
    FTimeOut: Integer;


    procedure makeSingle;
    function GetCount: Integer;
    procedure lock;
    procedure unLock;
  protected
    /// <summary>
    ///   清理空闲的对象
    /// </summary>
    procedure clear;

    /// <summary>
    ///  创建一个对象
    /// </summary>
    function createObject: TObject; virtual;
  public
    constructor Create(pvObjectClass: TClass = nil);
    destructor Destroy; override;

    /// <summary>
    ///  重置对象池
    /// </summary>
    procedure resetPool;

    /// <summary>
    ///  借用一个对象
    /// </summary>
    function borrowObject: TObject;


    /// <summary>
    ///   归还一个对象
    /// </summary>
    procedure releaseObject(pvObject:TObject);

    /// <summary>
    ///  获取正在使用的个数
    /// </summary>
    function getBusyCount:Integer;



    //等待全部还回
    function waitForReleaseSingle: Boolean;

    /// <summary>
    ///   等待全部归还信号灯
    /// </summary>
    procedure checkWaitForUsableSingle;

    /// <summary>
    ///  当前总的个数
    /// </summary>
    property Count: Integer read GetCount;

    /// <summary>
    ///  最大对象个数
    /// </summary>
    property MaxNum: Integer read FMaxNum write FMaxNum;



    /// <summary>
    ///  对象池名称
    /// </summary>
    property Name: String read FName write FName;

    /// <summary>
    ///   等待超时信号灯
    ///   单位毫秒
    /// </summary>
    property TimeOut: Integer read FTimeOut write FTimeOut;
  end;

implementation

procedure TMyObjectPool.clear;
var
  lvObj:PObjectBlock;
begin
  lock;
  try
    while FUsableList.Count > 0 do
    begin
      lvObj := PObjectBlock(FUsableList[FUsableList.Count-1]);
      lvObj.FObject.Free;
      FreeMem(lvObj, SizeOf(TObjectBlock));
      FUsableList.Delete(FUsableList.Count-1);
    end; 
  finally
    unLock;
  end;
end;

constructor TMyObjectPool.Create(pvObjectClass: TClass = nil);
begin
  inherited Create;
  FObjectClass := pvObjectClass;
  
  FLocker := TCriticalSection.Create();
  FBusyList := TList.Create;
  FUsableList := TList.Create;

  //默认可以使用5个
  FMaxNum := 5;

  //等待超时信号灯 5 秒
  FTimeOut := 5 * 1000;

  //
  FUsableSingle := CreateEvent(nil, True, True, nil);

  //创建信号灯,手动控制
  FReleaseSingle := CreateEvent(nil, True, True, nil);

  makeSingle;
end;

function TMyObjectPool.createObject: TObject;
begin
  Result := nil;
  if FObjectClass <> nil then
  begin
    Result := FObjectClass.Create;
  end;      
end;

destructor TMyObjectPool.Destroy;
begin
  waitForReleaseSingle;  
  clear;
  FLocker.Free;
  FBusyList.Free;
  FUsableList.Free;

  CloseHandle(FUsableSingle);
  CloseHandle(FReleaseSingle);
  inherited Destroy;
end;

function TMyObjectPool.getBusyCount: Integer;
begin
  Result := FBusyList.Count;
end;

{ TMyObjectPool }

procedure TMyObjectPool.releaseObject(pvObject:TObject);
var
  i:Integer;
  lvObj:PObjectBlock;
begin
  lock;
  try
    for i := 0 to FBusyList.Count - 1 do
    begin
      lvObj := PObjectBlock(FBusyList[i]);
      if lvObj.FObject = pvObject then
      begin
        FUsableList.Add(lvObj);
        lvObj.FRelaseTime := GetTickCount;
        FBusyList.Delete(i);
        Break;
      end;
    end;             

    makeSingle;
  finally
    unLock;
  end;
end;

procedure TMyObjectPool.resetPool;
begin
  waitForReleaseSingle;

  clear;
end;

procedure TMyObjectPool.unLock;
begin
  FLocker.Leave;
end;

function TMyObjectPool.borrowObject: TObject;
var
  i:Integer;
  lvObj:PObjectBlock;
  lvObject:TObject;
begin
  Result := nil;


  while True do
  begin
    //是否有可用的对象
    checkWaitForUsableSingle;
    如果当前有1个可用，100线程同时借用时，都可以直接进入等待成功。

    lock;
    try
      lvObject := nil;
      if FUsableList.Count > 0 then
      begin
        lvObj := PObjectBlock(FUsableList[FUsableList.Count-1]);
        FUsableList.Delete(FUsableList.Count-1);
        FBusyList.Add(lvObj);
        lvObj.FBorrowTime := getTickCount;
        lvObj.FRelaseTime := 0;
        lvObject := lvObj.FObject;
      end else
      begin
        if GetCount >= FMaxNum then
        begin
          //如果当前有1个可用，100线程同时借用时，都可以直接(checkWaitForUsableSingle)成功。
          continue;
          //退出(unLock)后再进行等待....
          //raise exception.CreateFmt('超出对象池[%s]允许的范围[%d]', [self.ClassName, FMaxNum]);
        end;
        lvObject := createObject;
        if lvObject = nil then raise exception.CreateFmt('不能得到对象,对象池[%s]未继承处理createObject函数', [self.ClassName]);

        GetMem(lvObj, SizeOf(TObjectBlock));
        try
          ZeroMemory(lvObj, SizeOf(TObjectBlock));
        
          lvObj.FObject := lvObject;
          lvObj.FBorrowTime := GetTickCount;
          lvObj.FRelaseTime := 0;
          FBusyList.Add(lvObj);
        except
          lvObject.Free;
          FreeMem(lvObj, SizeOf(TObjectBlock));
          raise;
        end;
      end;

      //设置信号灯
      makeSingle;

      Result := lvObject;
      //获取到
      Break;
    finally
      unLock;
    end;
  end;
end;

procedure TMyObjectPool.makeSingle;
begin
  if (GetCount < FMaxNum)      //还可以创建
     or (FUsableList.Count > 0)  //还有可使用的
     then
  begin
    //设置有信号
    SetEvent(FUsableSingle);
  end else
  begin
    //没有信号
    ResetEvent(FUsableSingle);
  end;

  if FBusyList.Count > 0 then
  begin
    //没有信号
    ResetEvent(FReleaseSingle);
  end else
  begin
    //全部归还有信号
    SetEvent(FReleaseSingle)
  end;
end;

function TMyObjectPool.GetCount: Integer;
begin
  Result := FUsableList.Count + FBusyList.Count;
end;

procedure TMyObjectPool.lock;
begin
  FLocker.Enter;
end;

function TMyObjectPool.waitForReleaseSingle: Boolean;
var
  lvRet:DWORD;
begin
  Result := false;
  lvRet := WaitForSingleObject(FReleaseSingle, INFINITE);
  if lvRet = WAIT_OBJECT_0 then
  begin
    Result := true;
  end;
end;

procedure TMyObjectPool.checkWaitForUsableSingle;
var
  lvRet:DWORD;
begin
  lvRet := WaitForSingleObject(FUsableSingle, FTimeOut);
  if lvRet <> WAIT_OBJECT_0 then
  begin
    raise Exception.CreateFmt('对象池[%s]等待可使用对象超时(%d),使用状态[%d/%d]!',
      [FName, lvRet, getBusyCount, FMaxNum]);
  end;                                                                 
end;

end.

http://www.cnblogs.com/hnxxcxg/archive/2013/07/15/3191622.html

// 标准模板
unit UntPools;
 
interface
 
uses
  Classes, SysUtils, UntThreadTimer;
 
type
  { 这是一个对像池, 可以池化所有 TObject 对像 }
  { 用法:
       在一个全局的地方定义
    var
       Pooler: TObjectPool;
 
    用到的地方
       obj := Pooler.LockObject as Txxx;
       try
       finally
         Pooler.UnlockObject;
       end;
 
    初始化
    initialization
       Pooler := TObjectPool.Create(要收集的类名)
    finallization
       Pooler.Free;
    end;
  }
  //池中对象 状态
  TPoolItem = class
  private
    FInstance: TObject; //对象
    FLocked: Boolean; //是否被使用
    FLastTime:TDateTime;//最近活跃时间
  public
    constructor Create(AInstance: TObject;const IsLocked :Boolean = True);
    destructor Destroy; override;
  end;
  //对象池
  TObjectPool = class
  private
    FCachedList: TThreadList;//对象池 中 对象 列表
    FMaxCacheSize,FMinCacheSize: Integer; //对象池最大值，最小值  如不设置系统默认为 20
    FCacheHit: Cardinal; //调用对象池 中 对象的 次数
    FCreationCount: Cardinal; //创建对象次数
    FObjectClass: TClass;
    FRequestCount: Cardinal; //调用对象池次数
    FAutoReleased: Boolean; //自动释放空闲的对象
    FTimer:TThreadedTimer; //多线程计时器
    FHourInterval:Integer;  //设置间隔时间（小时）
    function GetCurObjCount:Integer;
    function GetLockObjCount:Integer;
    procedure IniMinPools;//初始化最小池对象
    procedure SetFHourInterval(iValue:Integer);
  protected
    function CreateObject: TObject;// 创建对象
    procedure OnMyTimer(Sender: TObject);
  public
    constructor Create(AClass: TClass;MaxPools,MinPools:Integer);
    destructor Destroy; override;
 
    function LockObject: TObject;//获取对象
    procedure UnlockObject(Instance: TObject); //释放对象
 
 
    property ObjectClass: TClass read FObjectClass;
    property MaxCacheSize: Integer read FMaxCacheSize;//池子大小
    property CacheHit: Cardinal read FCacheHit; //调用池子中对象次数
    property CreationCount: Cardinal read FCreationCount;//创建对象次数
    property RequestCount: Cardinal read FRequestCount;//请求池次数
    property RealCount : Integer  read GetCurObjCount;//池中对象数量
    property LockObjCount: Integer read GetLockObjCount;//池子繁忙的对象数量
    property HourInterval: Integer read FHourInterval write SetFHourInterval;
    procedure StartAutoFree; //开启自动回收
    procedure StopAutoFree; //关闭自动回收
  end;
 
  { TObjectPool<T> }
  { 同样是对像池, 但支持模板 }
  { 用法:
       在一个全局的地方定义
    var
       Pooler: TObjectPool<要收集的类名>;
 
    用到的地方
       obj := Pooler.LockObject;
       try
 
       finally
 
         Pooler.UnlockObject;
       end;
 
    初始化
 
    initialization
       Pooler := TObjectPool<要收集的类名>.Create;
    finallization
       Pooler.Free;
    end;
  }
  TObjectPool<T: class> = class(TObjectPool)
  public
    constructor Create(const MaxPools:Integer = 0;const MinPools:Integer = 0);
 
    function LockObject: T;
  end;
 
implementation
 
{TPoolItem }
 
const
  MSecsPerMins = SecsPerMin * MSecsPerSec;
  //返回相差的分钟
  function MyMinutesBetWeen(const ANow, AThen: TDateTime): Integer;
  var
    tmpDay:Double;
  begin
    tmpDay := 0;
    if ANow < AThen then
      tmpDay := AThen - ANow
    else
      tmpDay := ANow - AThen;
    Result := Round(MinsPerDay * tmpDay);
  end;
 
constructor TPoolItem.Create(AInstance: TObject;const IsLocked :Boolean);
begin
  inherited Create;
  FInstance := AInstance;
  FLocked := IsLocked;
  FLastTime := Now;
end;
 
destructor TPoolItem.Destroy;
begin
  if Assigned(FInstance) then FreeAndNil(FInstance);
  inherited;
end;
 
{ TObjectPool }
constructor TObjectPool.Create(AClass: TClass; MaxPools, MinPools: Integer);
begin
  inherited Create;
  FObjectClass := AClass;
  FCachedList := TThreadList.Create;
  FMaxCacheSize := MaxPools;
  FMinCacheSize := MinPools;
  if FMaxCacheSize = 0 then FMaxCacheSize := 20;  //系统默认为20个并发
  if FMinCacheSize > FMaxCacheSize then FMinCacheSize := FMaxCacheSize;//系统默认最小值为0
  FCacheHit := 0;
  FCreationCount := 0;
  FRequestCount := 0;
  IniMinPools; //初始化最小池对象
  //计时销毁
  FTimer := TThreadedTimer.Create(nil); //计时
  FHourInterval := 4; //默认空闲4小时则回收
  FTimer.Interval := MSecsPerMins * MinsPerHour * FHourInterval;
  FTimer.OnTimer := OnMyTimer;
end;
 
function TObjectPool.CreateObject: TObject;
begin
  Result := FObjectClass.NewInstance;
  if Result is TDataModule then
    TDataModule(Result).Create(nil)
  else if Result is TComponent then
    TComponent(Result).Create(nil)
  else if Result is TPersistent then
    TPersistent(Result).Create
  else Result.Create;
end;
 
destructor TObjectPool.Destroy;
var
  I: Integer;
  LockedList: TList;
begin
  if Assigned(FCachedList) then
  begin
    LockedList := FCachedList.LockList;
    try
      for I := 0 to LockedList.Count - 1 do
        TPoolItem(LockedList[I]).Free;
    finally
      FCachedList.UnlockList;
      FCachedList.Free;
    end;
  end;
  FTimer.Free;
  inherited;
end;
 
function TObjectPool.GetCurObjCount: Integer;
var
  LockedList: TList;
begin
  Result := 0;
  LockedList := FCachedList.LockList;
  try
    Result := LockedList.Count;
  finally
    FCachedList.UnlockList;
  end;
end;
 
function TObjectPool.GetLockObjCount: Integer;
var
  LockedList: TList;
  i:Integer;
begin
  Result := 0;
  LockedList := FCachedList.LockList;
  try
    for I := 0 to LockedList.Count - 1 do
    begin
      if TPoolItem(LockedList[I]).FLocked then Result := Result + 1;
    end;
  finally
    FCachedList.UnlockList;
  end;
end;
 
procedure TObjectPool.IniMinPools;
var
  PoolsObject: TObject;
  LockedList: TList;
  I: Integer;
begin
  LockedList := FCachedList.LockList;
  try
    for I := 0 to FMinCacheSize - 1 do
    begin
      PoolsObject := CreateObject;
      if Assigned(PoolsObject) then
        LockedList.Add(TPoolItem.Create(PoolsObject,False));
    end;
  finally
    FCachedList.UnlockList;
  end;
end;
 
function TObjectPool.LockObject: TObject;
var
  LockedList: TList;
  I: Integer;
begin
  Result := nil;
  LockedList := FCachedList.LockList;
  try
    Inc(FRequestCount);
    for i := 0 to LockedList.Count - 1 do
    begin
      if not TPoolItem(LockedList.Items[i]).FLocked then
      begin
        Result := TPoolItem(LockedList.Items[i]).FInstance;
        TPoolItem(LockedList.Items[i]).FLocked := True;
        TPoolItem(LockedList.Items[i]).FLastTime := Now;
        Inc(FCacheHit);//从池中取的次数
        Break;
      end;
    end;
    //
    if not Assigned(Result) then
    begin
      Result := CreateObject;
      //Assert(Assigned(Result));
      Inc(FCreationCount);
      if LockedList.Count < FMaxCacheSize then //池子容量
        LockedList.Add(TPoolItem.Create(Result,True));
    end;
  finally
    FCachedList.UnlockList;
  end;
end;
 
procedure TObjectPool.OnMyTimer(Sender: TObject);
var
  i:Integer;
  LockedList: TList;
begin
  LockedList := FCachedList.LockList;
  try
    for I := LockedList.Count - 1 downto 0 do
    begin
      if MyMinutesBetween(Now,TPoolItem(LockedList.Items[i]).FLastTime) >= FHourInterval * MinsPerHour then //释放池子许久不用的ADO
      begin
        TPoolItem(LockedList.Items[i]).Free;
        LockedList.Delete(I);
      end;
    end;
  finally
    FCachedList.UnlockList;
  end;
end;
 
procedure TObjectPool.SetFHourInterval(iValue: Integer);
begin
  if iValue <= 1 then Exit;
  if FHourInterval = iValue then Exit;
  FTimer.Enabled := False;
  try
    FHourInterval := iValue;
    FTimer.Interval := MSecsPerMins * MinsPerHour * FHourInterval;
  finally
    FTimer.Enabled := True;
  end;
end;
 
procedure TObjectPool.StartAutoFree;
begin
  if not FTimer.Enabled then FTimer.Enabled := True;
end;
 
procedure TObjectPool.StopAutoFree;
begin
  if FTimer.Enabled then FTimer.Enabled := False;
end;
 
procedure TObjectPool.UnlockObject(Instance: TObject);
var
  LockedList: TList;
  I: Integer;
  Item: TPoolItem;
begin
  LockedList := FCachedList.LockList;
  try
    Item := nil;
    for i := 0 to LockedList.Count - 1 do
    begin
      Item := TPoolItem(LockedList.Items[i]);
      if Item.FInstance = Instance then
      begin
        Item.FLocked := False;
        Item.FLastTime := Now;
        Break;
      end;
    end;
    if not Assigned(Item) then Instance.Free;
  finally
    FCachedList.UnlockList;
  end;
end;
 
// 基于标准模板定义的泛型模板
{ TObjectPool<T> }
constructor TObjectPool<T>.Create(const MaxPools, MinPools: Integer);
begin
  inherited Create(T,MaxPools,MinPools);
end;
 
function TObjectPool<T>.LockObject: T;
begin
  Result := T(inherited LockObject);
end;
 
end.
 
// 基于泛型模板定义的具体模板
var
  FQueryMgr:TObjectPool<TUniQuery>; //Query池子
  FDspMgr:TObjectPool<TDataSetProvider>;//DSP池子
  FCDSMgr:TObjectPool<TClientDataSet>;//cds池子
  FDSMgr :TObjectPool<TDataSource>;//ds池子
  FUniSQLMgr:TObjectPool<TUniSQL>;//执行SQL池子
  FUniSPMgr :TObjectPool<TUniStoredProc>;//存储过程池子
 
// 创建具体模板
function QueryMgr:TObjectPool<TUniQuery>;
begin
  if not Assigned(FQueryMgr) then
    FQueryMgr := TObjectPool<TUniQuery>.Create(1000,20);
  Result := FQueryMgr;
end;