fpc/tests/webtbs/tw5800.pp

{$IFDEF FPC}{$mode objfpc}{$ENDIF}
{$h+}

uses
  sysutils;

type
{$INTERFACES COM}

  IAny3 = interface
    ['{239041BD-BEC9-468A-93AA-96B158EF97E0}']
    procedure z;
  end;

{$INTERFACES CORBA}
  IAny1 = interface
    ['{949041BD-BEC9-468A-93AA-96B158EF97E0}']
    procedure x;
  end;

  IAny2 = interface
    ['IANY2']
    procedure y;
  end;

  TAny = class(TInterfacedObject, IAny1, IAny2, IAny3)
    procedure x;
    procedure y;
    procedure z;
    constructor create;
    destructor destroy; override;
  end;

var
  gc,gx,gy,gz: Integer;

constructor TAny.create;
begin
  inherited create;
  Inc(gc);
end;

destructor TAny.destroy;
begin
  Dec(gc);
  inherited destroy;
end;

procedure TAny.x;
begin
  Inc(gx);
end;

procedure TAny.y;
begin
  Inc(gy);
end;

procedure TAny.z;
begin
  Inc(gz);
end;


procedure run;
var
  a : TAny;
  i1 : IAny1;
  i2 : IAny2;
  i3 : IAny3;
begin
  gc := 0;
  gx := 0;
  gy := 0;
  gz := 0;
  a := TAny.create();

  if not supports(TAny,IAny1) then
    halt(1);

  if not supports(TAny,IAny2) then
    halt(1);

  if not supports(TAny,IAny3) then
    halt(1);

  if supports(a,IAny1,i1) then
    i1.x
  else
    halt(1);

  if supports(a,IAny2,i2) then
    i2.y
  else
    halt(1);

  if supports(a,IAny3,i3) then
    i3.z
  else
    halt(1);

  (a as IAny1).x;
  (a as IAny2).y;
  (a as IAny3).z;
end;

begin
  run;
  writeln(gc,gx,gy,gz);

  if (gc<>0) or (gx<>2) or (gy<>2) or (gz<>2) then
    halt(1);
end.