3

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

An object pool needs two methods:

  • 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

So a use case would look like

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

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

4

5 回答 5

1

TMonitor在 Delphi-2009 中严重损坏。它在 Delphi-XE2 upd 4 中起作用，这里的答案基于（或更新）。

在这里，对象池是基于线程安全的TThreadedQueue。

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

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
于 2013-05-07T00:04:03.783 回答
0

今天刚刚遇到了Boosting Work Classes with a mini Object Pool，作者是 Eric，目前是dwScript 的出色开发者。

于 2013-09-27T15:51:58.767 回答
0

不，Delphi 中没有通用对象池。您将不得不自己滚动，或使用第三方代码，例如：delphipooling

于 2013-05-06T20:33:03.573 回答
0

根据您用于在多个线程上执行任务或作业的（线程）平台或体系结构，处理数据库连接的“通用”方法是使用threadvar每个线程的数据库连接。如果你有线程池或线程管理器，应该扩展为在添加线程时启动数据库连接（或在线程上运行的第一个任务时连接到数据库），并在线程被销毁时关闭数据库连接.

于 2013-05-06T20:05:02.753 回答
0

Spring4D - Spring.Container.Pool.pas有一个对象池实现，我没有尝试过，但是你知道，Delphi 社区的人都知道 Spring4D 的质量很高:)

好像没有文档，但是这里有测试用例

于 2017-09-01T04:27:41.007 回答