Delphi對象池MyObjectPool.pas

對象池一般在服務端使用，所以穩定性是第一的。

歡迎提意見

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.