QuickLib/Quick.Pooling.pas

{ ***************************************************************************

  Copyright (c) 2016-2020 Kike Pérez

  Unit        : Quick.Pooling
  Description : Pooling objects
  Author      : Kike Pérez
  Version     : 1.9
  Created     : 28/02/2020
  Modified    : 29/02/2020

  This file is part of QuickLib: https://github.com/exilon/QuickLib

 ***************************************************************************

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

  http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.

 *************************************************************************** }

unit Quick.Pooling;

{$i QuickLib.inc}

interface

uses
  System.SysUtils,
  System.SyncObjs,
  System.DateUtils,
  Quick.Commons,
  Quick.Threads;

type

  IPoolItem<T : class, constructor> = interface
  ['{D52E794B-FDC1-42C1-94BA-823DB74703E4}']
    function Item : T;
    function GetRefCount : Integer;
    function GetItemIndex : Integer;
    function GetLastAccess: TDateTime;
    property RefCount: Integer read GetRefCount;
    property ItemIndex : Integer read GetItemIndex;
    property LastAccess: TDateTime read GetLastAccess;
  end;

  TCreateDelegator<T> = reference to procedure(var aInstance : T);

  TPoolItem<T : class, constructor> = class(TInterfacedObject,IPoolItem<T>)
  private
    fItem : T;
    fItemIndex : Integer;
    fLastAccess : TDateTime;
    function GetRefCount : Integer;
    function GetLastAccess: TDateTime;
    function GetItemIndex : Integer;
  protected
    fLock : TCriticalSection;
    fSemaphore : TSemaphore;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
  public
    constructor Create(aSemaphore : TSemaphore; aLock : TCriticalSection; aItemIndex : Integer; aCreateProc : TCreateDelegator<T>);
    destructor Destroy; override;
    function Item : T;
    property RefCount: Integer read GetRefCount;
    property ItemIndex : Integer read GetItemIndex;
    property LastAccess: TDateTime read GetLastAccess;
  end;

  IObjectPool<T : class, constructor> = interface
  ['{AA856DFB-AE8C-46FE-A107-034677010A58}']
    function GetPoolSize: Integer;
    function Get : IPoolItem<T>;
    property PoolSize : Integer read GetPoolSize;
    function TimeoutMs(aTimeout : Integer) : IObjectPool<T>;
    function CreateDelegate(aCreateProc : TCreateDelegator<T>) : IObjectPool<T>;
    function AutoFreeIdleItemTimeMs(aIdleTimeMs : Integer) : IObjectPool<T>;
  end;

  TObjectPool<T : class, constructor> = class(TInterfacedObject,IObjectPool<T>)
  private
    fPool : TArray<IPoolItem<T>>;
    fPoolSize : Integer;
    fWaitTimeoutMs : Integer;
    fLock : TCriticalSection;
    fDelegate : TCreateDelegator<T>;
    fSemaphore : TSemaphore;
    fAutoFreeIdleItemTimeMs : Integer;
    fScheduler : TScheduledTasks;
    function GetPoolSize: Integer;
    procedure CreateScheduler;
    procedure CheckForIdleItems;
  public
    constructor Create(aPoolSize : Integer; aAutoFreeIdleItemTimeMs : Integer = 30000; aCreateProc : TCreateDelegator<T> = nil);
    destructor Destroy; override;
    property PoolSize : Integer read GetPoolSize;
    function TimeoutMs(aTimeout : Integer) : IObjectPool<T>;
    function CreateDelegate(aCreateProc : TCreateDelegator<T>) : IObjectPool<T>;
    function AutoFreeIdleItemTimeMs(aIdleTimeMs : Integer) : IObjectPool<T>;
    function Get : IPoolItem<T>;
  end;

implementation

{ TObjectPool<T> }

function TObjectPool<T>.AutoFreeIdleItemTimeMs(aIdleTimeMs: Integer): IObjectPool<T>;
begin
  fAutoFreeIdleItemTimeMs := aIdleTimeMs;
end;

constructor TObjectPool<T>.Create(aPoolSize : Integer; aAutoFreeIdleItemTimeMs : Integer = 30000; aCreateProc : TCreateDelegator<T> = nil);
begin
  fLock := TCriticalSection.Create;
  fPoolSize := aPoolSize;
  fWaitTimeoutMs := 30000;
  fDelegate := aCreateProc;
  fAutoFreeIdleItemTimeMs := aAutoFreeIdleItemTimeMs;
  fSemaphore := TSemaphore.Create(nil,fPoolSize,fPoolSize,'');
  CreateScheduler;
end;

procedure TObjectPool<T>.CreateScheduler;
begin
  fScheduler := TScheduledTasks.Create;
  fScheduler.AddTask('IdleCleaner',[],True,procedure(task : ITask)
      begin
        CheckForIdleItems;
      end)
      .StartInSeconds(10).RepeatEvery(fAutoFreeIdleItemTimeMs,TTimeMeasure.tmMilliseconds);
  fScheduler.Start;
end;

procedure TObjectPool<T>.CheckForIdleItems;
var
  i : Integer;
begin
  fLock.Enter;
  try
    for i := low(fPool) to High(fPool) do
    begin
      //check if item was not used for long time
      if (fPool[i] <> nil) and (fPool[i].RefCount = 1) and (MilliSecondsBetween(Now,fPool[i].LastAccess) > fAutoFreeIdleItemTimeMs) then
      begin
        fPool[i] := nil;
      end;
    end;
  finally
    fLock.Leave;
  end;
end;

function TObjectPool<T>.CreateDelegate(aCreateProc: TCreateDelegator<T>): IObjectPool<T>;
begin
  fDelegate := aCreateProc;
end;

destructor TObjectPool<T>.Destroy;
  var
  i: Integer;
begin
  fScheduler.Stop;
  fScheduler.Free;
  fLock.Enter;
  try
    for i := Low(fPool) to High(fPool) do fPool[i] := nil;
    SetLength(FPool,0);
  finally
    fLock.Leave;
  end;
  fLock.Free;
  fSemaphore.Free;
  inherited;
end;

function TObjectPool<T>.Get: IPoolItem<T>;
var
  i : Integer;
  waitResult: TWaitResult;
begin
  Result := nil;
  waitResult := fSemaphore.WaitFor(fWaitTimeoutMs);
  if waitResult <> TWaitResult.wrSignaled then raise Exception.Create('Connection Pool Timeout: Cannot obtain a connection');
  fLock.Enter;
  try
    if High(fPool) < fPoolSize then SetLength(fPool,High(fPool)+2);
    for i := Low(fPool) to High(fPool) do
    begin
      if fPool[i] = nil then
      begin
        fPool[i] := TPoolItem<T>.Create(fSemaphore,fLock,i,fDelegate);
        //writeln('create ' + i.ToString);
        Exit(fPool[i]);
      end;
      if fPool[i].RefCount = 1 then
      begin
        //writeln('get ' + i.ToString);
        Exit(fPool[i]);
      end;
    end;
  finally
    fLock.Leave;
  end;
end;

function TObjectPool<T>.GetPoolSize: Integer;
begin
  Result := fPoolSize;
end;

function TObjectPool<T>.TimeoutMs(aTimeout: Integer): IObjectPool<T>;
begin
  fWaitTimeoutMs := aTimeout;
end;

{ TPoolItem<T> }

function TPoolItem<T>.Item: T;
begin
  fLastAccess := Now();
  Result := fItem;
end;

constructor TPoolItem<T>.Create(aSemaphore : TSemaphore; aLock : TCriticalSection; aItemIndex : Integer; aCreateProc : TCreateDelegator<T>);
begin
  fLastAccess := Now();
  fItemIndex := aItemIndex;
  if Assigned(aCreateProc) then aCreateProc(fItem)
    else fItem := T.Create;
  fLock := aLock;
  fSemaphore := aSemaphore;
end;

destructor TPoolItem<T>.Destroy;
begin
  if Assigned(fItem) then fItem.Free;
  inherited;
end;

function TPoolItem<T>.GetItemIndex: Integer;
begin
  Result := fItemIndex;
end;

function TPoolItem<T>.GetLastAccess: TDateTime;
begin
  Result := fLastAccess;
end;

function TPoolItem<T>.GetRefCount: Integer;
begin
  Result := FRefCount;
end;

function TPoolItem<T>._AddRef: Integer;
begin
  fLock.Enter;
  //writeln('enter');
  try
    Inc(FRefCount);
    Result := FRefCount;
  finally
    fLock.Leave;
  end;
end;

function TPoolItem<T>._Release: Integer;
begin
  fLock.Enter;
  //writeln('exit');
  try
    Dec(fRefCount);
    Result := fRefCount;
    if Result = 0 then
    begin
      FreeAndNil(fItem);
      Destroy;
    end
    else fLastAccess := Now;
  finally
    fLock.Leave;
    if fRefCount = 1 then fSemaphore.Release;
  end;
end;

end.