是否有通用的“对象池"?实施德尔福? [英] Is there a generic "Object Pool" implementation for Delphi?

问题描述

我在寻找Delphi的数据库连接池实现时碰到了这一点.

I came across this while looking for a database connection pool implementation for Delphi.

对象池需要两种方法:

• get-从池中获取一个对象(如果池为空或其大小未达到其最大大小，则将创建一个新实例)，此方法必须是线程安全的，因此一个对象不能被两个线程同时获取.如果所有对象都在使用中，则get方法必须阻塞(也许有一个可选的超时时间)

• get - to acquire an object from the pool (this will create a new instance if the pool is empty or its size has not reached its maximum size), this methods must be thread safe so that one object can not be acquired by two threads at the same time. If all objects are iin use, the get method must block (maybe with an optional time out)

放置-将对象释放(返回)到池中

put - to release (return) an object to the pool

所以用例看起来像

O := Pool.Get;
try
  ... use O
finally
  Pool.Put(O);
end;

更新:添加了Delphi 2009标签，因此Generics.Collections和TMonitor可以成为实现的一部分

Update: added Delphi 2009 tag so Generics.Collections and TMonitor could be part of the implementation

推荐答案

TMonitor在Delphi-2009中严重损坏.它已在Delphi-XE2 upd 4中起作用，此处的答案是基于(或更新)的.

TMonitor is badly broken in Delphi-2009. It became functional in Delphi-XE2 upd 4, which the answer here is based on (or newer).

这里，对象池基于线程安全的TThreadedQueue.

Here, the object pool is based on a thread-safe TThreadedQueue.

内置创建对象的机制具有线程安全性. 从池中获取对象是线程安全的，并且在创建池时定义了超时. 队列大小也在池创建时定义，其中还传递了用于创建对象的回调例程.

A mechanism for creating pooled objects is built in with thread safety. Getting an object from the pool is thread-safe and a timeout is defined at pool creation. The queue size is also defined at pool creation, where a callback routine for object creation also is passed.

uses
  System.Classes,Generics.Collections,System.SyncObjs,System.Diagnostics;

type
  TObjectConstructor = function : TObject;

  TMyPool = Class
  private
    FQueueSize,FAllocatedObjects : integer;
    FGetTimeOut : Integer;
    FQueue : TThreadedQueue<TObject>;
    FObjectConstructor : TObjectConstructor;
    FCS : TCriticalSection;
    function AllocateNewObject : TObject;
  public
    Constructor Create( AnObjectConstructor : TObjectConstructor;
                        QueueSize           : Integer;
                        GetTimeOut          : Integer);
    Destructor Destroy; override;
    procedure Put( const AnObject : TObject);
    function Get( var AnObject : TObject) : TWaitResult;
  End;

function TMyPool.AllocateNewObject: TObject;
begin
  FCS.Enter;
  Try
    if Assigned(FObjectConstructor) and
       (FAllocatedObjects < FQueueSize)
    then
    begin
      Inc(FAllocatedObjects);
      Result := FObjectConstructor;
    end
    else
      Result := Nil;
  Finally
    FCS.Leave;
  End;
end;

constructor TMyPool.Create( AnObjectConstructor : TObjectConstructor;
                            QueueSize           : Integer;
                            GetTimeOut          : Integer);
begin
  Inherited Create;

  FCS := TCriticalSection.Create;
  FAllocatedObjects := 0;
  FQueueSize := QueueSize;
  FObjectConstructor := AnObjectConstructor;
  FGetTimeOut := GetTimeOut;
  FQueue := TThreadedQueue<TObject>.Create(FQueueSize+1,Infinite,10);
  // Adding an extra position in queue to safely remove all items on destroy
end;

destructor TMyPool.Destroy;
var
  AQueueSize : integer;
  AnObject : TObject;
  wr : TWaitResult;
begin
  FQueue.PushItem(Nil); // Just to make sure we have an item in queue
  repeat // Free objects in queue
    AnObject := nil;
    wr := FQueue.PopItem(AQueueSize,AnObject);
    if (wr = wrSignaled) then
      AnObject.Free;
  until (AQueueSize = 0);
  FQueue.Free;
  FCS.Free;

  Inherited;
end;

function TMyPool.Get(var AnObject: TObject) : TWaitResult;
var
  sw : TStopWatch;
begin
  AnObject := nil;
  // If queue is empty, and not filled with enough objects, create a new.
  sw := TStopWatch.Create;
  repeat
    sw.Start;
    Result := FQueue.PopItem( AnObject); // Timeout = 10 ms
    if (Result = wrTimeOut) and
       (FAllocatedObjects < FQueueSize) and
       Assigned(FObjectConstructor)
    then begin  // See if a new object can be allocated
      AnObject := Self.AllocateNewObject;
      if Assigned(AnObject) then
      begin
        Result := wrSignaled;
        Exit;
      end;
    end;
    sw.Stop;
  until (Result = wrSignaled) or (sw.ElapsedMilliseconds > FGetTimeOut);
end;

procedure TMyPool.Put( const AnObject: TObject);
begin
  FQueue.PushItem(AnObject); // Put object back into queue
end;

像这样定义您的TObjectConstructor函数:

function MyObjectConstructor : TObject;
begin
  Result := TMyObject.Create( {Some optional parameters});
end;

以及使用示例:

var
  AnObject : TObject;
  MyObject : TMyObject;
  wr : TWaitResult;
begin
  wr := MyObjPool.Get(AnObject);
  if (wr = wrSignaled) then 
  begin
    MyObject := TMyObject(AnObject);
    try
      // Do something with MyObject
    finally
      MyObjPool.Put(AnObject);
    end;
  end;
end

这篇关于是否有通用的“对象池"?实施德尔福?的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！