TVirtualMethodInterceptor

[TiGü]

Kurios, Instance.ClassType zeigt im Debugger TSub an, meint aber zur Laufzeit, dass es nicht TSub ist?

Delphi-Quellcode:

unit Unit3;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, System.Rtti;

type
  TBase = class
    procedure testMethod(); virtual;
  end;

  TSub = class(TBase)
    procedure testMethod(); override;
  end;

  TForm3 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    obj: TSub;
    interceptor: TVirtualMethodInterceptor;
    procedure interceptAfter(Instance: TObject; Method: TRttiMethod; const Args: TArray<TValue>; var Result: TValue);
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form3: TForm3;

implementation

{$R *.dfm}


procedure TForm3.FormCreate(Sender: TObject);
var
  clazz: TClass;
begin
  obj := TSub.Create();
  clazz := obj.ClassType();
  interceptor := TVirtualMethodInterceptor.Create(clazz);
  interceptor.OnAfter := interceptAfter;
  interceptor.Proxify(obj);

  obj.testMethod();
end;

procedure TForm3.interceptAfter(Instance: TObject; Method: TRttiMethod; const Args: TArray<TValue>; var Result: TValue);
var
  Ptr1, Ptr2, Ptr3, Ptr4: Pointer;
  obj: TSub;
  MyMethod: TMethod;
begin
  Ptr1 := Method.CodeAddress;

  if Instance.ClassType = TBase then
  begin
    Ptr2 := Addr(TBase.testMethod);
    if Ptr1 = Ptr2 then
      ShowMessage('After base method');
  end;

  if Instance.ClassType = TSub then
  begin
    Ptr3 := Addr(TSub.testMethod);
    if Ptr1 = Ptr3 then
      ShowMessage('After sub method');
  end;
end;

{ TBase }

procedure TBase.testMethod;
begin

end;

{ TSub }

procedure TSub.testMethod;
begin
  inherited;

end;

end.