I have this test program https://gist.github.com/real-mielofon/5002732
RttiValue := RttiMethod.Invoke(RttiInstance, [10]);
and simple unit with interface:
unit Unit163;
interface
type
{$M+}
ISafeIntf = interface
function TestMethod(aI: integer): integer; safecall;
end;
{$M-}
type
TSafeClass = class(TInterfacedObject, ISafeIntf)
public
function TestMethod(aI: integer): integer; safecall;
end;
implementation
function TSafeClass.TestMethod(aI: integer): integer;
begin
result := aI+1; // Exception !!
end;
end.
and I have kaboom on
result := aI+1;
if it is procedure or isn't safecall, then it's all right :-(
Having now tried this myself, and looked at the the code, my conclusion is that there is a bug. The RTTI unit does indeed attempt to perform safecall method re-writing. It just appears to get it wrong. I recommend that you submit your project as a QC report, and workaround the problem by using stdcall with HRESULT return values.
Related
This simple program doesn't compile. [Tested with XE5 and D10.]
program Project10;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.Classes;
function MakeProc: TThreadProcedure;
begin
Result := procedure begin end;
end;
begin
TThread.Queue(nil, MakeProc);
end.
Compiler reports error
[dcc32 Error] Project10.dpr(16): E2250 There is no overloaded version of 'Queue' that can be called with these arguments
in the TThread.Queue call.
Class TThread implements two Queue overloads.
class procedure Queue(const AThread: TThread; AMethod: TThreadMethod); overload; static;
class procedure Queue(AThread: TThread; AThreadProc: TThreadProcedure); overload; static;
I'm pretty sure that my code should match the second overload.
The only workaround I was able to find is this:
TThread.Queue(nil, procedure begin MakeProc; end);
Am I doing something wrong or is this a compiler bug? Is there a better workaround than my ugly hack?
The compiler evidently thinks you're trying to pass MakeProc itself as the argument. You can tell the compiler that you intend to call that function instead by adding parentheses, just as you would if the function took parameters:
TThread.Queue(nil, MakeProc());
Your workaround wouldn't seem to work. It would compile and run, but the function returned by MakeProc would never execute. Instead, the anonymous method wrapping MakeProc would run, call MakeProc, and then discard that function's result. (Since the function's result doesn't do anything in the code you've provided, you might not have noticed the difference.)
TThread.Queue method takes anonymous procedure as an argument. You cannot reference usual procedure in place of anonymous procedure. But you can call overloaded TThread.Queue method which takes class method reference as an argument. See example below:
type
TMyTestClass = class
public
procedure ThreadProc;
end;
{ TMyTestClass }
procedure TMyTestClass.ThreadProc;
begin
WriteLn('We are in thread');
end;
var
MyTestClass: TMyTestClass;
begin
with TMyTestClass.Create do
try
TThread.Queue(nil, ThreadProc);
finally
Free;
end;
end.
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.
Consider the follow code:
TMyList = class(TList<IMyItem>, IMyList)
Delphi shows me the error:
[DCC Error] test.pas(104): E2003 Undeclared identifier: 'QueryInterface'
Is there a generic list that implements IInterface?
The classes in Generics.Collections do not implement IInterface. You will have to introduce it yourself in your derived classes and provide the standard implementations. Or find a different, third party, set of container classes to work with.
For example:
TInterfacedList<T> = class(TList<T>, IInterface)
protected
FRefCount: Integer;
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
end;
function TInterfacedList<T>.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
if GetInterface(IID, Obj) then
Result := 0
else
Result := E_NOINTERFACE;
end;
function TInterfacedList<T>._AddRef: Integer;
begin
Result := InterlockedIncrement(FRefCount);
end;
function TInterfacedList<T>._Release: Integer;
begin
Result := InterlockedDecrement(FRefCount);
if Result = 0 then
Destroy;
end;
You can then declare your specialised class:
TMyList = class(TInterfacedList<IMyItem>, IMyList)
Remember that you need to treat this class like any other that uses reference counted lifetime management. Only refer to it through interfaces.
You'd really want to do some more work before TInterfacedList<T> was useful. You'd need to declare an IList<T> which would expose the list capabilities. It would be something like this:
IList<T> = interface
function Add(const Value: T): Integer;
procedure Insert(Index: Integer; const Value: T);
.... etc. etc.
end;
You can then simply add IList<T> to the list of interfaces supported by TInterfacedList<T> and the base class TList<T> would fulfil the interface contract.
TInterfacedList<T> = class(TList<T>, IInterface, IList<T>)
In addition to my comment above here some explanation why generic interfaces in Delphi don't work with guids.
program Project1;
{$APPTYPE CONSOLE}
uses
SysUtils;
type
IList<T> = interface
['{41FA0759-9BE4-49D7-B3DD-162CAA39CEC9}']
end;
IList_String1 = IList<string>;
IList_String2 = interface(IList<string>)
['{FE0CB7A6-FC63-4748-B436-36C07D501B7B}']
end;
TList<T> = class(TInterfacedObject, IList<T>)
end;
var
list: TList<string>;
guid: TGUID;
begin
list := TList<string>.Create;
guid := IList<Integer>;
Writeln('IList<Integer> = ', guid.ToString);
if Supports(list, IList<Integer>) then
Writeln('FAIL #1');
guid := IList_String1;
Writeln('IList_String1 = ', guid.ToString);
if not Supports(list, IList_String1) then
Writeln('FAIL #2');
guid := IList_String2;
Writeln('IList_String2 = ', guid.ToString);
if not Supports(list, IList_String2) then
Writeln('FAIL #3');
Readln;
end.
You see that it writes out the same guid for IList and for IList_String1 as IList got this guid and both are from this type. This results in Fail #1 because T does not matter when doing the supports call. Defining an alias for IList works (no Fail #2) but does not help because that still is the same guid. So what we need is what has been done with IList_String2. But that interface is not implemented by TList so of course we get Fail #3.
This has been reported long ago: http://qc.embarcadero.com/wc/qcmain.aspx?d=78458 [WayBack archived link]
Have a look at Alex Ciobanu's Collections library. It's got a bunch of generic collections, including replacements for the Generics.Collections types, that are usable as interfaces. (They were done that way to facilitate the LINQ-style Enex behavior he set up.)
Another alternative is to create a wrapper that inherits from TInterfacedObject and use composition and delegation for the list functionality:
interface
type
IList<T> = interface<IEnumerable<T>)
function Add(const Value: T): Integer;
..
end;
TList<T> = class(TInterfacedObject, IList<T>)
private
FList: Generics.Collections.TList<T>;
public
function Add(const Value:T): Integer;
..
end;
implementation
function TList<T>.Add(const Value:T): Integer;
begin
Exit(FList.Add(Value));
end;
Wrapping TList<T> and TDictionary<T> takes a little over 500 lines of code.
One caveat... I didn't include it here but I created an IEnumerable<T> (as well as the related IEnumerator<T>) that does not descend from IEnumerable . Most third party and OSS collection libraries do the same. If you're interested in why this blogpost pretty much sums it up.
Well, actually it doesn't mention everything. Even if you work around the interfaces stepping on each other you'll still have problems. An otherwise perfect implementation that satisfies both interfaces will succeed if you do Build but continue to fail with the same error message if you do an incremental compile (at least in D2009). Also the nongeneric IEnumerator forces you to return the current item as a TObject. This pretty much prevents you from holding anything in a collection that can't be cast to TObject. That's why none of the standard generic collections implement IEnumerable<T>
I am using Delphi XE.
The following unit fails to compile with this error:
[DCC Error] GTSJSONSerializer.pas(27): E2506 Method of parameterized type declared
in interface section must not use
local symbol 'TSuperRttiContext.AsJson<GTSJSONSerializer.TGTSJSONSerializer<T>.T>'
Why is that? Is there a workaround?
unit GTSJSONSerializer;
interface
type
TGTSJSONSerializer<T> = class
class function SerializeObjectToJSON(const aObject: T): string;
class function DeserializeJSONToObject(const aJSON: string): T;
end;
implementation
uses
SuperObject
;
class function TGTSJSONSerializer<T>.SerializeObjectToJSON(const aObject: T): string;
var
SRC: TSuperRttiContext;
begin
SRC := TSuperRttiContext.Create;
try
Result := SRC.AsJson<T>(aObject).AsString;
finally
SRC.Free;
end;
end;
class function TGTSJSONSerializer<T>.DeserializeJSONToObject(const aJSON: string): T;
var
LocalSO: ISuperObject;
SRC: TSuperRttiContext;
begin
SRC := TSuperRttiContext.Create;
try
LocalSO := SO(aJSON);
Result := SRC.AsType<T>(LocalSO);
finally
SRC.Free;
end;
end;
end.
From the XE2 DocWiki:
This happens when trying to assign a literal value to a generics data field.
program E2506;
{$APPTYPE CONSOLE}
uses
SysUtils;
type
TRec<T> = record
public
class var x: Integer;
class constructor Create;
end;
class constructor TRec<T>.Create;
begin
x := 4; // <-- e2506 Fix: overload the Create method to
// take one parameter x and assign it to the x field.
end;
begin
Writeln('E2506 Method of parameterized type declared' +
' in interface section must not use local symbol');
end.
I can't tell which of the local variables it might be objecting to, though; you have one local in SerialObjectToJSON and two in DeserializeJSONToObject. I'm also not sure based on the linked fix exactly how that applies to the code you posted. Could it be related to TSuperRTTIContext?
I can compile your unit with D2010, DXE and DXE2 against SuperObject revision 46.
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;