unit uROClassFactories;

{----------------------------------------------------------------------------}
{ RemObjects SDK Library - Core Library                                      }
{                                                                            }
{ compiler: Delphi 5 and up, Kylix 2 and up                                  }
{ platform: Win32, Linux                                                     }
{                                                                            }
{ (c)opyright RemObjects Software. all rights reserved.                      }
{                                                                            }
{ Using this code requires a valid license of the RemObjects SDK             }
{ which can be obtained at http://www.remobjects.com.                        }
{----------------------------------------------------------------------------}

{$I RemObjects.inc}

interface

uses {$IFDEF REMOBJECTS_TRIAL}uROTrial,{$ENDIF}
     SysUtils, SyncObjs, Contnrs, Classes,
     uROServer, uROThread, uROClasses, uROTypes,uROServerIntf;

type
  { TROSingletonClassFactory }
  TROSingletonClassFactory = class(TROClassFactory)
  private
    fInstance : IInterface;

  protected
    procedure CreateInstance(const aClientID : TGUID; out anInstance : IInterface); override;
    procedure ReleaseInstance(const aClientID: TGUID; var anInstance : IInterface); override;
  public
  end;

  { TROSynchronizedSingletonClassFactory }
  TROSynchronizedSingletonClassFactory = class(TROSingletonClassFactory)
  private
    fCriticalSection:TCriticalSection;
  protected
    procedure CreateInstance(const aClientID : TGUID; out anInstance : IInterface); override;
    procedure ReleaseInstance(const aClientID: TGUID; var anInstance : IInterface); override;
  public
    constructor Create(const anInterfaceName : string;
                       aCreatorFunc : TRORemotableCreatorFunc;
                       anInvokerClass : TROInvokerClass);
    destructor Destroy; override;
  end;

  TROPoolInterfaceEntry = record
    fInterface:IInterface;
    fInUse:Boolean;
  end;

  EROPoolNoFreeObjects = class(EROException);

  TROPoolBehavior = (pbFail, pbWait, pbCreateAdditional);

  { TROPooledClassFactory }
  TROPooledClassFactory = class(TROClassFactory,IROPooledClassFactory)
  private
    fInstances : array of TROPoolInterfaceEntry;
    fCriticalSection:TCriticalSection;
    fPoolBehavior:TROPoolBehavior;
    fPoolSize:Integer;
    //,fLastInc : integer;

  protected
    procedure CreateInstance(const aClientID : TGUID; out anInstance : IInterface); override;
    procedure ReleaseInstance(const aClientID: TGUID; var anInstance : IInterface); override;

  public
    constructor Create(const anInterfaceName : string;
                       aCreatorFunc : TRORemotableCreatorFunc;
                       anInvokerClass : TROInvokerClass;
                       aPoolSize : Integer;
                       aPoolBehavior:TROPoolBehavior=pbCreateAdditional;
                       aPreInitializePool:Boolean=false);
    destructor Destroy; override;
    procedure ClearPool();
  end;

  { TROPerClientClassFactory }
  TClientInstance = class
    ServerObject:IInterface;
    ClientID:TGUID;
    LastAccess:TDateTime;
  end;

  TROPerClientClassFactory = class;

  { TROPerClientClassFactory_TimeoutThread }
  TROPerClientClassFactory_TimeoutThread = class(TROThread)
  private
    fOwner:TROPerClientClassFactory;
    fTimeoutSeconds:Integer;
    fWakeUp:TROEvent;
  protected
    procedure Execute; override;
  public
    constructor Create(iOwner:TROPerClientClassFactory; iTimeoutSeconds:integer);
    destructor Destroy; override;
  end;

  { TROPerClientClassFactory }
  TROPerClientClassFactory = class(TROClassFactory)
  private
    fInstances:TObjectList;
    fCriticalSection:TCriticalSection;
    fTimeoutThread:TROPerClientClassFactory_TimeoutThread;
    fTimeoutSeconds:Integer;

  protected
    procedure CreateInstance(const aClientID : TGUID; out anInstance : IInterface); override;
    procedure ReleaseInstance(const aClientID: TGUID; var anInstance : IInterface); override;

  public
    constructor Create(const anInterfaceName : string;
                       aCreatorFunc : TRORemotableCreatorFunc;
                       anInvokerClass : TROInvokerClass;
                       aTimeoutSeconds:cardinal);
    destructor Destroy; override;

    procedure TimeoutSessions();
  end;

implementation

uses {$IFDEF DELPHI5}ActiveX, Windows, {$ENDIF} // for IsEqualGuid and Sleep
     {$IFDEF DEBUG_REMOBJECTS_CLASSFACTORIES}eDebugServer, {$ENDIF}
      uROClient, uRORes;

const POOL_SLEEP_MS_WHILE_WAITING = 500; { sleep 0.5 seconds between trys while waiting for a pooled
                                           instance to become free } 

{ TROSingletonClassFactory }

procedure TROSingletonClassFactory.CreateInstance(const aClientID: TGUID; out anInstance: IInterface);
begin
  if (fInstance=NIL)
    then inherited CreateInstance(aClientID, fInstance);

  anInstance := fInstance;
end;

procedure TROSingletonClassFactory.ReleaseInstance(const aClientID: TGUID; var anInstance: IInterface);
begin
  //DeactivateInstance(aClientID,anInstance);
  { Do nothing else, since we want to keep instance alive }
end;

{ TROPooledClassFactory }

constructor TROPooledClassFactory.Create(const anInterfaceName: string;
  aCreatorFunc: TRORemotableCreatorFunc; anInvokerClass: TROInvokerClass;
  aPoolSize : Integer; aPoolBehavior:TROPoolBehavior=pbCreateAdditional; aPreInitializePool:Boolean=false);
var i : integer;
begin
  inherited Create(anInterfaceName, aCreatorFunc, anInvokerClass);

  fCriticalSection := TCriticalSection.Create();

  SetLength(fInstances, aPoolSize);
  fPoolSize := aPoolSize;
  fPoolBehavior := aPoolBehavior;

  if fPoolSize < 1 then RaiseError(err_PoolSizeMustBe1orHigher,[]);
    
  //fLastInc := -1;
  if aPreInitializePool then
    for i := 0 to (fPoolSize-1) do inherited CreateInstance(EmptyGUID, fInstances[i].fInterface);
end;

destructor TROPooledClassFactory.Destroy;
var i : integer;
begin
  for i := Low(fInstances) to High(fInstances) do fInstances[i].fInterface := nil;
  FreeAndNil(fCriticalSection);
  inherited;
end;

procedure TROPooledClassFactory.CreateInstance(const aClientID : TGUID; out anInstance : IInterface);
var i:Integer;
    //, refcnt : integer;
begin
  anInstance := nil;

  repeat

    fCriticalSection.Acquire();
    try

      for I := 0 to fPoolSize-1 do begin
        if not fInstances[i].fInUse then begin

          { is this pool instance initialized yet? if not, create pool instance now }
          if not Assigned(fInstances[i].fInterface) then
            inherited CreateInstance(EmptyGUID, fInstances[i].fInterface);

          { return instance and break loop }
          anInstance := fInstances[i].fInterface;
          fInstances[i].fInUse := True;
          break;

        end;
      end; { for }

    finally
      fCriticalSection.Release();
    end;

    if not Assigned(anInstance) then
      case fPoolBehavior of
        pbFail:raise EROPoolNoFreeObjects.CreateFmt(err_NoFreeObjectsInPool,[GetInterfaceName, fPoolSize]);
        pbWait:Sleep(POOL_SLEEP_MS_WHILE_WAITING);
        pbCreateAdditional:inherited CreateInstance(EmptyGUID, anInstance);
      end; { case }

  until (fPoolBehavior <> pbWait) or (Assigned(anInstance));

  //if Assigned(anInstance) then ActivateInstance(aClientID,anInstance);

  //i := fLastInc;
  {while (anInstance=NIL) do try
    if (i>=fPoolSize-1) then i := 0 else Inc(i);

    refcnt := fInstances[i]._AddRef;
    if (refcnt=2) then begin
      anInstance := fInstances[i];
      fLastInc := i;
    end;
  finally
    fInstances[i]._Release;
  end;}
end;

procedure TROPooledClassFactory.ClearPool;
var i:Integer;
begin
  fCriticalSection.Acquire();
  try

    for i := 0 to fPoolSize-1 do begin
      fInstances[i].fInUse := false;
      fInstances[i].fInterface := nil;
    end; { for }

  finally
    fCriticalSection.Release();
  end;
end;


procedure TROPooledClassFactory.ReleaseInstance(const aClientID: TGUID; var anInstance: IInterface);
var i:Integer;
begin
  //DeactivateInstance(aClientID,anInstance);

  fCriticalSection.Acquire();
  try

    for i := 0 to fPoolSize-1 do begin
      if fInstances[i].fInterface = anInstance then begin

        { return instance and break loop }
        anInstance := nil;
        fInstances[i].fInUse := false;
        break;

      end;
    end;    { for }

  finally
    fCriticalSection.Release();
  end;

  { still assigned? then we had a spare object created to serve this request. Just free it. }
  if Assigned(anInstance) then anInstance := nil;
end;

{ TROSynchronizedSingletonClassFactory }

constructor TROSynchronizedSingletonClassFactory.Create(const anInterfaceName: string; aCreatorFunc: TRORemotableCreatorFunc; anInvokerClass: TROInvokerClass);
begin
  inherited;
  fCriticalSection := TCriticalSection.Create();
end;

destructor TROSynchronizedSingletonClassFactory.Destroy;
begin
  FreeAndNil(fCriticalSection);
  inherited;
end;

procedure TROSynchronizedSingletonClassFactory.CreateInstance(const aClientID : TGUID; out anInstance : IInterface);
begin
  fCriticalSection.Enter();
  inherited;
end;

procedure TROSynchronizedSingletonClassFactory.ReleaseInstance(const aClientID: TGUID; var anInstance: IInterface);
begin
  inherited;
  fCriticalSection.Leave();
end;

{ TROPerClientClassFactory }

constructor TROPerClientClassFactory.Create(const anInterfaceName: string;
  aCreatorFunc: TRORemotableCreatorFunc; anInvokerClass: TROInvokerClass;
  aTimeoutSeconds:cardinal);
begin
  inherited Create(anInterfaceName, aCreatorFunc, anInvokerClass);
  fCriticalSection := TCriticalSection.Create;
  fInstances := TObjectList.Create;
  fTimeoutSeconds := aTimeoutSeconds;
  fTimeoutThread := TROPerClientClassFactory_TimeoutThread.Create(Self, aTimeoutSeconds div 10);
end;

destructor TROPerClientClassFactory.Destroy;
begin
  fTimeoutThread.Free;
  FreeAndNil(fInstances);
  FreeAndNil(fCriticalSection);
  inherited;
end;

procedure TROPerClientClassFactory.CreateInstance(const aClientID: TGUID;
  out anInstance: IInterface);
var i : integer;
    instinfo : TClientInstance;
begin
  anInstance := NIL;

  fCriticalSection.Enter();
  try

    for i := 0 to fInstances.Count-1 do
      if IsEqualGUID(TClientInstance(fInstances[i]).ClientID, aClientID) then begin
        anInstance := TClientInstance(fInstances[i]).ServerObject;
        TClientInstance(fInstances[i]).LastAccess := Now();
        Exit;
      end;

    //CreatorFunc(anInstance); // If not found the creates it
    inherited CreateInstance(aClientID, anInstance);

    instinfo := TClientInstance.Create;
    instinfo.ServerObject := anInstance;
    instinfo.ClientID := aClientID;
    instinfo.LastAccess := Now();

    fInstances.Add(instinfo)
  finally
    fCriticalSection.Leave();
  end;
end;

procedure TROPerClientClassFactory.ReleaseInstance(const aClientID: TGUID; 
  var anInstance: IInterface);
var destcontr : IRODestructorController;
    i : integer;
begin
  //DeactivateInstance(aClientID,anInstance);

  if Supports(anInstance, IRODestructorController, destcontr) and destcontr.CanBeDestroyed then begin

    fCriticalSection.Enter();
    try
      for i := 0 to fInstances.Count-1 do
        if IsEqualGUID(TClientInstance(fInstances[i]).ClientID, aClientID) then begin
          anInstance := NIL;
          fInstances.Delete(i);
          break;
        end;
    finally
      fCriticalSection.Leave();
    end;

  end;
end;

procedure TROPerClientClassFactory.TimeoutSessions;
var i:Integer;

  function IsExpired(iInfo:TClientInstance):Boolean;
  var lExpireTime:TDateTime;
  const lSecsPerDay=24*60*60;
  begin
    lExpireTime := ((iInfo.LastAccess * lSecsPerDay) + fTimeoutSeconds) / lSecsPerDay;
    Result := lExpireTime < Now();
    {$IFDEF DEBUG_REMOBJECTS_CLASSFACTORIES}
    DebugServer.Write('Instance for Client ID %s - Last accessed %s, expires %s (now is %s)',
                      [GuidToString(iInfo.ClientID),
                      DateTimeToStr(iInfo.LastAccess),
                      DateTimeToStr(lExpireTime),
                      DateTimeToStr(Now())]);
    {$ENDIF DEBUG_REMOBJECTS_CLASSFACTORIES}
  end;

var lInstance:IInterface;
    lObjectTimeout:IROObjectTimeout;
begin
  {$IFDEF DEBUG_REMOBJECTS_CLASSFACTORIES}
  DebugServer.EnterMethod('TROPerClientClassFactory.TimeoutSessions()'); try
  DebugServer.Write('%d instances in class factory',[fInstances.Count]);
  {$ENDIF DEBUG_REMOBJECTS_CLASSFACTORIES}

  fCriticalSection.Enter();
  try

    for i := fInstances.Count-1 downto 0 do
      if IsExpired(TClientInstance(fInstances[i])) then begin
        {$IFDEF DEBUG_REMOBJECTS_CLASSFACTORIES}
        DebugServer.Write('Expired PerClient instance for %s',[GuidToString(TClientInstance(fInstances[i]).ClientID)]);
        {$ENDIF DEBUG_REMOBJECTS_CLASSFACTORIES}

        lInstance := (fInstances[i] as TClientInstance).ServerObject;
        if Supports(lInstance,IROObjectTimeout,lObjectTimeout) then
          lObjectTimeout.OnTimeout();
        lInstance := nil;

        fInstances.Delete(i);
      end;

  finally
    fCriticalSection.Leave();
  end;

  {$IFDEF DEBUG_REMOBJECTS_CLASSFACTORIES}
  finally DebugServer.ExitMethod('TROPerClientClassFactory.TimeoutSessions()'); end;
  {$ENDIF DEBUG_REMOBJECTS_CLASSFACTORIES}
end;

{ TROPerClientClassFactory_TimeoutThread }

constructor TROPerClientClassFactory_TimeoutThread.Create(iOwner: TROPerClientClassFactory; iTimeoutSeconds:integer);
begin
  inherited Create(true,'TROPerClientClassFactory_TimeoutThread');
  fWakeUp := TROEvent.Create(nil,False,False,'');
  fOwner := iOwner;
  fTimeoutSeconds := iTimeoutSeconds;
  if fTimeoutSeconds < 10 then fTimeoutSeconds := 10;
  Resume();
end;

destructor TROPerClientClassFactory_TimeoutThread.Destroy();
begin
  Terminate();
  fWakeUp.SetEvent();
  inherited;                           
  FreeAndNil(fWakeUp);
end;

procedure TROPerClientClassFactory_TimeoutThread.Execute;
begin
  while not Terminated do begin
    fWakeUp.WaitFor(fTimeoutSeconds*1000); { WaitFor expects ms }
    if not Terminated then begin
      fOwner.TimeoutSessions();
    end;
  end;    { while }
end;

initialization
  RegisterExceptionClass(EROPoolNoFreeObjects);
finalization
  UnregisterExceptionClass(EROPoolNoFreeObjects);
end.