Non virtual Method interception

program Project1;

{$APPTYPE CONSOLE}

uses
  DDetours,
  Generics.Collections,
  Rtti,
  SysUtils,
  TypInfo;

type
  TFoo = class
    procedure Bar;
  end;

{ TFoo }

procedure TFoo.Bar;
begin
  Writeln('TFoo.Bar');
end;

type
  TDispatchKinds = set of TDispatchKind;
  TMemberVisibilities = set of TMemberVisibility;
  TMethodInterceptor = class
  private class var
    fContext: TRttiContext;
    type
      PMethodIntercept = ^TMethodIntercept;
      TMethodIntercept = record
        Method: TRttiMethod;
        Impl: TMethodImplementation;
        Intercept: Pointer;
      end;
  private
    fInterceptors: TArray<TMethodIntercept>;
    fInterceptedInstances: TList<TObject>;
    procedure HandleIntercept(intercept: Pointer; const args: TArray<TValue>;
      out result: TValue);
  public
    constructor Create(classType: TClass;
      visibilities: TMemberVisibilities = [mvPublic..mvPublished];
      dispatchKinds: TDispatchKinds = [dkStatic]);
    destructor Destroy; override;

    procedure Proxify(const instance: TObject);
    procedure Unproxify(const instance: TObject);
  end;

{ TMethodInterceptor }

constructor TMethodInterceptor.Create(classType: TClass;
  visibilities: TMemberVisibilities;
  dispatchKinds: TDispatchKinds);
var
  method: TRttiMethod;
  methods: TArray<TRttiMethod>;
  i: Integer;
begin
  inherited Create;
  fInterceptedInstances := TList<TObject>.Create;
  methods := fContext.GetType(classType).GetMethods;
  SetLength(fInterceptors, Length(methods));
  for i := 0 to High(methods) do
  begin
    method := methods[i];
    if method.Parent.AsInstance.MetaclassType = TObject then
      Continue;
    if not (method.DispatchKind in dispatchKinds) then
      Continue;
    if not (method.Visibility in visibilities) then
      Continue;
    fInterceptors[i].Method := method;
    fInterceptors[i].Impl := method.CreateImplementation(@fInterceptors[i], HandleIntercept);
    fInterceptors[i].Intercept :=
      InterceptCreate(method.CodeAddress, fInterceptors[i].Impl.CodeAddress);
  end;
end;

destructor TMethodInterceptor.Destroy;
var
  i: Integer;
begin
  for i := 0 to High(fInterceptors) do
  begin
    if fInterceptors[i].Method <> nil then
    begin
      fInterceptors[i].Impl.Free;
      InterceptRemove(fInterceptors[i].Intercept);
    end;
  end;
  fInterceptedInstances.Free;
  inherited;
end;

procedure TMethodInterceptor.HandleIntercept(intercept: Pointer;
  const args: TArray<TValue>; out result: TValue);
var
  method: TRttiMethod;
begin
  method := PMethodIntercept(intercept).Method;
  if fInterceptedInstances.Contains(args[0].AsObject) then
    Writeln('intercepted: ', method.ToString);
  if method.ReturnType <> nil then
    Invoke(PMethodIntercept(intercept).Intercept, args,
      method.CallingConvention, method.ReturnType.Handle)
  else
    Invoke(PMethodIntercept(intercept).Intercept, args,
      method.CallingConvention, nil);
end;

procedure TMethodInterceptor.Proxify(const instance: TObject);
begin
  if not fInterceptedInstances.Contains(instance) then
    fInterceptedInstances.Add(instance);
end;

procedure TMethodInterceptor.Unproxify(const instance: TObject);
begin
  fInterceptedInstances.Remove(instance);
end;

procedure Main;
var
  f: TFoo;
  i: TMethodInterceptor;
begin
  f := TFoo.Create;
  try
    i := TMethodInterceptor.Create(TFoo);
    try
      f.Bar;
      i.Proxify(f);
      f.Bar;
    finally
      i.Free;
    end;
  finally
    f.Free;
  end;
end;

begin
  ReportMemoryLeaksOnShutdown := True;
  try
    Main;
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
  Readln;
end.