delphi - 为什么Detours lib无法在虚拟方法上运行？

我试图拦截系统上每个对象的构造/破坏。为此，我使用Detours Lib创建运行时补丁。它似乎可以像FastCode方法那样工作。而且我认为它应该具有相同的限制（无法修补操作码小于5个字节的方法）。
但是我选择这个库的原因是因为它创建了一个指向钩子方法的指针，所以我可以使用该指针来调用它。

因此，要进行补丁，我尝试使用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);

有人可以看到我做错了吗？

最佳答案

FreeInstance是实例方法，而不是简单的过程。而且，它是一种虚拟方法，据我所知，绕道虚拟方法通常涉及vtable修改。简而言之，尝试挂钩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弯路尚未安装
尚未安装TIntercept绕行
TObject绕道安装
TDictionary绕行安装
TObject绕道安装
@ TList`1.Pack $ 23 $ ActRec绕行安装
安装了TMoveArrayManager弯路
已安装TList弯路
安装了TRegGroup弯路
安装了TMoveArrayManager弯路
已安装TList弯路
TObject绕道安装
安装了TThreadList弯路
安装了TMoveArrayManager弯路
已安装TList弯路
TObject绕道安装
安装了TThreadList弯路
安装了TMoveArrayManager弯路
TObjectList绕行安装
安装了TRegGroups弯路
已安装TOrdinalIStringComparer弯路
安装了TThreadLocalCounter弯路
安装了TMultiReadExclusiveWriteSynchronizer弯路
已安装TComponent.Create@$929$ActRec弯路
已安装TDelegatedComparer弯路
TObject绕道安装
TObject绕道安装
TObject绕道安装
安装了EInvalidPointer弯路

关于delphi - 为什么Detours lib无法在虚拟方法上运行？，我们在Stack Overflow上找到一个类似的问题：https://stackoverflow.com/questions/29608243/