delphi – 将TObject.AfterConstruction重定向到其他过程的问题

unit Unit109;

interface

uses
  Windows;

implementation

uses
  SyncObjs,SysUtils;

type
  PJump = ^TJump;
  TJump = packed record
    OpCode: Byte;
    Distance: Pointer;
  end;

  TObjectHack = class(TObject)
  public
    procedure AfterConstruction;
  end;

function GetMethodAddress(AStub: Pointer): Pointer;
const
  CALL_OPCODE = $E8;
begin
  if PBYTE(AStub)^ = CALL_OPCODE then
  begin
    Inc(Integer(AStub));
    Result := Pointer(Integer(AStub) + SizeOf(Pointer) + PInteger(AStub)^);
  end
  else
    Result := nil;
end;

procedure AddressPatch(const ASource,ADestination: Pointer);
const
  JMP_OPCODE = $E9;
  SIZE = SizeOf(TJump);
var
  NewJump: PJump;
  OldProtect: Cardinal;
begin
  if VirtualProtect(ASource,SIZE,PAGE_EXECUTE_READWRITE,OldProtect) then
  begin
    NewJump := PJump(ASource);
    NewJump.OpCode := JMP_OPCODE;
    NewJump.Distance := Pointer(Integer(ADestination) - Integer(ASource) - 5);

    FlushInstructionCache(GetCurrentProcess,ASource,SizeOf(TJump));
    VirtualProtect(ASource,OldProtect,@OldProtect);
  end;
end;

procedure OldAfterConstruction;
asm
  call TObject.AfterConstruction;
end;

{ TCriticalSectionHack }
procedure TObjectHack.AfterConstruction;
begin
end;

initialization
  AddressPatch(GetMethodAddress(@OldAfterConstruction),@TObjectHack.AfterConstruction);

end.

PatchCodeDWORD(PDWORD(Integer(Self) + vmtAfterConstruction),DWORD(@TObjectHack.AfterConstruction));


procedure PatchCodeDWORD(ACode: PDWORD; AValue: DWORD);
var
  LRestoreProtection,LIgnore: DWORD;
begin
  if VirtualProtect(ACode,SizeOf(ACode^),LRestoreProtection) then
  begin
    ACode^ := AValue;
    VirtualProtect(ACode,LRestoreProtection,LIgnore);
    FlushInstructionCache(GetCurrentProcess,ACode,SizeOf(ACode^));
  end;
end;

已编辑 – 正在努力增加和减少项目数量.
使其工作只是将该单元作为您的dpr的第一个单元.
现在,我将优化一些方法,并在此处输出我想要的输出. (我不会重新发布帖子,没有必要)
但是,如果你想使用,可以免费测试和报告错误.
如果您想测试一个简单的输出,程序SaveInstancesToFile,它会在您的应用程序路径中使用计数器的输出创建一个test.txt文件.

unit ObjectCounter;

  {  Develop by rodrigofrezino@gmail.com
     Stackoverflow: https://stackoverflow.com/users/225010/saci
     Please,any bug let me know}

interface

  procedure SaveInstancesToFile;

implementation

uses
  Windows,SysUtils,Classes,TypInfo;

type

  PClassVars = ^TClassVars;
  TClassVars = class(TObject)
  private
    class var ListClassVars: TList;
  public
    InstanceCount: integer;
    BaseClassName: string;
    constructor Create;

    class procedure SaveToDisk;
  end;

  PJump = ^TJump;
  TJump = packed record
    OpCode: Byte;
    Distance: Pointer;
  end;

  TObjectHack = class(TObject)
  private
    class procedure SetClassVars(AClassVars: TClassVars);
    class function GetClassVars: TClassVars;

    procedure IncCounter;
    procedure DecCounter;
    procedure OldFreeInstace;
  public
    class function InitInstance(Instance: Pointer): TObject;
  end;

var
  FOldFreeInstance: Pointer;

procedure SaveInstancesToFile;
begin
  TClassVars.SaveToDisk;
end;

function GetMethodAddress(AStub: Pointer): Pointer;
const
  CALL_OPCODE = $E8;
begin
  if PBYTE(AStub)^ = CALL_OPCODE then
  begin
    Inc(Integer(AStub));
    Result := Pointer(Integer(AStub) + SizeOf(Pointer) + PInteger(AStub)^);
  end
  else
    Result := nil;
end;

procedure AddressPatch(const ASource,@OldProtect);
  end;
end;

procedure PatchCodeDWORD(ACode: PDWORD; AValue: DWORD);
var
  LRestoreProtection,SizeOf(ACode^));
  end;
end;

procedure OldAfterConstruction;
asm
  call TObject.InitInstance;
end;

{ TCriticalSectionHack }
procedure TObjectHack.DecCounter;
begin
  if (Self.ClassType <> TClassVars) then
    Dec(GetClassVars.InstanceCount);
  OldFreeInstace;
end;

class function TObjectHack.GetClassVars: TClassVars;
begin
  Result := PClassVars(Integer(Self) + vmtAutoTable)^;
end;

class procedure TObjectHack.SetClassVars(AClassVars: TClassVars);
begin
  AClassVars.BaseClassName := Self.ClassName;
  PatchCodeDWORD(PDWORD(Integer(Self) + vmtAutoTable),DWORD(AClassVars));
end;

procedure RegisterClassVarsSupport(const Classes: array of TObjectHack);
var
  LClass: TObjectHack;
  LRestoreProtection: DWORD;
  LIgnore: DWORD;
  LVMT: Pointer;
begin
  for LClass in Classes do
    if LClass.GetClassVars = nil then
    begin
      LClass.SetClassVars(TClassVars.Create);

      //Change de mvt to object mvt
      LVMT := PPointer(Integer(TObject) + vmtFreeInstance)^;
      if VirtualProtect(LVMT,SizeOf(LVMT^),LRestoreProtection) then
      begin
        LVMT :=  @TObjectHack.DecCounter;
        VirtualProtect(LVMT,LIgnore);
        FlushInstructionCache(GetCurrentProcess,LVMT,SizeOf(LVMT^));
      end;
    end
    else
      raise Exception.CreateFmt('Class %s has automated section or duplicated registration.',[LClass.ClassName]);
end;

procedure TObjectHack.IncCounter;
begin
  if (Self.ClassType = TClassVars) then
    Exit;

  if GetClassVars = nil then
    RegisterClassVarsSupport(Self);

  Inc(GetClassVars.InstanceCount);
end;

class function TObjectHack.InitInstance(Instance: Pointer): TObject;
asm
        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        MOV     EBX,EAX
        MOV     EDI,EDX
        STOSD
        MOV     ECX,[EBX].vmtInstanceSize
        XOR     EAX,EAX
        PUSH    ECX
        SHR     ECX,2
        DEC     ECX
        REP     STOSD
        POP     ECX
        AND     ECX,3
        REP     STOSB
        MOV     EAX,EDX
        MOV     EDX,ESP
@@0:    MOV     ECX,[EBX].vmtIntfTable
        TEST    ECX,ECX
        JE      @@1
        PUSH    ECX
@@1:    MOV     EBX,[EBX].vmtParent
        TEST    EBX,EBX
        JE      @@2
        MOV     EBX,[EBX]
        JMP     @@0
@@2:    CMP     ESP,EDX
        JE      @@5
@@3:    POP     EBX
        MOV     ECX,[EBX].TInterfaceTable.EntryCount
        ADD     EBX,4
@@4:    MOV     ESI,[EBX].TInterfaceEntry.VTable
        TEST    ESI,ESI
        JE      @@4a
        MOV     EDI,[EBX].TInterfaceEntry.IOffset
        MOV     [EAX+EDI],ESI
@@4a:   ADD     EBX,TYPE TInterfaceEntry
        DEC     ECX
        JNE     @@4
        CMP     ESP,EDX
        JNE     @@3
@@5:    MOV     EBX,EAX
        CALL    TObjectHack.IncCounter
        MOV     EAX,EBX
        POP     EDI
        POP     ESI
        POP     EBX
end;

procedure TObjectHack.OldFreeInstace;
asm
  call FOldFreeInstance;
end;

procedure InitFreeInstance;
begin
  FOldFreeInstance := PPointer(Integer(TObject) + vmtFreeInstance)^;
end;

{ TClassVars }

constructor TClassVars.Create;
begin
  ListClassVars.Add(Self);
end;

class procedure TClassVars.SaveToDisk;
var
  LStringList: TStringList;
  i: Integer;
begin                               
  LStringList := TStringList.Create;
  try
    LStringList.Add('CLASS | NUMBER OF INSTANCES');
    for i := 0 to ListClassVars.Count -1 do
      LStringList.Add(TClassVars(ListClassVars.Items[I]).BaseClassName + '|' + IntToStr(TClassVars(ListClassVars.Items[I]).InstanceCount));

    LStringList.SaveToFile(ExtractFilePath(ParamStr(0)) + 'test.txt');
  finally
    FreeAndNil(LStringList);
  end;
end;

initialization
  TClassVars.ListClassVars := TList.Create;
  InitFreeInstance;
  AddressPatch(GetMethodAddress(@OldAfterConstruction),@TObjectHack.InitInstance);

end.