unit Sparkle.Sys.ObjectPool;

{$I Sparkle.Inc}

interface

uses
  Generics.Defaults, SysUtils, SyncObjs;

type
  TPoolCreateItem<T> = reference to function: T;
  TPoolDestroyItem<T> = reference to procedure(const AItem: T);

  TPoolItemFactory<T: class> = class abstract(TInterfacedObject)
  protected
    function CreateItem: T; virtual; abstract;
    procedure DestroyItem(const Item: T); virtual;
  end;

  TPoolSimpleObjectFactory<T: class, constructor> = class(TPoolItemFactory<T>)
  protected
    function CreateItem: T; override;
  end;

  TPoolItemAnonymousFactory<T: class> = class(TPoolItemFactory<T>)
  strict private
    FCreateItem: TPoolCreateItem<T>;
    FDestroyItem: TPoolDestroyItem<T>;
  protected
    function CreateItem: T; override;
    procedure DestroyItem(const AItem: T); override;
  public
    constructor Create(ACreateItem: TPoolCreateItem<T>); overload;
    constructor Create(ACreateItem: TPoolCreateItem<T>; ADestroyItem: TPoolDestroyItem<T>); overload;
  end;

  IObjectPool = interface
    function AcquireObject: TObject;
    procedure ReleaseObject(const Item: TObject);
  end;

  TCustomObjectPool = class abstract(TInterfacedObject, IObjectPool)
  strict private
    FAcquireTimeout: Cardinal;
  public
    function AcquireObject: TObject; virtual; abstract;
    procedure ReleaseObject(const Item: TObject); virtual; abstract;
    procedure TouchObject(const Item: TObject); virtual; abstract;
    function CriticalSection: TCriticalSection; virtual; abstract;
    procedure CleanUp(InactivityTimeout: Integer); virtual; abstract;
    property AcquireTimeout: Cardinal read FAcquireTimeout write FAcquireTimeout;
  end;

  IObjectPool<T> = interface
    function Acquire: T;
    procedure Release(const Item: T);
  end;

  TObjectPool<T: class> = class(TCustomObjectPool, IObjectPool<T>, IObjectPool)
  strict private
    type
      TPoolItem<E> = class
      strict private
        FLastAccess: TDateTime;
        FItem: E;
      private
        FInUse: boolean;
        procedure SetInUse(const Value: boolean);
      protected
        property LastAccess: TDateTime read FLastAccess write FLastAccess;
        property Item: E read FItem write FItem;
        property InUse: boolean read FInUse write SetInUse;
        procedure Touch;
      public
        constructor Create(const AItem: E);
      end;
  strict private
    const
      DefaultAcquireTimeout = 10000;
  strict private
    type
      EPoolAcquireException = class(Exception)
      public
        constructor Create;
      end;
  strict private
    FFactory: TPoolItemFactory<T>;
    FPool: array of TPoolItem<T>;
    FSection: TCriticalSection;
    FSemaphore: TSemaphore;
    FEqualityComparer: IEqualityComparer<T>;
    procedure DestroyPoolItem(Index: integer); // call inside a critical section!
  public
    function AcquireObject: TObject; override;
    procedure ReleaseObject(const Item: TObject); override;
    procedure TouchObject(const Item: TObject); override;
    function CriticalSection: TCriticalSection; override;
    procedure CleanUp(InactivityTimeout: Integer); override;
  public
    constructor Create(const Size: integer; const AFactory: TPoolItemFactory<T>);
    destructor Destroy; override;
    function Acquire: T;
    procedure Release(const Item: T);
    procedure Touch(const Item: T);
  end;

  TSimpleObjectPool<T: class, constructor> = class(TObjectPool<T>)
  public
    constructor Create(const Size: integer);
  end;

  TInterfaceWrapper<T> = class
  strict private
    FInterface: T;
    {$IFDEF AUTOREFCOUNT}[Weak]{$ENDIF}
    FPool: TCustomObjectPool;
    FRefCount: integer;
  strict protected
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
  public
    constructor Create(AInterface: T; APool: TCustomObjectPool);
    property Intf: T read FInterface;
  end;

implementation

uses
  System.DateUtils;

{ TObjectPool<T> }

function TObjectPool<T>.Acquire: T;
var
  I: integer;
begin
  if FSemaphore.WaitFor(AcquireTimeout) <> wrSignaled then
    raise EPoolAcquireException.Create;
  FSection.Enter;
  try
    for I := Low(FPool) to High(FPool) do
    begin
      if FPool[I] = nil then
        FPool[I] := TPoolItem<T>.Create(FFactory.CreateItem);
      if not FPool[I].InUse then
      begin
        FPool[I].InUse := true;
        Exit(FPool[I].Item);
      end;
    end;
  finally
    FSection.Leave;
  end;
  Result := Default(T);
end;

function TObjectPool<T>.AcquireObject: TObject;
begin
  Result := Acquire;
end;

procedure TObjectPool<T>.CleanUp(InactivityTimeout: Integer);
var
  I: integer;
begin
  FSection.Enter;
  try
    for I := Low(FPool) to High(FPool) do
    begin
      if (FPool[I] <> nil) and (SecondsBetween(Now, FPool[I].LastAccess) > InactivityTimeout) then
      begin
        if FPool[I].InUse then
        begin
          FPool[I].InUse := false;
          FSemaphore.Release;
        end;
        DestroyPoolItem(I);
      end;
    end;
  finally
    FSection.Leave;
  end;
end;

constructor TObjectPool<T>.Create(const Size: integer; const AFactory: TPoolItemFactory<T>);
var
  I: Integer;
begin
  AcquireTimeout := DefaultAcquireTimeout;
  FSemaphore := TSemaphore.Create(nil, Size, Size, '');
  FEqualityComparer := TEqualityComparer<T>.Default;
  SetLength(FPool, Size);
  for I := Low(FPool) to High(FPool) do
    FPool[I] := nil;
  FSection := TCriticalSection.Create;
  FFactory := AFactory;
end;

function TObjectPool<T>.CriticalSection: TCriticalSection;
begin
  Result := FSection;
end;

destructor TObjectPool<T>.Destroy;
var
  I: Integer;
begin
  FSection.Enter;
  try
    for I := Low(FPool) to High(FPool) do
      if FPool[I] <> nil then
        DestroyPoolItem(I);
    SetLength(FPool, 0);
  finally
    FSection.Leave;
  end;
  FSection.Free;
  FFactory.Free;
  FSemaphore.Free;
  inherited;
end;

procedure TObjectPool<T>.DestroyPoolItem(Index: integer);
begin
  if FPool[Index] <> nil then
  begin
    FFactory.DestroyItem(FPool[Index].Item);
    FPool[Index].Free;
    FPool[Index] := nil;
  end;
end;

procedure TObjectPool<T>.Release(const Item: T);
var
  I: integer;
begin
  FSection.Enter;
  try
    for I := Low(FPool) to High(FPool) do
    begin
      if (FPool[I] <> nil) and FEqualityComparer.Equals(FPool[I].Item, Item) and FPool[I].InUse then
      begin
        FPool[I].InUse := false;
        FSemaphore.Release;
      end;
    end;
  finally
    FSection.Leave;
  end;
end;

procedure TObjectPool<T>.ReleaseObject(const Item: TObject);
begin
  Release(Item);
end;

procedure TObjectPool<T>.Touch(const Item: T);
var
  I: integer;
begin
  FSection.Enter;
  try
    for I := Low(FPool) to High(FPool) do
      if (FPool[I] <> nil) and FEqualityComparer.Equals(FPool[I].Item, Item) then
      begin
        FPool[I].Touch;
        break;
      end;
  finally
    FSection.Leave;
  end;
end;

procedure TObjectPool<T>.TouchObject(const Item: TObject);
begin
  Touch(Item);
end;

{ TPoolItem<T> }

constructor TObjectPool<T>.TPoolItem<E>.Create(const AItem: E);
begin
  FItem := AItem;
  Touch;
end;

procedure TObjectPool<T>.TPoolItem<E>.SetInUse(const Value: boolean);
begin
  FInUse := Value;
  Touch;
end;

procedure TObjectPool<T>.TPoolItem<E>.Touch;
begin
  FLastAccess := Now;
end;

{ TSimpleObjectPool<T> }

constructor TSimpleObjectPool<T>.Create(const Size: integer);
begin
  inherited Create(Size, TPoolSimpleObjectFactory<T>.Create);
end;

{ TPoolSimpleObjectFactory<T> }

function TPoolSimpleObjectFactory<T>.CreateItem: T;
begin
  Result := T.Create;
end;

{ TObjectPool<T>.EPoolAcquireException }

constructor TObjectPool<T>.EPoolAcquireException.Create;
begin
  inherited Create('Cannot retrieve object from object pool.');
end;

{ TPoolItemAnonymousFactory<T> }

constructor TPoolItemAnonymousFactory<T>.Create(ACreateItem: TPoolCreateItem<T>;
  ADestroyItem: TPoolDestroyItem<T>);
begin
  FCreateItem := ACreateItem;
  FDestroyItem := ADestroyItem;
end;

constructor TPoolItemAnonymousFactory<T>.Create(
  ACreateItem: TPoolCreateItem<T>);
begin
  Create(ACreateItem, nil);
end;

function TPoolItemAnonymousFactory<T>.CreateItem: T;
begin
  Result := FCreateItem;
end;

procedure TPoolItemAnonymousFactory<T>.DestroyItem(const AItem: T);
begin
  if Assigned(FDestroyItem) then
    FDestroyItem(AItem)
  else
    inherited DestroyItem(AItem);
end;

{ TInterfacePool<T>.TInterfaceWrapper<IT> }

constructor TInterfaceWrapper<T>.Create(AInterface: T; APool: TCustomObjectPool);
begin
  FInterface := AInterface;
  FPool := APool;
end;

function TInterfaceWrapper<T>.QueryInterface(
  const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
    Result := S_OK
  else
    Result := E_NOINTERFACE;
end;

function TInterfaceWrapper<T>._AddRef: Integer;
begin
  FPool.CriticalSection.Enter;
  try
    Inc(FRefCount);
    Result := FRefCount;
  finally
    FPool.CriticalSection.Leave;
  end;
  FPool.TouchObject(Self);
end;

function TInterfaceWrapper<T>._Release: Integer;
begin
  FPool.CriticalSection.Enter;
  try
    Dec(FRefCount);
    Result := FRefCount;
    if FRefCount = 0 then
      FPool.ReleaseObject(Self);
  finally
    FPool.CriticalSection.Leave;
  end;
end;

{ TPoolItemFactory<T> }

procedure TPoolItemFactory<T>.DestroyItem(const Item: T);
begin
  {$IFNDEF NEXTGEN}
  Item.Free;
  {$ENDIF}
end;

end.
