How to combine two methods with the same structure using RTTI?

[bravesofts 28]

I’m working on a class TMethodsInjector that uses RTTI to inject a method into a method-type property (like events). If a method is already assigned, I want to combine it with the new one (same signature) and assign the result.

The key part is here:

if not Assigned(LOldMethod.Code) then
  LCombined := LNewMethod
else
  LCombined := GenerateCombinedMethod(LRttiProperty, LOldMethod, LNewMethod);

I need help implementing GenerateCombinedMethod — it should dynamically wrap both LOldMethod and LNewMethod (same structure) into a single TMethod that invokes both in order.
Is there a clean way to do this using RTTI, without knowing the method signature in advance?

my full class code is:
 

unit API.Methods.Injector;

interface

uses
  System.Classes,
  System.SysUtils,
  System.Rtti,
  System.TypInfo;

type
  TMethodsInjector = class
  public
    class procedure InjectMethod(aTarget: TObject; const aPropertyName: string;
      aMethodAddress: Pointer; aMethodData: TObject); static;
  end;

implementation

{ TMethodsInjector }

class procedure TMethodsInjector.InjectMethod(aTarget: TObject; const aPropertyName: string;
  aMethodAddress: Pointer; aMethodData: TObject);
var
  LRttiContext: TRttiContext;
  LRttiType: TRttiType;
  LRttiProperty: TRttiProperty;
  LOldMethod, LNewMethod, LCombined: TMethod;
begin
  if not Assigned(aTarget) then
    Exit;

  LRttiContext := TRttiContext.Create;
  try
    LRttiType := LRttiContext.GetType(aTarget.ClassType);
    LRttiProperty := LRttiType.GetProperty(aPropertyName);

    if Assigned(LRttiProperty) and (LRttiProperty.PropertyType.TypeKind = tkMethod) then
    begin
      LOldMethod := GetMethodProp(aTarget, aPropertyName);

      LNewMethod.Code := aMethodAddress;
      LNewMethod.Data := aMethodData;

      if not Assigned(LOldMethod.Code) then
        LCombined := LNewMethod
      else
        LCombined := GenerateCombinedMethod(LRttiProperty, LOldMethod, LNewMethod);

      SetMethodProp(aTarget, aPropertyName, LCombined);

    end
    else
      raise Exception.CreateFmt('Property %s not found or is not a method on %s',
        [aPropertyName, aTarget.ClassName]);
  finally
    LRttiContext.Free;
  end;
end;

end.

 

[bravesofts 28]

i succeed to have this:

  TMethodsInjector = class
  private
    class var
      fM1, fM2: TMethod;

    class procedure InvokeCombined;
    class function CombineMethods(const M1, M2: TMethod): TMethod; static;
  public
    class procedure InjectPropertyMethod(aTarget: TObject; const aPropertyName: string;
      aMethodAddress: Pointer; aMethodData: TObject; aOverrideOldIfAssigned: Boolean = False); static;
  end;

implementation

{ TMethodsInjector }

class procedure TMethodsInjector.InvokeCombined;
type
  TProcOfObject = procedure of object;
begin
  if Assigned(fM1.Code) then TProcOfObject(fM1)();
  if Assigned(fM2.Code) then TProcOfObject(fM2)();
end;

class function TMethodsInjector.CombineMethods(const M1, M2: TMethod): TMethod;
begin
  fM1 := M1;
  fM2 := M2;

  TMethod(Result).Code := @InvokeCombined;
  TMethod(Result).Data := fM1.Data;
end;

class procedure TMethodsInjector.InjectPropertyMethod(aTarget: TObject; const aPropertyName: string;
  aMethodAddress: Pointer; aMethodData: TObject; aOverrideOldIfAssigned: Boolean);
var
  LRttiContext: TRttiContext;
  LRttiType: TRttiType;
  LRttiProperty: TRttiProperty;
  LOldMethod, LNewMethod, LCombined: TMethod;
begin
  if not Assigned(aTarget) then
    Exit;

  LRttiContext := TRttiContext.Create;
  try
    LRttiType := LRttiContext.GetType(aTarget.ClassType);
    LRttiProperty := LRttiType.GetProperty(aPropertyName);

    if Assigned(LRttiProperty) and (LRttiProperty.PropertyType.TypeKind = tkMethod) then
    begin
      LOldMethod := GetMethodProp(aTarget, aPropertyName);

      LNewMethod.Code := aMethodAddress;
      LNewMethod.Data := aMethodData;

      LCombined := LNewMethod; // Case old is nil or (assigned and must override)

      if Assigned(LOldMethod.Code) and not aOverrideOldIfAssigned then
        LCombined := CombineMethods(LOldMethod, LNewMethod);

      SetMethodProp(aTarget, aPropertyName, LCombined);

    end
    else
      raise Exception.CreateFmt('Property %s not found or is not a method on %s',
        [aPropertyName, aTarget.ClassName]);
  finally
    LRttiContext.Free;
  end;
end;

end.

the code works perfectly, but in case of mousedown i got AccessViolation error when i release my mouse from the dragging form,

here is the code:

    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    procedure InternalOnMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure InjectClickToButton(AButton: TButton; aWithOverride: Boolean = False);
  public
    { Public declarations }
  end;

implementation

uses
  API.Methods.Injector;

{$R *.dfm}

procedure GlobalOnClickHandler(Sender: TObject);
begin
  ShowMessage('Injected Click!');
end;

procedure TMainView.InjectClickToButton(AButton: TButton; aWithOverride: Boolean);
begin
  TMethodsInjector.InjectPropertyMethod(
    AButton,
    'OnClick',
    @GlobalOnClickHandler,
    Self,  // or Self if inside a class
    aWithOverride
  );
end;

procedure TMainView.BtnInjectWithoutOverrideClick(Sender: TObject);
begin
  InjectClickToButton(BtnTarget);
end;

procedure TMainView.BtnInjectWithOverrideClick(Sender: TObject);
begin
  InjectClickToButton(BtnTarget, True);
end;

procedure TMainView.BtnTargetClick(Sender: TObject);
begin
  ShowMessage('Hi from Default');
end;

procedure TMainView.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  ReleaseCapture;
end;

procedure TMainView.InternalOnMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  Perform(WM_SYSCOMMAND, $F012, 0);
end;

procedure TMainView.BtnIjectFormDragClick(Sender: TObject);
begin
  TMethodsInjector.InjectPropertyMethod(
    Self,
    'OnMouseDown',
    @TMainView.InternalOnMouseDown,
    Self
  );
end;

end.

 

Edited 41 minutes ago by bravesofts
remove unecessary overload