TVirtualMethodInterceptor - Wie kann ich zwei Methoden vergleichen?

[Zacherl]

Zitat von Der schöne Günther:

Als ersten Schritt wollte ich den String-Vergleich rausbekommen, denn kein Delphi-Refactoring-Tool der Welt erwischt so etwas, sollte die Methode einmal umbenannt werden (oder?).

Vollkommen korrekt, ja.

Die Delphi VMT ist COM-kompatibel, was bedeutet, dass sie einfach als array of Pointer implementiert ist und auch immer sein wird. Hierbei zeigt das erste Element auf die erste virtuelle Methode, das zweite Element auf die zweite virtuelle Methode, etc.

Hab mal aus dem Kopf ganz schnell was zusammengehackt:

Delphi-Quellcode:

type
  TBaseClass = class
  public
    procedure Virt1(const S: String); virtual;
    procedure Virt2(const S: String); virtual;
    procedure Virt3(const S: String); virtual;
  end;

  TDerivedClass = class(TBaseClass)
  public
    procedure Virt2(const S: String); override;
  end;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    class var FOriginalVirt2: procedure(Self: TBaseClass; const S: String);
    class procedure CallbackVirt2(Self: TBaseClass; const S: String); static;
  public
    procedure Hook(Instance: TObject; Target, Callback: Pointer; var OriginalFunc: Pointer);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TBaseClass }

procedure TBaseClass.Virt1(const S: String);
begin
  ShowMessage('A1: ' + S);
end;

procedure TBaseClass.Virt2(const S: String);
begin
  ShowMessage('A2: ' + S);
end;

procedure TBaseClass.Virt3(const S: String);
begin
  ShowMessage('A3: ' + S);
end;

{ TDerivedClass }

procedure TDerivedClass.Virt2(const S: String);
begin
  ShowMessage('B2: ' + S);
end;

class procedure TForm1.CallbackVirt2(Self: TBaseClass; const S: String);
begin
  FOriginalVirt2(Self, '[Intercepted]' + S);
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  C: TBaseClass;
begin
  C := TDerivedClass.Create;
  try
    C.Virt2('test');
    // Wichtig ist hier `TDerivedClass.Virt2` und nicht `TBaseClass.Virt2` zu verwenden!
    Hook(C, @TDerivedClass.Virt2, @CallbackVirt2, @FOriginalVirt2);
    C.Virt2('test');
  finally
    C.Free;
  end;
end;

procedure TForm1.Hook(Instance: TObject; Target, Callback: Pointer; var OriginalFunc: Pointer);
type
  PVMT = ^TVMT;
  TVMT = array[0..0] of Pointer;
var
  VMT: PVMT;
  I: Integer;
  OldProtect: DWord;
begin
  VMT := Pointer(Pointer(Instance)^);
  I := 0;
  // Achtung: Endlosschleife, wenn Target nicht existiert!
  while (VMT^[I] <> Target) do
  begin
    Inc(I);
  end;
  ShowMessage(I.ToString);
  OriginalFunc := VMT^[I];
  VirtualProtect(VMT, I * SizeOf(Pointer), PAGE_READWRITE, OldProtect);
  VMT^[I] := Callback;
  VirtualProtect(VMT, I * SizeOf(Pointer), OldProtect, OldProtect);
end;