Ann: Мониторинг создания объектов

_Vasilisk_
Дата: 15.01.2020 20:22:23
Понадобилось мне узнать какие объекты созданы в данный момент в программе.

В итоге появился такой класс

+
type
  TPatchObject = class
  strict private
    type
      TData = array[0..4] of Byte;
      TSavedInfo = record
        Start: Pointer;
        Data: TData;
      end;
  strict private
    class var
      FAfterConstructionInfo: TSavedInfo;
      FBeforeDestructionInfo: TSavedInfo;
  strict private
    class procedure NewAfterConstruction(ASender: TObject); static;
    class procedure NewBeforeDestruction(ASender: TObject); static;
    class procedure WriteAddr(var ASavedInfo: TSavedInfo; AData: Pointer; ASize: Cardinal); static;
    class procedure PatchProc(out ASavedInfo: TSavedInfo; AReserved, ANewAddr: Pointer); static;
    class procedure UnpatchProc(var ASavedInfo: TSavedInfo); static;
  public
    class procedure Init;
    class procedure DeInit;
    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;
  end;

{ TPatchObject }

class procedure TPatchObject.NewAfterConstruction(ASender: TObject);
begin
  // Do notify construction
  ASender.AfterConstruction;
end;

class procedure TPatchObject.NewBeforeDestruction(ASender: TObject);
begin
  // Do notify destruction
  ASender.BeforeDestruction;
end;

class procedure TPatchObject.WriteAddr(var ASavedInfo: TSavedInfo;
  AData: Pointer; ASize: Cardinal);
var
  LOldProtection: Cardinal;
begin
  Win32Check(VirtualProtect(ASavedInfo.Start, ASize, PAGE_READWRITE, @LOldProtection));
  try
    Move(ASavedInfo.Start^, ASavedInfo.Data, ASize);
    Move(AData^, ASavedInfo.Start^, ASize);
  finally
    Win32Check(VirtualProtect(ASavedInfo.Start, ASize, LOldProtection, @LOldProtection));
  end;
  Win32Check(FlushInstructionCache(GetCurrentProcess, ASavedInfo.Start, ASize));
end;

class procedure TPatchObject.PatchProc(out ASavedInfo: TSavedInfo; AReserved, ANewAddr: Pointer);
asm
  mov edx, [esp]   // Return point

  sub ecx, edx     // Offset from return point to new proc
  sub edx, 5       // Start write address
  mov [eax], edx

  mov edx, esp
  sub esp, 8       // Reserve 8 byte in stack

  sub edx, 4
  mov [edx], ecx
  dec edx
  mov [edx], byte ptr $E8     // call offset
  mov ecx, 5

  call WriteAddr
  add esp, 8
end;

class procedure TPatchObject.UnpatchProc(var ASavedInfo: TSavedInfo);
var
  LData: TData;
begin
  LData := ASavedInfo.Data;
  WriteAddr(ASavedInfo, @LData, SizeOf(LData));
  FillChar(ASavedInfo, SizeOf(ASavedInfo), 0);
end;

class procedure TPatchObject.Init;
var
  LObj: TObject;
begin
  LObj := Create;
  LObj.Free;
end;

class procedure TPatchObject.DeInit;
begin
  UnpatchProc(FAfterConstructionInfo);
  UnpatchProc(FBeforeDestructionInfo);
end;

procedure TPatchObject.AfterConstruction;
asm
  lea eax, FAfterConstructionInfo
  mov ecx, offset NewAfterConstruction
  jmp PatchProc
end;

procedure TPatchObject.BeforeDestruction;
asm
  lea eax, FBeforeDestructionInfo
  mov ecx, offset NewBeforeDestruction
  jmp PatchProc
end;

Схема использования:

Отредактировать методы NewAfterConstruction, NewBeforeDestruction для своей нотификации.
TPatchObject.Init;  // Включили мониторинг
......
TPatchObject.DeInit;  // Выключили мониторинг

Идея: при создании объекта вызывается такая процедура
function _AfterConstruction(const Instance: TObject): TObject;
begin
  try
    Instance.AfterConstruction;
    Result := Instance;
  except
    _BeforeDestruction(Instance, 1);
    raise;
  end;
end;
я поднимаюсь вверх по стеку и заменяю выделенную строку таким вызовом
TPatchObject.NewAfterConstruction(Instance)

Аналогично для _BeforeDestruction

Разрабатывалось и тестировалось на Delphi XE3 при компиляции под x86. Под x64 в текущем виде работать гарантировано не будет. Под другие версии Delphi скорее всего заработает без вопросов.


С уважением, Vasilisk
ziv-2014
Дата: 15.01.2020 21:16:41
Квейд
Дата: 16.01.2020 11:37:01
_Vasilisk_,

наверное, так можно сократить чуть

class procedure TPatchObject.Init;
begin
  Create.Free;
end;
_Vasilisk_
Дата: 16.01.2020 15:13:02
Квейд
наверное, так можно сократить чуть
Можно. Но отлаживать удобнее двумя операторами :)
KtoI
Дата: 18.01.2020 04:48:13
А чё у формы\панели уже не модно спрашивать Components ? Картинка с другого сайта.
DimaBr
Дата: 18.01.2020 10:47:09
KtoI
А чё у формы\панели уже не модно спрашивать Components ?

Если владелец - NIL то не у кого спрашивать
_Vasilisk_
Дата: 18.01.2020 17:59:55
KtoI
А чё у формы\панели уже не модно спрашивать Components ? Картинка с другого сайта.
List := TStringList.Create;
List.AddObject('One', TMemoryStream.Create);

Что и у кого будете спрашивать?