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

[bravesofts 29]

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 29]

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 yesterday at 09:58 AM by bravesofts
remove unecessary overload

[Der schöne Günther 336]

Can you show an example, how you would typically make use of it?

[bravesofts 29]

2 hours ago, Der schöne Günther said:

Can you show an example, how you would typically make use of it?

Yes, here’s a practical use case:

Example: Suppose I have a legacy application with over 100 forms, and I need to log every time a form is shown. Instead of modifying each form manually or forcing them to inherit from a new base class, I use TMethodsInjector to dynamically inject a logging procedure into the OnShow event of each form at runtime — all without changing the existing form code.

This approach is especially useful in scenarios where inheritance or code edits aren't feasible — such as working with third-party components, plugin-based modules, or dynamically loaded forms.

That said, this class is still in a beta/concept stage and hasn’t been fully battle-tested in real-world production scenarios. If you have a more robust or elegant way to achieve this kind of dynamic behavior injection without modifying the original source, I’d be genuinely glad to hear and learn from it!

[Anders Melander 1973]

8 hours ago, bravesofts said:

Is there a clean way to do this using RTTI, without knowing the method signature in advance?

No.

 

You have no way of knowing what the caller has put on the stack (or in the registers), what the called method does with it, what it returns and how.

You can probably make it work for very simple delegate types (TNotifyEvent for example) but I think it would be better to find a less fragile solution.

[dormky 4]

This is related : https://stackoverflow.com/questions/4652958/is-there-a-way-to-log-every-gui-event-in-delphi

 

I wrote this unit based on it, it might give you ideas. Note that this is not perf-tested and is probably quite bad in that regard with all the looping of rtti info. Also might crash if you have cases I have not covered when interpreting RTTI.

 

unit UEventLogger;

// See https://stackoverflow.com/questions/4652958/is-there-a-way-to-log-every-gui-event-in-delphi
// Call TEventLogger.AddEventInterceptors in every FormCreate.
// Since TEventLogger is a compnent, it gets destroyed when his parent gets destroyed.

interface

uses
  EEvents,
  EException,
  Classes,
  Controls,
  Generics.Collections,
  Rtti;

type
  OnEventLoggerEvent = reference to procedure(const event: string; const controlName: string);
  
  TEventLogger = class(TComponent)
  private
    EventName: string;
    originalEvent: TNotifyEvent;
    
    procedure HandleEvent(Sender: TObject);
    constructor Create(Control: TControl; EventName: string; originalEvent: TNotifyEvent);
    
    class procedure RecurseControls(Control: TControl; ExaminedControls: TList<TControl>; context: TRttiContext);

  public
    class procedure AddEventInterceptors(Control: TControl);
    class procedure RegisterEurekaLogWriter();

    class var logs: TArray<string>;
    class var OnEvent: OnEventLoggerEvent;
  end;

implementation

uses
  TypInfo,
  SysUtils,
  Windows;

type
  TStupidEL = class
    procedure OnReproduceRequest(AExceptionInfo: TEurekaExceptionInfo; var AReproduceText: String; var ACallNextHandler: Boolean);
  end;

var
  h: TStupidEL;

constructor TEventLogger.Create(Control: TControl; EventName: string; originalEvent: TNotifyEvent);
begin
  inherited Create(Control);
  self.EventName := EventName;
  self.originalEvent := originalEvent;
end;

procedure TEventLogger.HandleEvent(Sender: TObject);
begin
  // Log the event : datetime - event name - control name
  logs := logs + [FormatDateTime('dd/mm/yy hh:nn:ss.zzz', Now()) + ' - HandleEvent ' + EventName + ' on ' + (Sender as TControl).Owner.Name+'.'+(Sender as TControl).Name];
  if Assigned(OnEvent) then OnEvent(EventName, (Sender as TControl).Owner.Name+'.'+(Sender as TControl).Name);
  
  // Forward to the original handler
  originalEvent(Sender);
end;

class procedure TEventLogger.RecurseControls(Control: TControl; ExaminedControls: TList<TControl>; context: TRttiContext);
var
  theTypeInfo: TRttiInstanceType;
  theProperty: TRttiProperty;
  interceptor: TEventLogger;
  theEvent: TNotifyEvent;
  theValue: TValue;
  field: TRttiField;
  newControl: TControl;
  instanceType: TRttiInstanceType;
begin
  ExaminedControls.add(Control);

  theTypeInfo := context.GetType(Control.ClassInfo) as TRttiInstanceType;

  for theProperty in theTypeInfo.GetProperties do begin
    if (not theProperty.IsWritable) then continue;
    if (not (theProperty.PropertyType.ToString.StartsWith('TNotifyEvent'))) then continue;
    if (theProperty.Name = 'OnClick') or (theProperty.Name = 'OnDblClick') then begin
      theValue := theProperty.GetValue(Control);
      theEvent := nil;
      if not theValue.IsEmpty then
        theEvent := theValue.AsType<TNotifyEvent>();
      if Assigned(theEvent) then begin
        interceptor := TEventLogger.Create(Control, theProperty.Name, theEvent);
        theProperty.SetValue(Control, TValue.From<TNotifyEvent>(interceptor.HandleEvent));
      end;
    end
  end;

  try
    for field in theTypeInfo.GetFields do begin
      if field.name.StartsWith('F') then continue; // All the private F fields ; we're only interested in our boutons and things like that.
      if field.FieldType = nil then continue; // Undefined types, like pointers (^TQCTestAll)
      if field.FieldType.TypeKind = tkClass then begin
        instanceType := field.FieldType As TRttiInstanceType;
        if instanceType.MetaclassType.InheritsFrom(TControl) then begin
          newControl := nil;
          theValue := field.GetValue(Control);
          if not theValue.IsEmpty then
            newControl := theValue.AsType<TControl>;
          if Assigned(newControl) then
            if not ExaminedControls.Contains(newControl) then
              RecurseControls(newControl, ExaminedControls, context);
        end;
      end;
    end;
  except
    on E: EAccessViolation do
      // For some reason we can get an AccessViolation while looping through the fields. Seemed to happen
      // on ParentControl.
  end;
end;

class procedure TEventLogger.AddEventInterceptors(Control: TControl);
var
  examinedObjects: TList<TControl>;
begin
  examinedObjects := TList<TControl>.Create();
  TEventLogger.RecurseControls(Control, examinedObjects, TRttiContext.Create());
  examinedObjects.Free;
end;

procedure TStupidEL.OnReproduceRequest(AExceptionInfo: TEurekaExceptionInfo; var AReproduceText: String; var ACallNextHandler: Boolean);
begin
  AReproduceText := sLineBreak + String.join(sLineBreak, TEventLogger.logs);
  TEventLogger.logs := [];
end;

class procedure TEventLogger.RegisterEurekaLogWriter();
begin
  RegisterEventReproduceRequest(h.OnReproduceRequest);
end;

end.

 

Edited 5 hours ago by dormky