Browse Source

Fix for virtual interface when the class is inherited from another interface.

Henrique Gottardi Werlang 1 year ago
parent
commit
5f5e39c1f6
2 changed files with 50 additions and 45 deletions
  1. 49 37
      packages/rtl/src/rtti.pas
  2. 1 8
      packages/rtl/src/typinfo.pas

+ 49 - 37
packages/rtl/src/rtti.pas

@@ -507,9 +507,9 @@ type
 
     function Invoke(const MethodName: String; const Args: TJSValueDynArray): JSValue;
   public
-    constructor Create(InterfaceTypeInfo: TTypeInfoInterface); overload;
-    constructor Create(InterfaceTypeInfo: TTypeInfoInterface; const InvokeEvent: TVirtualInterfaceInvokeEvent); overload;
-    constructor Create(InterfaceTypeInfo: TTypeInfoInterface; const InvokeEvent: TVirtualInterfaceInvokeEventJS); overload;
+    constructor Create(PIID: PTypeInfo); overload;
+    constructor Create(PIID: PTypeInfo; const InvokeEvent: TVirtualInterfaceInvokeEvent); overload;
+    constructor Create(PIID: PTypeInfo; const InvokeEvent: TVirtualInterfaceInvokeEventJS); overload;
 
     destructor Destroy; override;
 
@@ -2167,59 +2167,71 @@ end;
 
 { TVirtualInterface }
 
-constructor TVirtualInterface.Create(InterfaceTypeInfo: TTypeInfoInterface);
-var
-  SelfInterfaceObject, InterfaceObject: TInterfaceObject;
+constructor TVirtualInterface.Create(PIID: PTypeInfo);
 
-  Method: TRttiMethod;
+  function Jump(MethodName: String): JSValue;
+  begin
+    Result :=
+      function: JSValue
+      begin
+        Result := TVirtualInterface(JSThis['$o']).Invoke(MethodName, TJSValueDynArray(JSValue(JSArguments)));
+      end;
+  end;
 
-  MethodName: String;
+  function GenerateNewMap(InterfaceInfo: TTypeInfoInterface): TJSObject;
+  var
+    MethodName: String;
+
+  begin
+    Result := TJSObject.New;
+
+    while Assigned(InterfaceInfo) do
+    begin
+      if InterfaceInfo = TypeInfo(IInterface) then
+      begin
+        Result['_AddRef'] := @_AddRef;
+        Result['_Release'] := @_Release;
+        Result['QueryInterface'] := @QueryInterface;
+      end
+      else
+        for MethodName in InterfaceInfo.Names do
+          Result[MethodName] := Jump(MethodName);
+
+      InterfaceInfo := InterfaceInfo.Ancestor;
+    end;
+  end;
+
+var
+  InterfaceInfo: TTypeInfoInterface;
+  InterfaceMaps: TJSObject;
 
 begin
   FContext := TRttiContext.Create;
-  FInterfaceType := FContext.GetType(InterfaceTypeInfo) as TRttiInterfaceType;
+  InterfaceMaps := TJSObject.New;
+  FInterfaceType := FContext.GetType(PIID) as TRttiInterfaceType;
 
-  if FInterfaceType.InterfaceTypeInfo.InterfaceInfo.kind <> 'com' then
-    raise EInvalidCast.Create;
+  InterfaceInfo := FInterfaceType.InterfaceTypeInfo;
 
-  InterfaceObject := TInterfaceObject(TJSObject.Create(FInterfaceType.InterfaceTypeInfo.InterfaceInfo));
-  InterfaceObject.Obj := Self;
-
-  for Method in FInterfaceType.GetMethods do
+  while Assigned(InterfaceInfo) do
   begin
-    asm
-      let MethodName = Method.GetName();
-    end;
+    InterfaceMaps[InterfaceInfo.InterfaceInfo.GUID] := GenerateNewMap(InterfaceInfo);
 
-    InterfaceObject[MethodName] :=
-      function: JSValue
-      begin
-        Result := TVirtualInterface(TInterfaceObject(JSThis).Obj).Invoke(MethodName, TJSValueDynArray(JSValue(JSArguments)));
-      end;
+    InterfaceInfo := InterfaceInfo.Ancestor;
   end;
 
-  InterfaceObject['_AddRef'] := @_AddRef;
-  InterfaceObject['_Release'] := @_Release;
-  InterfaceObject['QueryInterface'] := @QueryInterface;
-
-  SelfInterfaceObject := TInterfaceObject(TJSObject(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;
+  JSThis['$intfmaps'] := InterfaceMaps;
 end;
 
-constructor TVirtualInterface.Create(InterfaceTypeInfo: TTypeInfoInterface; const InvokeEvent: TVirtualInterfaceInvokeEvent);
+constructor TVirtualInterface.Create(PIID: PTypeInfo; const InvokeEvent: TVirtualInterfaceInvokeEvent);
 begin
-  Create(InterfaceTypeInfo);
+  Create(PIID);
 
   OnInvoke := InvokeEvent;
 end;
 
-constructor TVirtualInterface.Create(InterfaceTypeInfo: TTypeInfoInterface; const InvokeEvent: TVirtualInterfaceInvokeEventJS);
+constructor TVirtualInterface.Create(PIID: PTypeInfo; const InvokeEvent: TVirtualInterfaceInvokeEventJS);
 begin
-  Create(InterfaceTypeInfo);
+  Create(PIID);
 
   OnInvokeJS := InvokeEvent;
 end;

+ 1 - 8
packages/rtl/src/typinfo.pas

@@ -308,8 +308,8 @@ type
 
   TTypeInfoClass = class external name 'rtl.tTypeInfoClass'(TTypeInfoStruct)
   public
-    ClassType: TClass external name 'class';
     Ancestor: TTypeInfoClass external name 'ancestor';
+    ClassType: TClass external name 'class';
   end;
 
   { TTypeInfoExtClass - Kind = tkExtClass }
@@ -368,13 +368,6 @@ 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;