1140 lines
34 KiB
ObjectPascal
1140 lines
34 KiB
ObjectPascal
|
unit uROPSServerLink;
|
||
|
|
|
||
|
|
interface
|
||
|
|
uses
|
||
|
|
SysUtils, Classes, uPSCompiler, uPSUtils, uPSRuntime,
|
||
|
|
uROServer, uROClient, uRODL{$IFDEF WIN32},
|
||
|
|
Windows{$ELSE}, Types{$ENDIF}, uROTypes, uROClientIntf,
|
||
|
|
uROSerializer, uPSComponent;
|
||
|
|
|
||
|
|
type
|
||
|
|
|
||
|
|
TPSROModule = class
|
||
|
|
protected
|
||
|
|
class procedure ExecImp(exec: TPSExec; ri: TPSRuntimeClassImporter); virtual;
|
||
|
|
class procedure CompImp(comp: TPSPascalCompiler); virtual;
|
||
|
|
end;
|
||
|
|
TPSROModuleClass = class of TPSROModule;
|
||
|
|
TPSRemObjectsSdkPlugin = class;
|
||
|
|
TPSROModuleLoadEvent = procedure (Sender: TPSRemObjectsSdkPlugin) of object;
|
||
|
|
|
||
|
|
TPSRemObjectsSdkPlugin = class(TPSPlugin)
|
||
|
|
private
|
||
|
|
FRodl: TRODLLibrary;
|
||
|
|
FModules: TList;
|
||
|
|
FOnLoadModule: TPSROModuleLoadEvent;
|
||
|
|
|
||
|
|
FEnableIndyTCP: Boolean;
|
||
|
|
FEnableIndyHTTP: Boolean;
|
||
|
|
FEnableBinary: Boolean;
|
||
|
|
function GetHaveRodl: Boolean;
|
||
|
|
function MkStructName(Struct: TRODLStruct): string;
|
||
|
|
protected
|
||
|
|
procedure CompileImport1(CompExec: TPSScript); override;
|
||
|
|
procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
|
||
|
|
procedure Loaded; override;
|
||
|
|
public
|
||
|
|
|
||
|
|
procedure RODLLoadFromFile(const FileName: string);
|
||
|
|
|
||
|
|
procedure RODLLoadFromResource;
|
||
|
|
|
||
|
|
procedure RODLLoadFromStream(S: TStream);
|
||
|
|
|
||
|
|
procedure ClearRodl;
|
||
|
|
|
||
|
|
property HaveRodl: Boolean read GetHaveRodl;
|
||
|
|
|
||
|
|
constructor Create(AOwner: TComponent); override;
|
||
|
|
|
||
|
|
destructor Destroy; override;
|
||
|
|
|
||
|
|
|
||
|
|
procedure ReloadModules;
|
||
|
|
|
||
|
|
procedure RegisterModule(Module: TPSROModuleClass);
|
||
|
|
published
|
||
|
|
property OnLoadModule: TPSROModuleLoadEvent read FOnLoadModule write FOnLoadModule;
|
||
|
|
|
||
|
|
property EnableIndyTCP: Boolean read FEnableIndyTCP write FEnableIndyTCP default true;
|
||
|
|
|
||
|
|
property EnableIndyHTTP: Boolean read FEnableIndyHTTP write FEnableIndyHTTP default true;
|
||
|
|
|
||
|
|
property EnableBinary: Boolean read FEnableBinary write FEnableBinary default true;
|
||
|
|
end;
|
||
|
|
|
||
|
|
implementation
|
||
|
|
uses
|
||
|
|
uRODLToXML, uROPSImports;
|
||
|
|
|
||
|
|
procedure SIRegisterTROTRANSPORTCHANNEL(CL: TPSPascalCompiler);
|
||
|
|
Begin
|
||
|
|
With cl.AddClassN(cl.FindClass('TComponent'), 'TROTRANSPORTCHANNEL') do
|
||
|
|
begin
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure SIRegisterTROMESSAGE(CL: TPSPascalCompiler);
|
||
|
|
Begin
|
||
|
|
With cl.AddClassN(cl.FindClass('TComponent'),'TROMESSAGE') do
|
||
|
|
begin
|
||
|
|
RegisterProperty('MESSAGENAME', 'STRING', iptrw);
|
||
|
|
RegisterProperty('INTERFACENAME', 'STRING', iptrw);
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure TROMESSAGEINTERFACENAME_W(Self: TROMESSAGE; const T: STRING);
|
||
|
|
begin Self.INTERFACENAME := T; end;
|
||
|
|
|
||
|
|
procedure TROMESSAGEINTERFACENAME_R(Self: TROMESSAGE; var T: STRING);
|
||
|
|
begin T := Self.INTERFACENAME; end;
|
||
|
|
|
||
|
|
procedure TROMESSAGEMESSAGENAME_W(Self: TROMESSAGE; const T: STRING);
|
||
|
|
begin Self.MESSAGENAME := T; end;
|
||
|
|
|
||
|
|
procedure TROMESSAGEMESSAGENAME_R(Self: TROMESSAGE; var T: STRING);
|
||
|
|
begin T := Self.MESSAGENAME; end;
|
||
|
|
|
||
|
|
procedure RIRegisterTROTRANSPORTCHANNEL(Cl: TPSRuntimeClassImporter);
|
||
|
|
Begin
|
||
|
|
with Cl.Add(TROTRANSPORTCHANNEL) do
|
||
|
|
begin
|
||
|
|
RegisterVirtualConstructor(@TROTRANSPORTCHANNEL.CREATE, 'CREATE');
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure RIRegisterTROMESSAGE(Cl: TPSRuntimeClassImporter);
|
||
|
|
Begin
|
||
|
|
with Cl.Add(TROMESSAGE) do
|
||
|
|
begin
|
||
|
|
RegisterVirtualConstructor(@TROMESSAGE.CREATE, 'CREATE');
|
||
|
|
RegisterPropertyHelper(@TROMESSAGEMESSAGENAME_R,@TROMESSAGEMESSAGENAME_W,'MESSAGENAME');
|
||
|
|
RegisterPropertyHelper(@TROMESSAGEINTERFACENAME_R,@TROMESSAGEINTERFACENAME_W,'INTERFACENAME');
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
|
||
|
|
type
|
||
|
|
TRoObjectInstance = class;
|
||
|
|
{ }
|
||
|
|
IROClass = interface
|
||
|
|
['{246B5804-461F-48EC-B2CA-FBB7B69B0D64}']
|
||
|
|
function SLF: TRoObjectInstance;
|
||
|
|
end;
|
||
|
|
TRoObjectInstance = class(TInterfacedObject, IROClass)
|
||
|
|
private
|
||
|
|
FMessage: IROMessage;
|
||
|
|
FChannel: IROTransportChannel;
|
||
|
|
public
|
||
|
|
constructor Create;
|
||
|
|
function SLF: TRoObjectInstance;
|
||
|
|
property Message: IROMessage read FMessage write FMessage;
|
||
|
|
property Channel: IROTransportChannel read FChannel write FChannel;
|
||
|
|
end;
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
function CreateProc(Caller: TPSExec; p: PIFProcRec; Global, Stack: TPSStack): Boolean;
|
||
|
|
var
|
||
|
|
temp, res: TPSVariantIFC;
|
||
|
|
Chan: TROTransportChannel;
|
||
|
|
Msg: TROMessage;
|
||
|
|
NewRes: TRoObjectInstance;
|
||
|
|
begin
|
||
|
|
res := NewTPSVariantIFC(Stack[Stack.count -1], True);
|
||
|
|
if (Res.Dta = nil) or (res.aType.BaseType <> btInterface) then
|
||
|
|
begin
|
||
|
|
Caller.CMD_Err2(erCustomError, 'RO Invoker: Invalid Parameters');
|
||
|
|
Result := False;
|
||
|
|
exit;
|
||
|
|
end;
|
||
|
|
IUnknown(Res.Dta^) := nil;
|
||
|
|
|
||
|
|
NewRes := TRoObjectInstance.Create;
|
||
|
|
|
||
|
|
temp := NewTPSVariantIFC(Stack[Stack.Count -4], True);
|
||
|
|
|
||
|
|
if (temp.aType <> nil) and (temp.Dta <> nil) and (Temp.aType.BaseType = btClass) and (TObject(Temp.Dta^) is TROTransportChannel) then
|
||
|
|
Chan := TROTransportChannel(temp.dta^)
|
||
|
|
else
|
||
|
|
Chan := nil;
|
||
|
|
temp := NewTPSVariantIFC(Stack[Stack.Count -3], True);
|
||
|
|
if (temp.aType <> nil) and (temp.Dta <> nil) and (Temp.aType.BaseType = btClass) and (TObject(Temp.Dta^) is TROMessage) then
|
||
|
|
Msg := TROMessage(temp.dta^)
|
||
|
|
else
|
||
|
|
Msg := nil;
|
||
|
|
if (msg = nil) or (chan = nil) then
|
||
|
|
begin
|
||
|
|
Chan.free;
|
||
|
|
msg.Free;
|
||
|
|
|
||
|
|
NewRes.Free;
|
||
|
|
Result := false;
|
||
|
|
Caller.CMD_Err2(erCustomError, 'Could not create message');
|
||
|
|
exit;
|
||
|
|
end;
|
||
|
|
|
||
|
|
IRoClass(Res.Dta^) := NewRes;
|
||
|
|
|
||
|
|
NewRes.Message := Msg;
|
||
|
|
NewRes.Channel := Chan;
|
||
|
|
Result := True;
|
||
|
|
end;
|
||
|
|
|
||
|
|
function NilProc(Caller: TPSExec; p: PIFProcRec; Global, Stack: TPSStack): Boolean;
|
||
|
|
var
|
||
|
|
n: TPSVariantIFC;
|
||
|
|
begin
|
||
|
|
n := NewTPSVariantIFC(Stack[Stack.count -1], True);
|
||
|
|
if (n.Dta = nil) or (n.aType = nil) or (n.aType.BaseType <> btInterface) then
|
||
|
|
begin
|
||
|
|
Caller.CMD_Err2(erCustomError, 'RO Invoker: Cannot free');
|
||
|
|
Result := False;
|
||
|
|
exit;
|
||
|
|
end;
|
||
|
|
IUnknown(n.Dta^) := nil;
|
||
|
|
Result := True;
|
||
|
|
end;
|
||
|
|
|
||
|
|
type
|
||
|
|
TROStructure = class(TPersistent, IROCustomStreamableType, IROCustomStreamableStruct)
|
||
|
|
private
|
||
|
|
FVar: TPSVariantIFC;
|
||
|
|
FExec: TPSExec;
|
||
|
|
protected
|
||
|
|
function GetTypeName: string;
|
||
|
|
procedure SetTypeName(const s: string);
|
||
|
|
procedure Write(Serializer: TROSerializer; const Name: string);
|
||
|
|
procedure Read(Serializer: TROSerializer; const Name: string);
|
||
|
|
function _AddRef: Integer; stdcall;
|
||
|
|
function _Release: Integer; stdcall;
|
||
|
|
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
|
||
|
|
function CanImplementType(const aName: string):boolean;
|
||
|
|
procedure SetNull(b: Boolean);
|
||
|
|
function IsNull: Boolean;
|
||
|
|
public
|
||
|
|
constructor Create(aVar: TPSVariantIfc; Exec: TPSExec);
|
||
|
|
end;
|
||
|
|
TROArray = class(TROStructure, IROCustomStreamableType, IROCustomStreamableStruct, IROCustomStreamableArray)
|
||
|
|
protected
|
||
|
|
function GetCount: Longint;
|
||
|
|
procedure SetCount(l: Longint);
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure WriteUserDefined(Exec: TPSExec; const Msg: IROMessage; const Name: string; const n: TPSVariantIfc);
|
||
|
|
var
|
||
|
|
obj: TROStructure;
|
||
|
|
begin
|
||
|
|
if n.aType.BaseType = btArray then
|
||
|
|
obj := TROArray.Create(n, exec)
|
||
|
|
else if n.aType.BaseType = btRecord then
|
||
|
|
obj := TROStructure.Create(n, exec)
|
||
|
|
else
|
||
|
|
raise Exception.Create('Unknown custom type');
|
||
|
|
try
|
||
|
|
Msg.Write(Name, obj.ClassInfo, obj, []);
|
||
|
|
finally
|
||
|
|
obj.Free;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure ReadUserDefined(Exec: TPSExec; const Msg: IROMessage; const Name: string; const n: TPSVariantIfc);
|
||
|
|
var
|
||
|
|
obj: TROStructure;
|
||
|
|
begin
|
||
|
|
if n.aType.BaseType = btArray then
|
||
|
|
obj := TROArray.Create(n, exec)
|
||
|
|
else if n.aType.BaseType = btRecord then
|
||
|
|
obj := TROStructure.Create(n, exec)
|
||
|
|
else
|
||
|
|
raise Exception.Create('Unknown custom type');
|
||
|
|
try
|
||
|
|
Msg.Read(Name, obj.ClassInfo, obj, []);
|
||
|
|
finally
|
||
|
|
obj.Free;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
function RoProc(Caller: TPSExec; p: TIFExternalProcRec; Global, Stack: TIfList): Boolean;
|
||
|
|
var
|
||
|
|
s, s2: string;
|
||
|
|
res, n: TPSVariantIFC;
|
||
|
|
aType: TRODataType;
|
||
|
|
aMode: TRODLParamFlag;
|
||
|
|
StartOffset, I: Longint;
|
||
|
|
__request, __response : TMemoryStream;
|
||
|
|
Inst: TRoObjectInstance;
|
||
|
|
|
||
|
|
begin
|
||
|
|
s := p.Decl;
|
||
|
|
|
||
|
|
if s[1] = #255 then
|
||
|
|
begin
|
||
|
|
n := NewTPSVariantIFC(Stack[Stack.Count -1], True);
|
||
|
|
res.Dta := nil;
|
||
|
|
res.aType := nil;
|
||
|
|
StartOffset := Stack.Count -2;
|
||
|
|
end
|
||
|
|
else
|
||
|
|
begin
|
||
|
|
n := NewTPSVariantIFC(Stack[Stack.Count -2], True);
|
||
|
|
res := NewTPSVariantIFC(Stack[Stack.Count -1], True);
|
||
|
|
StartOffset := Stack.Count -3;
|
||
|
|
end;
|
||
|
|
|
||
|
|
if (n.Dta = nil) or (N.aType = nil) or (n.aType.BaseType <> btInterface) or (Longint(n.Dta^) = 0) then
|
||
|
|
begin
|
||
|
|
Caller.CMD_Err2(erCustomError, 'RO Invoker: Invalid Parameters');
|
||
|
|
Result := False;
|
||
|
|
exit;
|
||
|
|
end;
|
||
|
|
|
||
|
|
Inst := IROClass(n.dta^).Slf;
|
||
|
|
Delete(s, 1, 1);
|
||
|
|
i := StartOffset;
|
||
|
|
try
|
||
|
|
Inst.SLF.Message.InitializeRequestMessage(Inst.Channel, '', Copy(p.Name,1,pos('.', p.Name) -1), Copy(p.Name, pos('.', p.Name)+1, MaxInt));
|
||
|
|
while Length(s) > 0 do
|
||
|
|
begin
|
||
|
|
s2 := copy(s, 2, ord(s[1]));
|
||
|
|
Char(aMode) := s[length(s2)+2];
|
||
|
|
Char(aType) := s[length(s2)+3];
|
||
|
|
Delete(s, 1, length(s2)+3);
|
||
|
|
n := NewTPSVariantIFC(Stack[i], True);
|
||
|
|
Dec(I);
|
||
|
|
if ((aMode = fIn) or (aMode = fInOut)) and (n.Dta <> nil) then
|
||
|
|
begin
|
||
|
|
case aType of
|
||
|
|
rtInteger: Inst.Message.Write(s2, TypeInfo(Integer), Integer(n.Dta^), []);
|
||
|
|
rtDateTime: Inst.Message.Write(s2, TypeInfo(DateTime), Double(n.Dta^), []);
|
||
|
|
rtDouble: Inst.Message.Write(s2, TypeInfo(Double), Double(n.Dta^), []);
|
||
|
|
rtCurrency: Inst.Message.Write(s2, TypeInfo(Double), Double(n.Dta^), []);
|
||
|
|
rtWideString: Inst.Message.Write(s2, TypeInfo(WideString), WideString(n.Dta^), []);
|
||
|
|
rtString: Inst.Message.Write(s2, TypeInfo(String), String(n.Dta^), []);
|
||
|
|
rtInt64: Inst.Message.Write(s2, TypeInfo(Int64), Int64(n.Dta^), []);
|
||
|
|
rtBoolean: Inst.Message.Write(s2, TypeInfo(Boolean), Byte(n.Dta^), []);
|
||
|
|
rtUserDefined: WriteUserDefined(Caller, Inst.Message, s2, n);
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
__request := TMemoryStream.Create;
|
||
|
|
__response := TMemoryStream.Create;
|
||
|
|
try
|
||
|
|
Inst.Message.WriteToStream(__request);
|
||
|
|
Inst.Channel.Dispatch(__request, __response);
|
||
|
|
Inst.Message.ReadFromStream(__response);
|
||
|
|
finally
|
||
|
|
__request.Free;
|
||
|
|
__response.Free;
|
||
|
|
end;
|
||
|
|
s := p.Decl;
|
||
|
|
Delete(s, 1, 1);
|
||
|
|
i := StartOffset;
|
||
|
|
while Length(s) > 0 do
|
||
|
|
begin
|
||
|
|
s2 := copy(s, 2, ord(s[1]));
|
||
|
|
Char(aMode) := s[length(s2)+2];
|
||
|
|
Char(aType) := s[length(s2)+3];
|
||
|
|
Delete(s, 1, length(s2)+3);
|
||
|
|
n := NewTPSVariantIFC(Stack[i], True);
|
||
|
|
Dec(I);
|
||
|
|
if ((aMode = fOut) or (aMode = fInOut)) and (n.Dta <> nil) then
|
||
|
|
begin
|
||
|
|
case aType of
|
||
|
|
rtInteger: Inst.Message.Read(s2, TypeInfo(Integer), Longint(n.Dta^), []);
|
||
|
|
rtDateTime: Inst.Message.Read(s2, TypeInfo(DateTime), double(n.dta^), []);
|
||
|
|
rtDouble: Inst.Message.Read(s2, TypeInfo(Double), double(n.dta^), []);
|
||
|
|
rtCurrency: Inst.Message.Read(s2, TypeInfo(Double), double(n.dta^), []);
|
||
|
|
rtWideString: Inst.Message.Read(s2, TypeInfo(WideString), widestring(n.Dta^), []);
|
||
|
|
rtString: Inst.Message.Read(s2, TypeInfo(String), string(n.dta^), []);
|
||
|
|
rtInt64: Inst.Message.Read(s2, TypeInfo(Int64), Int64(n.Dta^), []);
|
||
|
|
rtBoolean: Inst.Message.Read(s2, TypeInfo(Boolean), Boolean(n.Dta^), []);
|
||
|
|
rtUserDefined: ReadUserDefined(Caller, Inst.Message, s2, n);
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
aType := TRODataType(p.Decl[1]);
|
||
|
|
case aType of
|
||
|
|
rtInteger: Inst.Message.Read('Result', TypeInfo(Integer), Longint(res.Dta^), []);
|
||
|
|
rtDateTime: Inst.Message.Read('Result', TypeInfo(DateTime), Double(res.dta^), []);
|
||
|
|
rtDouble: Inst.Message.Read('Result', TypeInfo(Double), Double(res.Dta^), []);
|
||
|
|
rtCurrency: Inst.Message.Read('Result', TypeInfo(Double), double(res.Dta^), []);
|
||
|
|
rtWideString: Inst.Message.Read('Result', TypeInfo(WideString), WideString(res.Dta^), []);
|
||
|
|
rtString: Inst.Message.Read('Result', TypeInfo(String), String(res.Dta^), []);
|
||
|
|
rtInt64: Inst.Message.Read('Result', TypeInfo(Int64), Int64(res.dta^), []);
|
||
|
|
rtBoolean: Inst.Message.Read('Result', TypeInfo(Boolean), Boolean(res.dta^), []);
|
||
|
|
rtUserDefined: ReadUserDefined(Caller, Inst.Message, 'Result', res);
|
||
|
|
end;
|
||
|
|
except
|
||
|
|
on e: Exception do
|
||
|
|
begin
|
||
|
|
Caller.CMD_Err2(erCustomError, e.Message);
|
||
|
|
Result := False;
|
||
|
|
exit;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
Result := True;
|
||
|
|
end;
|
||
|
|
|
||
|
|
function SProcImport(Sender: TPSExec; p: TIFExternalProcRec; Tag: Pointer): Boolean;
|
||
|
|
var
|
||
|
|
s: string;
|
||
|
|
begin
|
||
|
|
s := p.Decl;
|
||
|
|
Delete(s, 1, pos(':', s));
|
||
|
|
if s[1] = '-' then
|
||
|
|
p.ProcPtr := @NilProc
|
||
|
|
else if s[1] = '!' then
|
||
|
|
begin
|
||
|
|
P.ProcPtr := @CreateProc;
|
||
|
|
p.Decl := Copy(s, 2, MaxInt);
|
||
|
|
end else
|
||
|
|
begin
|
||
|
|
Delete(s, 1, 1);
|
||
|
|
p.Name := Copy(S,1,pos('!', s)-1);
|
||
|
|
Delete(s, 1, pos('!', s));
|
||
|
|
p.Decl := s;
|
||
|
|
p.ProcPtr := @RoProc;
|
||
|
|
end;
|
||
|
|
Result := True;
|
||
|
|
end;
|
||
|
|
|
||
|
|
|
||
|
|
type
|
||
|
|
TMYComp = class(TPSPascalCompiler);
|
||
|
|
TRoClass = class(TPSExternalClass)
|
||
|
|
private
|
||
|
|
FService: TRODLService;
|
||
|
|
FNilProcNo: Cardinal;
|
||
|
|
FCompProcno: Cardinal;
|
||
|
|
function CreateParameterString(l: TRODLOperation): string;
|
||
|
|
function GetDT(DataType: string): TRODataType;
|
||
|
|
procedure MakeDeclFor(Dest: TPSParametersDecl; l: TRODLOperation);
|
||
|
|
public
|
||
|
|
constructor Create(Se: TPSPascalCompiler; Service: TRODLService; Const Typeno: TPSType);
|
||
|
|
|
||
|
|
function SelfType: TPSType; override;
|
||
|
|
function Func_Find(const Name: string; var Index: Cardinal): Boolean; override;
|
||
|
|
function Func_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; override;
|
||
|
|
function SetNil(var ProcNo: Cardinal): Boolean; override;
|
||
|
|
|
||
|
|
function ClassFunc_Find(const Name: string; var Index: Cardinal): Boolean; override;
|
||
|
|
function ClassFunc_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; override;
|
||
|
|
function IsCompatibleWith(Cl: TPSExternalClass): Boolean; override;
|
||
|
|
end;
|
||
|
|
|
||
|
|
{ TROPSLink }
|
||
|
|
procedure TPSRemObjectsSdkPlugin.RODLLoadFromFile(const FileName: string);
|
||
|
|
var
|
||
|
|
f: TFileStream;
|
||
|
|
begin
|
||
|
|
f := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);
|
||
|
|
try
|
||
|
|
RODLLoadFromStream(f);
|
||
|
|
finally
|
||
|
|
f.Free;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure TPSRemObjectsSdkPlugin.RODLLoadFromResource;
|
||
|
|
var
|
||
|
|
rs: TResourceStream;
|
||
|
|
begin
|
||
|
|
rs := TResourceStream.Create(HInstance, 'RODLFILE', RT_RCDATA);
|
||
|
|
try
|
||
|
|
RODLLoadFromStream(rs);
|
||
|
|
finally
|
||
|
|
rs.Free;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure TPSRemObjectsSdkPlugin.RODLLoadFromStream(S: TStream);
|
||
|
|
begin
|
||
|
|
FreeAndNil(FRodl);
|
||
|
|
with TXMLToRODL.Create do
|
||
|
|
begin
|
||
|
|
try
|
||
|
|
FRodl := Read(S);
|
||
|
|
finally
|
||
|
|
Free;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
|
||
|
|
destructor TPSRemObjectsSdkPlugin.Destroy;
|
||
|
|
begin
|
||
|
|
FreeAndNil(FRodl);
|
||
|
|
FModules.Free;
|
||
|
|
inherited Destroy;
|
||
|
|
end;
|
||
|
|
|
||
|
|
{ TRoClass }
|
||
|
|
|
||
|
|
constructor TRoClass.Create(Se: TPSPascalCompiler; Service: TRODLService; Const Typeno: TPSType);
|
||
|
|
begin
|
||
|
|
inherited Create(SE, TypeNo);
|
||
|
|
FService := Service;
|
||
|
|
FNilProcNo := Cardinal(-1);
|
||
|
|
FCompProcNo := Cardinal(-1);
|
||
|
|
end;
|
||
|
|
|
||
|
|
function TRoClass.GetDT(DataType: string): TRODataType;
|
||
|
|
begin
|
||
|
|
DataType := LowerCase(DataType);
|
||
|
|
if DataType = 'integer' then
|
||
|
|
Result := rtInteger
|
||
|
|
else if DataType = 'datetime' then
|
||
|
|
Result := rtDateTime
|
||
|
|
else if DataType = 'double' then
|
||
|
|
Result := rtDouble
|
||
|
|
else if DataType = 'currency' then
|
||
|
|
Result := rtCurrency
|
||
|
|
else if DataType = 'widestring' then
|
||
|
|
Result := rtWidestring
|
||
|
|
else if DataType = 'string' then
|
||
|
|
Result := rtString
|
||
|
|
else if DataType = 'int64' then
|
||
|
|
Result := rtInt64
|
||
|
|
else if DataType = 'boolean' then
|
||
|
|
Result := rtBoolean
|
||
|
|
else if DataType = 'variant' then
|
||
|
|
Result := rtVariant
|
||
|
|
else if DataType = 'binary' then
|
||
|
|
Result := rtBinary
|
||
|
|
else
|
||
|
|
Result := rtUserDefined;
|
||
|
|
end;
|
||
|
|
|
||
|
|
function TRoClass.CreateParameterString(l: TRODLOperation): string;
|
||
|
|
var
|
||
|
|
i: Longint;
|
||
|
|
begin
|
||
|
|
if L.Result = nil then
|
||
|
|
begin
|
||
|
|
Result := #$FF;
|
||
|
|
end else
|
||
|
|
begin
|
||
|
|
Result := Chr(Ord(GetDT(l.Result.DataType)));
|
||
|
|
end;
|
||
|
|
for i := 0 to l.Count -1 do
|
||
|
|
begin
|
||
|
|
if l.Items[i].Flag = fResult then Continue;
|
||
|
|
Result := Result + Chr(Length(l.Items[i].Info.Name))+ l.Items[i].Info.Name + Chr(Ord(l.Items[i].Flag)) + Chr(Ord(GetDT(l.Items[i].DataType)));
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure TRoClass.MakeDeclFor(Dest: TPSParametersDecl; l: TRODLOperation);
|
||
|
|
var
|
||
|
|
i: Longint;
|
||
|
|
dd: TPSParameterDecl;
|
||
|
|
begin
|
||
|
|
if l.Result <> nil then
|
||
|
|
begin
|
||
|
|
Dest.Result := TMyComp(SE).at2ut(SE.FindType(l.Result.DataType));
|
||
|
|
end;
|
||
|
|
for i := 0 to l.Count -1 do
|
||
|
|
begin
|
||
|
|
if l.Items[i].Flag = fResult then Continue;
|
||
|
|
dd := Dest.AddParam;
|
||
|
|
if l.Items[i].Flag = fIn then
|
||
|
|
dd.mode := pmIn
|
||
|
|
else
|
||
|
|
dd.Mode := pmInOut;
|
||
|
|
dd.OrgName := l.Items[i].Info.Name;
|
||
|
|
dd.aType := TMyComp(SE).at2ut(SE.FindType(l.Items[i].DataType));
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
function TRoClass.Func_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean;
|
||
|
|
var
|
||
|
|
h, i: Longint;
|
||
|
|
s, e: string;
|
||
|
|
P: TPSProcedure;
|
||
|
|
p2: TPSExternalProcedure;
|
||
|
|
begin
|
||
|
|
s := 'roclass:_'+FService.Info.Name + '.' + FService.Default.Items[Index].Info.Name;
|
||
|
|
h := MakeHash(s);
|
||
|
|
for i := 0 to TMyComp(SE).FProcs.Count -1 do
|
||
|
|
begin
|
||
|
|
P := TMyComp(SE).FProcs[i];
|
||
|
|
if (p is TPSExternalProcedure) then
|
||
|
|
begin
|
||
|
|
p2 := TPSExternalProcedure(p);
|
||
|
|
if (p2.RegProc.NameHash = h) and (Copy(p2.RegProc.ImportDecl, 1, pos('!', p2.RegProc.ImportDecl)) = s) then
|
||
|
|
begin
|
||
|
|
Procno := I;
|
||
|
|
Result := True;
|
||
|
|
Exit;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
e := CreateParameterString(FService.Default.Items[Index]);
|
||
|
|
s := s + '!' + e;
|
||
|
|
ProcNo := TMyComp(SE).AddUsedFunction2(P2);
|
||
|
|
p2.RegProc := TPSRegProc.Create;
|
||
|
|
TMYComp(SE).FRegProcs.Add(p2.RegProc);
|
||
|
|
p2.RegProc.Name := '';
|
||
|
|
p2.RegProc.ExportName := True;
|
||
|
|
MakeDeclFor(p2.RegProc.Decl, FService.Default.Items[Index]);
|
||
|
|
p2.RegProc.ImportDecl := s;
|
||
|
|
Result := True;
|
||
|
|
end;
|
||
|
|
|
||
|
|
function TRoClass.Func_Find(const Name: string; var Index: Cardinal): Boolean;
|
||
|
|
var
|
||
|
|
i: Longint;
|
||
|
|
begin
|
||
|
|
for i := 0 to FService.Default.Count -1 do
|
||
|
|
begin
|
||
|
|
if CompareText(FService.Default.Items[i].Info.Name, Name) = 0 then
|
||
|
|
begin
|
||
|
|
Index := i;
|
||
|
|
Result := True;
|
||
|
|
Exit;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
Result := False;
|
||
|
|
end;
|
||
|
|
|
||
|
|
const
|
||
|
|
PSClassType = '!ROClass';
|
||
|
|
MyGuid: TGuid = '{CADCCF37-7FA0-452E-971D-65DA691F7648}';
|
||
|
|
|
||
|
|
function TRoClass.SelfType: TPSType;
|
||
|
|
begin
|
||
|
|
Result := SE.FindType(PSClassType);
|
||
|
|
if Result = nil then
|
||
|
|
begin
|
||
|
|
Result := se.AddInterface(se.FindInterface('IUnknown'), MyGuid, PSClassType).aType;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
function TRoClass.SetNil(var ProcNo: Cardinal): Boolean;
|
||
|
|
var
|
||
|
|
P: TPSExternalProcedure;
|
||
|
|
begin
|
||
|
|
if FNilProcNo <> Cardinal(-1) then
|
||
|
|
ProcNo:= FNilProcNo
|
||
|
|
else
|
||
|
|
begin
|
||
|
|
ProcNo := TMyComp(SE).AddUsedFunction2(P);
|
||
|
|
p.RegProc := TPSRegProc.Create;
|
||
|
|
TMyComp(SE).FRegProcs.Add(p.RegProc);
|
||
|
|
p.RegProc.Name := '';
|
||
|
|
p.RegProc.ExportName := True;
|
||
|
|
with p.RegProc.Decl.AddParam do
|
||
|
|
begin
|
||
|
|
OrgName := 'VarNo';
|
||
|
|
aType := TMYComp(Se).at2ut(SelfType);
|
||
|
|
end;
|
||
|
|
p.RegProc.ImportDecl := 'roclass:-';
|
||
|
|
FNilProcNo := Procno;
|
||
|
|
end;
|
||
|
|
Result := True;
|
||
|
|
end;
|
||
|
|
|
||
|
|
function TRoClass.ClassFunc_Call(Index: Cardinal;
|
||
|
|
var ProcNo: Cardinal): Boolean;
|
||
|
|
var
|
||
|
|
P: TPSExternalProcedure;
|
||
|
|
begin
|
||
|
|
if FCompProcNo <> Cardinal(-1) then
|
||
|
|
begin
|
||
|
|
Procno := FCompProcNo;
|
||
|
|
Result := True;
|
||
|
|
Exit;
|
||
|
|
end;
|
||
|
|
ProcNo := TMyComp(SE).AddUsedFunction2(P);
|
||
|
|
p.RegProc := TPSRegProc.Create;
|
||
|
|
TMyComp(SE).FRegProcs.Add(p.RegProc);
|
||
|
|
p.RegProc.ExportName := True;
|
||
|
|
p.RegProc.Decl.Result := TMyComp(SE).at2ut(SelfType);
|
||
|
|
with p.RegProc.Decl.AddParam do
|
||
|
|
begin
|
||
|
|
Orgname := 'Message';
|
||
|
|
aType :=TMyComp(SE).at2ut(SE.FindType('TROMESSAGE'));
|
||
|
|
end;
|
||
|
|
with p.RegProc.Decl.AddParam do
|
||
|
|
begin
|
||
|
|
Orgname := 'Channel';
|
||
|
|
aType :=TMyComp(SE).at2ut(SE.FindType('TROTRANSPORTCHANNEL'));
|
||
|
|
end;
|
||
|
|
p.RegProc.ImportDecl := 'roclass:!';
|
||
|
|
FCompProcNo := Procno;
|
||
|
|
Result := True;
|
||
|
|
end;
|
||
|
|
|
||
|
|
function TRoClass.ClassFunc_Find(const Name: string;
|
||
|
|
var Index: Cardinal): Boolean;
|
||
|
|
begin
|
||
|
|
if Name = 'CREATE' then
|
||
|
|
begin
|
||
|
|
Result := True;
|
||
|
|
Index := 0;
|
||
|
|
end else
|
||
|
|
result := False;
|
||
|
|
end;
|
||
|
|
|
||
|
|
function TRoClass.IsCompatibleWith(Cl: TPSExternalClass): Boolean;
|
||
|
|
begin
|
||
|
|
Result := Cl is TRoClass;
|
||
|
|
end;
|
||
|
|
|
||
|
|
{ TRoObjectInstance }
|
||
|
|
|
||
|
|
function TRoObjectInstance.SLF: TRoObjectInstance;
|
||
|
|
begin
|
||
|
|
Result := Self;
|
||
|
|
end;
|
||
|
|
|
||
|
|
constructor TRoObjectInstance.Create;
|
||
|
|
begin
|
||
|
|
FRefCount := 1;
|
||
|
|
end;
|
||
|
|
|
||
|
|
|
||
|
|
function TPSRemObjectsSdkPlugin.MkStructName(Struct: TRODLStruct): string;
|
||
|
|
var
|
||
|
|
i: Longint;
|
||
|
|
begin
|
||
|
|
Result := '!ROStruct!'+Struct.Info.Name+ ',';
|
||
|
|
for i := 0 to Struct.Count -1 do
|
||
|
|
begin
|
||
|
|
Result := Result + Struct.Items[i].Info.Name+ ',';
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
function CompareStructItem(const S1, S2: TRODLTypedEntity): Integer;
|
||
|
|
begin
|
||
|
|
Result := CompareText(S1.Info.Name, S2.Info.Name);
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure SortStruct(struct: TRODLStruct; First, Last: Longint);
|
||
|
|
var
|
||
|
|
l, r, Pivot: Integer;
|
||
|
|
begin
|
||
|
|
while First < Last do
|
||
|
|
begin
|
||
|
|
Pivot := (First + Last) div 2;
|
||
|
|
l := First - 1;
|
||
|
|
r := Last + 1;
|
||
|
|
repeat
|
||
|
|
repeat inc(l); until CompareStructItem(Struct.Items[l], Struct.Items[Pivot]) >= 0;
|
||
|
|
repeat dec(r); until CompareStructItem(Struct.Items[r], Struct.Items[Pivot]) <= 0;
|
||
|
|
if l >= r then break;
|
||
|
|
Struct.Exchange(l, r);
|
||
|
|
until false;
|
||
|
|
if First < r then SortStruct(Struct, First, r);
|
||
|
|
First := r+1;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure TPSRemObjectsSdkPlugin.CompileImport1(CompExec: TPSScript);
|
||
|
|
var
|
||
|
|
i, i1: Longint;
|
||
|
|
Enum: TRODLEnum;
|
||
|
|
TempType: TPSType;
|
||
|
|
Struct: TRODLStruct;
|
||
|
|
Arr: TRODLArray;
|
||
|
|
RecType: TPSRecordFieldTypeDef;
|
||
|
|
Service: TRODLService;
|
||
|
|
begin
|
||
|
|
if FRODL = nil then exit;
|
||
|
|
if CompExec.Comp.FindType('TDateTime') = nil then
|
||
|
|
raise Exception.Create('Please register the DateUtils library first');
|
||
|
|
SIRegisterTROTRANSPORTCHANNEL(CompExec.Comp);
|
||
|
|
SIRegisterTROMESSAGE(CompExec.Comp);
|
||
|
|
if CompExec.Comp.FindType('DateTime') = nil then
|
||
|
|
CompExec.Comp.AddTypeCopyN('DateTime', 'TDateTime');
|
||
|
|
if CompExec.Comp.FindType('Currency') = nil then
|
||
|
|
CompExec.Comp.AddTypeCopyN('Currency', 'Double'); // for now
|
||
|
|
for i := 0 to FRodl.EnumCount -1 do
|
||
|
|
begin
|
||
|
|
Enum := FRodl.Enums[i];
|
||
|
|
TempType := CompExec.Comp.AddType(Enum.Info.Name, btEnum);
|
||
|
|
for i1 := 0 to Enum.Count -1 do
|
||
|
|
begin
|
||
|
|
CompExec.Comp.AddConstant(Enum.Items[i1].Info.Name, TempType).SetUInt(i1);
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
for i := 0 to FRodl.StructCount -1 do
|
||
|
|
begin
|
||
|
|
Struct := FRodl.Structs[i];
|
||
|
|
SortStruct(Struct, 0, Struct.Count-1);
|
||
|
|
TempType := CompExec.Comp.AddType('', btRecord);
|
||
|
|
TempType.ExportName := True;
|
||
|
|
TempType.Name := MkStructName(Struct);
|
||
|
|
for i1 := 0 to Struct.Count -1 do
|
||
|
|
begin
|
||
|
|
RecType := TPSRecordType(TempType).AddRecVal;
|
||
|
|
RecType.FieldOrgName := Struct.Items[i1].Info.Name;
|
||
|
|
RecType.aType := CompExec.Comp.FindType(Struct.Items[i1].DataType);
|
||
|
|
end;
|
||
|
|
CompExec.Comp.AddTypeCopy(Struct.Info.Name, TempType);
|
||
|
|
end;
|
||
|
|
for i := 0 to FRodl.ArrayCount -1 do
|
||
|
|
begin
|
||
|
|
Arr := FRodl.Arrays[i];
|
||
|
|
TempType := CompExec.Comp.AddType(Arr.Info.Name, btArray);
|
||
|
|
TPSArrayType(TempType).ArrayTypeNo := CompExec.Comp.FindType(Arr.ElementType);
|
||
|
|
end;
|
||
|
|
for i := 0 to FRodl.ServiceCount -1 do
|
||
|
|
begin
|
||
|
|
Service := FRodl.Services[i];
|
||
|
|
TempType := CompExec.Comp.AddType(Service.Info.Name, btExtClass);
|
||
|
|
TPSUndefinedClassType(TempType).ExtClass := TRoClass.Create(CompExec.Comp, Service, TempType);
|
||
|
|
end;
|
||
|
|
for i := 0 to FModules.Count -1 do
|
||
|
|
TPSROModuleClass(FModules[i]).CompImp(CompExec.Comp);
|
||
|
|
end;
|
||
|
|
|
||
|
|
function TPSRemObjectsSdkPlugin.GetHaveRodl: Boolean;
|
||
|
|
begin
|
||
|
|
Result := FRodl <> nil;
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure TPSRemObjectsSdkPlugin.ClearRodl;
|
||
|
|
begin
|
||
|
|
FRodl.Free;
|
||
|
|
FRodl := nil;
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure TPSRemObjectsSdkPlugin.ExecImport1(CompExec: TPSScript;
|
||
|
|
const ri: TPSRuntimeClassImporter);
|
||
|
|
var
|
||
|
|
i: Longint;
|
||
|
|
begin
|
||
|
|
if FRODL = nil then exit;
|
||
|
|
CompExec.Exec.AddSpecialProcImport('roclass', SProcImport, nil);
|
||
|
|
RIRegisterTROTRANSPORTCHANNEL(ri);
|
||
|
|
RIRegisterTROMESSAGE(ri);
|
||
|
|
for i := 0 to FModules.Count -1 do
|
||
|
|
TPSROModuleClass(FModules[i]).ExecImp(CompExec.Exec, ri);
|
||
|
|
end;
|
||
|
|
|
||
|
|
constructor TPSRemObjectsSdkPlugin.Create(AOwner: TComponent);
|
||
|
|
begin
|
||
|
|
inherited Create(AOwner);
|
||
|
|
FModules := TList.Create;
|
||
|
|
//FEnableSOAP := True;
|
||
|
|
FEnableBinary := True;
|
||
|
|
FEnableIndyTCP := True;
|
||
|
|
FEnableIndyHTTP := True;
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure TPSRemObjectsSdkPlugin.Loaded;
|
||
|
|
begin
|
||
|
|
inherited Loaded;
|
||
|
|
ReloadModules;
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure TPSRemObjectsSdkPlugin.RegisterModule(
|
||
|
|
Module: TPSROModuleClass);
|
||
|
|
begin
|
||
|
|
FModules.Add(Module);
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure TPSRemObjectsSdkPlugin.ReloadModules;
|
||
|
|
begin
|
||
|
|
FModules.Clear;
|
||
|
|
if FEnableIndyTCP then RegisterModule(TPSROIndyTCPModule);
|
||
|
|
if FEnableIndyHTTP then RegisterModule(TPSROIndyHTTPModule);
|
||
|
|
//if FEnableSOAP then RegisterModule(TPSROSoapModule);
|
||
|
|
if FEnableBinary then RegisterModule(TPSROBinModule);
|
||
|
|
if assigned(FOnLoadModule) then
|
||
|
|
FOnLoadModule(Self);
|
||
|
|
end;
|
||
|
|
|
||
|
|
{ TPSROModule }
|
||
|
|
|
||
|
|
class procedure TPSROModule.CompImp(comp: TPSPascalCompiler);
|
||
|
|
begin
|
||
|
|
// do nothing
|
||
|
|
end;
|
||
|
|
|
||
|
|
class procedure TPSROModule.ExecImp(exec: TPSExec;
|
||
|
|
ri: TPSRuntimeClassImporter);
|
||
|
|
begin
|
||
|
|
// do nothing
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure IntRead(Exec: TPSExec; Serializer: TROSerializer;
|
||
|
|
const Name: string; aVar: TPSVariantIFC; arridx: Longint);
|
||
|
|
var
|
||
|
|
i: Longint;
|
||
|
|
s, s2: string;
|
||
|
|
r: TROStructure;
|
||
|
|
begin
|
||
|
|
case aVar.aType.BaseType of
|
||
|
|
btS64: Serializer.Read(Name, TypeInfo(int64), Int64(avar.Dta^), arridx);
|
||
|
|
btu32: Serializer.Read(Name, TypeInfo(cardinal), Cardinal(avar.Dta^), arridx);
|
||
|
|
bts32: Serializer.Read(Name, TypeInfo(longint), Longint(avar.Dta^), arridx);
|
||
|
|
btu16: Serializer.Read(Name, TypeInfo(word), Word(aVar.Dta^), arridx);
|
||
|
|
btS16: Serializer.Read(Name, TypeInfo(smallint), Smallint(aVar.Dta^), arridx);
|
||
|
|
btu8: Serializer.Read(Name, TypeInfo(byte), Byte(aVar.Dta^), arridx);
|
||
|
|
btS8: Serializer.Read(Name, TypeInfo(shortint), Shortint(aVar.Dta^), arridx);
|
||
|
|
btDouble:
|
||
|
|
begin
|
||
|
|
if aVar.aType.ExportName = 'TDATETIME' then
|
||
|
|
Serializer.Read(Name, TypeInfo(datetime), Double(avar.Dta^), arridx)
|
||
|
|
else
|
||
|
|
Serializer.Read(Name, TypeInfo(double), Double(aVar.Dta^), arridx);
|
||
|
|
end;
|
||
|
|
btSingle: Serializer.Read(Name, TypeInfo(single), Single(avar.Dta^), arridx);
|
||
|
|
btExtended: Serializer.Read(Name, TypeInfo(extended), Extended(avar.dta^), arridx);
|
||
|
|
btWideString: Serializer.Read(Name, TypeInfo(widestring), widestring(avar.dta^), arridx);
|
||
|
|
btString: Serializer.Read(Name, TypeInfo(string), string(avar.dta^), arridx);
|
||
|
|
btArray:
|
||
|
|
begin
|
||
|
|
if (TPSTypeRec_Array(avar.aType).ArrayType.BaseType = btRecord) then
|
||
|
|
begin
|
||
|
|
for i := 0 to PSDynArrayGetLength(Pointer(aVar.Dta^), aVar.aType) -1 do
|
||
|
|
begin
|
||
|
|
r := TROStructure.Create(PSGetArrayField(avar, i), Exec);
|
||
|
|
try
|
||
|
|
Serializer.Read(Name, typeinfo(TROArray), r, i);
|
||
|
|
finally
|
||
|
|
r.Free;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
end else if (TPSTypeRec_Array(avar.aType).ArrayType.BaseType = btArray) then
|
||
|
|
begin
|
||
|
|
for i := 0 to PSDynArrayGetLength(Pointer(aVar.Dta^), aVar.aType) -1 do
|
||
|
|
begin
|
||
|
|
r := TROArray.Create(PSGetArrayField(avar, i), Exec);
|
||
|
|
try
|
||
|
|
Serializer.Read(Name, typeinfo(TROArray), r, i);
|
||
|
|
finally
|
||
|
|
r.Free;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
end else begin
|
||
|
|
for i := 0 to PSDynArrayGetLength(Pointer(aVar.Dta^), aVar.aType) -1 do
|
||
|
|
begin
|
||
|
|
IntRead(Exec, Serializer, Name, PSGetArrayField(avar, i), i);
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
btRecord:
|
||
|
|
begin
|
||
|
|
s := avar.aType.ExportName;
|
||
|
|
if copy(s,1, 10) <> '!ROStruct!' then
|
||
|
|
raise Exception.Create('Invalid structure: '+s);
|
||
|
|
Delete(s,1,pos(',',s));
|
||
|
|
for i := 0 to TPSTypeRec_Record(aVar.aType).FieldTypes.Count -1 do
|
||
|
|
begin
|
||
|
|
s2 := copy(s,1,pos(',',s)-1);
|
||
|
|
delete(s,1,pos(',',s));
|
||
|
|
if (TPSTypeRec(TPSTypeRec_Record(aVar.aType).FieldTypes[i]).BaseType = btRecord) then
|
||
|
|
begin
|
||
|
|
|
||
|
|
r := TROStructure.Create(PSGetRecField(aVar, i), Exec);
|
||
|
|
try
|
||
|
|
Serializer.Read(s2, typeinfo(TROStructure), r, -1);
|
||
|
|
finally
|
||
|
|
r.Free;
|
||
|
|
end;
|
||
|
|
end else if (TPSTypeRec(TPSTypeRec_Record(aVar.aType).FieldTypes[i]).BaseType = btArray) then
|
||
|
|
begin
|
||
|
|
r := TROArray.Create(PSGetRecField(aVar, i), Exec);
|
||
|
|
try
|
||
|
|
Serializer.Read(s2, typeinfo(TROArray), r, -1);
|
||
|
|
finally
|
||
|
|
r.Free;
|
||
|
|
end;
|
||
|
|
end else
|
||
|
|
IntRead(Exec, Serializer, s2, PSGetRecField(aVar, i), -1);
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
else
|
||
|
|
raise Exception.Create('Unable to read type');
|
||
|
|
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure IntWrite(Exec: TPSExec; Serializer: TROSerializer;
|
||
|
|
const Name: string; aVar: TPSVariantIFC; arridx: Longint);
|
||
|
|
var
|
||
|
|
i: Longint;
|
||
|
|
s, s2: string;
|
||
|
|
r: TROStructure;
|
||
|
|
begin
|
||
|
|
case aVar.aType.BaseType of
|
||
|
|
btS64: Serializer.Write(Name, TypeInfo(int64), Int64(avar.Dta^), arridx);
|
||
|
|
btu32: Serializer.Write(Name, TypeInfo(cardinal), Cardinal(avar.Dta^), arridx);
|
||
|
|
bts32: Serializer.Write(Name, TypeInfo(longint), Longint(avar.Dta^), arridx);
|
||
|
|
btu16: Serializer.Write(Name, TypeInfo(word), Word(avar.Dta^), arridx);
|
||
|
|
btS16: Serializer.Write(Name, TypeInfo(smallint), Smallint(aVar.Dta^), arridx);
|
||
|
|
btu8: Serializer.Write(Name, TypeInfo(byte), Byte(aVar.Dta^), arridx);
|
||
|
|
btS8: Serializer.Write(Name, TypeInfo(shortint), ShortInt(aVar.Dta^), arridx);
|
||
|
|
btDouble:
|
||
|
|
begin
|
||
|
|
if aVar.aType.ExportName = 'TDATETIME' then
|
||
|
|
Serializer.Write(Name, TypeInfo(datetime), Double(aVar.Dta^), arridx)
|
||
|
|
else
|
||
|
|
Serializer.Write(Name, TypeInfo(double), Double(aVar.Dta^), arridx);
|
||
|
|
end;
|
||
|
|
btSingle: Serializer.Write(Name, TypeInfo(single), Single(aVar.Dta^), arridx);
|
||
|
|
btExtended: Serializer.Write(Name, TypeInfo(extended), Extended(aVar.Dta^), arridx);
|
||
|
|
btWideString: Serializer.Write(Name, TypeInfo(widestring), WideString(aVar.Dta^), arridx);
|
||
|
|
btString: Serializer.Write(Name, TypeInfo(string), String(aVar.Dta^), arridx);
|
||
|
|
btArray:
|
||
|
|
begin
|
||
|
|
if (TPSTypeRec_Array(avar.aType).ArrayType.BaseType = btRecord) then
|
||
|
|
begin
|
||
|
|
for i := 0 to PSDynArrayGetLength(Pointer(aVar.Dta^), aVar.aType) -1 do
|
||
|
|
begin
|
||
|
|
r := TROStructure.Create(PSGetArrayField(aVar, i), Exec);
|
||
|
|
try
|
||
|
|
Serializer.Write(Name, typeinfo(TROArray), r, i);
|
||
|
|
finally
|
||
|
|
r.Free;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
end else if (TPSTypeRec_Array(avar.aType).ArrayType.BaseType = btArray) then
|
||
|
|
begin
|
||
|
|
for i := 0 to PSDynArrayGetLength(Pointer(aVar.Dta^), aVar.aType) -1 do
|
||
|
|
begin
|
||
|
|
r := TROArray.Create(PSGetArrayField(aVar, i), Exec);
|
||
|
|
try
|
||
|
|
Serializer.Write(Name, typeinfo(TROArray), r, i);
|
||
|
|
finally
|
||
|
|
r.Free;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
end else begin
|
||
|
|
for i := 0 to PSDynArrayGetLength(Pointer(aVar.Dta^), aVar.aType) -1 do
|
||
|
|
begin
|
||
|
|
IntWrite(Exec, Serializer, Name, PSGetArrayField(aVar, i), i);
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
btRecord:
|
||
|
|
begin
|
||
|
|
s := avar.aType.ExportName;
|
||
|
|
if copy(s,1, 10) <> '!ROStruct!' then
|
||
|
|
raise Exception.Create('Invalid structure: '+s);
|
||
|
|
Delete(s,1,pos(',',s));
|
||
|
|
for i := 0 to TPSTypeRec_Record(aVar.aType).FieldTypes.Count -1 do
|
||
|
|
begin
|
||
|
|
s2 := copy(s,1,pos(',',s)-1);
|
||
|
|
delete(s,1,pos(',',s));
|
||
|
|
if (TPSTypeRec(TPSTypeRec_Record(aVar.aType).FieldTypes[i]).BaseType = btRecord) then
|
||
|
|
begin
|
||
|
|
r := TROStructure.Create(PSGetRecField(aVar, i), Exec);
|
||
|
|
try
|
||
|
|
Serializer.Write(s2, typeinfo(TROStructure), r, -1);
|
||
|
|
finally
|
||
|
|
r.Free;
|
||
|
|
end;
|
||
|
|
end else if (TPSTypeRec(TPSTypeRec_Record(aVar.aType).FieldTypes[i]).BaseType = btArray) then
|
||
|
|
begin
|
||
|
|
r := TROArray.Create(PSGetRecField(aVar, i), Exec);
|
||
|
|
try
|
||
|
|
Serializer.Write(s2, typeinfo(TROArray), r, -1);
|
||
|
|
finally
|
||
|
|
r.Free;
|
||
|
|
end;
|
||
|
|
end else
|
||
|
|
IntWrite(Exec, Serializer, s2, PSGetRecField(aVar, i), -1);
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
else
|
||
|
|
raise Exception.Create('Unable to read type');
|
||
|
|
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
{ TROStructure }
|
||
|
|
|
||
|
|
constructor TROStructure.Create(aVar: TPSVariantIfc; Exec: TPSExec);
|
||
|
|
begin
|
||
|
|
inherited Create;
|
||
|
|
FVar := aVar;
|
||
|
|
FExec := Exec;
|
||
|
|
end;
|
||
|
|
|
||
|
|
function TROStructure.IsNull: Boolean;
|
||
|
|
begin
|
||
|
|
Result := False;
|
||
|
|
end;
|
||
|
|
|
||
|
|
function TROStructure.QueryInterface(const IID: TGUID;
|
||
|
|
out Obj): HResult;
|
||
|
|
begin
|
||
|
|
if GetInterface(IID, Obj) then
|
||
|
|
Result := 0
|
||
|
|
else
|
||
|
|
Result := E_NOINTERFACE;
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure TROStructure.Read(Serializer: TROSerializer;
|
||
|
|
const Name: string);
|
||
|
|
begin
|
||
|
|
IntRead(FExec, Serializer, Name, FVar, -1);
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure TROStructure.SetNull(b: Boolean);
|
||
|
|
begin
|
||
|
|
// null not supported
|
||
|
|
end;
|
||
|
|
|
||
|
|
function TROStructure.GetTypeName: string;
|
||
|
|
var
|
||
|
|
s: string;
|
||
|
|
begin
|
||
|
|
s := fvar.atype.ExportName;
|
||
|
|
delete(s,1,1);
|
||
|
|
delete(s,1,pos('!', s));
|
||
|
|
result := copy(s,1,pos(',',s)-1);
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure TROStructure.Write(Serializer: TROSerializer;
|
||
|
|
const Name: string);
|
||
|
|
begin
|
||
|
|
IntWrite(FExec, Serializer, Name, FVar, -1);
|
||
|
|
end;
|
||
|
|
|
||
|
|
|
||
|
|
function TROStructure._AddRef: Integer;
|
||
|
|
begin
|
||
|
|
// do nothing
|
||
|
|
Result := 1;
|
||
|
|
end;
|
||
|
|
|
||
|
|
function TROStructure._Release: Integer;
|
||
|
|
begin
|
||
|
|
// do nothing
|
||
|
|
Result := 1;
|
||
|
|
end;
|
||
|
|
|
||
|
|
function TROStructure.CanImplementType(const aName: string): boolean;
|
||
|
|
begin
|
||
|
|
if SameText(aName, Self.GetTypeName) then
|
||
|
|
Result := True
|
||
|
|
else
|
||
|
|
Result := False;
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure TROStructure.SetTypeName(const s: string);
|
||
|
|
begin
|
||
|
|
// Do nothing
|
||
|
|
end;
|
||
|
|
|
||
|
|
{ TROArray }
|
||
|
|
|
||
|
|
function TROArray.GetCount: Longint;
|
||
|
|
begin
|
||
|
|
|
||
|
|
// we should have an array in pVar now so assume that's true
|
||
|
|
Result := PSDynArrayGetLength(Pointer(fVar.Dta^), fvar.aType);
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure TROArray.SetCount(l: Integer);
|
||
|
|
begin
|
||
|
|
PSDynArraySetLength(Pointer(fVAr.Dta^), fVar.aType, l);
|
||
|
|
end;
|
||
|
|
|
||
|
|
end.
|