Querying for the implementing object from an interface (2)

Getting down to the actual implementation of interface-to-object casts in D2010, Allen Bauer reports that the solution was actually quite simple. Basically, given interface casting already used IInterface.QueryInterface, and the default implementation of IInterface.QueryInterface called TObject.GetInterface, ‘all’ that was needed was for TObject.GetInterface to check for a special GUID, outputting Self if found. This made me wonder — can we use the same technique in earlier versions of Delphi? Well, one thing we can’t do is override the semantics of the ‘as’ and ‘is’ operators, or indeed hard casts of the form TMyObject(IntfRef). Nonetheless, a long-established alternative to casting for interfaces is the Supports RTL function, added in D6 IIRC. What we can do, then, is to add an overload to Supports that takes an interface reference as its first parameter and a class type as its second one. While this isn’t as neat as the D2010 solution, it can be as generic.

Taking one step at a time though, start up the IDE and create a new console project. In the first instance, we’ll try to implement the functionality just for one class and at the level of QueryInterface — a proof of concept if you will:

program IntfToObjTest;

{$APPTYPE CONSOLE}

uses
  SysUtils;

const
  IID_GETIMPLEMENTOR: TGUID = '{4C12C697-6FE2-4263-A2D8-85034F0D0E01}';

type
  IMyInterface = interface
  ['{EAB2D50E-A246-41FB-819F-3FF80ABE7C92}']
    procedure TestIntf;
  end;

  TMyObject = class(TInterfacedObject, IInterface, IMyInterface)
  protected
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    procedure TestIntf;
  public
    MsgText: string;
    procedure TestObj;
  end;

function TMyObject.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if IsEqualGUID(IID, IID_GETIMPLEMENTOR) then
  begin
    Pointer(Obj) := Self;
    Result := 0;
  end
  else
    Result := inherited QueryInterface(IID, Obj)
end;

procedure TMyObject.TestIntf;
begin
  Writeln('IMyInterface.TestIntf called');
end;

procedure TMyObject.TestObj;
begin
  Writeln('TMyObject.TestObj called (MsgText = "', MsgText, '")');
end;

procedure Test;
var
  Intf: IMyInterface;
  Obj: TMyObject;
begin
  Intf := TMyObject.Create;
  Intf.TestIntf;
  if not Supports(Intf, IID_GETIMPLEMENTOR, Obj) then
    WriteLn('ERROR: call to Supports failed')
  else
  begin
    Obj.MsgText := 'Hello from the caller!';
    Obj.TestObj;
  end;
end;

begin
  try
    Test;
    Writeln;
    Write('Press ENTER to exit');
    Readln;
  except
    on E:Exception do
      Writeln(E.Classname, ': ', E.Message);
  end;
end.

It works! Well, ‘works’ with two (rather large!) limitations — the Supports call does no type checking, and in a ‘real’ situation, every class would need to re-implement QueryInterface for the Supports call to work at all. So, for the next step, let’s lessen the first issue with a custom overload of Supports:

function Supports(const Intf: IInterface; ClassType: TClass; out Obj): Boolean; overload;
begin
  Result := (Intf.QueryInterface(IID_GETIMPLEMENTOR, Obj) = 0) and
    TObject(Obj).InheritsFrom(ClassType);
  if not Result then Pointer(Obj) := nil;
end;

How, though, can we now make this function work without requiring every object to have explicitly re-implemented QueryInterface? The cleanest way is probably to patch TObject.GetInterface, though there is one problem – in patching it, we lose the original implemention, so a bit of copy and pasting from System.pas is required:

function NewGetInterface(Self: TObject; const IID: TGUID; out Obj): Boolean;
begin
  Result := IsEqualGUID(IID, IID_GETIMPLEMENTOR);
  if Result then
  begin
    Pointer(Obj) := Self;
    Exit;
  end;
  //!!!paste (or adapt) the original TObject.GetInterface code here
end;

procedure DoPatch;
type
  TProcRec = packed record
    case Integer of
      0: (OpCode: Word; Attr: ^Pointer);
      1: (Jump: Byte; Offset: Integer);
  end;
const
  VPDataSize = 5;
var
  OldProtect: DWORD;
  Ptr: ^TProcRec;
begin
  Ptr := @TObject.GetInterface;
  //get the method's real address if the app was compiled with packages
  if Ptr.OpCode = $25FF then
    Pointer(Ptr) := Ptr.Attr^;
  //do the actual patching
  if VirtualProtect(Ptr, VPDataSize, PAGE_EXECUTE_READWRITE, OldProtect) then
  begin
    Ptr.Jump := $E9;
    Ptr.Offset := Integer(@NewGetInterface) - (Integer(Ptr) + VPDataSize);
    VirtualProtect(Ptr, VPDataSize, OldProtect, @OldProtect);
    FlushInstructionCache(GetCurrentProcess, Ptr, VPDataSize);
  end;
end;

initialization
  DoPatch;

I’ve upload a version of the code here. Use it at your own risk though, especially given it’s something I’ve rattled out fairly quickly. In fact, I rattled it out so quickly that the original version had a severe bug stemming from my forgetting that patching GetInterface means you lose the original implementation unless you undo the patch. Given the need to adapt a bit of System.pas — even it is only a bit — I’ve now taken it down however. Still, if you’ve read this far, you probably have the intelligence to reconstruct it.