* updated testcase for bug #5800

git-svn-id: trunk@12725 -

tests/webtbs/tw5800.pp

@@ -1,57 +1,92 @@
 {$IFDEF FPC}{$mode objfpc}{$ENDIF}
 
 uses
-	sysutils;
+  sysutils;
 
 type
 {$INTERFACES CORBA}
-	IAny1 = interface
-		//['{949041BD-BEC9-468A-93AA-96B158EF97E0}']
-		procedure x;
-	end;
+  IAny1 = interface
+    ['{949041BD-BEC9-468A-93AA-96B158EF97E0}']
+    procedure x;
+  end;
 
-	IAny2 = interface
-        //['{4743E9F5-74B2-411D-94CE-AAADDB8F45E0}']
-		procedure y;
-	end;
+  IAny2 = interface
+    ['IANY2']
+    procedure y;
+  end;
 
-	TAny = class(TInterfacedObject, IAny1, IAny2)
-		procedure x;
-		procedure y;
-	end;
+{$INTERFACES COM}
 
+  IAny3 = interface
+    ['{239041BD-BEC9-468A-93AA-96B158EF97E0}']
+    procedure z;
+  end;
+
+  TAny = class(TInterfacedObject, IAny1, IAny2, IAny3)
+    procedure x;
+    procedure y;
+    procedure z;
+  end;
+
+
+var
+  gx,gy,gz: Integer;
 
 procedure TAny.x;
 begin
-	WriteLn('x');
+  Inc(gx);
 end;
 
 procedure TAny.y;
 begin
-	WriteLn('y');
+  Inc(gy);
 end;
 
-procedure any(const z : IAny1); overload;
+procedure TAny.z;
 begin
-	z.x;
+  Inc(gz);
 end;
 
-procedure any(const z : IAny2); overload;
+
+var
+  a : TAny;
+  i1 : IAny1;
+  i2 : IAny2;
+  i3 : IAny3;
 begin
-	z.y;
-end;
+  gx := 0;
+  gy := 0;
+  gz := 0;
+  a := TAny.Create();
 
+  if not supports(TAny,IAny1) then
+    halt(1);
 
-var
-	a : TAny;
+  if not supports(TAny,IAny2) then
+    halt(1);
 
-begin
-	a := TAny.Create();
+  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, IAny1)) then begin end; // remove this line to get it compile
+  if supports(a,IAny3,i3) then
+    i3.z
+  else
+    halt(1);
 
-	any(a as IAny1);
-	any(a as IAny2);
+  (a as IAny1).x;
+  (a as IAny2).y;
+  (a as IAny3).z;
 
-	//a.Free();
+  if (gx<>2) or (gy<>2) or (gz<>2) then
+    halt(1);
 end.