Delphi 是否有通用的“对象池”实现？答案

【问题标题】：Is there a generic "Object Pool" implementation for Delphi?Delphi 是否有通用的“对象池”实现？
【发布时间】：2013-04-30 12:31:08
【问题描述】：

我在寻找 Delphi 的数据库连接池实现时遇到了这个问题。

一个对象池需要两个方法：

get - 从池中获取对象（如果池为空或其大小未达到最大大小，这将创建一个新实例），此方法必须是线程安全的，这样一个对象就不能被两个线程同时获取。如果所有对象都在使用中，get 方法必须阻塞（可能有一个可选的超时）
put - 将对象释放（返回）到池中

所以一个用例看起来像

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

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

【问题讨论】：

泛型意味着泛型？
您的目标是哪个版本的 Delphi？
@ArnaudBouchez 添加了 Delphi 2009 标记（泛型在此版本中无法正常工作，但以后可能会是不同的主题）
@SirRufo 是的，泛型绝对可以让它更具吸引力
见Pool of Objects - Synchronize - Delphi。

标签： delphi oop delphi-2009 pool

【解决方案1】：

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

【讨论】：

【解决方案2】：

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

【讨论】：

"delphipooling" unicode 准备好了吗？可以在Delphi XE中使用吗？

【解决方案3】：

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

【讨论】：

有适用于 D2009 和 XE TMonitor 的补丁（请参阅thedelphigeek.com/2011/05/tmonitor-bug.html）
请注意，TMonitor 中有两个错误。当多个消费者遇到一个空队列时，它会表现出丑陋的一面。我认为这是@gabr 上显示的补丁更正的内容。当多个消费者到达一个完整的队列时，会出现另一个错误。有关这些条件的测试，请参阅TThreadedQueue not capable of multiple consumers?。在 XE2 更新 4 之前，我使用了一个稍加修改的队列，显示为 here，而不是 TThreadedQueue。
非常感谢您指出 TMonitor 中的第二个严重问题。至少它适用于 Delphi 2009 中的一位消费者，总比没有好;)

【解决方案4】：

今天刚刚遇到Boosting Work Classes with a mini Object Pool，作者是 Eric，现任 awesome dwScript 开发人员。

【讨论】：

【解决方案5】：

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

好像没有文档，但是有test cases here

【讨论】：