paweld/pas2js
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/pas2js.git synced 2025-08-22 17:39:03 +02:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Henrique Gottardi Werlang 2024-03-01 16:38:23 -03:00
parent d43629c689
commit 5f5e39c1f6
2 changed files with 53 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

92
packages/rtl/src/rtti.pas
View File

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

9
packages/rtl/src/typinfo.pas
View File

@ -308,8 +308,8 @@ type
TTypeInfoClass = class external name 'rtl.tTypeInfoClass'(TTypeInfoStruct) TTypeInfoClass = class external name 'rtl.tTypeInfoClass'(TTypeInfoStruct)
public public
ClassType: TClass external name 'class';
Ancestor: TTypeInfoClass external name 'ancestor'; Ancestor: TTypeInfoClass external name 'ancestor';
ClassType: TClass external name 'class';
end; end;
{ TTypeInfoExtClass - Kind = tkExtClass } { TTypeInfoExtClass - Kind = tkExtClass }
@ -368,13 +368,6 @@ type
procedure &set(const value: JSValue); procedure &set(const value: JSValue);
end; 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); EPropertyError = class(Exception);
function GetTypeName(TypeInfo: TTypeInfo): string; function GetTypeName(TypeInfo: TTypeInfo): string;