paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-09 07:28:26 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Get method by address. Patch by Lipinast Lekrisov

Browse Source
This commit is contained in:
Michaël Van Canneyt 2024-12-17 17:57:17 +01:00
parent 6c1c3e35ee
commit 072cb55315
2 changed files with 29 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
packages/rtl-objpas/src/inc/rtti.pp
View File

@ -394,6 +394,7 @@ type
function GetMethods: TRttiMethodArray; virtual; overload;
function GetMethods(const aName: string): TRttiMethodArray; overload; virtual;
function GetMethod(const aName: String): TRttiMethod; virtual;
function GetMethod(aCodeAddress: CodePointer): TRttiMethod; overload; virtual;
function ToString : RTLString; override;
property IsInstance: boolean read GetIsInstance;
property IsManaged: boolean read GetIsManaged;
@ -7507,7 +7508,7 @@ end;
function TRttiType.GetMethod(const aName: String): TRttiMethod;
var
methods: specialize TArray<TRttiMethod>;
methods: TRttiMethodArray;
method: TRttiMethod;
begin
methods := GetMethods;
@ -7517,6 +7518,18 @@ begin
Result := Nil;
end;
function TRttiType.GetMethod(aCodeAddress: CodePointer): TRttiMethod;
var
methods: TRttiMethodArray;
method: TRttiMethod;
begin
methods := GetMethods;
for method in methods do
if method.CodeAddress = aCodeAddress then
Exit(method);
Result := Nil;
end;
function TRttiType.ToString: RTLString;
begin
Result:=Name;

15
packages/rtl-objpas/tests/tests.rtti.pas
View File

@ -109,6 +109,7 @@ type
Procedure TestProperties;
Procedure TestDeclaredMethods;
Procedure TestMethods;
Procedure TestMethodByAddress;
Procedure TestMethodsInherited;
Procedure TestPrivateFieldAttributes;
Procedure TestProtectedFieldAttributes;
@ -1822,6 +1823,20 @@ begin
CheckMethod('Full declared',1, A[0],'PublicAdditionalMethod',mvPublic);
end;
procedure TTestClassExtendedRTTI.TestMethodByAddress;
var
Obj : TRttiObject;
RttiData : TRttiInstanceType absolute obj;
M1,M2 : TRttiMethod;
begin
Obj:=FCtx.GetType(TAdditionalMethodClassRTTI.ClassInfo);
M1:=RttiData.GetMethod('PublicAdditionalMethod');
AssertNotNull('have method',m1);
M2:=RttiData.GetMethod(@TAdditionalMethodClassRTTI.PublicAdditionalMethod);
AssertSame('Correct method ',M1,M2);
end;
procedure TTestClassExtendedRTTI.TestMethodsInherited;
Var
A : TRttiMethodArray;