I'm trying to intercept the construction/destruction of every object on my system. For this I'm using Detours Lib to create the runtime patch. It seem to work the some way as FastCode approach does. And I think it should have the same limitation (could not patch methods with opcode smaller than 5 bytes). But the reason I choose this lib is because it creates a pointer to the hooked method, and I can call it using this pointer.
So, to do my patches I'm trying to use TObject.NewInstance, and TObject.FreeInstance.
It's all ok with TObject.NewInstance, but when I try to do the same for TObject.FreeInstance, TObject.Free, TObject.BeforeDestruction (in this case I think it is because the limitation I described above), I get access violation.
Here is a code example:
var
TrampolineGetMemory: function: TObject;
TrampolineFreeInstance: procedure = nil;
implementation
type
TObjectHack = class(TObject)
function NNewInstanceTrace: TObject;
procedure NFreeInstance;
end;
procedure TObjectHack.NFreeInstance;
begin
TrampolineFreeInstance; {ERROR: apparently the jmp does not go to a valid addr}
end;
function TObjectHack.NNewInstanceTrace: TObject;
begin
Result := TrampolineGetMemory; {everything ok here}
end;
initialization
@TrampolineGetMemory := InterceptCreate(@TObject.NewInstance, @TObjectHack.NNewInstanceTrace);
@TrampolineFreeInstance := InterceptCreate(@TObject.FreeInstance, @TObjectHack.NFreeInstance);
finalization
InterceptRemove(@TrampolineGetMemory);
InterceptRemove(@TrampolineFreeInstance);
Some one can see something I'm doing wrong ?
FreeInstance is an instance method rather than a simple procedure. What's more, it is a virtual method, and detouring a virtual method typically involves vtable modification, as I understand it. Simply put, trying to hook FreeInstance is the wrong way to instrument instance destruction.
Instead, make a detour of System._ClassDestroy or TObject.CleanupInstance. An example of the former:
{$APPTYPE CONSOLE}
uses
System.SysUtils,
DDetours;
var
TrampolineClassDestroy: procedure(const Instance: TObject);
procedure DetouredClassDestroy(const Instance: TObject);
begin
// this is called from inside InterceptCreate, hence the test for
// TrampolineClassDestroy being assigned
if Assigned(TrampolineClassDestroy) then begin
TrampolineClassDestroy(Instance);
Writeln(Instance.ClassName, ' detour installed');
end else begin
Writeln(Instance.ClassName, ' detour not yet installed');
end;
end;
function System_ClassDestroy: Pointer;
asm
MOV EAX, offset System.@ClassDestroy
end;
procedure Main;
begin
TrampolineClassDestroy := InterceptCreate(System_ClassDestroy, @DetouredClassDestroy);
TObject.Create.Free;
end;
begin
try
Main;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
Output
TThreadsIDList detour not yet installed TIntercept detour not yet installed TObject detour installed TDictionary detour installed TObject detour installed @TList`1.Pack$23$ActRec detour installed TMoveArrayManager detour installed TList detour installed TRegGroup detour installed TMoveArrayManager detour installed TList detour installed TObject detour installed TThreadList detour installed TMoveArrayManager detour installed TList detour installed TObject detour installed TThreadList detour installed TMoveArrayManager detour installed TObjectList detour installed TRegGroups detour installed TOrdinalIStringComparer detour installed TThreadLocalCounter detour installed TMultiReadExclusiveWriteSynchronizer detour installed TComponent.Create@$929$ActRec detour installed TDelegatedComparer detour installed TObject detour installed TObject detour installed TObject detour installed EInvalidPointer detour installed