インスタンスの数を調べる。

発端

だ、だめだ。かなり粘ったけど TObject がインスタンス化された数、かつ、生存数を取得するなんてできぬ… #cross2014

— HOSOKAWA Jun (@pik) 13 Jan 2014

というツイートがあったんですが、確かインスタンスの生成と破棄時にそれぞれ呼ばれるメソッドがあったような…というおぼろげな記憶を元にやってみたらできました。

実装

unit Lyna.InstanceInfo;

interface

uses
  Winapi.Windows, System.Generics.Collections;

var
  TotalObjCount: Cardinal;
  ObjCountDictionary: TDictionary<TClass,Cardinal>;

implementation

function _MyInitInstance(Self: TClass; Instance: Pointer): TObject;
asm
  // System.pasからTObject.InitInstanceの中身をコピペしてね☆
end;

function MyInitInstance(Self: TClass; Instance: Pointer): TObject;
var
  cnt: Cardinal;
begin
  Result := _MyInitInstance(Self, Instance);

  Inc(TotalObjCount);
  if ObjCountDictionary.TryGetValue(Self, cnt) then
    ObjCountDictionary[Self] := cnt + 1
  else
    ObjCountDictionary.Add(Self, 1);
end;

procedure _MyCleanupInstance(Self: TObject);
asm
  // System.pasからTObject.CleanupInstanceの中身をコピペしてね☆
end;

procedure MyCleanupInstance(Self: TObject);
var
  cnt: Cardinal;
begin
  Dec(TotalObjCount);
  if ObjCountDictionary.TryGetValue(Self.ClassType, cnt) then
    ObjCountDictionary[Self.ClassType] := cnt - 1;

  _MyCleanupInstance(Self);
end;

type
  TOrgCodes = array[0..4] of Byte;

var
  InitInstanceOrgCodes: TOrgCodes;
  CleanupInstanceOrgCodes: TOrgCodes;

procedure HookObj;

  procedure JmpHookProc(Target: Pointer; ReplaceProc: Pointer; out OrgCodes: TOrgCodes);
  var
    oldProtect: Cardinal;
  begin
    VirtualProtect(Target, 5, PAGE_READWRITE, oldProtect);
    Move(Target^, OrgCodes, 5);
    PByte(Target)^ := $E9;
    PInteger(Integer(Target)+1)^ := Integer(ReplaceProc) - Integer(Target) - 5;
    VirtualProtect(Target, 5, oldProtect, oldProtect);
    FlushInstructionCache(GetCurrentProcess, Target, 5);
  end;

begin
  JmpHookProc(@TObject.InitInstance, @MyInitInstance, InitInstanceOrgCodes);
  JmpHookProc(@TObject.CleanupInstance, @MyCleanupInstance, CleanupInstanceOrgCodes);
end;

procedure UnhookObj;

  procedure UnhookProc(Target: Pointer; const OrgCodes: TOrgCodes);
  var
    oldProtect: Cardinal;
  begin
    VirtualProtect(Target, 5, PAGE_READWRITE, oldProtect);
    Move(OrgCodes, Target^, 5);
    VirtualProtect(Target, 5, oldProtect, oldProtect);
    FlushInstructionCache(GetCurrentProcess, Target, 5);
  end;

begin
  UnhookProc(@TObject.InitInstance, InitInstanceOrgCodes);
  UnhookProc(@TObject.CleanupInstance, CleanupInstanceOrgCodes);
end;

initialization
  ObjCountDictionary := TDictionary<TClass,Cardinal>.Create;
  HookObj;
finalization
  UnhookObj;
  ObjCountDictionary.Free;
end.

使い方

プロジェクトファイルのusesの先頭にこのユニットを書き加えるだけでOKです。TotalObjCountで全インスタンスの数、ObjCountDictionaryでクラスごとのインスタンスの数が得られます。

仕組み

Delphiではクラスのインスタンスを生成する際、コンストラクタの内部でTObjectのメソッドがいくつか呼ばれてます。
その中身はメモリを確保するメソッドだったりその中身を初期化するメソッドだったりするわけですが、ここではその初期化するメソッド（InitInstance）に処理を組み込むことでインスタンスをカウントしています。同様にデストラクタの中でもその反対の処理が走るので、その中の後始末をするメソッド（CleanupInstance）に処理を組み込んでます。

ただ、100％処理できるわけではないです。Delphiはインスタンスの生成と破棄用の内部メソッドであるNewInstanceとFreeInstanceが仮想メソッドなので、その中でInitInstanceやCleanupInstanceを呼ばないクラスの場合は捕捉できません。
もっともこれらのメソッドを呼ばないクラスというのは相当特殊かつ稀なので、ほとんどの場合において気にする必要はないと思います。

本日のまとめ

やってみて思ったけどこれ面白い！
全インスタンスのおはようからおやすみまでをチェックできるので、何気に応用の幅が広そう。