blob: ca49f4c9315331d0c96d5ce4bab47dec7fbf20c8 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
|
{ %version=1.1 }
{$mode objfpc}
uses
classes;
type
{$M+}
TTestCaseTest = class(TObject)
published
procedure TestSetUp;
procedure TestAsString;
end;
procedure TTestCaseTest.TestSetup;
begin
writeln('TestSetup');
end;
procedure TTestCaseTest.TestAsString;
begin
writeln('TestAsString');
end;
function GetMethodNameTableAddress(AClass: TClass): Pointer;
type
TMethodNameRec = packed record
name : pshortstring;
addr : pointer;
end;
TMethodNameTable = packed record
count : dword;
entries : packed array[0..0] of TMethodNameRec;
end;
pMethodNameTable = ^TMethodNameTable;
var
methodTable : pMethodNameTable;
vmt: TClass;
begin
vmt := aClass;
if assigned(vmt) then
begin
methodTable := pMethodNameTable((Pointer(vmt) + vmtMethodTable)^);
Result := methodTable;
end;
end;
begin
writeln('Address of TestSetUp : ',ptrint(TTestCaseTest.MethodAddress('TestSetUp')));
writeln('Address of TestAsString : ',ptrint(TTestCaseTest.MethodAddress('TestAsString')));
if not (Assigned(GetMethodNameTableAddress(TTestCaseTest))) then
halt(1);
end.
|
