Delphi Interface Reference Counting - delphi

I ran into a strange situation while testing something today.
I have a number of interfaces and objects. The code looks like this:
IInterfaceZ = interface(IInterface)
['{DA003999-ADA2-47ED-A1E0-2572A00B6D75}']
procedure DoSomething;
end;
IInterfaceY = interface(IInterface)
['{55BF8A92-FCE4-447D-B58B-26CD9B344EA7}']
procedure DoNothing;
end;
TObjectB = class(TInterfacedObject, IInterfaceZ)
procedure DoSomething;
end;
TObjectC = class(TInterfacedObject, IInterfaceY)
public
FTest: string;
procedure DoNothing;
end;
TObjectA = class(TInterfacedObject, IInterfaceZ, IInterfaceY)
private
FInterfaceB: IInterfaceZ;
FObjectC: TObjectC;
function GetBB: IInterfaceZ;
public
procedure AfterConstruction; override;
procedure BeforeDestruction; override;
property BB: IInterfaceZ read GetBB implements IInterfaceZ;
property CC: TObjectC read FObjectC implements IInterfaceY;
end;
procedure TObjectB.DoSomething;
begin
Sleep(1000);
end;
procedure TObjectA.AfterConstruction;
begin
inherited;
FInterfaceB := TObjectB.Create;
FObjectC := TObjectC.Create;
FObjectC.FTest := 'Testing';
end;
procedure TObjectA.BeforeDestruction;
begin
FreeAndNil(FObjectC);
FInterfaceB := nil;
inherited;
end;
function TObjectA.GetBB: IInterfaceZ;
begin
Result := FInterfaceB;
end;
procedure TObjectC.DoNothing;
begin
ShowMessage(FTest);
end;
Now if I access the various implementations like this I get the following results:
procedure TestInterfaces;
var
AA: TObjectA;
YY: IInterfaceY;
ZZ: IInterfaceZ;
NewYY: IInterfaceY;
begin
AA := TObjectA.Create;
// Make sure that the Supports doesn't kill the object.
// This line of code is necessary in XE2 but not in XE4
AA._AddRef;
// This will add one to the refcount for AA despite the fact
// that AA has delegated the implementation of IInterfaceY to
// to FObjectC.
Supports(AA, IInterfaceY, YY);
YY.DoNothing;
// This will add one to the refcount for FInterfaceB.
// This is also allowing a supports from a delegated interface
// to another delegated interface.
Supports(YY, IInterfaceZ, ZZ);
ZZ.DoSomething;
// This will fail because the underlying object is actually
// the object referenced by FInterfaceB.
Supports(ZZ, IInterfaceY, NewYY);
NewYY.DoNothing;
end;
The first Supports call, which uses the variable in the implements, returns YY which is actually a reference to TObjectA. My AA variable is reference counted. Because the underlying reference counted object is a TObjectA, the second supports, which uses the interface in the supports call, works and returns me an interface. The underlying object is actually now a TObjectB. The internal object behind FInterfaceB is the object being reference counted. This part makes sense because GetBB is actually FInterfaceB. As expected here, the last call to Supports returns a null for NewYY and the call at the end fails.
My question is this, is the reference counting on TObjectA with the first supports call by design? In other words, when the property that implements the interface is returning an object and not an interface does this mean that the owner object will be the one doing the reference counting? I was always under the impression that implements would also result in the internal delegated object being reference counted instead of the main object.
The declarations are as follows:
property BB: IInterfaceZ read GetBB implements IInterfaceZ;
With this option above, the internal object behind FInterfaceB is the one that is reference counted.
property CC: TObjectC read FObjectC implements IInterfaceY;
With this second option above, TObjectA is the one that is being reference counted and not the delegated object FObjectC.
Is this by design?
Edit
I just tested this in XE2 and the behavior is different. The second Supports statement returns nil for ZZ. The debugger in XE4 tells me that the YY is referring to (TObjectA as IInterfaceY). In XE2 it tells me that its a (Pointer as IInterfaceY). Also, in XE2, the AA is not ref counted on the first support statement but the internal FObjectC is reference counted.
Additional Information after the question answered
There is one caveat to this. You can chain the Interface version but not the object version. That means that something like this will work:
TObjectBase = class(TInterfacedObject, IMyInterface)
…
end;
TObjectA = class(TInterfacedObject, IMyInterface)
FMyInterfaceBase: IMyInterface;
property MyDelegate: IMyInterface read GetMyInterface implements IMyInterface;
end;
function TObjectA.GetMyInterface: IMyInterface;
begin
result := FMyInterfaceBase;
end;
TObjectB = class(TInterfacedObject, IMyInterface)
FMyInterfaceA: IMyInterface;
function GetMyInterface2: IMyInterface;
property MyDelegate2: IMyInterface read GetMyInterface2 implements IMyInterface;
end;
function TObjectB.GetMyInterface2: IMyInterface;
begin
result := FMyInterfaceA;
end;
But the object version gives a compiler error with this saying that TObjectB doesn't implement the methods for the interface.
TObjectBase = class(TInterfacedObject, IMyInterface)
…
end;
TObjectA = class(TInterfacedObject, IMyInterface)
FMyObjectBase: TMyObjectBase;
property MyDelegate: TMyObjectBase read FMyObjectBase implements IMyInterface;
end;
TObjectB = class(TInterfacedObject, IMyInterface)
FMyObjectA: TObjectA;
property MyDelegate2: TObjectA read FMyObjectA implements IMyInterface;
end;
So if you want to start chaining the delegation then you need to stick to interfaces or work around it another way.

tl;dr This is all by design – it's just that the design changes between XE2 and XE3.
XE3 and later
There is quite a difference between delegation to an interface type property and delegation to a class type property. Indeed the documentation calls out this difference explicitly with different sections for the two delegation variants.
The difference from your perspective is as follows:
When TObjectA implements IInterfaceY by delegating to class type property CC, the implementing object is the instance of TObjectA.
When TObjectA implements IInterfaceZ by delegating to interface type property BB, the implementing object is the object that implements FInterfaceB.
One key thing to realise in all this is that when you delegate to a class type property, the class that is delegated to need not implement any interfaces. So it need not implement IInterface and so need not have _AddRef and _Release methods.
To see this, modify your code's definition of TObjectC to be like so:
TObjectC = class
public
procedure DoNothing;
end;
You will see that this code compiles, runs, and behaves exactly the same way as does your version.
In fact this is ideally how you would declare a class to which an interface is delegated as a class type property. Doing it this way avoids the lifetime issues with mixing interface and class type variables.
So, let's look at your three calls to Supports:
Supports(AA, IInterfaceY, YY);
Here the implementing object is AA and so the reference count of AA is incremented.
Supports(YY, IInterfaceZ, ZZ);
Here the implementing object is the instance of TObjectB so its reference count is incremented.
Supports(ZZ, IInterfaceY, NewYY);
Here, ZZ is an interface implemented by the instance of TObjectB which does not implement IInterfaceY. Hence Supports returns False and NewYY is nil.
XE2 and earlier
The design changes between XE2 and XE3 coincide with the introduction of the mobile ARM compiler and there were many low-level changes to support ARC. Clearly some of these changes apply to the desktop compilers too.
The behavioural difference that I can find concerns delegation of interface implementation to class type properties. And specifically when the class type in question supports IInterface. In that scenario, in XE2, the reference counting is performed by the inner object. That differs from XE3 which has the reference counting performed by the outer object.
Note that for a class type that does not support IInterface, the reference counting is performed by the outer object in all versions. That makes sense since there's no way for the inner object to do it.
Here's my example code to demonstrate the difference:
{$APPTYPE CONSOLE}
uses
SysUtils;
type
Intf1 = interface
['{56FF4B9A-6296-4366-AF82-9901A5287BDC}']
procedure Foo;
end;
Intf2 = interface
['{71B0431C-DB83-49F0-B084-0095C535AFC3}']
procedure Bar;
end;
TInnerClass1 = class(TObject, Intf1)
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
procedure Foo;
end;
TInnerClass2 = class
procedure Bar;
end;
TOuterClass = class(TObject, Intf1, Intf2)
private
FInnerObj1: TInnerClass1;
FInnerObj2: TInnerClass2;
public
constructor Create;
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
property InnerObj1: TInnerClass1 read FInnerObj1 implements Intf1;
property InnerObj2: TInnerClass2 read FInnerObj2 implements Intf2;
end;
function TInnerClass1.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
if GetInterface(IID, Obj) then
Result := 0
else
Result := E_NOINTERFACE;
end;
function TInnerClass1._AddRef: Integer;
begin
Writeln('TInnerClass1._AddRef');
Result := -1;
end;
function TInnerClass1._Release: Integer;
begin
Writeln('TInnerClass1._Release');
Result := -1;
end;
procedure TInnerClass1.Foo;
begin
Writeln('Foo');
end;
procedure TInnerClass2.Bar;
begin
Writeln('Bar');
end;
constructor TOuterClass.Create;
begin
inherited;
FInnerObj1 := TInnerClass1.Create;
end;
function TOuterClass.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
if GetInterface(IID, Obj) then
Result := 0
else
Result := E_NOINTERFACE;
end;
function TOuterClass._AddRef: Integer;
begin
Writeln('TOuterClass._AddRef');
Result := -1;
end;
function TOuterClass._Release: Integer;
begin
Writeln('TOuterClass._Release');
Result := -1;
end;
var
OuterObj: TOuterClass;
I1: Intf1;
I2: Intf2;
begin
OuterObj := TOuterClass.Create;
Supports(OuterObj, Intf1, I1);
Supports(OuterObj, Intf2, I2);
I1.Foo;
I2.Bar;
I1 := nil;
I2 := nil;
Readln;
end.
The output on XE2 is:
TInnerClass1._AddRef
TOuterClass._AddRef
Foo
Bar
TInnerClass1._Release
TOuterClass._Release
The output on XE3 is:
TOuterClass._AddRef
TOuterClass._AddRef
Foo
Bar
TOuterClass._Release
TOuterClass._Release
Discussion
Why did the design change? I cannot answer that definitively, not being privy to the decision making. However, the behaviour in XE3 feels better to me. If you declare a class type variable you would expect its lifetime to be managed as any other class type variable would be. That is, by explicit calls to destructor on the desktop compilers, and by ARC on the mobile compilers.
The behaviour of XE2 on the other hand feels inconsistent. Why should the fact that a property is used for interface implementation delegation change the way its lifetime is managed?
So, my instincts tell me that this was a design flaw, at best, in the original implementation of interface implementation delegation. The design flaw has led to confusion and lifetime management troubles over the years. The introduction to ARC forced Embarcadero to review this issue and they changed the design. My belief is that the introduction of ARC required a design change because Embarcadero have a track record of not changing behaviour unless absolutely necessary.
The paragraphs above are clearly speculation on my part, but that's the best I have to offer!

You are mixing object pointers and interface pointers, which is always a recipe for disaster. TObjectA is not incrementing the reference count of its inner objects to ensure they stay alive for its entire lifetime, and TestInterfaces() is not incrementing the reference count of AA to ensure it survives through the entire set of tests. Object pointers DO NOT participate in reference counting! You have to manage it manually, eg:
procedure TObjectA.AfterConstruction;
begin
inherited;
FObjectB := TObjectB.Create;
FObjectB._AddRef;
FObjectC := TObjectC.Create;
FObjectC._AddRef;
FObjectC.FTest := 'Testing';
end;
procedure TObjectA.BeforeDestruction;
begin
FObjectC._Release;
FObjectB._Release;
inherited;
end;
AA := TObjectA.Create;
AA._AddRef;
Needless to say, manual reference counting undermines the use of interfaces.
When dealing with interfaces, you need to either:
Disable reference counting completely to avoid premature destructions. TComponent, for instance, does exactly that.
Do EVERYTHING using interface pointers, NEVER with object pointers. This ensures proper reference counting across the board. This is generally the preferred solution.

Related

How to access private methods without helpers?

In Delphi 10 Seattle I could use the following code to work around overly strict visibility restrictions.
How do I get access to private variables?
type
TBase = class(TObject)
private
FMemberVar: integer;
end;
And how do I get access to plain or virtual private methods?
type
TBase2 = class(TObject)
private
procedure UsefullButHidden;
procedure VirtualHidden; virtual;
procedure PreviouslyProtected; override;
end;
Previously I would use a class helper to break open the base class.
type
TBaseHelper = class helper for TBase
function GetMemberVar: integer;
In Delphi 10.1 Berlin, class helpers no longer have access to private members of the subject class or record.
Is there an alternative way to access private members?
If there is extended RTTI info generated for the class private members - fields and/or methods you can use it to gain access to them.
Of course, accessing through RTTI is way slower than it was through class helpers.
Accessing methods:
var
Base: TBase2;
Method: TRttiMethod;
Method := TRttiContext.Create.GetType(TBase2).GetMethod('UsefullButHidden');
Method.Invoke(Base, []);
Accessing variables:
var
Base: TBase;
v: TValue;
v := TRttiContext.Create.GetType(TBase).GetField('FMemberVar').GetValue(Base);
Default RTTI information generated for RTL/VCL/FMX classes is following
Fields - private, protected, public, published
Methods - public, published
Properties - public, published
Unfortunately, that means accessing private methods via RTTI for core Delphi libraries is not available. #LU RD's answer covers hack that allows private method access for classes without extended RTTI.
Working with RTTI
There is still a way to use class helpers for access of private methods in Delphi 10.1 Berlin:
type
TBase2 = class(TObject)
private
procedure UsefullButHidden;
procedure VirtualHidden; virtual;
procedure PreviouslyProtected; override;
end;
TBase2Helper = class helper for TBase2
procedure OpenAccess;
end;
procedure TBase2Helper.OpenAccess;
var
P : procedure of object;
begin
TMethod(P).Code := #TBase2.UsefullButHidden;
TMethod(P).Data := Self;
P; // Call UsefullButHidden;
// etc
end;
Unfortunately there is no way to access strict private/private fields by class helpers with Delphi 10.1 Berlin. RTTI is an option, but can be considered slow if performance is critical.
Here is a way to define the offset to a field at startup using class helpers and RTTI:
type
TBase = class(TObject)
private // Or strict private
FMemberVar: integer;
end;
type
TBaseHelper = class helper for TBase
private
class var MemberVarOffset: Integer;
function GetMemberVar: Integer;
procedure SetMemberVar(value: Integer);
public
class constructor Create; // Executed at program start
property MemberVar : Integer read GetMemberVar write SetMemberVar;
end;
class constructor TBaseHelper.Create;
var
ctx: TRTTIContext;
begin
MemberVarOffset := ctx.GetType(TBase).GetField('FMemberVar').Offset;
end;
function TBaseHelper.GetMemberVar: Integer;
begin
Result := PInteger(Pointer(NativeInt(Self) + MemberVarOffset))^;
end;
procedure TBaseHelper.SetMemberVar(value: Integer);
begin
PInteger(Pointer(NativeInt(Self) + MemberVarOffset))^ := value;
end;
This will have the benefit that the slow RTTI part is only executed once.
Note: Using RTTI for access of protected/private methods
The RTL/VCL/FMX have not declared visibility for access of protected/private methods with RTTI. It must be set with the local directive {$RTTI}.
Using RTTI for access of private/protected methods in other code requires for example setting :
{$RTTI EXPLICIT METHODS([vcPublic, vcProtected, vcPrivate])}
If you want a clean way that does not impact performance, you still can access private fields from a record helper using the with statement.
function TValueHelper.GetAsInteger: Integer;
begin
with Self do begin
Result := FData.FAsSLong;
end;
end;
I hope they keep this method open, because we have code with high performance demands.
Assuming that extended RTTI is not available, then without resorting to what would be considered hacking, you cannot access private members from code in a different unit. Of course, if RTTI is available it can be used.
It is my understanding that the ability to crack private members using helpers was an unintentional accident. The intention is that private members only be visible from code in the same unit, and strict private members only be visible from code in the same class. This change corrects the accident.
Without the ability to have the compiler crack the class for you, you would need to resort to other ways to do so. For instance, you could re-declare enough of the TBase class to be able to trick the compiler into telling you where a member lived.
type
THackBase = class(TObject)
private
FMemberVar: integer;
end;
Now you can write
var
obj: TBase;
....
MemberVar := THackBase(obj).FMemberVar;
But this is horrendously brittle and will break as soon as the layout of TBase is changed.
That will work for data members, but for non-virtual methods, you'd probably need to use runtime disassembly techniques to find the location of the code. For virtual members this technique can be used to find the VMT offset.
Further reading:
http://hallvards.blogspot.nl/2004/06/hack-5-access-to-private-fields.html
https://bitbucket.org/NickHodges/delphi-unit-tests/wiki/Accessing%20Private%20Members
If you don't need ARM compiler support, you can find another solution here.
With inline asembler, you can access private field or method, easily.
I think David's answer is better in most case, but if you need a quick solution for a huge class, this method could be more useful.
Update(June 17): I've just noticed, I forgot to share his sample code for accessing private fields from his post. sorry.
unit UnitA;
type
THoge = class
private
FPrivateValue: Integer;
procedure PrivateMethod;
end;
end.
unit UnitB;
type
THogeHelper = class helper for THoge
public
function GetValue: Integer;
procedure CallMethod;
end;
function THogeHelper.GetValue: Integer;
asm
MOV EAX,Self.FPrivateValue
end;
procedure THogeHelper.CallMethod;
asm
CALL THoge.PrivateMethod
end;
Here is his sample code for calling private method.
type
THoge = class
private
procedure PrivateMethod (Arg1, Arg2, Arg3 : Integer);
end;
// Method 1
// Get only method pointer (if such there is a need to assign a method pointer to somewhere)
type
THogePrivateProc = procedure (Self: THoge; Arg1, Arg2, Arg3: Integer);
THogePrivateMethod = procedure (Arg1, Arg2, Arg3: Integer) of object;
function THogeHelper.GetMethodAddr: Pointer;
asm
{$ifdef CPUX86}
LEA EAX, THoge.PrivateMethod
{$else}
LEA RAX, THoge.PrivateMethod
{$endif}
end;
var
hoge: THoge;
proc: THogePrivateProc;
method: THogePrivateMethod;
begin
// You can either in here of the way,
proc := hoge.GetMethodAddr;
proc (hoge, 1, 2, 3);
// Even here of how good
TMethod (method) .Code := hoge.GetMethodAddr;
TMethod (method) .Data := hoge;
method (1, 2, 3) ;
end;
// Method 2
// To jump (here is simple if you just simply call)
procedure THogeHelper.CallMethod (Arg1, Arg2, Arg3 : Integer);
asm
JMP THoge.PrivateMethod
end;
unit UnitA;
type
THoge = class
private
FPrivateValue: Integer;
procedure PrivateMethod;
end;
end.
Just use 'with' statement to access private fields !
See the sample code below, taken from this article I noticed today. (Thanks, Mr.DEKO as always !)
This hack is originally reported on QualityPortal in August 2019 as described on above aritcle. (login required)
before rewrite (using "asm" method)
function TPropertyEditorHelper.GetPropList: PInstPropList;
{$IF CompilerVersion < 31.0}
begin
Result := Self.FPropList;
end;
{$ELSE}
// http://d.hatena.ne.jp/tales/20160420/1461081751
asm
MOV EAX, Self.FPropList;
end;
{$IFEND}
rewrite using 'with'
function TPropertyEditorHelper.GetPropList: PInstPropList;
begin
with Self do
Result := FPropList;
end;
I was amazed it's so simple :-)

Casting object to interface type with no TInterfacedObject as base class

I need a class implementing interface with no reference counting. I did the following:
IMyInterface = interface(IInterface)
['{B84904DF-9E8A-46E0-98E4-498BF03C2819}']
procedure InterfaceMethod;
end;
TMyClass = class(TObject, IMyInterface)
protected
function _AddRef: Integer;stdcall;
function _Release: Integer;stdcall;
function QueryInterface(const IID: TGUID; out Obj): HResult;stdcall;
public
procedure InterfaceMethod;
end;
procedure TMyClass.InterfaceMethod;
begin
ShowMessage('The Method');
end;
function TMyClass.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
if GetInterface(IID, Obj) then
Result := 0
else
Result := E_NOINTERFACE;
end;
function TMyClass._AddRef: Integer;
begin
Result := -1;
end;
function TMyClass._Release: Integer;
begin
Result := -1;
end;
Lack of reference counting works fine. But my concern is that I cannot cast TMyClass to IMyInterface using as operator:
var
MyI: IMyInterface;
begin
MyI := TMyClass.Create as IMyInterface;
I am given
[DCC Error] E2015 Operator not applicable to this operand type
The problem disappears when TMyClass derives from TInterfacedObject - i.e. I can do such casting without compiler error. Obviously I do not want to use TInterfacedObject as a base class as it would make my class reference counted. Why is such casting disallowed and how one would workaround it?
The reason you cannot use as in your code is that your class does not explicitly list IInterface in its list of supported interfaces. Even though your interface derives from IInterface, unless you actually list that interface, your class does not support it.
So, the trivial fix is to declare your class like this:
TMyClass = class(TObject, IInterface, IMyInterface)
The reason that your class needs to implement IInterface is that is what the compiler is relying on in order to implement the as cast.
The other point I would like to make is that you should, in general, avoid using interface inheritance. By and large it serves little purpose. One of the benefits of using interfaces is that you are free from the single inheritance constraint that comes with implementation inheritance.
But in any case, all Delphi interfaces automatically inherit from IInterface so in your case there's no point specifying that. I would declare your interface like this:
IMyInterface = interface
['{B84904DF-9E8A-46E0-98E4-498BF03C2819}']
procedure InterfaceMethod;
end;
More broadly you should endeavour not to use inheritance with your interfaces. By taking that approach you will encourage less coupling and that leads to greater flexibility.

In Delphi is it possible to bind an interface to an object that doesn't implement it

I know Delphi XE2 has the new TVirtualInterface for creating implementations of an interface at runtime. Unfortunately I am not using XE2 and I'm wondering what kind of hackery is involved in doing this sort of thing in older versions of Delphi.
Lets say I have the following interface:
IMyInterface = interface
['{8A827997-0058-4756-B02D-8DCDD32B7607}']
procedure Go;
end;
Is it possible to bind to this interface at runtime without the help of the compiler?
TMyClass = class(TObject, IInterface)
public
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
procedure Go; //I want to dynamically bind IMyInterface.Go here
end;
I've tried a simple hard cast:
var MyInterface: IMyInterface;
begin
MyInterface := IMyInterface(TMyClass.Create);
end;
but the compiler prevents this.
Then I tried an as cast and it at least compiled:
MyInterface := TMyClass.Create as IMyInterface;
So I imagine the key is to get QueryInterface to return a valid pointer to an Implementation of the interface being queried. How would I go about constructing one at runtime?
I've dug through System.pas so I'm at least vaguely familiar with how GetInterface, GetInterfaceEntry and InvokeImplGetter work. (thankfully Embacadero chose to leave the pascal source along with the optimized assembly). I may not be reading it right but it appears that there can be interface entries with an offset of zero in which case there is an alternative means of assigning the interface using InvokeImplGetter.
My ultimate goal is to simulate some of the abilities of dynamic proxies and mocks that are available in languages with reflection support. If I can successfully bind to an object that has the same method names and signatures as the interface it would be a big first step. Is this even possible or am I barking up the wrong tree?
Adding support for an interface to an existing class at runtime can theoretically be done, but it would be really tricky, and it would require D2010 or later for RTTI support.
Each class has a VMT, and the VMT has an interface table pointer. (See the implementation of TObject.GetInterfaceTable.) The interface table contains interface entries, which contain some metadata, including the GUID, and a pointer to the interface vtable itself. If you really wanted to, you could create a copy of the interface table, (DO NOT do this the original one; you're likely to end up corrupting memory!) add a new entry to it containing a new interface vtable with the pointers pointing to the correct methods, (which you could match by looking them up with RTTI,) and then change the class's interface table pointer to point to the new table.
Be very careful. This sort of work is really not for the faint of heart, and it seems to me it's of kind of limited utility. But yes, it's possible.
I'm not sure, what you want to accomplish and why you want to dynamically bind that interface, but here is a way to do it (don't know if it fits your need):
type
IMyInterface = interface
['{8A827997-0058-4756-B02D-8DCDD32B7607}']
procedure Go;
end;
TMyClass = class(TInterfacedObject, IInterface)
private
FEnabled: Boolean;
protected
property Enabled: Boolean read FEnabled;
public
constructor Create(AEnabled: Boolean);
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
procedure Go; //I want to dynamically bind IMyInterface.Go here
end;
TMyInterfaceWrapper = class(TAggregatedObject, IMyInterface)
private
FMyClass: TMyClass;
protected
property MyClass: TMyClass read FMyClass implements IMyInterface;
public
constructor Create(AMyClass: TMyClass);
end;
constructor TMyInterfaceWrapper.Create(AMyClass: TMyClass);
begin
inherited Create(AMyClass);
FMyClass := AMyClass;
end;
constructor TMyClass.Create(AEnabled: Boolean);
begin
inherited Create;
FEnabled := AEnabled;
end;
procedure TMyClass.Go;
begin
ShowMessage('Go');
end;
function TMyClass.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
if Enabled and (IID = IMyInterface) then begin
IMyInterface(obj) := TMyInterfaceWrapper.Create(Self);
result := 0;
end
else begin
if GetInterface(IID, Obj) then
Result := 0
else
Result := E_NOINTERFACE;
end;
end;
And this is the corresponding test code:
var
intf: IInterface;
my: IMyInterface;
begin
intf := TMyClass.Create(false);
if Supports(intf, IMyInterface, my) then
ShowMessage('wrong');
intf := TMyClass.Create(true);
if Supports(intf, IMyInterface, my) then
my.Go;
end;

Delphi Rtti for interfaces in a generic context

for a framework I wrote a wrapper which takes any object, interface or record type to explore its properties or fields. The class declaration is as follows:
TWrapper<T> = class
private
FType : TRttiType;
FInstance : Pointer;
{...}
public
constructor Create (var Data : T);
end;
In the constructor I try to get the type information for further processing steps.
constructor TWrapper<T>.Create (var Data : T);
begin
FType := RttiCtx.GetType (TypeInfo (T));
if FType.TypeKind = tkClass then
FInstance := TObject (Data)
else if FType.TypeKind = tkRecord then
FInstance := #Data
else if FType.TypeKind = tkInterface then
begin
FType := RttiCtx.GetType (TObject (Data).ClassInfo); //<---access violation
FInstance := TObject (Data);
end
else
raise Exception.Create ('Unsupported type');
end;
I wonder if this access violation is a bug in delphi compiler (I'm using XE).
After further investigation I wrote a simple test function, which shows, that asking for the class name produces this exception as well:
procedure TestForm.FormShow (Sender : TObject);
var
TestIntf : IInterface;
begin
TestIntf := TInterfacedObject.Create;
OutputDebugString(PChar (TObject (TestIntf).ClassName)); //Output: TInterfacedObject
Test <IInterface> (TestIntf);
end;
procedure TestForm.Test <T> (var Data : T);
begin
OutputDebugString(PChar (TObject (Data).ClassName)); //access violation
end;
Can someone explain me, what is wrong? I also tried the procedure without a var parameter which did not work either. When using a non generic procedure everything works fine, but to simplify the use of the wrapper the generic solution would be nice, because it works for objects and records the same way.
Kind regards,
Christian
Your code contains two wrong assumptions:
That you can obtain meaningful RTTI from Interfaces. Oops, you can get RTTI from interface types.
That a Interface is always implemented by a Delphi object (hence your attempt to extract the RTTI from the backing Delphi object).
Both assumptions are wrong. Interfaces are very simple VIRTUAL METHOD tables, very little magic to them. Since an interface is so narrowly defined, it can't possibly have RTTI. Unless of course you implement your own variant of RTTI, and you shouldn't. LE: The interface itself can't carry type information the way an TObject does, but the TypeOf() operator can get TypeInfo if provided with a IInterface
Your second assumption is also wrong, but less so. In the Delphi world most interfaces will be implemented by Delphi objects, unless of course you obtain the interface from a DLL written in an other programming language: Delphi's interfaces are COM-compatible, so it's implementations can be consumed from any other COM-compatible language and vice versa. But since we're talking Delphi XE here, you can use this syntax to cast an interface to it's implementing object in an intuitive and readable way:
TObject := IInterface as TObject;
that is, use the as operator. Delphi XE will at times automagically convert a hard cast of this type:
TObject := TObject(IInterface);
to the mentioned "as" syntax, but I don't like this magic because it looks very counter-intuitive and behaves differently in older versions of Delphi.
Casting the Interface back to it's implementing object is also wrong from an other perspective: It would show all the properties of the implementing object, not only those related to the interface, and that's very wrong, because you're using Interfaces to hide those implementation details in the first place!
Example: Interface implementation not backed by Delphi object
Just for fun, here's a quick demo of an interface that's not backed by an Delphi object. Since an Interface is nothing but an pointer to a virtual method table, I'll construct the virtual method table, create a pointer to it and cast the the pointer to the desired Interface type. All method pointers in my fake Virtual Method table are implemented using global functions and procedures. Just imagine trying to extract RTTI from my i2 interface!
program Project26;
{$APPTYPE CONSOLE}
uses
SysUtils;
type
// This is the interface I will implement without using TObject
ITestInterface = interface
['{CFC4942D-D8A3-4C81-BB5C-6127B569433A}']
procedure WriteYourName;
end;
// This is a sample, sane implementation of the interface using an
// TInterfacedObject method
TSaneImplementation = class(TInterfacedObject, ITestInterface)
public
procedure WriteYourName;
end;
// I'll use this record to construct the Virtual Method Table. I could use a simple
// array, but selected to use the record to make it easier to see. In other words,
// the record is only used for grouping.
TAbnormalImplementation_VMT = record
QueryInterface: Pointer;
AddRef: Pointer;
ReleaseRef: Pointer;
WriteYourName: Pointer;
end;
// This is the object-based implementation of WriteYourName
procedure TSaneImplementation.WriteYourName;
begin
Writeln('I am the sane interface implementation');
end;
// This will implement QueryInterfce for my fake IInterface implementation. All the code does
// is say the requested interface is not supported!
function FakeQueryInterface(const Self:Pointer; const IID: TGUID; out Obj): HResult; stdcall;
begin
Result := S_FALSE;
end;
// This will handle reference counting for my interface. I am not using true reference counting
// since there is no memory to be freed, si I am simply returning -1
function DummyRefCounting(const Self:Pointer): Integer; stdcall;
begin
Result := -1;
end;
// This is the implementation of WriteYourName for my fake interface.
procedure FakeWriteYourName(const Self:Pointer);
begin
WriteLn('I am the very FAKE interface implementation');
end;
var i1, i2: ITestInterface;
R: TAbnormalImplementation_VMT;
PR: Pointer;
begin
// Instantiate the sane implementation
i1 := TSaneImplementation.Create;
// Instantiate the very wrong implementation
R.QueryInterface := #FakeQueryInterface;
R.AddRef := #DummyRefCounting;
R.ReleaseRef := #DummyRefCounting;
R.WriteYourName := #FakeWriteYourName;
PR := #R;
i2 := ITestInterface(#PR);
// As far as all the code using ITestInterface is concerned, there is no difference
// between "i1" and "i2": they are just two interface implementations.
i1.WriteYourName; // Calls the sane implementation
i2.WriteYourName; // Calls my special implementation of the interface
WriteLn('Press ENTER to EXIT');
ReadLn;
end.
Two possible answers.
If this always happens, even when T is an object, then it's a compiler error and you ought to file a QC report about it. (With Interfaces, the cast-an-interface-to-an-object thing requires some black magic from the compiler, and it's possible that the generics subsystem doesn't implement it properly.)
If you're taking a T that's not an object, though, such as a record type, and getting this error, then everything's working as designed; you're just using typecasts improperly.
Either way, there's a way to get RTTI information out of any arbitrary type. You know how TRttiContext.GetType has two overloads? Use the other one. Instead of calling GetType (TObject (Data).ClassInfo), try calling GetType(TypeInfo(Data)).
Oh, and declare FInstance as a T instead of a pointer. It'll save you a lot of hassle.

How to pass a method as callback to a Windows API call?

I'd like to pass a method of a class as callback to a WinAPI function. Is this possible and if yes, how?
Example case for setting a timer:
TMyClass = class
public
procedure TimerProc(Wnd:HWND; uMsg:DWORD; idEvent:PDWORD; dwTime:DWORD);
procedure DoIt;
end;
[...]
procedure TMyClass.DoIt;
begin
SetTimer(0, 0, 8, #TimerProc); // <-???- that's what I want to do (last param)
end;
Thanks for your help!
Edit: The goal is to specify a method of this class as callback. No procedure outside the class.
Edit2: I appreciate all your help but as long as the method has no "TMyClass." in front of its name it is not what I am searching for. I used to do it this way but wondered if could stay fully in the object oriented world. Pointer magic welcome.
Madshi has a MethodToProcedure procedure. It's in the "madTools.pas" which is in the "madBasic" package. If you use it, you should change the calling convention for "TimerProc" to stdcall and DoIt procedure would become,
TMyClass = class
private
Timer: UINT;
SetTimerProc: Pointer;
[...]
procedure TMyClass.DoIt;
begin
SetTimerProc := MethodToProcedure(Self, #TMyClass.TimerProc);
Timer := SetTimer(0, 0, 8, SetTimerProc);
end;
// After "KillTimer(0, Timer)" is called call:
// VirtualFree(SetTimerProc, 0, MEM_RELEASE);
I've never tried but I think one could also try to duplicate the code in the "classses.MakeObjectInstance" for passing other procedure types than TWndMethod.
Which version of Delphi are you using?
In recent ones you can use static class methods for this:
TMyClass = class
public
class procedure TimerProc(Wnd:HWND; uMsg:DWORD; idEvent:PDWORD; dwTime:DWORD); stdcall; static;
procedure DoIt;
end;
[...]
procedure TMyClass.DoIt;
begin
SetTimer(0, 0, 8, #TimerProc);
end;
The TimerProc procedure should be a standard procedure, not a method pointer.
A method pointer is really a pair of
pointers; the first stores the address
of a method, and the second stores a
reference to the object the method
belongs to
Edit
This might be as much OOP as you are going to get it. All the nasty stuff is hidden from anyone using your TMyClass.
unit Unit2;
interface
type
TMyClass = class
private
FTimerID: Integer;
FPrivateValue: Boolean;
public
constructor Create;
destructor Destroy; override;
procedure DoIt;
end;
implementation
uses
Windows, Classes;
var
ClassList: TList;
constructor TMyClass.Create;
begin
inherited Create;
ClassList.Add(Self);
end;
destructor TMyClass.Destroy;
var
I: Integer;
begin
I := ClassList.IndexOf(Self);
if I <> -1 then
ClassList.Delete(I);
inherited;
end;
procedure TimerProc(Wnd:HWND; uMsg:DWORD; idEvent:PDWORD; dwTime:DWORD); stdcall;
var
I: Integer;
myClass: TMyClass;
begin
for I := 0 to Pred(ClassList.Count) do
begin
myClass := TMyClass(ClassList[I]);
if myClass.FTimerID = Integer(idEvent) then
myClass.FPrivateValue := True;
end;
end;
procedure TMyClass.DoIt;
begin
FTimerID := SetTimer(0, 0, 8, #TimerProc); // <-???- that's what I want to do (last param)
end;
initialization
ClassList := TList.Create;
finalization
ClassList.Free;
end.
Edit: (as mentioned by glob)
Don't forget to add the stdcall calling convention.
Response to your second edit:
If you want a reply that includes a pointer to a TMyClass instance, you may be out of luck. Fundamentally, the procedure Windows will call has a certain signature and is not an object method. You cannot directly work around that, not even with __closure or procedure of object magic, except as described below and in other answers. Why?
Windows has no knowledge of it being an object method, and wants to call a procedure with a specific signature.
The pointer is no longer a simple pointer - it has two halves, the object instance and the method. It needs to save the Self, as well as the method.
By the way, I don't understand what is wrong with a short dip outside the object-oriented world. Non-OO code is not necessarily dirty if used well.
Original, pre-your-edit answer:
It's not possible exactly as you are trying to do it. The method that SetTimer wants must exactly follow the TIMERPROC signature - see the MSDN documentation. This is a simple, non-object procedure.
However, the method TMyClass.DoIt is an object method. It actually has two parts: the object on which it is called, and the method itself. In Delphi, this is a "procedure of object" or a "closure" (read about procedural types here). So, the signatures are not compatible, and you cannot store the object instance, which you need in order to call an object method. (There are also calling convention problems - standard Delphi methods are implemented using the fastcall convention, whereas TIMERPROC specifies CALLBACK which, from memory, is a macro that expands to stdcall. Read more about calling conventions and especially fastcall.)
So, what do you do? You need to map your non-object-oriented callback into object-oriented code.
There are several ways, and the simplest is this:
If you only have one timer ever, then you know that when your timer callback is called it is that specific timer that fired. Save a method pointer in a variable that is of type procedure of object with the appropriate signature. See the Embarcadero documentation link above for more details. It will probably look like:
type TMyObjectProc = procedure of object;
var pfMyProc : TMyObjectProc;
Then, initialise pfMyProc to nil. In TMyClass.DoIt, set pfMyProc to #DoIt - that is, it is now pointing at the DoIt procedure in the context of that specific TMyClass instantiation. Your callback can then call that method.
(If you're interested, class variables that are of a procedural type like this are how event handlers are stored internally. The OnFoo properties of a VCL object are pointers to object procedures.)
Unfortunately this procedural architecture is not object-oriented, but it's how it has to be done.
Here's what some full code might look like (I'm not at a compiler, so it may not work as written, but it should be close):
type TMyObjectProc = procedure of object;
var pfMyProc : TMyObjectProc;
initialization
pfMyProc = nil;
procedure MyTimerCallback(hWnd : HWND; uMsg : DWORD; idEvent : PDWORD; dwTime : DWORD); stdcall;
begin
if Assigned(pfMyProc) then begin
pfMyProc(); // Calls DoIt, for the object that set the timer
pfMyProc = nil;
end;
end;
procedure TMyClass.MyOOCallback;
begin
// Handle your callback here
end;
procedure TMyClass.DoIt;
begin
pfMyProc = #MyOOCallback;
SetTimer(0, 0, 8, # MyTimerCallback);
end;
Another way would be to take advantage of the fact your timer has a unique ID. Save a mapping between the timer ID and the the object. In the callback, convert from the ID to the pointer, and call the object's method.
Edit: I've noticed a comment to another answer suggesting using the address of your object as the timer ID. This will work, but is a potentially dangerous hack if you end up having two objects at the same address at different times, and you don't call KillTimer. I've used that method but don't personally like it - I think the extra bookkeeping of keeping a (timer ID, object pointer) map is better. It really comes down to personal style, though.
I've used MakeObjectInstance a few times to do the same.
Here's an article on the subject:
How to use a VCL class member-function as a Win32 callback
TMyClass = class
public
procedure DoIt;
procedure DoOnTimerViaMethod;
end;
var MyReceiverObject: TMyClass;
[...]
procedure TimerProc(Wnd:HWND; uMsg:DWORD; idEvent:PDWORD; dwTime:DWORD); stdcall:
begin
if Assigned(MyReceiverObject) then
MyReceiverObject.DoOnTimerViaMethod;
end;
procedure TMyClass.DoIt;
begin
MyReceiverObject := Self;
SetTimer(0, 0, 8, #TimerProc); // <-???- that's what I want to do (last param)
end;
Not perfect. Watch for the threads, variable overwriting etc. But it does the job.

Resources