#1346. Draft of objects spy. Размышления. Заготовочка для следилки за объектами

https://bitbucket.org/lulinalex/mindstream/src/c3db0b6368040992e0f4eae64854d6e4ea34844a/Lab/RefCount/l3ObjectsSpy.pas?at=B284_Inheritance_Try&fileviewer=file-view-default

unit l3ObjectsSpy;

interface

procedure Test;

implementation

uses
 System.SysUtils
 , System.Classes
 , System.Generics.Collections
 , WinApi.Windows
 ;

type
 Tl3SpiedObjects = class(TList<Pointer>)
 end;//Tl3SpiedObjects

 Tl3ObjectsSpy = class(Tl3SpiedObjects)
  strict private
   class var g_Instance: Tl3ObjectsSpy;
  public
   class procedure LogNew(anObject: TObject);
   class procedure LogFree(anObject: TObject);
   class procedure HookClasses;
   class procedure CheckUnfreed;
 end;//Tl3ObjectsSpy

class procedure Tl3ObjectsSpy.LogNew(anObject: TObject);
begin
 if (g_Instance = nil) then
  g_Instance := Tl3ObjectsSpy.Create;
 g_Instance.Add(anObject);
end;

class procedure Tl3ObjectsSpy.LogFree(anObject: TObject);
begin
 if (g_Instance <> nil) then
  g_Instance.Remove(anObject);
end;

procedure DoHookClasses; forward;

class procedure Tl3ObjectsSpy.HookClasses;
begin
 DoHookClasses;
end;

class procedure Tl3ObjectsSpy.CheckUnfreed;
begin
 if (g_Instance <> nil) then
  if (g_Instance.Count > 0) then
   WriteLn(g_Instance.Count);
end;

type
 PMem = PAnsiChar;

function NewInstancePtr(aClass: TClass): PPointer;
begin
 Result := PPointer(PMem(aClass) + vmtNewInstance);
end;

function FreeInstancePtr(aClass: TClass): PPointer;
begin
 Result := PPointer(PMem(aClass) + vmtFreeInstance);
end;

procedure LogNew(anObject: TObject);
begin
 Tl3ObjectsSpy.LogNew(anObject);
end;

procedure LogFree(anObject: TObject);
begin
 Tl3ObjectsSpy.LogFree(anObject);
end;

type
 THackObject = class(TObject)
  public
   class function NewInstance: TObject; override;
   procedure FreeInstance; override;
 end;//THackObject

class function THackObject.NewInstance: TObject;
begin
 Result := inherited NewInstance;
 LogNew(Result);
end;

procedure THackObject.FreeInstance;
begin
 LogFree(Self);
 inherited FreeInstance;
end;

type
 THackInterfacedObject = class(TInterfacedObject)
  public
   class function NewInstance: TObject; override;
   procedure FreeInstance; override;
 end;//THackInterfacedObject

class function THackInterfacedObject.NewInstance: TObject;
begin
 Result := inherited NewInstance;
 LogNew(Result);
end;

procedure THackInterfacedObject.FreeInstance;
begin
 LogFree(Self);
 inherited FreeInstance;
end;

procedure HookPtr(aPointer: PPointer; aValue: Pointer);
var
 l_Old : DWORD;
 l_New : DWORD;
begin
 VirtualProtect(aPointer, SizeOf(Pointer), PAGE_EXECUTE_READWRITE, l_Old);
 try
  aPointer^ := aValue;
 finally
  VirtualProtect(aPointer, SizeOf(Pointer), l_Old, l_New);
 end;
end;

function HookPtrDone(aPointer: PPointer; aFrom: Pointer; aTo: Pointer): Boolean;
begin
 Result := (aPointer^ = aFrom);
 if Result then
  HookPtr(aPointer, aTo);
end;

function HookNew(aClass: TClass): Boolean;
var
 l_Ptr : PPointer;
begin
 Result := true;
 l_Ptr := NewInstancePtr(aClass);
 if HookPtrDone(l_Ptr, @TObject.NewInstance, @THackObject.NewInstance) then
  Exit;
 if HookPtrDone(l_Ptr, @TInterfacedObject.NewInstance, @THackInterfacedObject.NewInstance) then
  Exit;
 Result := false;
end;

function HookFree(aClass: TClass): Boolean;
var
 l_Ptr : PPointer;
begin
 Result := true;
 l_Ptr := FreeInstancePtr(aClass);
 if HookPtrDone(l_Ptr, @TObject.FreeInstance, @THackObject.FreeInstance) then
  Exit;
 if HookPtrDone(l_Ptr, @TInterfacedObject.FreeInstance, @THackInterfacedObject.FreeInstance) then
  Exit;
 Result := false;
end;

function HookClassPrim(aClass: TClass): Boolean;
begin
 Result := false;
 if HookNew(aClass) then
  Result := true;
 if HookFree(aClass) then
  Result := true;
end;

procedure HookClass(aClass: TClass);
var
 l_Class : TClass;
begin
 l_Class := aClass;
 while (l_Class <> nil) do
 begin
  if not HookClassPrim(l_Class) then
   Exit;
  l_Class := l_Class.ClassParent;
 end;//l_Class <> nil
end;

procedure DoHookClasses;
begin
 HookClass(TObject);
 HookClass(TStream);
 HookClass(TInterfacedObject);
 HookClass(TThread);
 HookClass(TComponent);
 //HookClass(TExternalThread);
end;

procedure Test;
var
 l_O : TObject;
 l_S : TStream;
 l_IO : TInterfacedObject;
 l_T : TThread;
begin
 //HookClasses;
 l_O := TObject.Create;
 FreeAndNil(l_O);

 l_S := TStream.Create;
 FreeAndNil(l_S);

 l_IO := TInterfacedObject.Create;
 FreeAndNil(l_IO);

 l_T := TThread.Create;
 FreeAndNil(l_T);
end;

initialization
 Tl3ObjectsSpy.HookClasses;
finalization
 Tl3ObjectsSpy.CheckUnfreed;
end.

(+) http://edn.embarcadero.com/article/28344

Вызывать CheckUnfreed в секции финализации на самом деле бессмысленно, т.к. могли ещё не вызваться другие секции финализации, в которых ещё не были освобождены объекты. И следилка покажет утечку, которой на самом деле нет.

Надо встраиваться в NotifyUnloadModule, который вызывается после всех секций инициализации. Я над этим сейчас работаю.

Ну и потокозащищённость надо конечно добавить.

Ну и ещё надо запоминать адрес места аллокации. Чтобы потом можно было найти по коду проблемное место. Это тоже делается достаточно просто.

Можно даже стек снять, но это сильно скажется на производительности.

Вскорости опубликую доработанную версию данного класса.

Ещё появилась мысль, что можно поставить Hook на классы своего приложения и включать его в ini-файле и в хуке звать методы из скриптов, которые можно править не останавливая приложения. Таким образом через подобные "разьёмы" снимать диагностику с классов реализации не останавливая и не перекомпилируя приложение.

Над этим я тоже работаю.

Update. Опробовал сегодня следилку "в боевых условиях".Даже с раскруткой стека. Удобно. Нашёл пару утечек. Скоро выложу обновлённый вариант.