Adding interfaces to any class (tnx Warfley!)

[Thaddy]

A couple of weeks ago I proposed a feature request that enables you to add a COM interface to any class.
Warfley implemented it and Florian committed it two days ago.

Since my dreamed up code in the feature request contains a bug (I could not test it, because it did not exist in the first place) Here is the working code that I envisioned:

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

1. Program examplecom;
2. {
3.   The ability to add a COM interface to classes
4.   that do not inherit from TInterfacedObject.
5.  
6.   Allows automatic memory management (ARC style)
7. }
8.  
9. {$mode delphi}
10. uses classes;
11.  
12. type
13.   { you can skip this and use simply IInterface here }
14.   IInterfaced = interface
15.    ['{ADEAD83C-06E1-41A5-A40B-C19D06FE8B9F}']
16.   end;
17.  
18.   TInterfaced<T:class,constructor> = class(T,IInterfaced)
19.   private
20.     frefcount:integer;
21.     FDestroyCount:integer;
22.   public
23.     { winapi is cross platform: the compiler chooses the right calling convention }
24.     function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;
25.       out obj) : longint;winapi;
26.     function _AddRef : longint;winapi;
27.     function _Release : longint;winapi;
28.     destructor destroy;override;
29.     procedure AfterConstruction;override;    
30.     procedure BeforeDestruction;override;
31.     class function NewInstance : TObject;override;
32.   end;
33.  
34.  
35.   function TInterfaced<T>.QueryInterface(
36.   {$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint;winapi;
37.   begin
38.     if GetInterface(iid,obj) then
39.       result:=S_OK
40.      else
41.       result:=longint(E_NOINTERFACE);
42.   end;
43.  
44.   function TInterfaced<T>._AddRef : longint;winapi;
45.   begin
46.     _addref:=InterlockedIncrement(frefcount);
47.   end;
48.  
49.   function TInterfaced<T>._Release : longint;winapi;
50.   begin
51.     Result := InterlockedDecrement(frefcount);
52.     if Result = 0 then
53.       Destroy;
54.   end;
55.  
56.   destructor TInterfaced<T>.Destroy;
57.   begin
58.     FRefCount:=0;
59.     FDestroyCount:=0;
60.     inherited Destroy;
61.   end;
62.  
63.   procedure TInterfaced<T>.AfterConstruction;
64.   begin
65.     InterlockedDecrement(frefcount);
66.   end;
67.  
68.   procedure TInterfaced<T>.BeforeDestruction;
69.   begin
70.     if frefcount <> 0 then
71.       halt(204);
72.   end;
73.  
74.   class function TInterfaced<T>.NewInstance : TObject;
75.   begin
76.     result:= inherited NewInstance;
77.     TInterfaced<T>(result).frefcount := 1;
78.   end;
79.  
80. type
81.   TInterfacedStringlist = TInterfaced<TStringlist>;
82.    
83. var
84.   List:IInterfaced;
85.   SList:TStringlist;
86. begin
87.   List :=TInterfacedStringlist.create;
88.   with list as TInterfacedStringlist do
89.   begin
90.     Add('some text');
91.     writeln(Text);
92.   end;
93.   { alternatively }
94.   Slist := list as TInterfacedStringlist;
95.   slist.add('some more text');
96.   writeln(slist.text);  
97. { no leaks! }
98. end.

Again, tnx Warfley!!

THIS ONLY WORKS FOR A TRUNK LATER THAN DECEMBER 8, 2024
If you can't read the above don't bother to ask questions.

[cdbc]

Hi
Nifty \o/ Me Likey 
...ahumm, the curly bracket in this:

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

1. class(}T,IInterfaced)

is just a typo, right?!?
Regards Benny

[Thaddy]

Actually a pasto, not a typo. Corrected.
What Frederic implemented has, much, much more possibilities, though.
Not only this.

Because with a class restriction <T:class> now all methods and members of TObject are available instead or the previous dummy.
This is quite an important change.

[cdbc]

Hi Thaddy
Yup, that /little/ difference is actually *all-important*... As I said: Nifty \o/
Regards Benny

[Thaddy]

what I find is:
Cosy here, nice and calm...
Few can see it.

[ASerge]

Here is the working code that I envisioned:...

But what if we do without generic, for which a lot of code will be generated for each class:

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

1. {$MODE OBJFPC}
2. {$APPTYPE CONSOLE}
3.  
4. uses SysUtils, Classes;
5.  
6. type
7.   TIntfWrapper = class(TInterfacedObject, IInterface)
8.   strict private
9.     FObj: TObject;
10.     FOwned: Boolean;
11.     function QueryInterface(constref iid: TGuid; out Obj): LongInt; winapi;
12.   public
13.     constructor Create(AObj: TObject; AOwned: Boolean = True);
14.     destructor Destroy; override;
15.   end;
16.  
17. { TSome }
18.  
19. constructor TIntfWrapper.Create(AObj: TObject; AOwned: Boolean);
20. begin
21.   FObj := AObj;
22.   FOwned := AOwned;
23. end;
24.  
25. destructor TIntfWrapper.Destroy;
26. begin
27.   if FOwned then
28.     FreeAndNil(FObj);
29.   inherited;
30. end;
31.  
32. function TIntfWrapper.QueryInterface(constref iid: TGuid; out Obj): LongInt; winapi;
33. begin
34.   if IsEqualGUID(iid, IObjectInstance) then
35.   begin
36.     Pointer(Obj) := FObj;
37.     Result := S_OK;
38.   end else
39.     Result := inherited;
40. end;
41.  
42. var
43.   IList: IInterface;
44. begin
45.   IList := TIntfWrapper.Create(TStringList.Create);
46.   with IList as TStringList do
47.   begin
48.     Add('some text');
49.     Writeln(Text);
50.   end;
51.   Readln;
52. end.

There is no need to wait for the new version of FPC, it works now.

[Thaddy]

@Aserge
It is about avoiding TInterfacedObject and bolt on COM support to existing classes.
I can't see that you have missed that...
( there is some more news.. look at the T... )

To prevent flame wars:
Noobs should shut up.. for now. Do not even bother to react.

[ASerge]

@Aserge
It is about avoiding TInterfacedObject and bolt on COM support to existing classes.
I can't see that you have missed that...
( there is some more news.. look at the T... )

I'm sorry, but I really don't understand. Why can't TInterfacedObject be used? Is this a continuation of some other topic?

[Thaddy]

Because this allows no inheritance of TInterfacedObject? Is that so hard to grasp?
This not a party trick, find out what happens with T...
Again, noobs should not even try to answer...

[ASerge]

Because this allows no inheritance of TInterfacedObject? Is that so hard to grasp?

Hard. In my example:

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

1. constructor Create(AObj: TObject;...

any object, not only inherited from TInterfacedObject.

[cdbc]

Hi
@ASerge: Look closer my friend...
It takes a <T:class, constructor> as 'specialization *and* at the same time, inherits from <T>. This makes for the "Bolted On" aspect.
Note: I jumped through some hoops, trying to get it all to work, in 'IStringList'
Regards Benny

[lainz]

Awesome addition. Congratulations!

Finally we can have any interfaced object with easy and don't re writing code.

[PascalDragon]

Here is the working code that I envisioned:...

But what if we do without generic, for which a lot of code will be generated for each class:

As Thaddy said, the point is not to inherit from TInterfacedObject if e.g. you have some class hierarchy for which you can't simply change the ancestor (e.g. some third party code). And in that case the generic approach will keep the amount of duplicated source code small (in the binary there will still be a duplicate for each class type).

[ASerge]

And in that case the generic approach will keep the amount of duplicated source code small (in the binary there will still be a duplicate for each class type).

I still don't understand why we need to add a hierarchy and additional code to each class.
Let me rewrite my example.
Unit with one(!) function:

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

1. unit uIntfWrapper;
2.  
3. {$mode ObjFPC}{$H+}
4.  
5. interface
6.  
7. function WrapByInterface(SomeObj: TObject; AOwned: Boolean = True): IInterface;
8.  
9. implementation
10.  
11. uses SysUtils, Classes;
12.  
13. type
14.   TIntfWrapper = class(TInterfacedObject, IInterface)
15.   strict private
16.     FObj: TObject;
17.     FOwned: Boolean;
18.     function QueryInterface(constref iid: TGuid; out Obj): LongInt; winapi;
19.   public
20.     constructor Create(AObj: TObject; AOwned: Boolean = True);
21.     destructor Destroy; override;
22.   end;
23.  
24. function WrapByInterface(SomeObj: TObject; AOwned: Boolean): IInterface;
25. begin
26.   Result := TIntfWrapper.Create(SomeObj, AOwned);
27. end;
28.  
29. { TIntfWrapper }
30.  
31. constructor TIntfWrapper.Create(AObj: TObject; AOwned: Boolean);
32. begin
33.   FObj := AObj;
34.   FOwned := AOwned;
35. end;
36.  
37. destructor TIntfWrapper.Destroy;
38. begin
39.   if FOwned then
40.     FreeAndNil(FObj);
41.   inherited;
42. end;
43.  
44. function TIntfWrapper.QueryInterface(constref iid: TGuid; out Obj): LongInt; winapi;
45. begin
46.   if IsEqualGUID(iid, IObjectInstance) then
47.   begin
48.     Pointer(Obj) := FObj;
49.     Result := S_OK;
50.   end else
51.     Result := inherited;
52. end;
53.  
54. end.

and using it:

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

1. {$MODE OBJFPC}
2. {$APPTYPE CONSOLE}
3.  
4. uses SysUtils, Classes, uIntfWrapper;
5.  
6. var
7.   IList: IInterface;
8. begin
9.   IList := WrapByInterface(TStringList.Create);
10.   with IList as TStringList do
11.   begin
12.     Add('some text');
13.     Writeln(Text);
14.   end;
15.   Readln;
16. end.

No hierarchy, no inheritance, no code duplication. One function for all cases, and you use your class as it is.

[Warfley]

In this example you can convert the TIntfWrapper to the base class using the as operator. But how do you convert it back? So if you have a base object you know is wrapped into a TIntfWrapper, you can't get that wrapper. With Thaddies approach the object itself is the wrapper:

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

1. // Convert interface to object
2. MyInterface as TMyClass;
3. // Converting to interface
4. TInterfaced<TMyClass>(myInstance) as IInterface
5.  

Independently of that, what would be interesting to extend Thaddys code with a generic interface parameter. Haven't tested it, but it would be quite neat if that is possible:

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

1. TInterfaced<T:class,constructor;I> = class(T,I)
2. ...

So one could for example write an interface that mirrors the public signature of an existing object (like TStringList) and use this to create a TStringList derivate an interfaced version with that