更新时间:2023-11-13 18:18:46
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