Gemfury

bee / lazarus deb

Repository URL to install this package:
Details
lazarus / usr / share / lazarus / 1.6 / components / PascalScript / Source / uROPSServerLink.pas
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.
bee / lazarus deb

Products

About

Resources

Contact Gemfury
