Get method's name as string from the code inside that method
Playing with ReturnAddress I discovered that it will be pretty easy to implement retrieval of name of an object's method without any RTTI or debug info. Could be useful for logging.
Alas, it relies on class layout internals but that's the only way to do. Code bases on TObject.MethodAddress
// Get address of currently executed code
function GetCurrentAddress: Pointer;
begin
Result := ReturnAddress;
end;
// Get name of class method that contains the given address.
// Note that it has to utilize some internals
function GetMethodName(AClass: TClass; Address: Pointer): string; overload;
type // copy declaration from System's impl section
PMethRec = ^MethRec;
MethRec = packed record
recSize: Word;
methAddr: Pointer;
nameLen: Byte;
{ nameChars[nameLen]: AnsiChar }
end;
var
LMethTablePtr: Pointer;
LMethCount: Word;
LMethEntry, LResultMethEntry: PMethRec;
begin
Result := '';
{ Obtain the method table and count }
LMethTablePtr := PPointer(PByte(AClass) + vmtMethodTable)^;
if LMethTablePtr = nil then // no methods...
Exit;
LMethCount := PWord(LMethTablePtr)^;
if LMethCount = 0 then // no methods...
Exit;
Inc(PWord(LMethTablePtr));
// Get all method entries and find max method entry addr that is less (or equal - very unlikely tho) than Address
LMethEntry := LMethTablePtr;
LResultMethEntry := nil;
while LMethCount > 0 do
begin
// Only consider methods starting before the Address
if PByte(LMethEntry.methAddr) <= PByte(Address) then
begin
// Not assigned yet
if (LResultMethEntry = nil) or
// Current entry is closer to Address, reassign the variable
(PByte(LMethEntry.methAddr) > PByte(LResultMethEntry.methAddr)) then
LResultMethEntry := LMethEntry;
end;
Dec(LMethCount);
LMethEntry := Pointer(PByte(LMethEntry) + LMethEntry.recSize); // get next
end;
if LResultMethEntry <> nil then
Result := string(PShortString(@LResultMethEntry.nameLen)^);
end;
// Get name of object's method that contains the given address
function GetMethodName(AObject: TObject; Address: Pointer): string; overload;
begin
Result := GetMethodName(AObject.ClassType, Address);
end;
Test cases:
program Project2;
{$APPTYPE CONSOLE}
{$R *.res}
type
TBaseClass = class
procedure method; virtual;
end;
TTestClass = class(TBaseClass)
procedure foo;
procedure method; override;
procedure method1; inline;
procedure bar;
class procedure classMethod;
end;
procedure TBaseClass.method;
begin
end;
procedure TTestClass.method;
var s: string;
begin
Assert(GetMethodName(Self, GetCurrentAddress) = 'method', 'override');
// do some stuff to get another address
str(123, s);
Assert(GetMethodName(Self, GetCurrentAddress) = 'method', 'override');
end;
procedure TTestClass.foo;
begin
Assert(GetMethodName(Self, GetCurrentAddress) = 'foo', 'usual - 1st');
end;
procedure TTestClass.bar;
begin
Assert(GetMethodName(Self, GetCurrentAddress) = 'bar', 'usual - last');
end;
procedure TTestClass.method1;
begin
Assert(GetMethodName(Self, GetCurrentAddress) <> 'method1', 'inline');
end;
class procedure TTestClass.classMethod;
begin
Assert(GetMethodName(Self, GetCurrentAddress) = 'classMethod', 'class method');
end;
var
cl: TTestClass;
begin
cl := TTestClass.Create;
cl.foo;
cl.method;
cl.method1; // ! inlined methods won't be detected !
cl.bar;
cl.classMethod;
TTestClass.classMethod;
Writeln('All tests OK');
readln;
end.
