moparisthebest/Simba
1
0
Fork 0
mirror of https://github.com/moparisthebest/Simba synced 2024-11-26 11:12:14 -05:00
Code Issues Releases Wiki Activity
b5e0bbf5ff
Simba/Units/PascalScript/uROPSServerLink.pas

1232 lines
38 KiB
ObjectPascal
Raw Normal View History

PS Added git-svn-id: http://www.villavu.com/repositories/merlijn/mufasa@38 3f818213-9676-44b0-a9b4-5e4c4e03d09d
2009-09-12 02:24:59 -04:00
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;
public
procedure CompileImport1(CompExec: TPSScript); override;
procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
protected
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;
(*----------------------------------------------------------------------------*)
procedure SIRegister_TROBinaryMemoryStream(CL: TPSPascalCompiler);
begin
//with RegClassS(CL,'TMemoryStream', 'TROBinaryMemoryStream') do
with CL.AddClassN(CL.FindClass('TMemoryStream'),'TROBinaryMemoryStream') do
begin
RegisterMethod('Constructor Create2( const iString : Ansistring);');
RegisterMethod('Constructor Create;');
RegisterMethod('Procedure Assign( iSource : TStream)');
RegisterMethod('Function Clone : TROBinaryMemoryStream');
RegisterMethod('Procedure LoadFromString( const iString : Ansistring)');
RegisterMethod('Procedure LoadFromHexString( const iString : Ansistring)');
RegisterMethod('Function ToString : AnsiString');
RegisterMethod('Function ToHexString : Ansistring');
RegisterMethod('Function ToReadableString : Ansistring');
RegisterMethod('Function WriteAnsiString( AString : AnsiString) : integer');
RegisterProperty('CapacityIncrement', 'integer', iptrw);
end;
end;
(*----------------------------------------------------------------------------*)
procedure SIRegister_uROClasses(CL: TPSPascalCompiler);
begin
SIRegister_TROBinaryMemoryStream(CL);
end;
(* === run-time registration functions === *)
(*----------------------------------------------------------------------------*)
procedure TROBinaryMemoryStreamCapacityIncrement_W(Self: TROBinaryMemoryStream; const T: integer);
begin Self.CapacityIncrement := T; end;
(*----------------------------------------------------------------------------*)
procedure TROBinaryMemoryStreamCapacityIncrement_R(Self: TROBinaryMemoryStream; var T: integer);
begin T := Self.CapacityIncrement; end;
(*----------------------------------------------------------------------------*)
Function TROBinaryMemoryStreamCreate_P(Self: TClass; CreateNewInstance: Boolean):TObject;
Begin Result := TROBinaryMemoryStream.Create; END;
(*----------------------------------------------------------------------------*)
Function TROBinaryMemoryStreamCreate2_P(Self: TClass; CreateNewInstance: Boolean; const iString : Ansistring):TObject;
Begin Result := TROBinaryMemoryStream.Create(iString); END;
(*----------------------------------------------------------------------------*)
procedure RIRegister_TROBinaryMemoryStream(CL: TPSRuntimeClassImporter);
begin
with CL.Add(TROBinaryMemoryStream) do
begin
RegisterConstructor(@TROBinaryMemoryStreamCreate2_P, 'Create2');
RegisterConstructor(@TROBinaryMemoryStreamCreate_P, 'Create');
RegisterMethod(@TROBinaryMemoryStream.Assign, 'Assign');
RegisterMethod(@TROBinaryMemoryStream.Clone, 'Clone');
RegisterMethod(@TROBinaryMemoryStream.LoadFromString, 'LoadFromString');
RegisterMethod(@TROBinaryMemoryStream.LoadFromHexString, 'LoadFromHexString');
RegisterMethod(@TROBinaryMemoryStream.ToString, 'ToString');
RegisterMethod(@TROBinaryMemoryStream.ToHexString, 'ToHexString');
RegisterMethod(@TROBinaryMemoryStream.ToReadableString, 'ToReadableString');
RegisterMethod(@TROBinaryMemoryStream.WriteAnsiString, 'WriteAnsiString');
RegisterPropertyHelper(@TROBinaryMemoryStreamCapacityIncrement_R,@TROBinaryMemoryStreamCapacityIncrement_W,'CapacityIncrement');
end;
end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_uROClasses(CL: TPSRuntimeClassImporter);
begin
RIRegister_TROBinaryMemoryStream(CL);
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]));
aMode := TRODLParamFlag(ord(s[length(s2)+2]));
aType := TRODataType(ord(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]));
aMode := TRODLParamFlag(ord(s[length(s2)+2]));
aType := TRODataType(ord(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: tbtstring; 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: tbtstring; 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(tbtchar('!'), 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: tbtstring; 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: tbtstring;
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');
if CompExec.Comp.FindType('TStream') = nil then
raise Exception.Create('Please register the sysutils/classes library first');
SIRegisterTROTRANSPORTCHANNEL(CompExec.Comp);
SIRegisterTROMESSAGE(CompExec.Comp);
SIRegister_uROClasses(CompExec.Comp);
CompExec.Comp.AddTypeCopyN('Binary', 'TROBinaryMemoryStream');
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);
if RecType.aType = nil then begin
Arr := fRodl.FindArray(Struct.Items[i1].DataType);
if Arr <> nil then begin
RecType.aType := CompExec.Comp.AddType(Arr.Info.Name, btArray);
TPSArrayType(RecType.aType).ArrayTypeNo := CompExec.Comp.FindType(Arr.ElementType);
end;
end;
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.FindType(Arr.Info.Name);
if TempType <> nil then begin
if not (TempType is TPSArrayType) then begin
CompExec.Comp.MakeError('ROPS', ecDuplicateIdentifier, Arr.Info.Name);
end;
end else begin
TempType := CompExec.Comp.AddType(Arr.Info.Name, btArray);
end;
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);
RIRegister_TROBinaryMemoryStream(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.
Reference in New Issue Copy Permalink