david
2824855ea7
- Recompilación en Delphi10 de todos los paquetes de RO para generar las DCU's en Lib\D10 - Recompilación en Delphi10 de todos los paquetes de DA para generar las DCU's en Lib\D10 git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.RemObjects@9 b6239004-a887-0f4b-9937-50029ccdca16
469 lines
14 KiB
ObjectPascal
469 lines
14 KiB
ObjectPascal
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.
|