Typecasts and Interfaces

[XCalibre8]

Hey guys, I'm fairly new to Lazarus with 14 years Delphi experience. FYI I don't currently have internet at home so forgive me if I don't reply quickly, I try to ensure I check emails etc at least a few times a week.

I seem to have a bit of an issue with some intermediate level features.

I've build an object hierarchy which uses interfaces and self draws to a canvas.

This isn't functional code, I'm just writing it out with a touch of copy/paste, but it should illustrate what's going on, forgive me for not writing out all object properties etc, the ones you see used are there in the real interface definition

Code: Pascal  [Select][+][-]

1. unit Fake;
2.  
3. interface
4.  
5. type
6.   TMyCustomObject = class(TInterfacedObject, IQRectDrawable, IQMultiView, IQExplosive,
7.     IQThemeable, IQHitable);
8.     //IQHitable Methods
9.     function HitTest(x,y: Integer): Boolean;
10.     function HitObject(x,y: Integer): TObject;
11.   end;
12.  
13.   TMyForm = class(TForm)
14.     fvSelObject: TObject;
15.     imgCanvas: TImage;
16.     actMinimize: TAction;
17.     actLess: TAction;
18.     procedure imgCanvasMouseDown(Params shown in declaration);
19.     procedure actSASMinLessUpdate(Sender: TObject);
20.   end;
21.  
22. function TMyCustomObject .HitTest(x, y: Integer): Boolean;
23. var
24.   lvHitRect: TRect;
25. begin
26.   lvHitRect := FSizeRect;
27.   MoveRect(lvHitRect,FDrawPos.x,FDrawPos.y);
28.   Result := (x >= lvHitRect.Left) and (x <= lvHitRect.Right)
29.     and (y >= lvHitRect.Top) and (y <= lvHitRect.Bottom);
30. end;
31.  
32. function TMyCustomObject .HitObject(x, y: Integer): TObject;
33. var
34.   lvHitRect: TRect;
35. begin
36.   Result := nil;
37.   if HitTest(x,y) then
38.   begin
39.     lvHitRect := SetRect;
40.     MoveRect(lvHitRect,FDrawPos.x,FDrawPos.y);
41.     if (x >= lvHitRect.Left) and (x <= lvHitRect.Right)
42.       and (y >= lvHitRect.Top) and (y <= lvHitRect.Bottom) then
43.       Result := Self
44.     else
45.     begin
46.       Result := FStorageTypes.HitObject(x,y);
47.       if Result = nil then
48.         Result := FDatabases.HitObject(x,y);
49.       if Result = nil then
50.         Result := FSystems.HitObject(x,y);
51.     end;
52.   end
53.   else Result := nil;
54. end;
55.  
56. procedure TMyForm .imgCanvasMouseDown(Sender: TObject;
57.   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
58. var
59.   i: Integer;
60.   lvSys: TSelfAwareSystem;
61. begin
62.   fvSelObject := nil;
63.   for i := 0 to Pred(fvSystemSets.Count) do
64.   begin
65.     lvSys := TSelfAwareSystem(fvSystemSets.Objects[i]);
66.     if lvSys.HitTest(x,y) then
67.       fvSelObject := lvSys.HitObject(x,y);
68.   end;
69. end;  
70.  
71. procedure TMyForm .actSASMinLessUpdate(Sender: TObject);
72. var
73.   lvIQMV: IQMultiView;
74. begin
75.   if Sender is TAction then
76.   begin
77.     if Assigned(fvSelObject) and (fvSelObject is TInterfacedObject) then
78.       if TInterfacedObject(fvSelObject).GetInterface(GUID_IQMultiView,lvIQMV) then
79.         TAction(Sender).Enabled := lvIQMV.LessPossible
80.       else TAction(Sender).Enabled := False
81.     else TAction(Sender).Enabled := False;
82.   end;
83. end;
84.  

So the problems I'm getting are in the update events for the actions.

Everything appears to go through OK but the variable fvSelObject is only evaluating as a TInterfacedObject the first time I click on it and even so the call to GetInterface returns false. On the second click the object returns itself the same as the first time since it has no child objects yet but the check on (fvSelObject is TInterfacedObject) no longer comes back true and the debug code insight is different, showing only a vPtr memory reference rather than the object structure even though the memory address shown is the same in both scenarios.

I'll be proceeding to work around this by making the implementation less generic, though continuing down that path long term would invalidate the point of having designed a generic structure in the first place.

If this rings any bells with anyone I'd love to know if there's something I can do to get interfaces working with more generic holder objects. I've had no problems using them from correctly typed objects but that shouldn't be necessary when you should be able to do a check on whether the object is a TInterfacedObject and call GetInterface.

FYI the system I'm designing will be available for use on a open source inspired licence eventually. As much as I love open source we really need a system where programs can share source with authorized members and those devs can get paid based on their contributions if/when the product makes money as well. I hate seeing so many great ideas fall by the wayside because they're not commercial.

[engkin]

Make sure your interfaces have GUIDs, and consider using Supports.

You might want to read the replies to this question on the mailing list.

Edit:
Corrected a typo.

[Thaddy]

The guids are not necessary at all. That's for external code.
Just do not use hardcasts, Use is and as and proper exception handling.
Unless you are referencing external code that should be enough.
And exactly like you should do in Delphi.

[engkin]

The guids are not necessary at all.

I take your word. Any explanation why this code, based on Michalis' post does not work properly?

Code: Pascal  [Select][+][-]

1. {$mode objfpc}{$H+}{$J-}
2. {$interfaces corba}
3.  
4. { Simple test that without GUIDs, the "is" operator on interfaces
5.   returns "true" when a class implements *any* interface.
6.   Most likely because "is" simply compares GUIDs, and "no GUID" equals
7.   something like "GUID all filled with zeros".
8.   This means that GUIDs are necessary, for both CORBA and COM interfaces,
9.   if you want reliable "is". }
10.  
11. uses SysUtils, Classes;
12.  
13. type
14.   IMyInterface = interface
15.     procedure Shoot;
16.   end;
17.  
18.   IMyUnrelatedInterface = interface
19.     procedure Eat;
20.   end;
21.  
22.   TMyClass1 = class(IMyInterface)
23.     procedure Shoot;
24.   end;
25.  
26.   TMyClass2 = class(IMyUnrelatedInterface)
27.     procedure Eat;
28.   end;
29.  
30.   TMyClass3 = class
31.     procedure Shoot;
32.   end;
33.  
34. procedure TMyClass1.Shoot;
35. begin
36.   Writeln('TMyClass1.Shoot');
37. end;
38.  
39. procedure TMyClass2.Eat;
40. begin
41.   Writeln('TMyClass2.Eat');
42. end;
43.  
44. procedure TMyClass3.Shoot;
45. begin
46.   Writeln('TMyClass3.Shoot');
47. end;
48.  
49. procedure UseThroughInterface(I: IMyInterface);
50. begin
51.   Write('Shooting... ');
52.   I.Shoot;
53. end;
54.  
55. var
56.   C1: TMyClass1;
57.   C2: TMyClass2;
58.   C3: TMyClass3;
59. begin
60.   C1 := TMyClass1.Create;
61.   C2 := TMyClass2.Create;
62.   C3 := TMyClass3.Create;
63.   try
64.     WriteLn('C1-');
65.     if C1 is IMyInterface then
66.       UseThroughInterface(C1 as IMyInterface);
67.     WriteLn('-C1');
68.     { VERY WRONG: "C2 is IMyInterface" is evaluated as "true",
69.       and the "I.Shoot" call inside "UseThroughInterface" calls
70.       the "TMyClass2.Eat" method. }
71.       WriteLn('C2-');
72.     if C2 is IMyInterface then
73.       UseThroughInterface(C2 as IMyInterface);
74.     WriteLn('-C2');
75.     WriteLn('C3-');
76.     if C3 is IMyInterface then
77.       UseThroughInterface(C3 as IMyInterface);
78.     WriteLn('-C3');
79.   finally
80.     FreeAndNil(C1);
81.     FreeAndNil(C2);
82.     FreeAndNil(C3);
83.   end;
84. end.

Its output is:

C1-
Shooting... TMyClass1.Shoot
-C1
C2-
Shooting... TMyClass2.Eat
-C2
C3-
-C3

While the expected output is:

C1-
Shooting... TMyClass1.Shoot
-C1
C2-
-C2
C3-
-C3

Edit:
The compiler emits fpc_class_is_corbaintf for "if C2 is IMyInterface":

Code: Pascal  [Select][+][-]

1.     function fpc_class_is_corbaintf(const S: pointer; const iid: Shortstring): Boolean;[public,alias: 'FPC_CLASS_IS_CORBAINTF']; compilerproc;
2.       begin
3.         fpc_class_is_corbaintf:=Assigned(S) and Assigned(TObject(S).GetInterfaceEntryByStr(iid));
4.       end;

GetInterfaceEntryByStr:

Code: Pascal  [Select][+][-]

1.       class function TObject.GetInterfaceEntryByStr(const iidstr : shortstring) : pinterfaceentry;
2.         var
3.           i: longint;
4.           intftable: pinterfacetable;
5.           ovmt: PVmt;
6.         begin
7.           ovmt := PVmt(Self);
8.           while Assigned(ovmt) and (ovmt^.vIntfTable <> @emptyintf) do
9.           begin
10.             intftable:=ovmt^.vIntfTable;
11.             if assigned(intftable) then
12.             begin
13.               for i:=0 to intftable^.EntryCount-1 do
14.               begin
15.                 result:=@intftable^.Entries[i];
16.                 if assigned(result^.iidstr) and (result^.iidstr^ = iidstr) then
17.                   Exit;
18.               end;
19.             end;
20.             ovmt := ovmt^.vParent;
21.           end;
22.           result:=nil;
23.         end;

[ASerge]

From documentation

The as and is operators also work on COM interfaces.

For COM the expression "Instance is Interface" is not Delphi compatible and moreover, it call Release (delete object), so the next code fails.

[jc99]

@engkin: I Think it's even worse:
Try this:

Code: Pascal  [Select][+][-]

1. program Prj_TestInterface;
2.  
3. {$mode delphi}
4. {$interfaces corba}
5. uses sysutils;
6.  
7. type
8.   IMyDelegate = interface  //['{B4DF70E1-EFC8-4C98-ABA2-F42A71A9EA02}']
9.     procedure DoThis (value: integer);
10.   end;
11.  
12.   IMyDelegate2 = interface// ['{8D53C8E5-8533-4C94-A55F-3A4070FA28FC}']
13.     procedure DoThat (value: integer);
14.   end;
15.  
16.   { TMyClass }
17.  
18.   TMyClass = class (TInterfacedObject, IMyDelegate)
19.     procedure DoThis (value: integer);
20.   end;
21.  
22.   { TMyClass2 }
23.   TMyClass2 = class (TInterfacedObject, IMyDelegate2)
24.     procedure DoThat (value: integer);
25.   end;
26.  
27.   { TMyClass3 }
28.   TMyClass3 = class (TInterfacedObject, IMyDelegate2,IMyDelegate)
29.     procedure DoThat (value: integer);
30.     procedure DoThis (value: integer);
31.   end;
32.  
33. procedure TMyClass3.DoThat(value: integer);
34. begin
35.   WriteLn('MyClass3.DoThat('+inttostr(value)+'): Fail!!!');
36. end;
37.  
38. procedure TMyClass3.DoThis(value: integer);
39. begin
40.   WriteLn('MyClass2.DoThis('+inttostr(value)+'): Also a Success!!!');
41. end;
42.  
43. { TMyClass }
44.  
45. procedure TMyClass.DoThis(value: integer);
46.  
47. begin
48.   WriteLn('MyClass.DoThis('+inttostr(value)+'): Success!!!');
49. end;
50.  
51. { TMyClass 2 }
52.  
53. procedure TMyClass2.DoThat(value: integer);
54. begin
55.   WriteLn('MyClass2.DoThat('+inttostr(value)+'): Fail !!!');
56. end;
57.  
58.  
59. procedure TestDelegate(AClass:TInterfacedObject);
60.  
61. begin
62.   try
63.     if assigned(AClass) then
64.       if Aclass is IMyDelegate then
65.         (Aclass as IMyDelegate).DoThis(1)
66.       else
67.         WriteLn(AClass.ClassName+' does not implement IMyDelegate')
68.     else
69.       WriteLn('AClass is not assigned');
70.   except
71.     WriteLn(AClass.ClassName+' --> Exception');
72.   end;
73. end;
74.  
75.  
76. var test:array[0..4] of TInterfacedObject;
77.   i: Integer;
78.   Str: string;
79.  
80. begin
81.   test[0]:= TInterfacedObject.Create;
82.   test[1]:= TMyClass.Create;
83.   test[2]:= TMyClass2.Create;
84.   test[3]:= TMyClass3.Create;
85.   for i := 0 to high(test) do
86.     TestDelegate(test[i]);
87.   WriteLn('Type <enter> to continue');
88.   ReadLn(Str);
89.   for i := 0 to high(test) do
90.     test[i].Free;
91. end.

Output is:

TInterfacedObject does not implement IMyDelegate
MyClass.DoThis(1): Success!!!
MyClass2.DoThat(1): Fail !!!
MyClass3.DoThat(1): Fail!!!
AClass is not assigned
Type <enter> to continue

Expected was :

TInterfacedObject does not implement IMyDelegate
MyClass.DoThis(1): Success!!!
TMyClass2 does not implement IMyDelegate
MyClass2.DoThis(1): Also a Success!!!
AClass is not assigned
Type <enter> to continue

Workaround are the GUID's

[engkin]

Workaround are the GUID's

Would It be considered official with this answer from Jonas Maebe to this bug report?

If you wish to get a corba interface from a class instance, you have to give your corba interface an identifier string so that the RTL can find it (if you don't, then it gets an empty identifier and things run awry).

I use[d] the term GUID loosely, as for Corba interfaces it is not "supposed" to be called GUID.

[jc99]

@engkin: I fully agree with you. ID's (better GUID's) are necessary
So I vote for a hint in the compiler if the ID is missing.
Or use the Interface-type-name as an default ID, at least for corba.

[engkin]

@engkin: I fully agree with you. ID's (better GUID's) are necessary
So I vote for a hint in the compiler if the ID is missing.
Or use the Interface-type-name as an default ID, at least for corba.

Using Interface-type-name might cause a problem. The compiler does not, yet, complain if two different corba interfaces have the same ID:

Code: Pascal  [Select][+][-]

1. {$interfaces corba}
2. ...
3.   IMyInterfaceSJ = interface ['Test']
4.     procedure Shoot;
5.     procedure Jump;
6.   end;
7.  
8.   IMyInterfaceS = interface ['Test']
9.     procedure Shoot;
10.   end;

When two classes implement these interfaces:

Code: Pascal  [Select][+][-]

1.   TMyClassJSL = class(IMyInterfaceSJ)
2.     procedure Shoot;
3.     procedure Jump;
4.     procedure Laugh;
5.   end;
6.  
7.   TMyClassS = class(IMyInterfaceS)
8.     procedure Shoot;
9.   end;

Operator "is" will return True for all these four tests:

Code: Pascal  [Select][+][-]

1. JSL is IMyInterfaceSJ
2. JSL is IMyInterfaceS  { Should return False }
3. S is IMyInterfaceSJ  { Should return False }
4. S is IMyInterfaceS

IMHO, the compiler should:
1-Complain when using "is" or "as" operators on corba interfaces that have no ID.
2-Complain if two corba interfaces have the same ID if any of them is used with "is" or "as" operators.

Any idea why "never nil" in the comment next to IIDStr?

Code: Pascal  [Select][+][-]

1. //objpash.inc
2.        tinterfaceentry = record
3.          IID         : pguid; { if assigned(IID) then Com else Corba}
4.          VTable      : Pointer;
5.          IOffset     : sizeuint;
6.          IIDStr      : pshortstring; { never nil. Com: upper(GuidToString(IID^)) }
7. ...
8.  

When no ID is provided, it points to an address that contains an empty shortstring, and it makes assigned(result^.iidstr) part of the following code useless:

Code: Pascal  [Select][+][-]

1. //objpas.inc
2.       class function TObject.GetInterfaceEntryByStr(const iidstr : shortstring) : pinterfaceentry;
3. ...
4.                 if assigned(result^.iidstr) and (result^.iidstr^ = iidstr) then

[jc99]

With default to  interface-type-name I meant
if you write

Code: Pascal  [Select][+][-]

1. {$interfaces corba}
2. ...
3. type
4.   IMyInterfaceSJ = interface
5.       procedure Shoot;    
6.       procedure Jump;  
7.   end;  
8.  
9.   IMyInterfaceS = interface
10.       procedure Shoot;
11.   end;
12.  

Should default to:

Code: Pascal  [Select][+][-]

1.     {$interfaces corba}
2.     ...
3. type
4.       IMyInterfaceSJ = interface ['IMyInterfaceSJ']
5.         procedure Shoot;
6.         procedure Jump;
7.       end;
8.      
9.       IMyInterfaceS = interface ['IMyInterfaceS']
10.         procedure Shoot;
11.       end;
12.  

If you provide your own ID-String the default is overwritten.
A Compiler-Hint when providing equal ID's to different interfaces is a good Idea, you have my support on this.

[engkin]

If you provide your own ID-String the default is overwritten.
A Compiler-Hint when providing equal ID's to different interfaces is a good Idea, you have my support on this.

Thank you. Time for a bug report.