TVirtualInterface equivalent to the Delphi implementation.

packages/rtl/rtti.pas

@@ -460,20 +460,30 @@ type
 
   EInvoke = EJS;
 
-  TVirtualInterfaceInvokeEvent = function(const aMethodName: string;
+  TVirtualInterfaceInvokeEvent = reference to procedure(Method: TRttiMethod; const Args: specialize TArray<TValue>; out Result: TValue);
-    const Args: TJSValueDynArray): JSValue of object;
+  TVirtualInterfaceInvokeEventJS = reference to function(const aMethodName: String; const Args: TJSValueDynArray): JSValue;
 
   { TVirtualInterface: A class that can implement any IInterface. Any method
     call is handled by the OnInvoke event. }
   TVirtualInterface = class(TInterfacedObject, IInterface)
   private
+    FContext: TRttiContext;
+    FInterfaceType: TRttiInterfaceType;
     FOnInvoke: TVirtualInterfaceInvokeEvent;
+    FOnInvokeJS: TVirtualInterfaceInvokeEventJS;
+
+    function Invoke(const MethodName: String; const Args: TJSValueDynArray): JSValue;
   public
-    constructor Create(InterfaceTypeInfo: Pointer); overload; assembler;
+    constructor Create(InterfaceTypeInfo: TTypeInfoInterface); overload;
-    constructor Create(InterfaceTypeInfo: Pointer;
+    constructor Create(InterfaceTypeInfo: TTypeInfoInterface; const InvokeEvent: TVirtualInterfaceInvokeEvent); overload;
-      const InvokeEvent: TVirtualInterfaceInvokeEvent); overload;
+    constructor Create(InterfaceTypeInfo: TTypeInfoInterface; const InvokeEvent: TVirtualInterfaceInvokeEventJS); overload;
+
+    destructor Destroy; override;
+
     function QueryInterface(const iid: TGuid; out obj): Integer; override;
+
     property OnInvoke: TVirtualInterfaceInvokeEvent read FOnInvoke write FOnInvoke;
+    property OnInvokeJS: TVirtualInterfaceInvokeEventJS read FOnInvokeJS write FOnInvokeJS;
   end;
 
 procedure CreateVirtualCorbaInterface(InterfaceTypeInfo: Pointer;
@@ -2018,46 +2028,68 @@ end;
 
 { TVirtualInterface }
 
-constructor TVirtualInterface.Create(InterfaceTypeInfo: Pointer); assembler;
+constructor TVirtualInterface.Create(InterfaceTypeInfo: TTypeInfoInterface);
-asm
+var
-  var IntfType = InterfaceTypeInfo.interface;
+  SelfInterfaceObject, InterfaceObject: TInterfaceObject;
-  if (IntfType.$kind !== 'com') rtl.raiseE('EInvalidCast');
+
-  var guid = IntfType.$guid;
+  Method: TRttiMethod;
-  var i = Object.create(IntfType); // needed by IntfVar is IntfType
+
-  i.$o = this;
+  MethodName: String;
-  // copy IInterface methods: _AddRef, _Release, QueryInterface
+
-  var iinterfaceguid = '{00000000-0000-0000-C000-000000000046}';
+begin
-  var map = this.$intfmaps[iinterfaceguid];
+  FContext := TRttiContext.Create;
-  for (var key in map){
+  FInterfaceType := FContext.GetType(InterfaceTypeInfo) as TRttiInterfaceType;
-    var v = map[key];
+
-    if (typeof(v)!=='function') continue;
+  if FInterfaceType.InterfaceTypeInfo.InterfaceInfo.kind <> 'com' then
-    i[key] = map[key];
+    raise EInvalidCast.Create;
-  }
+
-  // all other methods call OnInvoke
+  InterfaceObject := TInterfaceObject(TJSObject.Create(FInterfaceType.InterfaceTypeInfo.InterfaceInfo));
-  do {
+  InterfaceObject.Obj := Self;
-    var names = IntfType.$names;
+
-    if (!names) break;
+  for Method in FInterfaceType.GetMethods do
-    for (var j=0; j<names.length; j++){
+  begin
-      let fnname = names[j];
+    asm
-      if (i[fnname]) continue;
+      let MethodName = Method.GetName();
-      i[fnname] = function(){ return this.$o.FOnInvoke(fnname,arguments); };
+    end;
-    }
+
-    IntfType = Object.getPrototypeOf(IntfType);
+    InterfaceObject[MethodName] :=
-  } while(IntfType!=null);
+      function: JSValue
-  // create a new list of interface map, supporting IInterface and IntfType
+      begin
-  this.$intfmaps = {};
+        Result := TVirtualInterface(TInterfaceObject(JSThis).Obj).Invoke(MethodName, TJSValueDynArray(JSValue(JSArguments)));
-  this.$intfmaps[iinterfaceguid] = map;
+      end;
-  this.$intfmaps[guid] = {};
+  end;
-  // store the implementation of IntfType (used by the as-operator)
+
-  this.$interfaces = {};
+  InterfaceObject['_AddRef'] := @_AddRef;
-  this.$interfaces[guid] = i;
+  InterfaceObject['_Release'] := @_Release;
+  InterfaceObject['QueryInterface'] := @QueryInterface;
+
+  SelfInterfaceObject := TInterfaceObject(Self);
+  SelfInterfaceObject.InterfaceMaps := TJSObject.New;
+  SelfInterfaceObject.InterfaceMaps[GUIDToString(IInterface)] := InterfaceObject;
+  SelfInterfaceObject.InterfaceMaps[FInterfaceType.Guid.ToString] := TJSObject.New;
+  SelfInterfaceObject.Interfaces := TJSObject.New;
+  SelfInterfaceObject.Interfaces[FInterfaceType.Guid.ToString] := InterfaceObject;
 end;
 
-constructor TVirtualInterface.Create(InterfaceTypeInfo: Pointer;
+constructor TVirtualInterface.Create(InterfaceTypeInfo: TTypeInfoInterface; const InvokeEvent: TVirtualInterfaceInvokeEvent);
-  const InvokeEvent: TVirtualInterfaceInvokeEvent);
 begin
   Create(InterfaceTypeInfo);
-  OnInvoke:=InvokeEvent;
+
+  OnInvoke := InvokeEvent;
+end;
+
+constructor TVirtualInterface.Create(InterfaceTypeInfo: TTypeInfoInterface; const InvokeEvent: TVirtualInterfaceInvokeEventJS);
+begin
+  Create(InterfaceTypeInfo);
+
+  OnInvokeJS := InvokeEvent;
+end;
+
+destructor TVirtualInterface.Destroy;
+begin
+  FContext.Free;
+
+  inherited;
 end;
 
 function TVirtualInterface.QueryInterface(const iid: TGuid; out obj): Integer;
@@ -2065,6 +2097,50 @@ begin
   Result := inherited QueryInterface(iid, obj);
 end;
 
+function TVirtualInterface.Invoke(const MethodName: String; const Args: TJSValueDynArray): JSValue;
+var
+  Method: TRttiMethod;
+
+  Return: TValue;
+
+  function GenerateParams: specialize TArray<TValue>;
+  var
+    A: Integer;
+
+    Return: TValue;
+
+    Param: TRttiParameter;
+
+    Parameters: specialize TArray<TRttiParameter>;
+
+  begin
+    Parameters := Method.GetParameters;
+
+    SetLength(Result, Length(Parameters));
+
+    for A := Low(Parameters) to High(Parameters) do
+    begin
+      Param := Parameters[A];
+
+      TValue.Make(Args[A], Param.ParamType.Handle, Result[A]);
+
+      Result[A].FReferenceVariableData := (pfVar in Param.Flags) or (pfOut in Param.Flags);
+    end;
+  end;
+
+begin
+  if Assigned(FOnInvokeJS) then
+    Result := FOnInvokeJS(MethodName, Args)
+  else
+  begin
+    Method := FInterfaceType.GetMethod(MethodName);
+
+    FOnInvoke(Method, GenerateParams, Return);
+
+    Result := Return.AsJSValue;
+  end;
+end;
+
 function Invoke(ACodeAddress: Pointer; const AArgs: TJSValueDynArray;
   ACallConv: TCallConv; AResultType: PTypeInfo; AIsStatic: Boolean;
   AIsConstructor: Boolean): TValue;

packages/rtl/typinfo.pas

@@ -352,6 +352,13 @@ type
     procedure &set(const value: JSValue);
   end;
 
+  TInterfaceObject = class external name 'Object' (TJSObject)
+  public
+    InterfaceMaps: TJSObject external name '$intfmaps';
+    Interfaces: TJSObject external name '$interfaces';
+    Obj: TInterfacedObject external name '$o';
+  end;
+
   EPropertyError  = class(Exception);
 
 function GetTypeName(TypeInfo: TTypeInfo): string;