Obtaining a sub-interface from an interface

Question

This is a bit of special case of interfaces, where a class implements multiple versions of the same interface, ie. something like the following

IBase = interface
   procedure Foo;
end;

ISub = interface (IBase)
   procedure Bar;
end;

ISpecialBase = interface (IBase) end;

ISpecialSub = interface (ISub) end;

TMyClass = class(TInterfacedObject, ISpecialBase, ISpecialSub)

   procedure SpecialFoo1;
   procedure SpecialFoo2;
   procedure SpecialBar;

   procedure ISpecialBase.Foo = SpecialFoo1;

   procedure ISpecialSub.Foo = SpecialFoo2;
   procedure ISpecialSub.Bar = SpecialBar;

   function GetTheRightOne(parameters) : IBase;

end;

...

function TMyClass.GetTheRightOne(parameters) : IBase;
begin
   if (something complex depending on parameters) then
      Result := ISpecialBase(Self)
   else Result := ISpecialSub(Self)
end;

of course there are about a dozen ISpecialXxxx in the real case.

There is a very important need to have only one instance, ie. I want to avoid having to create adapters or dummy instances just to defer the ISpecialXxxx implementations, as the sole purpose of the previous design is precisely to have a single instance handle many outstanding interfaces (ie. the RefCount of the TMyClass can get in the thousandths).

Now the problem is that GetTheRightOne() returns an IBase, yet at some point I want to check if that IBase can be cast to an ISub.

Is there a way to do it with the above declaration form?

One way could be add a

function GetSub : ISub;

to IBase, but that really makes the design a lot heavier, as it would have to be implemented for each ISpecialXxxx, and would be redundant with the ISpecialXxxx "inheritence", so I'm looking for a more elegant solution (assuming it exists).

(I have other "bloat" solutions, so I'm really want to emphasize I'm looking for a non-bloat solution)

edit : some more details

• GUIDs are there in the original code (but their lack isn't what's causing the difficulty)
• Supports & QueryInterface don't work, because of the ISpecialXxx needed to have multiple version of the interface per class, ISub isn't listed explitly, and so isn't found. Both works however when using an adapter/dummy class to defer the interface (as then ISub can be listed explicitly)

edit2 : if you want the gory details

Check https://code.google.com/p/dwscript/source/browse/trunk/Source/dwsJSONConnector.pas (r2492), the TdwsJSONConnectorType class, and the IJSONLow interface, the goal is to have the IConnectorFastCall detected from it when it's passed as an IConnectorCall, and thus be able to have LowFastCall invoked rather than LowCall.

The detection has to occur in TConnectorCallExpr.AssignConnectorSym, line 294, where there is currently a QueryInterface.

Note that the QueryInterface works in the case of TdwsJSONIndexReadCall & TdwsJSONIndexWriteCall as they implement the IConnectorCall & IConnectorFastCall from distinct classes & instances. But that's what I'd like to avoid.

Of course ideally, the goal would be to fold back everything into the ConnectorType class (single class, single instance), and for each interface, a particular ConnectorType class should be free to implement either IConnectorCall or IConnectorFastCall.

Answer 1

To see if an implementor of an interface implements another interface you can use Supports or QueryInterface, as in the following pseudo-code:

var
  Base: IBase;
  Sub: ISub;
begin
  Base := X.GetTheRightOne(Params);  
  if Supports(Base, ISub, Sub) then
    Sub.Bar;
end;

Edit: For the above to work you need to add IIDs to the declarations of the interfaces.

Answer 2

One hackish way relies on how the compiler stores the interface VTable data. The compiler stores separate VTables for each interface an object implements. After each VTable it stores the number of interfaces the object implements.

So we can use this to determine if we got the VTable of the ancestor interface, or that of a descendant.

At least this is how it works in XE3 and XE5, I must admit I'm a bit of a n00b when it comes to how interfaces are implemented.

Downsides to this, besides relying on implementation details, is that you'll have to keep the GetSub function in sync if you add methods to the IBase interface. Also, if you have two different, unrelated, ISub's then this code cannot detect which you got. You may be able to hack that in but I'd rather not go there...

{$APPTYPE CONSOLE}

uses
  System.SysUtils;

type
  IBase = interface
    procedure Foo;
  end;

  ISub = interface (IBase)
    procedure Bar;
  end;

  ISpecialBase = interface (IBase)
  end;

  ISpecialSub = interface (ISub)
  end;

  TMyClass = class(TInterfacedObject, ISpecialBase, ISpecialSub)

    procedure SpecialFoo1;
    procedure SpecialFoo2;
    procedure SpecialBar;

    procedure ISpecialBase.Foo = SpecialFoo1;

    procedure ISpecialSub.Foo = SpecialFoo2;
    procedure ISpecialSub.Bar = SpecialBar;

    function GetTheRightOne(const Param: boolean) : IBase;
  end;


{ TMyClass }

function TMyClass.GetTheRightOne(const Param: boolean): IBase;
begin
  if Param then
    Result := ISpecialBase(Self)
  else
    Result := ISpecialSub(Self);
end;

procedure TMyClass.SpecialBar;
begin
  WriteLn('SubBar');
end;

procedure TMyClass.SpecialFoo1;
begin
  WriteLn('BaseFoo');
end;

procedure TMyClass.SpecialFoo2;
begin
  WriteLn('SubFoo');
end;

function GetSub(const Intf: IInterface): ISub;
type
  PPVtable = ^PVtable;
  PVtable = ^TVtable;
  TVtable = array[0..MaxInt div SizeOf(Pointer) - 1] of Pointer;
var
  intfVTable: PPVtable;
  caddr: NativeUInt;
begin
  result := nil;
  intfVTable := PPVTable(Intf);
  // 3 is offset to user methods
  // +0 = first user method, +1 = second user method etc
  // get the "address" of the first method in ISub
  caddr := NativeUInt(intfVTable^[3+1]);
  // compiler stores number of interface entries the
  // implementing object implements right after the interface vtable
  // so if we get a low number here, it means Intf is the IBase interface
  // and not the ISub
  if caddr > $100 then
    result := ISub(Intf);
end;

procedure CallIt(const b: IBase);
var
  s: ISub;
begin
  b.Foo;

  s := GetSub(b);
  if Assigned(s) then
    s.Bar;
end;

var
  c: TMyClass;
  b: IBase;
begin
  try
    c := TMyClass.Create;

    b := c.GetTheRightOne(True);
    CallIt(b);

    WriteLn('---');

    b := c.GetTheRightOne(False);
    CallIt(b);

    WriteLn('...');

  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
  ReadLn;
end.

This outputs

BaseFoo
---
SubFoo
SubBar
...

as we want.

Answer 3

Here is my current "best" solution:

I abandoned the method resolution clause, and moved to dummy classes tied to the main class, and that are instantiated only once.

This way, GetInterface & Supports can be used, as the ISub is explicit again.

However, this raises an issue of circular reference: the main class needs to reference the specials (if only to return them in GetTheRightOne()), and the specials need to reference the main class (to access parameters stored there or redirect to methods of the main class).

Both the main class and the specials are reference-counted interfaces, and of course, the usage context is multi-threaded, so usual weak reference schemes would introduce the need for a global lock.

However given that the specials are dummy classes used only for interface resolution of the main class, we can override their _AddRef & _Release to have the reference count centralized on the main class (i.e. the _AddRef & _Release just redirect to the main class's _AddRef & _Release, and no longer maintain a reference count of their own).

Answer 4

Interface inheritance does not follow the same principles as class inheritance. So in order to test if an IBase supports ISub the implementing class needs to explicitly declare ISub:

TMyClass = class(TInterfacedObject, ISub, ISpecialBase, ISpecialSub)

Querying for an interface does not check for inherited interfaces. AFAIR when interfaces where introduced in Delphi 2 (?) one of the compiler guys once noted that interface inheritance was nothing more than syntactic sugar.