TVirtualMethodInterceptor 虚方法拦截

在delphi xe 的rtti.pas 中TVirtualMethodInterceptor .可以在程序运行时，动态创建一个派生的元类，该类通过创建一个新的虚拟方法表并将其填充以拦截调用和参数的存根（stub）来覆盖祖先中的每个虚拟方法。当用这个新的元类替换“祖先”的任何实例的元类引用时，用户可以随后拦截虚拟函数调用，即时更改参数，更改返回值，拦截和抑制异常或引发新异常，或者完全替换调用基础方法。从概念上讲，它有点类似于.NET和Java中的动态代理。这就像能够在运行时从类派生，重写方法（但不添加新的实例字段），然后将实例的运行时类型更改为该新的派生类一样。

这有什么用呢，我想就是随时拦截其它方法调用，当然缺点就是仅限于虚方法。

1示列：

uses SysUtils, Rtti;
{$apptype console}
type
  TFoo = class
    // Frob doubles x and returns the new x + 10
    function Frob(var x: Integer): Integer; virtual;
  end;

function TFoo.Frob(var x: Integer): Integer;
begin
  x := x * 2;
  Result := x + 10;
end;

procedure WorkWithFoo(Foo: TFoo);
var
  a, b: Integer;
begin
  a := 10;
  Writeln('  before: a = ', a);
  try
    b := Foo.Frob(a);
    Writeln('  Result = ', b);
    Writeln('  after:  a = ', a);
  except
    on e: Exception do
      Writeln('  Exception: ', e.ClassName);
  end;
end;

procedure P;
var
  foo: TFoo;
  vmi: TVirtualMethodInterceptor;
begin
  vmi := nil;
  foo := TFoo.Create;
  try
    Writeln('Before hackery:');
    WorkWithFoo(foo);
    
    vmi := TVirtualMethodInterceptor.Create(foo.ClassType);
    
    vmi.OnBefore := procedure(Instance: TObject; Method: TRttiMethod;
      const Args: TArray<TValue>; out DoInvoke: Boolean; out Result: TValue)
    var
      i: Integer;
    begin
      Write('[before] Calling ', Method.Name, ' with args: ');
      for i := 0 to Length(Args) - 1 do
        Write(Args[i].ToString, ' ');
      Writeln;
    end;
    
    // Change foo's metaclass pointer to our new dynamically derived
    // and intercepted descendant
    vmi.Proxify(foo);
    
    Writeln('After interception:');
    WorkWithFoo(foo);
  finally
    foo.Free;
    vmi.Free;
  end;
end;

begin
  P;
end.

程序输出，可以看出，调用动所有虚类都起作用:

Before hackery:
  before: a = 10
  Result = 30
  after:  a = 20
After interception:
  before: a = 10
[before] Calling Frob with args: 10 
  Result = 30
  after:  a = 20
[before] Calling BeforeDestruction with args: 
[before] Calling FreeInstance with args:

 

2.示例：

procedure P;
var
  foo: TFoo;
  vmi: TVirtualMethodInterceptor;
  ctx: TRttiContext;
  m: TRttiMethod;
begin
  vmi := nil;
  foo := TFoo.Create;
  try
    Writeln('Before hackery:');
    WorkWithFoo(foo);
    
    vmi := TVirtualMethodInterceptor.Create(foo.ClassType);
    
    m := ctx.GetType(TFoo).GetMethod('Frob');
    vmi.OnBefore := procedure(Instance: TObject; Method: TRttiMethod;
      const Args: TArray; out DoInvoke: Boolean; out Result: TValue)
    begin
      if Method = m then
      begin
        DoInvoke := False;
        Result := 42;
        Args[0] := -Args[0].AsInteger;
      end;
    end;


Here, I inhibit the invocation and hard-code the result to 42, while negating the first argument. The proof is in the output:

Before hackery:
  before: a = 10
  Result = 30
  after:  a = 20
After interception:
  before: a = 10
  Result = 42
  after:  a = -10

 

拦截函数中也可以触发异常:

    vmi.OnBefore := procedure(Instance: TObject; Method: TRttiMethod;
      const Args: TArray; out DoInvoke: Boolean; out Result: TValue)
    begin
      if Method = m then
        raise Exception.Create('Aborting');
    end;

And output:

Before hackery:
  before: a = 10
  Result = 30
  after:  a = 20
After interception:
  before: a = 10
  Exception: Exception

It's not limited to interception before the logically inherited call, but also interception after the call, again with the opportunity to fiddle with arguments and return value:

//运行后拦截，修改out,var变量及返回值结果

    m := ctx.GetType(TFoo).GetMethod('Frob');
    vmi.OnAfter := procedure(Instance: TObject; Method: TRttiMethod;
      const Args: TArray; var Result: TValue)
    begin
      if Method = m then
        Result := Result.AsInteger + 1000000;
    end;

And output:

Before hackery:
  before: a = 10
  Result = 30
  after:  a = 20
After interception:
  before: a = 10
  Result = 1000030
  after:  a = 20

And if the inherited implementation raises an exception, that can even be squashed:

调用触发异常时，拦截处理，可以处理异常并正常返回，也可以触发异常。

function TFoo.Frob(var x: Integer): Integer;
begin
  raise Exception.Create('Abort');
end;

// ...
    m := ctx.GetType(TFoo).GetMethod('Frob');
    vmi.OnException := procedure(Instance: TObject; Method: TRttiMethod;
      const Args: TArray; out RaiseException: Boolean;
      TheException: Exception; out Result: TValue)
    begin
      if Method = m then
      begin
        RaiseException := False;
        Args[0] := Args[0].AsInteger * 2;
        Result := Args[0].AsInteger + 10;
      end;
    end;

Output:

Before hackery:
  before: a = 10
  Exception: Exception
After interception:
  before: a = 10
  Result = 30
  after:  a = 20

One thing the TVirtualMethodInterceptor class doesn't have, however, is a way to unhook (unproxify) the object. If the object is never unhooked, it's important that the object doesn't outlive the interceptor, because the interceptor needs to allocate executable memory in order to create the little stubs with which it redirects method calls to the events. Fortunately, it's pretty trivial to do:

//原理探究：

    PPointer(foo)^ := vmi.OriginalClass;

Another point: the class inheritance chain is changed by the hooking process. This can be shown easily:

//...
    Writeln('After interception:');
    WorkWithFoo(foo);
    
    Writeln('Inheritance chain while intercepted:');
    cls := foo.ClassType;
    while cls <> nil do
    begin
      Writeln(Format('  %s (%p)', [cls.ClassName, Pointer(cls)]));
      cls := cls.ClassParent;
    end;
    
    PPointer(foo)^ := vmi.OriginalClass;
    
    Writeln('After unhooking:');
    WorkWithFoo(foo);
    
    Writeln('Inheritance chain after unhooking:');
    cls := foo.ClassType;
    while cls <> nil do
    begin
      Writeln(Format('  %s (%p)', [cls.ClassName, Pointer(cls)]));
      cls := cls.ClassParent;
    end;
// ...

And output:

Before hackery:
  before: a = 10
  Exception: Exception
After interception:
  before: a = 10
  Result = 30
  after:  a = 20
Inheritance chain while intercepted:
  TFoo (01F34DA8)
  TFoo (0048BD84)
  TObject (004014F0)
After unhooking:
  before: a = 10
  Exception: Exception
Inheritance chain after unhooking:
  TFoo (0048BD84)
  TObject (004014F0)