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