delphi - 为什么 Detours lib 不适用于虚拟方法？

Question

我正在尝试拦截系统上每个对象的构造/销毁。为此，我使用 Detours Lib创建运行时补丁。它似乎以某种方式工作 FastCode方法确实如此。我认为它应该有相同的限制(无法修补操作码小于 5 个字节的方法)。 但我选择这个库的原因是因为它创建了一个指向 Hook 方法的指针，我可以使用这个指针来调用它。

因此，为了进行修补，我尝试使用 TObject.NewInstance 和 TObject.FreeInstance。

TObject.NewInstance 没问题，但是当我尝试对 TObject.FreeInstance、TObject.Free、TObject.BeforeDestruction 执行相同操作时(在这种情况下，我认为这是因为我上面描述的限制)，我可以访问违规。

这里是一个代码示例:

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);

有人能看出我做错了什么吗？

Answer 1

FreeInstance 是一个实例方法而不是一个简单的过程。更重要的是，它是一个虚拟方法，而绕过虚拟方法通常会涉及到vtable修改，据我了解。简而言之，尝试 Hook FreeInstance 是检测实例销毁的错误方法。

相反，请绕道使用System._ClassDestroy或TObject.CleanupInstance。前者的一个例子:

{$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.

输出

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