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
1220 lines
39 KiB
ObjectPascal
1220 lines
39 KiB
ObjectPascal
unit uROServer;
|
|
|
|
{----------------------------------------------------------------------------}
|
|
{ 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
|
|
Classes, SysUtils, SyncObjs,
|
|
{$IFDEF REMOBJECTS_TRIAL}uROTrial, {$ENDIF}
|
|
{$IFDEF REMOBJECTS_UseEncryption}uROEncryption, {$ENDIF}
|
|
uRORes, uROServerIntf, uROClient, uROClientIntf, uROClasses, uROTypes,
|
|
uROEventRepository;
|
|
|
|
type
|
|
TROServer = class;
|
|
|
|
{ TMessageInvokeMethod }
|
|
TMessageInvokeMethod = procedure(const anInstance: IInterface;
|
|
const aMessage: IROMessage;
|
|
const aTransport: IROTransport;
|
|
out oResponseOptions:TROResponseOptions) of object;
|
|
|
|
{ TRORemotable }
|
|
TRORemotable = class(TInterfacedObject, IROObjectRetainer)
|
|
private
|
|
fRetainedObjects : TList;
|
|
|
|
protected
|
|
{$IFDEF DELPHI7UP}
|
|
procedure Synchronize(aMethod: TThreadMethod);
|
|
{$ENDIF DELPHI7UP}
|
|
|
|
{ IROObjectRetainer }
|
|
procedure RetainObject(const anObject : TObject);
|
|
procedure ReleaseObject(const anObject : TObject);
|
|
function IsRetained(const anObject : TObject) : boolean;
|
|
|
|
public
|
|
constructor Create; virtual;
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
TRORemotableClass = class of TRORemotable;
|
|
|
|
{ TROInvoker }
|
|
{$M+}
|
|
TROInvoker = class(TInterfacedObject, IROInvoker)
|
|
private
|
|
|
|
protected
|
|
function CustomHandleMessage(const aFactory: IROClassFactory;
|
|
const aMessage: IROMessage;
|
|
const aTransport: IROTransport;
|
|
out oResponseOptions: TROResponseOptions): boolean; virtual;
|
|
|
|
procedure BeforeInvoke(aMethodPtr: TMessageInvokeMethod;
|
|
const anInstance: IInterface;
|
|
const aFactory: IROClassFactory;
|
|
const aMessage: IROMessage;
|
|
const aTransport: IROTransport); virtual;
|
|
|
|
procedure AfterInvoke(aMethodPtr: TMessageInvokeMethod;
|
|
const anInstance: IInterface;
|
|
const aFactory: IROClassFactory;
|
|
const aMessage: IROMessage;
|
|
const aTransport: IROTransport;
|
|
anException: Exception); virtual;
|
|
|
|
public
|
|
constructor Create; virtual;
|
|
destructor Destroy; override;
|
|
|
|
function HandleMessage(const aFactory: IROClassFactory;
|
|
const aMessage: IROMessage;
|
|
const aTransport: IROTransport;
|
|
out oResponseOptions: TROResponseOptions): boolean;
|
|
|
|
published
|
|
{ IROServerEventsBroker invocation - Ghost methods }
|
|
procedure Invoke_RegisterEventClient(const __Instance:IInterface; const __Message:IROMessage; const __Transport:IROTransport; out __oResponseOptions:TROResponseOptions);
|
|
procedure Invoke_UnregisterEventClient(const __Instance:IInterface; const __Message:IROMessage; const __Transport:IROTransport; out __oResponseOptions:TROResponseOptions);
|
|
procedure Invoke_RegisterClient(const __Instance:IInterface; const __Message:IROMessage; const __Transport:IROTransport; out __oResponseOptions:TROResponseOptions);
|
|
procedure Invoke_UnregisterClient(const __Instance:IInterface; const __Message:IROMessage; const __Transport:IROTransport; out __oResponseOptions:TROResponseOptions);
|
|
procedure Invoke_GetEventsData(const __Instance:IInterface; const __Message:IROMessage; const __Transport:IROTransport; out __oResponseOptions:TROResponseOptions);
|
|
end;
|
|
{$M-}
|
|
|
|
TROInvokerClass = class of TROInvoker;
|
|
|
|
{ TROClassFactory }
|
|
TRORemotableCreatorFunc = procedure(out anInstance: IInterface);
|
|
|
|
{ TROMessageDispatcher }
|
|
TROMessageDispatchers = class;
|
|
TROMessageDispatcher = class(TCollectionItem)
|
|
private
|
|
fDispatchers: TROMessageDispatchers;
|
|
fMessage: TROMessage;
|
|
fEnabled: boolean;
|
|
fDummyName: string;
|
|
|
|
fMessageIntf: pointer;
|
|
fModuleInfoIntf: pointer;
|
|
|
|
function GetMessageIntf: IROMessage;
|
|
function GetModuleInfoIntf: IROModuleInfo;
|
|
function GetServer: TROServer;
|
|
|
|
protected
|
|
procedure SetMessage(const Value: TROMessage); virtual;
|
|
function GetDisplayName: string; override;
|
|
|
|
property Server:TROServer read GetServer;
|
|
|
|
public
|
|
constructor Create(aCollection: TCollection); override;
|
|
destructor Destroy; override;
|
|
|
|
procedure Assign(Source: TPersistent); override;
|
|
|
|
function ProcessMessage(const aTransport: IROTransport; aRequeststream, aResponsestream: TStream; out oResponseOptions: TROResponseOptions): boolean;
|
|
function CanHandleMessage(const aTransport: IROTransport; aRequeststream: TStream): boolean; virtual;
|
|
|
|
property MessageIntf: IROMessage read GetMessageIntf;
|
|
property ModuleIntf: IROModuleInfo read GetModuleInfoIntf;
|
|
published
|
|
property Name: string read GetDisplayName write fDummyName;
|
|
property Message: TROMessage read fMessage write SetMessage;
|
|
property Enabled: boolean read fEnabled write fEnabled;
|
|
end;
|
|
|
|
TROMessageDispatcherClass = class of TROMessageDispatcher;
|
|
|
|
{ TROMessageDispatchers }
|
|
|
|
TROMessageDispatchers = class(TCollection)
|
|
private
|
|
fServer: TROServer;
|
|
|
|
function GetDispatcher(Index: integer): TROMessageDispatcher;
|
|
|
|
protected
|
|
function GetSupportsMultipleDispatchers: boolean; virtual;
|
|
function GetDispatcherClass: TROMessageDispatcherClass; virtual;
|
|
{$IFDEF DELPHI6UP}
|
|
procedure Notify(Item: TCollectionItem; Action: TCollectionNotification); override;
|
|
{$ENDIF DELPHI6UP}
|
|
property Server:TROServer read fServer;
|
|
|
|
public
|
|
constructor Create(aServer: TROServer); virtual;
|
|
destructor Destroy; override;
|
|
|
|
procedure CleanReferences(aMessage: TROMessage);
|
|
function FindDuplicate(aMessage: TROMessage): TROMessageDispatcher;
|
|
function FindDispatcher(const aTransport: IROTransport; aRequestStream: TStream): TROMessageDispatcher;
|
|
|
|
function DispatcherByName(const aName: string): TROMessageDispatcher;
|
|
|
|
property Dispatchers[Index: integer]: TROMessageDispatcher read GetDispatcher; default;
|
|
property SupportsMultipleDispatchers: boolean read GetSupportsMultipleDispatchers;
|
|
end;
|
|
|
|
TROMessageDispatchersClass = class of TROMessageDispatchers;
|
|
|
|
{ TROServer }
|
|
TROGetRODLReader = procedure (Sender: TROServer; var aRODLReader: TROCustomRODLReader) of object;
|
|
|
|
{$IFDEF REMOBJECTS_UseEncryption}
|
|
TROServer = class(TROBaseConnection)
|
|
{$ELSE}
|
|
TROServer = class(TROComponent)
|
|
{$ENDIF}
|
|
private
|
|
fDoneAfterLoad,
|
|
fLoadActive: boolean;
|
|
|
|
fOnAfterServerDeactivate: TNotifyEvent;
|
|
fOnAfterServerActivate: TNotifyEvent;
|
|
fOnBeforeServerDeactivate: TNotifyEvent;
|
|
fOnBeforeServerActivate: TNotifyEvent;
|
|
fDispatchers: TROMessageDispatchers;
|
|
fOnReadFromStream: TStreamOperation;
|
|
fOnWriteToStream: TStreamOperation;
|
|
FOnGetRODLReader: TROGetRODLReader;
|
|
//fAsyncResponseStorage: TROAsyncResponseStorage;
|
|
|
|
function GetActive: boolean;
|
|
procedure SetActive(const Value: boolean);
|
|
procedure SetDispatchers(const Value: TROMessageDispatchers);
|
|
//procedure SetAsyncResponseStorage(const Value:TROAsyncResponseStorage);
|
|
|
|
private
|
|
procedure TriggerReadFromStream(iStream: TStream);
|
|
procedure TriggerWriteToStream(iStream: TStream);
|
|
|
|
protected
|
|
{ Internals }
|
|
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
|
|
|
|
procedure IntSetActive(const Value: boolean); virtual; abstract;
|
|
function IntGetActive: boolean; virtual; abstract;
|
|
|
|
procedure Loaded; override;
|
|
|
|
function GetDispatchersClass: TROMessageDispatchersClass; virtual;
|
|
|
|
function DispatchMessage(const aTransport: IROTransport; aRequeststream, aResponsestream: TStream): boolean; overload;
|
|
function DispatchMessage(const aTransport: IROTransport; aRequeststream, aResponsestream: TStream; out oResponseOptions: TROResponseOptions): boolean; overload;
|
|
|
|
function IntDispatchMessage(Dispatcher: TROMessageDispatcher; const aTransport: IROTransport; aRequeststream, aResponsestream: TStream; out oResponseOptions: TROResponseOptions): boolean;
|
|
property OnGetRODLReader: TROGetRODLReader read FOnGetRODLReader write FOnGetRODLReader;
|
|
function GetRODLReader: TROCustomRODLReader;
|
|
public
|
|
constructor Create(aOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
procedure CheckProperties; virtual;
|
|
published
|
|
property Active: boolean read GetActive write SetActive default false;
|
|
//property AsyncResponseStorage:TROAsyncResponseStorage read fAsyncResponseStorage write SetAsyncResponseStorage;
|
|
|
|
property Dispatchers: TROMessageDispatchers read fDispatchers write SetDispatchers;
|
|
|
|
property OnBeforeServerActivate: TNotifyEvent read fOnBeforeServerActivate write fOnBeforeServerActivate;
|
|
property OnAfterServerActivate: TNotifyEvent read fOnAfterServerActivate write fOnAfterServerActivate;
|
|
property OnBeforeServerDeactivate: TNotifyEvent read fOnBeforeServerDeactivate write fOnBeforeServerDeactivate;
|
|
property OnAfterServerDeactivate: TNotifyEvent read fOnAfterServerDeactivate write fOnAfterServerDeactivate;
|
|
property OnWriteToStream: TStreamOperation read fOnWriteToStream write fOnWriteToStream;
|
|
property OnReadFromStream: TStreamOperation read fOnReadFromStream write fOnReadFromStream;
|
|
end;
|
|
|
|
TROServerClass = class of TROServer;
|
|
|
|
TROClassFactory = class(TInterfacedObject, IROClassFactory)
|
|
private
|
|
fCreatorFunc: TRORemotableCreatorFunc;
|
|
fInterfaceName: string;
|
|
fInvoker: IROInvoker;
|
|
fInvokerClass: TROInvokerClass;
|
|
|
|
protected
|
|
{ IROClassFactory }
|
|
procedure CreateInstance(const aClientID: TGUID; out anInstance: IInterface); virtual;
|
|
procedure ReleaseInstance(const aClientID: TGUID; var anInstance: IInterface); virtual;
|
|
|
|
{procedure ActivateInstance(const aClientID:TGUID; const anInstance:IInterface);
|
|
procedure DeactivateInstance(const aClientID:TGUID; const anInstance:IInterface);}
|
|
|
|
function GetInterfaceName: string;
|
|
function GetInvoker: IROInvoker;
|
|
|
|
property CreatorFunc: TRORemotableCreatorFunc read fCreatorFunc;
|
|
|
|
public
|
|
constructor Create(const anInterfaceName: string;
|
|
aCreatorFunc: TRORemotableCreatorFunc;
|
|
anInvokerClass: TROInvokerClass);
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
EROSendNoResponse = class(EROException);
|
|
|
|
procedure ROSendNoResponse;
|
|
|
|
function MainProcessMessage(
|
|
const aMessage: IROMessage;
|
|
const aTransport: IROTransport;
|
|
aRequestStream,
|
|
aResponseStream: TStream;
|
|
out oResponseOptions: TROResponseOptions): boolean;
|
|
|
|
procedure RegisterClassFactory(const aClassFactory: IROClassFactory);
|
|
procedure UnRegisterClassFactory(const aClassFactory: IROClassFactory);
|
|
function GetClassFactory(const anInterfaceName: string): IROClassFactory;
|
|
function FindClassFactory(const anInterfaceName: string): IROClassFactory; {$IFDEF VER140UP} deprecated; {$ENDIF} // Please use GetClassFactory. mh.
|
|
function TryFindClassFactory(const anInterfaceName: string): IROClassFactory;
|
|
function IsClassFactoryRegistered(const anInterfaceName: string):boolean;
|
|
function GetClassFactoryNames:IROStrings;
|
|
|
|
procedure RegisterServerClass(aROMessageClass: TROServerClass);
|
|
procedure UnregisterServerClass(aROMessageClass: TROServerClass);
|
|
function GetServerClass(Index: integer): TROServerClass;
|
|
function GetServerClassCount: integer;
|
|
|
|
implementation
|
|
|
|
uses
|
|
Contnrs;
|
|
|
|
procedure ROSendNoResponse;
|
|
begin
|
|
{
|
|
NOTE
|
|
|
|
This exception is expected to be raised if you use the ROSendNoResponse
|
|
function in your asynchronous/broadcast channels. YOu can safely ignore
|
|
when the Delphi IDE breaks on this line, and you can add it to the ist
|
|
of "Silent" exceptions under Tools|Debugger Options|Language Exceptions.
|
|
}
|
|
raise EROSendNoResponse.Create('');
|
|
end;
|
|
|
|
var
|
|
_ServerClasses: TClassList;
|
|
|
|
procedure RegisterServerClass(aROMessageClass: TROServerClass);
|
|
begin
|
|
_ServerClasses.Add(aROMessageClass);
|
|
end;
|
|
|
|
procedure UnregisterServerClass(aROMessageClass: TROServerClass);
|
|
begin
|
|
_ServerClasses.Remove(aROMessageClass);
|
|
end;
|
|
|
|
function GetServerClass(Index: integer): TROServerClass;
|
|
begin
|
|
result := TROServerClass(_ServerClasses[Index]);
|
|
end;
|
|
|
|
function GetServerClassCount: integer;
|
|
begin
|
|
result := _ServerClasses.Count
|
|
end;
|
|
|
|
type
|
|
TROClassFactoryList = class(TInterfaceList)
|
|
private
|
|
function GetItems(Index: integer): IROClassFactory;
|
|
protected
|
|
public
|
|
function Add(aClassFactory: IROClassFactory): integer;
|
|
function GetClassFactoryByInterfaceName(const anInterfaceName: string): IROClassFactory;
|
|
function FindClassFactoryByInterfaceName(const anInterfaceName: string): IROClassFactory;
|
|
function GetNames:IROStrings;
|
|
property Items[Index: integer]: IROClassFactory read GetItems; default;
|
|
end;
|
|
|
|
var
|
|
_ClassFactoryList: TROClassFactoryList;
|
|
|
|
function ClassFactoryList: TROClassFactoryList;
|
|
begin
|
|
if (_ClassFactoryList = nil) then _ClassFactoryList := TROClassFactoryList.Create;
|
|
result := _ClassFactoryList;
|
|
end;
|
|
|
|
function MainProcessMessage(const aMessage: IROMessage; const aTransport: IROTransport; aRequestStream, aResponseStream: TStream; out oResponseOptions: TROResponseOptions): boolean;
|
|
var
|
|
factory: IROClassFactory;
|
|
moduleinfo: IROModuleInfo;
|
|
dataformat: TDataFormat;
|
|
http: IROHTTPTransport;
|
|
begin
|
|
oResponseOptions := [];
|
|
// result := FALSE; // reenabled because of a compiler warning
|
|
|
|
try
|
|
if (aMessage = nil) then RaiseError(err_NILMessage, []);
|
|
|
|
case aRequestStream.Size of
|
|
// Metadata retrieval
|
|
MetadataRequestIDLength : begin
|
|
oResponseOptions := oResponseOptions + [roDontEncrypt];
|
|
DataFormat := 'text/xml';
|
|
if Supports(aMessage, IROModuleInfo, moduleinfo) then
|
|
moduleinfo.GetRodlInfo(aResponseStream, aTransport, dataformat)
|
|
else
|
|
RaiseError(err_InvalidRequestStream, [aRequestStream.Size]);
|
|
if supports(aTransport, IROHttpTransport, http) then
|
|
http.ContentType := dataformat;
|
|
|
|
result := TRUE;
|
|
end;
|
|
0 : begin
|
|
oResponseOptions := oResponseOptions + [roDontEncrypt];
|
|
DataFormat := 'text/xml';
|
|
if Supports(aMessage, IROModuleInfo, moduleinfo) then
|
|
moduleinfo.GetModuleInfo(aResponseStream, aTransport, dataformat)
|
|
else
|
|
RaiseError(err_InvalidRequestStream, [aRequestStream.Size]);
|
|
if supports(aTransport, IROHttpTransport, http) then
|
|
http.ContentType := dataformat;
|
|
result := TRUE;
|
|
end;
|
|
|
|
// Probing
|
|
ProbeRequestIDLength : begin
|
|
aResponseStream.Write(ProbeResponseID, ProbeResponseIDLength);
|
|
Result := TRUE;
|
|
end;
|
|
|
|
// Messages
|
|
else begin
|
|
aMessage.InitializeRead(aTransport);
|
|
aMessage.ReadFromStream(aRequestStream);
|
|
|
|
case aMessage.MessageType of
|
|
mtPoll: begin
|
|
if IsEqualGUID(aMessage.ClientID, EmptyGUID) then
|
|
raise EROServerException.Create('Poll messages may not be sent with empty Client ID.');
|
|
|
|
raise EROServerException.Create('.NET-style polling is not implemented in RO/Delphi, yet.');
|
|
end;
|
|
|
|
mtRequest, mtResponse: begin
|
|
if (aMessage.InterfaceName = '') then
|
|
RaiseError(err_UnspecifiedInterface, [])
|
|
else if (aMessage.MessageName = '') then
|
|
RaiseError(err_UnspecifiedMessage, [])
|
|
else if IsEqualGUID(aMessage.ClientID, EmptyGUID) then
|
|
aMessage.ClientID := NewGuid();
|
|
|
|
if IsEqualGUID(aMessage.ClientID, EmptyGUID) then
|
|
aMessage.ClientID := NewGuid();
|
|
|
|
factory := GetClassFactory(aMessage.InterfaceName);
|
|
result := factory.Invoker.HandleMessage(factory, aMessage, aTransport, oResponseOptions);
|
|
|
|
aMessage.WriteToStream(aResponseStream);
|
|
end;
|
|
|
|
else begin
|
|
raise EROServerException.CreateFmt('Unsupported messages type %d.', [integer(aMessage.MessageType)]);
|
|
end;
|
|
|
|
end;
|
|
|
|
end;
|
|
end;
|
|
except
|
|
on E: EROSendNoResponse do begin
|
|
result := FALSE;
|
|
oResponseOptions := oResponseOptions + [roNoResponse];
|
|
aMessage.InitializeExceptionMessage(aTransport, '', aMessage.InterfaceName, aMessage.MessageName);
|
|
aMessage.WriteException(aResponseStream, E);
|
|
end;
|
|
on E: Exception do begin
|
|
result := FALSE;
|
|
aMessage.InitializeExceptionMessage(aTransport, '', aMessage.InterfaceName, aMessage.MessageName);
|
|
aMessage.WriteException(aResponseStream, E);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function GetClassFactory(const anInterfaceName: string): IROClassFactory;
|
|
begin
|
|
result := ClassFactoryList.GetClassFactoryByInterfaceName(anInterfaceName);
|
|
end;
|
|
|
|
function FindClassFactory(const anInterfaceName: string): IROClassFactory;
|
|
begin
|
|
result := ClassFactoryList.GetClassFactoryByInterfaceName(anInterfaceName);
|
|
end;
|
|
|
|
function TryFindClassFactory(const anInterfaceName: string): IROClassFactory;
|
|
begin
|
|
result := ClassFactoryList.FindClassFactoryByInterfaceName(anInterfaceName);
|
|
end;
|
|
|
|
function IsClassFactoryRegistered(const anInterfaceName: string):boolean;
|
|
begin
|
|
result := assigned(_ClassFactoryList) and assigned(ClassFactoryList.FindClassFactoryByInterfaceName(anInterfaceName));
|
|
end;
|
|
|
|
function GetClassFactoryNames:IROStrings;
|
|
begin
|
|
result := ClassFactoryList.GetNames();
|
|
end;
|
|
|
|
procedure RegisterClassFactory(const aClassFactory: IROClassFactory);
|
|
begin
|
|
ClassFactoryList.Add(aClassFactory);
|
|
end;
|
|
|
|
procedure UnRegisterClassFactory(const aClassFactory: IROClassFactory);
|
|
begin
|
|
if assigned(_ClassFactoryList) then
|
|
_ClassFactoryList.Remove(aClassFactory);
|
|
end;
|
|
|
|
{ TROClassFactoryList }
|
|
|
|
function TROClassFactoryList.Add(aClassFactory: IROClassFactory): integer;
|
|
begin
|
|
{ ToDo: make sure no other class factopry is registered yet, that serves
|
|
the same class name
|
|
http://www.remobjects.com/bugdb?bug=E14CD985-B996-45A3-B480-7C22F09093F5 }
|
|
|
|
result := inherited Add(aClassFactory);
|
|
end;
|
|
|
|
function TROClassFactoryList.GetClassFactoryByInterfaceName(const anInterfaceName: string): IROClassFactory;
|
|
begin
|
|
result := FindClassFactoryByInterfaceName(anInterfaceName);
|
|
if not Assigned(result) then RaiseError(err_ClassFactoryNotFound, [anInterfaceName]);
|
|
end;
|
|
|
|
function TROClassFactoryList.FindClassFactoryByInterfaceName(const anInterfaceName: string): IROClassFactory;
|
|
var
|
|
i:integer;
|
|
begin
|
|
result := nil;
|
|
for i := 0 to (Count - 1) do
|
|
if (CompareText(anInterfaceName, Items[i].GetInterfaceName) = 0) then begin
|
|
result := Items[i];
|
|
Break;
|
|
end;
|
|
end;
|
|
|
|
function TROClassFactoryList.GetItems(Index: integer): IROClassFactory;
|
|
begin
|
|
result := inherited Items[Index] as IROClassFactory
|
|
end;
|
|
|
|
function TROClassFactoryList.GetNames: IROStrings;
|
|
var
|
|
i:integer;
|
|
begin
|
|
result := NewROStrings();
|
|
for i := 0 to Count-1 do begin
|
|
Result.Add(Items[i].InterfaceName)
|
|
end;
|
|
end;
|
|
|
|
{ TROInvoker }
|
|
|
|
constructor TROInvoker.Create;
|
|
begin
|
|
inherited Create;
|
|
end;
|
|
|
|
procedure TROInvoker.BeforeInvoke(aMethodPtr: TMessageInvokeMethod;
|
|
const anInstance: IInterface;
|
|
const aFactory: IROClassFactory;
|
|
const aMessage: IROMessage;
|
|
const aTransport: IROTransport);
|
|
var
|
|
dispnotifier: IRODispatchNotifier;
|
|
objactivation: IROObjectActivation;
|
|
streamaccess : IROStreamAccess;
|
|
currpos : integer;
|
|
begin
|
|
streamaccess := NIL;
|
|
currpos := -1; // introduced for a compiler warning...
|
|
|
|
if Supports(aMessage, IROStreamAccess, streamaccess)
|
|
then currpos := streamaccess.Stream.Position;
|
|
|
|
// This can be enanched by descendants
|
|
if Supports(anInstance, IROObjectActivation, objactivation) then begin
|
|
objactivation.OnActivate(aMessage.ClientID, aMessage);
|
|
if (streamaccess<>NIL)
|
|
then streamaccess.Stream.Position := currpos;
|
|
end;
|
|
|
|
if Supports(anInstance, IRODispatchNotifier, dispnotifier) then begin
|
|
dispnotifier.GetDispatchInfo(aTransport, aMessage);
|
|
if (streamaccess<>NIL)
|
|
then streamaccess.Stream.Position := currpos;
|
|
end;
|
|
end;
|
|
|
|
procedure TROInvoker.AfterInvoke(aMethodPtr: TMessageInvokeMethod;
|
|
const anInstance: IInterface;
|
|
const aFactory: IROClassFactory;
|
|
const aMessage: IROMessage;
|
|
const aTransport: IROTransport;
|
|
anException: Exception);
|
|
var
|
|
objactivation: IROObjectActivation;
|
|
begin
|
|
if Supports(anInstance, IROObjectActivation, objactivation) then begin
|
|
objactivation.OnDeactivate(aMessage.ClientID);
|
|
end;
|
|
end;
|
|
|
|
function TROInvoker.CustomHandleMessage(const aFactory: IROClassFactory;
|
|
const aMessage: IROMessage;
|
|
const aTransport: IROTransport;
|
|
out oResponseOptions: TROResponseOptions): boolean;
|
|
var
|
|
mtd: TMessageInvokeMethod;
|
|
instance: IInterface;
|
|
begin
|
|
result := FALSE;
|
|
|
|
mtd := nil;
|
|
instance := nil;
|
|
|
|
// The message is guaranteed not to be NIL and to have a name and an InterfaceName at this point
|
|
@mtd := MethodAddress('Invoke_' + aMessage.MessageName);
|
|
if (@mtd <> nil) then try
|
|
try
|
|
aFactory.CreateInstance(aMessage.ClientID, instance);
|
|
|
|
if (instance = nil) then RaiseError(err_ClassFactoryDidNotReturnInstance, [aMessage.InterfaceName]);
|
|
|
|
BeforeInvoke(mtd, instance, aFactory, aMessage, aTransport);
|
|
mtd(instance, aMessage, aTransport, oResponseOptions);
|
|
AfterInvoke(mtd, instance, aFactory, aMessage, aTransport, nil);
|
|
|
|
result := TRUE;
|
|
except
|
|
on E: Exception do begin
|
|
AfterInvoke(mtd, instance, aFactory, aMessage, aTransport, E);
|
|
raise;
|
|
end;
|
|
end;
|
|
finally
|
|
if (instance <> nil) then aFactory.ReleaseInstance(aMessage.ClientID, instance);
|
|
end
|
|
else
|
|
RaiseError(err_UnknownMethod, [aMessage.MessageName, aFactory.InterfaceName]);
|
|
end;
|
|
|
|
destructor TROInvoker.Destroy;
|
|
begin
|
|
inherited;
|
|
end;
|
|
|
|
function TROInvoker.HandleMessage(const aFactory: IROClassFactory;
|
|
const aMessage: IROMessage;
|
|
const aTransport: IROTransport;
|
|
out oResponseOptions: TROResponseOptions): boolean;
|
|
begin
|
|
result := CustomHandleMessage(aFactory, aMessage, aTransport, oResponseOptions);
|
|
end;
|
|
|
|
procedure TROInvoker.Invoke_RegisterEventClient(const __Instance:IInterface; const __Message:IROMessage; const __Transport:IROTransport; out __oResponseOptions:TROResponseOptions);
|
|
{ procedure RegisterEventClient(const ClientID: String; const EventTypes: String); }
|
|
var
|
|
ClientID: String;
|
|
EventTypes: String;
|
|
begin
|
|
try
|
|
__Message.Read('ClientID', TypeInfo(String), ClientID, []);
|
|
__Message.Read('EventTypes', TypeInfo(String), EventTypes, []);
|
|
|
|
(__Instance as IROServerEventsBroker).RegisterEventClient(ClientID, EventTypes);
|
|
|
|
__Message.InitializeResponseMessage(__Transport, 'ChatLibrary', 'ChatService', 'RegisterEventClientResponse');
|
|
__Message.Finalize;
|
|
|
|
__oResponseOptions := [roNoResponse];
|
|
|
|
finally
|
|
end;
|
|
end;
|
|
|
|
procedure TROInvoker.Invoke_UnregisterEventClient(const __Instance:IInterface; const __Message:IROMessage; const __Transport:IROTransport; out __oResponseOptions:TROResponseOptions);
|
|
{ procedure UnregisterEventClient(const ClientID: String; const EventTypes: String); }
|
|
var
|
|
ClientID: String;
|
|
EventTypes: String;
|
|
begin
|
|
try
|
|
__Message.Read('ClientID', TypeInfo(String), ClientID, []);
|
|
__Message.Read('EventTypes', TypeInfo(String), EventTypes, []);
|
|
|
|
(__Instance as IROServerEventsBroker).UnregisterEventClient(ClientID, EventTypes);
|
|
|
|
__Message.InitializeResponseMessage(__Transport, 'ChatLibrary', 'ChatService', 'UnregisterEventClientResponse');
|
|
__Message.Finalize;
|
|
|
|
__oResponseOptions := [roNoResponse];
|
|
|
|
finally
|
|
end;
|
|
end;
|
|
|
|
procedure TROInvoker.Invoke_GetEventsData(const __Instance:IInterface; const __Message:IROMessage; const __Transport:IROTransport; out __oResponseOptions:TROResponseOptions);
|
|
{ function GetEventsData(const ClientID: String; out EventsData: Binary): Integer; }
|
|
var
|
|
ClientID: String;
|
|
EventsData: Binary;
|
|
lResult: Integer;
|
|
begin
|
|
EventsData := nil;
|
|
try
|
|
__Message.Read('ClientID', TypeInfo(String), ClientID, []);
|
|
|
|
lResult := (__Instance as IROServerEventsBroker).GetEventsData(ClientID, EventsData);
|
|
|
|
__Message.InitializeResponseMessage(__Transport, 'ChatLibrary', 'ChatService', 'GetEventsDataResponse');
|
|
__Message.Write('Result', TypeInfo(Integer), lResult, []);
|
|
__Message.Write('EventsData', TypeInfo(Binary), EventsData, []);
|
|
__Message.Finalize;
|
|
|
|
finally
|
|
EventsData.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TROInvoker.Invoke_RegisterClient(const __Instance: IInterface;
|
|
const __Message: IROMessage; const __Transport: IROTransport;
|
|
out __oResponseOptions: TROResponseOptions);
|
|
begin
|
|
Invoke_RegisterEventClient(__Instance, __Message, __Transport, __oResponseOptions);
|
|
end;
|
|
|
|
procedure TROInvoker.Invoke_UnregisterClient(const __Instance: IInterface;
|
|
const __Message: IROMessage; const __Transport: IROTransport;
|
|
out __oResponseOptions: TROResponseOptions);
|
|
begin
|
|
Invoke_UnregisterEventClient(__Instance, __Message, __Transport, __oResponseOptions);
|
|
end;
|
|
|
|
{ TRORemotable }
|
|
|
|
constructor TRORemotable.Create;
|
|
begin
|
|
inherited;
|
|
end;
|
|
|
|
destructor TRORemotable.Destroy;
|
|
begin
|
|
FreeAndNIL(fRetainedObjects);
|
|
inherited;
|
|
end;
|
|
|
|
{$IFDEF DELPHI7UP}
|
|
|
|
procedure TRORemotable.Synchronize(aMethod: TThreadMethod);
|
|
begin
|
|
TThread.Synchronize(nil, aMethod);
|
|
end;
|
|
{$ENDIF DELPHI7UP}
|
|
|
|
function TRORemotable.IsRetained(const anObject: TObject): boolean;
|
|
begin
|
|
result := (fRetainedObjects<>NIL) and (fRetainedObjects.IndexOf(anObject)>=0)
|
|
end;
|
|
|
|
procedure TRORemotable.RetainObject(const anObject: TObject);
|
|
begin
|
|
// Only creates it if necessary
|
|
if (fRetainedObjects=NIL) then
|
|
fRetainedObjects := TList.Create;
|
|
|
|
fRetainedObjects.Add(anObject);
|
|
end;
|
|
|
|
procedure TRORemotable.ReleaseObject(const anObject: TObject);
|
|
var idx : integer;
|
|
begin
|
|
// Only creates it if necessary
|
|
if (fRetainedObjects=NIL) then Exit;
|
|
|
|
idx := fRetainedObjects.IndexOf(anObject);
|
|
if (idx>=0) then fRetainedObjects.Delete(idx);
|
|
end;
|
|
|
|
{ TROMessageDispatcher }
|
|
|
|
constructor TROMessageDispatcher.Create(aCollection: TCollection);
|
|
begin
|
|
inherited Create(aCollection);
|
|
|
|
fEnabled := TRUE;
|
|
fDispatchers := TROMessageDispatchers(aCollection);
|
|
fModuleInfoIntf := nil;
|
|
fMessageIntf := nil;
|
|
end;
|
|
|
|
destructor TROMessageDispatcher.Destroy;
|
|
begin
|
|
fModuleInfoIntf := nil;
|
|
fMessageIntf := nil;
|
|
Message := nil;
|
|
inherited;
|
|
end;
|
|
|
|
function TROMessageDispatcher.ProcessMessage(const aTransport: IROTransport; aRequeststream, aResponsestream: TStream; out oResponseOptions: TROResponseOptions): boolean;
|
|
var
|
|
lMessage: IROMessage;
|
|
begin
|
|
lMessage := (MessageIntf as IROMessageCloneable).Clone();
|
|
result := MainProcessMessage(lMessage, aTransport, aRequeststream, aResponsestream, oResponseOptions);
|
|
end;
|
|
|
|
function TROMessageDispatcher.GetDisplayName: string;
|
|
begin
|
|
if (fMessage = nil) then
|
|
result := '[Unassigned]'
|
|
else
|
|
result := fMessage.Name;
|
|
end;
|
|
|
|
function TROMessageDispatcher.GetMessageIntf: IROMessage;
|
|
begin
|
|
result := IROMessage(fMessageIntf);
|
|
end;
|
|
|
|
function TROMessageDispatcher.GetModuleInfoIntf: IROModuleInfo;
|
|
begin
|
|
result := IROModuleInfo(fModuleInfoIntf)
|
|
end;
|
|
|
|
procedure TROMessageDispatcher.SetMessage(const Value: TROMessage);
|
|
var
|
|
ref: IROMessage;
|
|
begin
|
|
if (Value = fMessage) then Exit;
|
|
|
|
if (Value <> nil) then begin
|
|
if (fDispatchers.FindDuplicate(Value) <> nil) then RaiseError(err_DispatcherAlreadyAssigned, [Value.Name]);
|
|
if not Value.GetInterface(IROMessage, ref) then RaiseError(err_IROMessageNotSupported, [Value.ClassName]);
|
|
|
|
fMessageIntf := pointer(ref);
|
|
Value.GetInterface(IROModuleInfo, fModuleInfoIntf);
|
|
Value.FreeNotification(Server);
|
|
|
|
end
|
|
else begin
|
|
fMessageIntf := nil;
|
|
fModuleInfoIntf := nil;
|
|
end;
|
|
|
|
fMessage := Value;
|
|
end;
|
|
|
|
function TROMessageDispatcher.CanHandleMessage(const aTransport: IROTransport; aRequeststream: TStream): boolean;
|
|
begin
|
|
result := fEnabled;
|
|
end;
|
|
|
|
procedure TROMessageDispatcher.Assign(Source: TPersistent);
|
|
var
|
|
SourceDispatcher: TROMessageDispatcher;
|
|
begin
|
|
if Source is TROMessageDispatcher then begin
|
|
SourceDispatcher := TROMessageDispatcher(Source);
|
|
Name := SourceDispatcher.Name;
|
|
Message := SourceDispatcher.Message;
|
|
Enabled := SourceDispatcher.Enabled;
|
|
end
|
|
else
|
|
inherited Assign(Source);
|
|
end;
|
|
|
|
function TROMessageDispatcher.GetServer: TROServer;
|
|
begin
|
|
result := fDispatchers.Server;
|
|
end;
|
|
|
|
{ TROMessageDispatchers }
|
|
|
|
procedure TROMessageDispatchers.CleanReferences(aMessage: TROMessage);
|
|
var
|
|
i: integer;
|
|
begin
|
|
for i := 0 to (Count - 1) do
|
|
if (Dispatchers[i].Message = aMessage) then begin
|
|
Dispatchers[i].Message := nil;
|
|
end;
|
|
end;
|
|
|
|
constructor TROMessageDispatchers.Create(aServer: TROServer);
|
|
begin
|
|
inherited Create(GetDispatcherClass);
|
|
fServer := aServer;
|
|
end;
|
|
|
|
destructor TROMessageDispatchers.Destroy;
|
|
begin
|
|
inherited;
|
|
end;
|
|
|
|
function TROMessageDispatchers.FindDispatcher(const aTransport: IROTransport;
|
|
aRequestStream: TStream): TROMessageDispatcher;
|
|
var
|
|
i: integer;
|
|
begin
|
|
result := nil;
|
|
|
|
for i := 0 to (Count - 1) do
|
|
if Dispatchers[i].CanHandleMessage(aTransport, aRequestStream) then begin
|
|
result := Dispatchers[i];
|
|
Break;
|
|
end;
|
|
end;
|
|
|
|
function TROMessageDispatchers.DispatcherByName(
|
|
const aName: string): TROMessageDispatcher;
|
|
var
|
|
i: integer;
|
|
begin
|
|
result := nil;
|
|
for i := 0 to (Count - 1) do
|
|
if (CompareText(Dispatchers[i].Name, aName) = 0) then begin
|
|
result := Dispatchers[i];
|
|
Exit;
|
|
end;
|
|
end;
|
|
|
|
function TROMessageDispatchers.FindDuplicate(
|
|
aMessage: TROMessage): TROMessageDispatcher;
|
|
var
|
|
i: integer;
|
|
begin
|
|
result := nil;
|
|
|
|
for i := 0 to (Count - 1) do
|
|
if (Dispatchers[i].Message = aMessage) then begin
|
|
result := Dispatchers[i];
|
|
Exit;
|
|
end;
|
|
end;
|
|
|
|
function TROMessageDispatchers.GetDispatcher(
|
|
Index: integer): TROMessageDispatcher;
|
|
begin
|
|
result := TROMessageDispatcher(inherited Items[Index]);
|
|
end;
|
|
|
|
function TROMessageDispatchers.GetDispatcherClass: TROMessageDispatcherClass;
|
|
begin
|
|
result := TROMessageDispatcher;
|
|
end;
|
|
|
|
function TROMessageDispatchers.GetSupportsMultipleDispatchers: boolean;
|
|
begin
|
|
result := FALSE;
|
|
end;
|
|
|
|
{$IFDEF DELPHI6UP}
|
|
|
|
procedure TROMessageDispatchers.Notify(Item: TCollectionItem;
|
|
Action: TCollectionNotification);
|
|
begin
|
|
inherited;
|
|
if (Action = cnAdded) then begin
|
|
if not SupportsMultipleDispatchers and (Count > 1) then begin
|
|
|
|
(*if (csDesigning in fServer.ComponentState) then begin
|
|
{ TODO: This is really bad. I should probabily just make a component editor and control it in there.
|
|
The problem is that I cannot find a way to stop a TCollection.Add method gracefully.
|
|
After this method is called TCollection.InsertItem continues and invokes NotifyDesigner
|
|
passing Item. That will obviously fail since Item is being freed here... }
|
|
MessageDlg(Format(err_ServerOnlySupportsOneDispatcher+'.'+#13#10+
|
|
'You can ignore the error that Delphi will raise in the IDE after you close this dialog.', [fServer.ClassName]), mtError, [mbOK], 0);
|
|
end;*)
|
|
|
|
FreeAndNIL(Item);
|
|
RaiseError(err_ServerOnlySupportsOneDispatcher, [])
|
|
end;
|
|
end;
|
|
end;
|
|
{$ENDIF DELPHI6UP}
|
|
|
|
{ TROServer }
|
|
|
|
constructor TROServer.Create(aOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
fDispatchers := GetDispatchersClass.Create(Self);
|
|
end;
|
|
|
|
destructor TROServer.Destroy;
|
|
begin
|
|
fDispatchers.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TROServer.TriggerReadFromStream(iStream: TStream);
|
|
begin
|
|
if Assigned(OnReadFromStream) then begin
|
|
iStream.Position := 0;
|
|
OnReadFromStream(iStream);
|
|
iStream.Position := 0;
|
|
end;
|
|
end;
|
|
|
|
procedure TROServer.TriggerWriteToStream(iStream: TStream);
|
|
begin
|
|
if Assigned(OnWriteToStream) then begin
|
|
iStream.Position := 0;
|
|
OnWriteToStream(iStream);
|
|
iStream.Position := 0;
|
|
end;
|
|
end;
|
|
|
|
function TROServer.DispatchMessage(const aTransport: IROTransport; aRequeststream, aResponsestream: TStream): boolean;
|
|
var
|
|
lIgnore: TROResponseOptions;
|
|
begin
|
|
result := DispatchMessage(aTransport, aRequeststream, aResponsestream, lIgnore);
|
|
end;
|
|
|
|
function TROServer.DispatchMessage(const aTransport: IROTransport; aRequeststream, aResponsestream: TStream; out oResponseOptions: TROResponseOptions): boolean;
|
|
var
|
|
dispatcher: TROMessageDispatcher;
|
|
excstr: string;
|
|
begin
|
|
result := false;
|
|
try
|
|
{aRequeststream.Position := 0;
|
|
if Assigned(OnReadFromStream) then OnReadFromStream(aRequeststream);
|
|
aRequeststream.Position := 0;}
|
|
|
|
dispatcher := Dispatchers.FindDispatcher(aTransport, aRequeststream);
|
|
|
|
if (dispatcher = nil) then RaiseError(err_CannotFindMessageDispatcher, []); // Should never happen! If this happens there's no way to format the exception correctly
|
|
|
|
result := IntDispatchMessage(dispatcher, aTransport, aRequeststream, aResponsestream, oResponseOptions);
|
|
|
|
except
|
|
on E: Exception do begin
|
|
if (E.Message <> '') then
|
|
excstr := E.Message
|
|
else
|
|
excstr := err_UnhandledException;
|
|
aResponseStream.Write(excstr[1], Length(excstr));
|
|
TriggerWriteToStream(aResponsestream);
|
|
end;
|
|
end;
|
|
|
|
aResponsestream.Position := 0; // Just in case
|
|
{aResponsestream.Position := 0;
|
|
if Assigned(OnWriteToStream) then OnWriteToStream(aResponsestream);
|
|
aResponsestream.Position := 0;}
|
|
end;
|
|
|
|
function TROServer.GetActive: boolean;
|
|
begin
|
|
result := IntGetActive;
|
|
end;
|
|
|
|
procedure TROServer.Loaded;
|
|
begin
|
|
inherited;
|
|
|
|
IntSetActive(FALSE);
|
|
Active := fLoadActive;
|
|
fDoneAfterLoad := TRUE;
|
|
end;
|
|
|
|
procedure TROServer.Notification(AComponent: TComponent;
|
|
Operation: TOperation);
|
|
begin
|
|
inherited;
|
|
|
|
if (Operation = opRemove) then begin
|
|
if (aComponent is TROMessage) then fDispatchers.CleanReferences(TROMessage(aComponent));
|
|
//if aComponent = AsyncResponseStorage then AsyncResponseStorage := nil;
|
|
end;
|
|
end;
|
|
|
|
procedure TROServer.SetActive(const Value: boolean);
|
|
begin
|
|
if (csLoading in ComponentState) then begin
|
|
fDoneAfterLoad := FALSE;
|
|
fLoadActive := Value
|
|
end
|
|
|
|
else begin
|
|
if (Value = Active) then Exit;
|
|
|
|
case Value of
|
|
TRUE: if Assigned(fOnBeforeServerActivate) then fOnBeforeServerActivate(Self);
|
|
FALSE: if Assigned(fOnBeforeServerDeactivate) then fOnBeforeServerDeactivate(Self);
|
|
end;
|
|
|
|
IntSetActive(Value);
|
|
|
|
if (Value = Active) then begin
|
|
case Value of
|
|
TRUE: if Assigned(fOnAfterServerActivate) then fOnAfterServerActivate(Self);
|
|
FALSE: if Assigned(fOnAfterServerDeactivate) then fOnAfterServerDeactivate(Self);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TROServer.SetDispatchers(const Value: TROMessageDispatchers);
|
|
begin
|
|
fDispatchers := Value;
|
|
end;
|
|
|
|
function TROServer.GetDispatchersClass: TROMessageDispatchersClass;
|
|
begin
|
|
result := TROMessageDispatchers; // Default
|
|
end;
|
|
|
|
{procedure TROServer.SetAsyncResponseStorage(const Value:TROAsyncResponseStorage);
|
|
begin
|
|
if fAsyncResponseStorage <> Value then begin
|
|
fAsyncResponseStorage := Value;
|
|
if Assigned(fAsyncResponseStorage) then fAsyncResponseStorage.FreeNotification(self);
|
|
end;
|
|
end;}
|
|
|
|
function TROServer.IntDispatchMessage(Dispatcher: TROMessageDispatcher;
|
|
const aTransport: IROTransport; aRequeststream, aResponsestream: TStream;
|
|
out oResponseOptions: TROResponseOptions): boolean;
|
|
{$IFDEF REMOBJECTS_UseEncryption}
|
|
var
|
|
DEncRequest, DUnEncResponse: TMemoryStream;
|
|
{$ENDIF}
|
|
begin
|
|
{$IFDEF REMOBJECTS_UseEncryption}
|
|
if Encryption.EncryptionMethod <> tetNone then begin
|
|
dEncRequest := TMemoryStream.Create;
|
|
dUnEncResponse := TMemoryStream.Create;
|
|
try
|
|
DoDecryption(aRequeststream, dEncRequest);
|
|
DEncRequest.Position := 0;
|
|
TriggerReadFromStream(dEncRequest);
|
|
result := dispatcher.ProcessMessage(aTransport, dEncRequest, dUnEncResponse, oResponseOptions); // This traps exception and cannot fail
|
|
TriggerWriteToStream(dUnEncResponse);
|
|
if roDontEncrypt in oResponseOptions then
|
|
begin
|
|
DUnEncResponse.Position := 0;
|
|
aResponsestream.CopyFrom(DUnEncResponse, DUnEncResponse.Size);
|
|
aResponsestream.Position := 0;
|
|
end else
|
|
DoEncryption(dUnEncResponse, aResponsestream);
|
|
finally
|
|
dEncRequest.Free;
|
|
dUnEncResponse.free;
|
|
end;
|
|
end
|
|
else
|
|
{$ENDIF}
|
|
begin
|
|
TriggerReadFromStream(aRequeststream);
|
|
result := dispatcher.ProcessMessage(aTransport, aRequeststream, aResponsestream, oResponseOptions); // This traps exception and cannot fail
|
|
TriggerWriteToStream(aResponsestream);
|
|
end;
|
|
end;
|
|
|
|
procedure TROServer.CheckProperties;
|
|
begin
|
|
// nothing
|
|
end;
|
|
|
|
function TROServer.GetRODLReader: TROCustomRODLReader;
|
|
begin
|
|
Result:=nil;
|
|
if Assigned(FOnGetRODLReader) then FOnGetRODLReader(Self,Result);
|
|
end;
|
|
|
|
{ TROClassFactory }
|
|
|
|
constructor TROClassFactory.Create(const anInterfaceName: string;
|
|
aCreatorFunc: TRORemotableCreatorFunc;
|
|
anInvokerClass: TROInvokerClass);
|
|
begin
|
|
inherited Create;
|
|
|
|
fInvoker := nil;
|
|
fCreatorFunc := aCreatorFunc;
|
|
fInterfaceName := anInterfaceName;
|
|
fInvokerClass := anInvokerClass;
|
|
|
|
RegisterClassFactory(Self);
|
|
end;
|
|
|
|
destructor TROClassFactory.Destroy;
|
|
begin
|
|
inherited;
|
|
end;
|
|
|
|
procedure TROClassFactory.CreateInstance(const aClientID: TGUID; out anInstance: IInterface);
|
|
begin
|
|
fCreatorFunc(anInstance);
|
|
end;
|
|
|
|
function TROClassFactory.GetInterfaceName: string;
|
|
begin
|
|
result := fInterfaceName
|
|
end;
|
|
|
|
function TROClassFactory.GetInvoker: IROInvoker;
|
|
begin
|
|
if (fInvoker = nil) then fInvoker := fInvokerClass.Create; // Only creates it when really needed
|
|
|
|
result := fInvoker;
|
|
end;
|
|
|
|
procedure TROClassFactory.ReleaseInstance(const aClientID: TGUID; var anInstance: IInterface);
|
|
begin
|
|
anInstance := nil;
|
|
end;
|
|
|
|
function FinalizeClasses: boolean;
|
|
begin
|
|
FreeAndNil(_ClassFactoryList);
|
|
result := True;
|
|
end;
|
|
|
|
initialization
|
|
_ServerClasses := TClassList.Create;
|
|
_ClassFactoryList := nil;
|
|
{$IFNDEF DESIGNTIME}
|
|
AddTerminateProc(FinalizeClasses);
|
|
{$ENDIF DESIGNTIME}
|
|
RegisterExceptionClass(EROSendNoResponse);
|
|
finalization
|
|
UnregisterExceptionClass(EROSendNoResponse);
|
|
FreeAndNil(_ServerClasses);
|
|
{$IFDEF DESIGNTIME}
|
|
FinalizeClasses();
|
|
{$ENDIF DESIGNTIME}
|
|
end.
|
|
|