Playing around with TVirtualMethodInterceptor

Beyond bug fixes, one of the few things new to XE1 was TVirtualMethodInterceptor, a class for hooking virtual method calls made against an arbitrary object. Some months ago I had a quick try of it. Finding Barry Kelly’s example just a little too simple and abstract, I wrote my own – a (very) basic logger. The interface went like this:

uses
  SysUtils, Classes, TypInfo, RTTI;

type
  IVirtualMethodLogger = interface
    procedure StopLogging(ObjectStillAlive: Boolean = True);
  end;

function LogVirtualMethodCalls(Obj: TObject; Output: TTextWriter;
  OwnOutput: Boolean = False): IVirtualMethodLogger; overload;
function LogVirtualMethodCalls(Obj: TObject; const LogFile: string;
  Append: Boolean = True): IVirtualMethodLogger; overload;

And the implementation like this:

type
  TVirtualMethodLogger = class(TInterfacedObject, IVirtualMethodLogger)
  strict private
    FInterceptor: TVirtualMethodInterceptor;
    FObject: TObject;
    FOwnOutput: Boolean;
    FOutput: TTextWriter;
  public
    constructor Create(Obj: TObject; Output: TTextWriter;
      OwnOutput: Boolean);
    destructor Destroy; override;
    procedure StopLogging(ObjectStillAlive: Boolean = True);
  end;

constructor TVirtualMethodLogger.Create(Obj: TObject; Output: TTextWriter;
  OwnOutput: Boolean);
begin
  inherited Create;
  FObject := Obj;
  FOutput := Output;
  FOwnOutput := OwnOutput;
  FInterceptor := TVirtualMethodInterceptor.Create(Obj.ClassType);
  FInterceptor.OnBefore :=
    procedure(Instance: TObject; Method: TRttiMethod;
      const Args: TArray<TValue>; out DoInvoke: Boolean; out Result: TValue)
    begin
      Output.Write(DateTimeToStr(Now));
      Output.WriteLine(' %s.%s called with %d argument(s)',
        [Obj.ClassName, Method.Name, Length(Args)]);
    end;
  FInterceptor.OnException :=
    procedure(Instance: TObject; Method: TRttiMethod;
      const Args: TArray<TValue>; out RaiseException: Boolean;
      AException: Exception; out Result: TValue)
    begin
      Output.WriteLine('Exception raised (' + AException.ClassName +
        '): ' + AException.Message);
    end;
  FInterceptor.Proxify(Obj);
end;

destructor TVirtualMethodLogger.Destroy;
begin
  StopLogging;
  inherited Destroy;
end;

procedure TVirtualMethodLogger.StopLogging(ObjectStillAlive: Boolean = True);
begin
  if FInterceptor = nil then Exit;
  try
    if ObjectStillAlive then
    {$IF RTLVersion >= 23}
      FInterceptor.Unproxify(FObject);
    {$ELSE}
      PPointer(FObject)^ := FInterceptor.OriginalClass;
    {$IFEND}
    FreeAndNil(FInterceptor);
    FOutput.Flush;
  finally
    if FOwnOutput then FOutput.Free;
  end;
end;

function LogVirtualMethodCalls(Obj: TObject; Output: TTextWriter;
  OwnOutput: Boolean = False): IVirtualMethodLogger;
begin
  Result := TVirtualMethodLogger.Create(Obj, Output, OwnOutput);
end;

function LogVirtualMethodCalls(Obj: TObject; const LogFile: string;
  Append: Boolean = True): IVirtualMethodLogger;
begin
  Result := TVirtualMethodLogger.Create(Obj, TStreamWriter.Create(LogFile, Append), True);
end;

The idea was then to use it with a VCL form:

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, VMLog;

type
  TForm1 = class(TForm)
    btnShowMessage: TButton;
    btnRaiseException: TButton;
    procedure btnShowMessageClick(Sender: TObject);
    procedure btnRaiseExceptionClick(Sender: TObject);
  strict private
    FLogger: IVirtualMethodLogger;
  public
    constructor Create(AOwner: TComponent); override;
    procedure MsgProc; virtual;
    procedure BadProc; virtual;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

constructor TForm1.Create(AOwner: TComponent);
begin
  FLogger := LogVirtualMethodCalls(Self, ChangeFileExt(ParamStr(0), '.log'), False);
  inherited;
end;

procedure TForm1.MsgProc;
begin
  ShowMessage('Hello virtual method logging world');
end;

procedure TForm1.btnShowMessageClick(Sender: TObject);
begin
  MsgProc;
end;

procedure TForm1.BadProc;
begin
  raise EProgrammerNotFound.Create('Dozy, dozy...');
end;

procedure TForm1.btnRaiseExceptionClick(Sender: TObject);
begin
  BadProc;
end;

Unfortunately, this didn’t work as expected: the application just hung!

Motivated more recently to look at it again, I found the problem – the ordinary life of a VCL form involves frequent calls to virtual methods that have untyped parameters (in particular, DefaultHandler and Dispatch), and TVirtualMethodInterceptor doesn’t handle these properly. Since TVirtualMethodInterceptor already filters out various things, the easiest fix is just to have it filter out such methods too.

To do this, take a copy of Rtti.pas (XE1) or System.Rtti.pas (XE2), open it up, and add the following helper function immediately before the implementation for TVirtualMethodInterceptor.CreateProxyClass:

function HasUntypedParameter(AMethod: TRttiMethod): Boolean;
var
  Param: TRttiParameter;
begin
  for Param in AMethod.GetParameters do
    if Param.ParamType = nil then Exit(True);
  Exit(False);
end;

Next, amend TVirtualMethodInterceptor.CreateProxyClass itself. Specifically, immediately after

    if not m.HasExtendedInfo then
      Continue;

add

    if HasUntypedParameter(m) then
      Continue;

This wil now allow the class to at least run when hooking a form. Nonetheless, you should keep in mind that my demo won’t actually log that much, even if you have the form do lots more things. This is due to TVirtualMethodInterceptor relying upon extended RTTI, and RTTI only being generated for public and published methods by default. Since virtual methods (especially in the VCL) tend to have protected visibility, TVirtualMethodInterceptor simply won’t be able to hook a good fair few.

PS: I’ve QCed the bug (see report no. 101873).