Dynamic Interface (or Strong "Duck Typing")

http://d.hatena.ne.jp/lethevert/20050922/p1
ダウンキャストを、後付けinterface→元々のオブジェクトが持っているinterface、に限定すれば、TAggregateObjectで可能ですね。Objectから任意のinterfaceを生成する元々のVB9のサンプルとは全然違うという話は置いておいて。

program Duck;

{$APPTYPE CONSOLE}

uses
  SysUtils, Crt;

type
  IAnObject = interface
    ['{BE464EC2-D871-4BA6-B4F2-4DB0A4C983C5}']
    function CalcSomething(X: Integer): Integer;
    procedure DoSomething;
  end;

  TAnObject = class(TInterfacedObject, IAnObject)
    function CalcSomething(X: Integer): Integer;
    procedure DoSomething;
  end;

procedure TAnObject.DoSomething;
begin
  WriteLn('DoSomething');
end;

function TAnObject.CalcSomething(X: Integer): Integer;
begin
  Result := X * 2
end;

type
  IDuck = interface
    procedure DoSomething;
  end;

procedure AnProcedureThatNeedsInterface(const intf: IDuck);
var
  obj: IAnObject;
begin
  intf.DoSomething;
  obj := intf as IAnObject;
  WriteLn(obj.CalcSomething(100));
end;

type
  TDuckAdapter = class(TAggregatedObject, IDuck)
    FAnObject: TAnObject;
    constructor Create(const AnObject: TAnObject);
    property AsDuck: TAnObject read FAnObject implements IDuck;
  end;

constructor TDuckAdapter.Create(const AnObject: TAnObject);
begin
  inherited Create(AnObject);
  FAnObject := AnObject;
end;

var
  obj: TAnObject;
  intf: IDuck;
begin
  obj := TAnObject.Create;
  intf := TDuckAdapter.Create(obj);
  AnProcedureThatNeedsInterface(intf);
end.

逆をやるには、TAnObjectがIDuckのことを知らない以上はQueryInterfaceに細工が必要で、これは例えTAnObjectに手を入れられないとしても、VirtualProtectでVMT上の関数ポインタ差し替えてやるだけで(以下略)
元々のサンプルのようにやるには、公開部をpublishedにするかこの間見つけたIInvokableを使うかぐらいでしょうか。
こうやってネタを小出しにしているせいで、ObjectPascal Magic Programmingのところが増えていかないという話。
双方向のダウンキャストを可能にする(以下略)版。

program Duck;

{$APPTYPE CONSOLE}

uses
  Windows, SysUtils, Crt;

type
  IAnObject = interface
    ['{BE464EC2-D871-4BA6-B4F2-4DB0A4C983C5}']
    function CalcSomething(X: Integer): Integer;
    procedure DoSomething;
  end;

  TAnObject = class(TInterfacedObject, IAnObject)
    function CalcSomething(X: Integer): Integer;
    procedure DoSomething;
  end;

procedure TAnObject.DoSomething;
begin
  WriteLn('DoSomething');
end;

function TAnObject.CalcSomething(X: Integer): Integer;
begin
  Result := X * 2
end;

type
  IDuck = interface
    ['{FDB7A78C-E3FC-4205-B773-D15C79DC12F5}']
    procedure DoSomething;
  end;

procedure AnProcedureThatNeedsInterface(const intf: IDuck);
var
  obj: IAnObject;
begin
  intf.DoSomething;
  obj := intf as IAnObject;
  WriteLn(obj.CalcSomething(100));
end;

type
  TDuckAdapter = class(TAggregatedObject, IDuck)
    FAnObject: TAnObject;
    constructor Create(const AnObject: TAnObject);
    property AsDuck: TAnObject read FAnObject implements IDuck;
  end;

constructor TDuckAdapter.Create(const AnObject: TAnObject);
begin
  inherited Create(AnObject);
  FAnObject := AnObject;
end;

procedure SampleMain(obj: IInterface);
var
  intf: IDuck;
begin
　intf := obj as IDuck;
　AnProcedureThatNeedsInterface(intf);
end;

var
  OldQueryInterface: function(const Self: IInterface; const IID: TGUID; out Obj): HResult; stdcall;
  Offset: Cardinal;

function NewQueryInterface(const Self: IInterface; const IID: TGUID; out Obj): HResult; stdcall;
begin
  if IsEqualGUID(IID, IDuck) then begin
    IDuck(Obj) := TDuckAdapter.Create(TAnObject(Cardinal(Self) - Offset));
    Result := 0
  end else begin
    Result := OldQueryInterface(Self, IID, Obj)
  end;
end;

procedure InstallContraryIsAlsoTruth;
var
  Entry: PInterfaceEntry;
  OldAccess: DWORD;
begin
  {手を抜いているが実際は全部のentryに対して行う}
  Entry := TAnObject.GetInterfaceEntry(IInterface);
  OldQueryInterface := PPointer(Entry.VTable)^;
  Offset := Entry.IOffset;
  VirtualProtect(Entry.VTable, 4, PAGE_READWRITE, OldAccess);
  PPointer(Entry.VTable)^ := @NewQueryInterface;
  VirtualProtect(Entry.VTable, 4, OldAccess, nil);
end;

var
  obj: TAnObject;
  intf: IDuck;
begin
  obj := TAnObject.Create;
  intf := TDuckAdapter.Create(obj);
  AnProcedureThatNeedsInterface(intf);
  InstallContraryIsAlsoTruth;
  SampleMain(obj);
end.