Gleiche Interface-Referenzen?

[Sir Rufo]

Es ist da doch etwas komplizierter:

Delphi-Quellcode:

program dp_184186;

{$APPTYPE CONSOLE}
{$R *.res}

uses
  System.SysUtils;

type
  IFoo = interface
    ['{E4CA5AB6-B9DF-403C-B30B-72636041B010}']
  end;

  IBar = interface( IFoo )
    ['{6DFEAA0D-E3CA-4DCE-8450-7E54DC6DD7AC}']
  end;

  TFoo = class( TInterfacedObject, IFoo )
  end;

  TBar = class( TInterfacedObject, IBar )
  end;

  TFooBar = class( TFoo, IBar )
  end;

  TFooFooBar = class( TFoo, IFoo, IBar )
  end;

procedure PrintIntfRef( const RefName: string; const Ref: IInterface );
begin
  Writeln( Format( '%s($%p)', [RefName, Pointer( Ref )] ) );
end;

procedure PrintFoo( const AFoo: IFoo );
begin
  PrintIntfRef( 'IFoo', AFoo );
end;

procedure PrintBar( const ABar: IBar );
begin
  PrintIntfRef( 'IBar', ABar );
end;

procedure Test;
var
  LBar: IBar;
begin
  Writeln( 'TBar' );
  LBar := TBar.Create;
  PrintFoo( LBar );
  // PrintFoo( LBar as IFoo ); // EIntfCastError
  PrintBar( LBar );

  Writeln( 'TFooBar' );
  LBar := TFooBar.Create;
  PrintFoo( LBar );
  PrintFoo( LBar as IFoo );
  PrintBar( LBar );

  Writeln( 'TFooBar' );
  LBar := TFooFooBar.Create;
  PrintFoo( LBar );
  PrintFoo( LBar as IFoo );
  PrintBar( LBar );
end;

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

end.

Und die Lösung lautet hier:

Delphi-Quellcode:

procedure PrintFooAsFoo( const AFoo: IFoo );
var
  LFoo: IFoo;
begin
  if Supports( AFoo, IFoo, LFoo )
  then
    PrintIntfRef( 'IFoo', LFoo )
  else
    PrintIntfRef( 'IFoo', AFoo );
end;