(*=====================================================================================================================================================================================================
Structure de base des assistants de classe "étendus".

  type
    TObjectHelper = class helper for TObject
    private type
      TFields = class(THelperFields)
        Champ1 :integer;
      end;
    private
      function  Fields :TFields;
      function  GetChamp1: integer;
      procedure SetChamp1(const Value: integer);
    public
      property  Champ1 :integer read GetChamp1 write SetChamp1;
    end;

  implementation

  function TObjectHelper.Fields: TFields;
  begin
    Result := TFields.Get(Self);
  end;

  function TObjectHelper.GetChamp1: integer;
  begin
    Result := Fields.Champ1;
  end;

  procedure TObjectHelper.SetChamp1(const Value: integer);
  begin
    Fields.Champ1 := Value;
  end;
=====================================================================================================================================================================================================*)

unit HelperFields;

interface

uses
  Winapi.Windows, System.SysUtils, System.Classes, System.Generics.Collections, System.Rtti;

type
  THelperFields = class abstract
  public
    class function Get(aInstance :TObject) :pointer;
    constructor    Create; virtual;
  end;

implementation

type
  TVMI = class
  private
    Interceptor :TVirtualMethodInterceptor;
    RefCount    :integer;
  public
    procedure   Proxify(aInstance :TObject);
    function    Unproxify(aInstance :TObject) :boolean;
    constructor Create(aClass :TClass; aOnBefore :TInterceptBeforeNotify);
    destructor  Destroy; override;
  end;

  THelperFieldsClass = class of THelperFields;
  THelperDictionary  = TDictionary<THelperFieldsClass, pointer>;
  TObjectDictionary  = TDictionary<TObject, THelperDictionary>;
  TVMIDictionary     = TDictionary<string, TVMI>;

  THelperFieldsManager = class
  private
    class var
      Manager    :THelperFieldsManager;
      Lock       :TObject;
    var
      VMIList    :TVMIDictionary;
      ObjectList :TObjectDictionary;

    function GetFields(aInstance :TObject; aFieldsClass: THelperFieldsClass) :pointer;
    function Remove(aInstance :TObject) :boolean;
    class procedure VMIOnBefore(aInstance: TObject; aMethod: TRttiMethod; const aArgs: TArray<TValue>; out aDoInvoke: Boolean; out aResult: TValue);
  public
    constructor Create;
    destructor  Destroy; override;
    class function    Get(aInstance :TObject; aFieldsClass: THelperFieldsClass) :pointer;
    class constructor Create;
    class destructor  Destroy;
  end;

{ THelperFields }

constructor THelperFields.Create;
begin
end;

class function THelperFields.Get(aInstance: TObject): pointer;
begin
  Result := THelperFieldsManager.Get(aInstance, Self);
end;

{ TVMI }

constructor TVMI.Create(aClass :TClass; aOnBefore :TInterceptBeforeNotify);
begin
  inherited Create;
  Interceptor := TVirtualMethodInterceptor.Create(aClass);
  Interceptor.OnBefore := aOnBefore;
end;

destructor TVMI.Destroy;
begin
  Interceptor.Free;
  inherited;
end;

procedure TVMI.Proxify(aInstance: TObject);
begin
  // Peut déjà être surchargé si plusieurs assistants
  if aInstance.ClassType <> Interceptor.OriginalClass then Exit;

  Interceptor.Proxify(aInstance);
  Inc(RefCount);
end;

function TVMI.Unproxify(aInstance: TObject) :boolean;
begin
  Interceptor.Unproxify(aInstance);
  Dec(RefCount);
  Result := RefCount = 0;
end;

{ THelperFieldsManager }

class constructor THelperFieldsManager.Create;
begin
  Lock := TObject.Create;
end;

class destructor THelperFieldsManager.Destroy;
begin
  Lock.Free;
end;

constructor THelperFieldsManager.Create;
begin
  inherited;
  VMIList    := TVMIDictionary.Create;
  ObjectList := TObjectDictionary.Create;
end;

destructor THelperFieldsManager.Destroy;
begin
  VMIList.Free;
  ObjectList.Free;

  inherited;
end;

function THelperFieldsManager.GetFields(aInstance: TObject; aFieldsClass: THelperFieldsClass): pointer;
var
  Helpers :THelperDictionary;
begin
  // Création de la liste des assistants
  if not ObjectList.TryGetValue(aInstance, Helpers) then
  begin
    Helpers := THelperDictionary.Create;
    ObjectList.Add(aInstance, Helpers);
  end
  // ou récupération des champs si ils existent
  else if Helpers.TryGetValue(aFieldsClass, Result) then Exit;

  // Création des champs
  Result := aFieldsClass.Create;
  Helpers.Add(aFieldsClass, Result);

  // Création de l'intercepteur
  var VMI :TVMI;
  if not VMIList.TryGetValue(aInstance.ClassName, VMI) then
  begin
    VMI := TVMI.Create(aInstance.ClassType, VMIOnBefore);
    VMIList.Add(aInstance.ClassName, VMI);
  end;

  // Applique la surcharge (ProxyClass)
  VMI.Proxify(aInstance);
end;

class function THelperFieldsManager.Get(aInstance: TObject; aFieldsClass: THelperFieldsClass): pointer;
begin
  TMonitor.Enter(Lock);
  try
    if not Assigned(Manager) then
      Manager := THelperFieldsManager.Create;

    Result := Manager.GetFields(aInstance, aFieldsClass);
  finally
    TMonitor.Exit(Lock);
  end;
end;

function THelperFieldsManager.Remove(aInstance: TObject) :boolean;
var
  VMI     :TVMI;
  Helpers :THelperDictionary;
begin
  // Destruction des assistants
  if ObjectList.TryGetValue(aInstance, Helpers) then
  begin
    for var Helper in Helpers do
      TObject(Helper.Value).Free;

    Helpers.Free;
  end;

  // Retourne la libération possible du manager
  ObjectList.Remove(aInstance);
  Result := ObjectList.Count = 0;

  if VMIList.TryGetValue(aInstance.ClassName, VMI) then
  begin
    // Suppression de la surcharge et de l'intercepteur si plus utilisé
    if VMI.Unproxify(aInstance) then
    begin
      VMIList.Remove(aInstance.ClassName);
      TThread.CreateAnonymousThread(procedure
                                    begin
                                      VMI.Free;
                                    end).Start;
    end;
  end;
end;

class procedure THelperFieldsManager.VMIOnBefore(aInstance: TObject; aMethod: TRttiMethod; const aArgs: TArray<TValue>; out aDoInvoke: Boolean; out aResult: TValue);
begin
  // Seule FreeInstance nous intéresse
  if not SameText(aMethod.Name, 'FreeInstance') then Exit;

  TMonitor.Enter(Lock);
  try
    // Suppression et destruction du manager si plus utilisé
    if Manager.Remove(aInstance) then
      FreeAndNil(Manager);
  finally
    TMonitor.Exit(Lock);
  end;
end;

end.