Unused interface reference is not destroyed - delphi

i had another bug in my app caused by careless usage of Delphi interfaces. When i pass an interface to a procedure which ignores that argument, the instance is never freed. See the following simple example:
ITest = interface
procedure Test;
end;
Tester = class(TInterfacedObject, ITest)
public
procedure Test;
end;
Base = class
public
procedure UseTestOrNot(test : ITest); virtual; abstract;
end;
A = class(Base)
public
procedure UseTestOrNot(test : ITest); override;
end;
B = class(Base)
public
procedure UseTestOrNot(test : ITest); override;
end;
{ A }
procedure A.UseTestOrNot(test: ITest);
begin
test.Test();
end;
{ B }
procedure B.UseTestOrNot(test: ITest);
begin
WriteLn('No test here');
end;
// -------- Test ---------------------------------------
var
list : TObjectList<Base>;
x : Base;
t : ITest;
begin
ReportMemoryLeaksOnShutdown := true;
list := TObjectList<Base>.Create;
list.Add(A.Create);
list.Add(B.Create);
// 1 x Tester leak for each B in list:
for x in list do
x.UseTestOrNot(Tester.Create);
// this is ok
for x in list do
begin
t := Tester.Create;
x.UseTestOrNot(t);
end;
list.Free;
end.
Can you please explain what goes wrong with the reference counter?
Can you give any best practice/ guideline (like "Never create an interfaced instance inside a function call [if you don't know what happens inside]).
The best solution i can think of for this example is to write a template method in class Base that saves the passed test instance and calls an abstract DoUseTestOrNot method.
EDIT
Delphi 2010

It is a different manifestation of the bugs here.
I will add this to the QC report.
This does not reproduce in Delphi XE update 1 any more.
--jeroen

Add a guid to you ITest declaration
ITest = interface
['{DB6637F9-FAD3-4765-9EC1-0A374AAC7469}']
procedure Test;
end;
Change the loop to this
for x in list do
x.UseTestOrNot(Tester.Create as ITest);
The GUID is neccesary to be able to use as
Test.Create as ITest makes the compiler to add the release where the created object goes out of scope.

Related

Implement stack of function pointers in Delphi

We have declared a type which can be used as a progress callback (such as loading every 10,000 lines from a gigantic log file):
// Declared in some base unit
TProcedureCallback = procedure() of object;
// Declared in the class that loads the events
procedure ReadEvents(callback: TProcedureCallback);
// Implementation of above method
procedure TEvents.ReadEvents(callback: TProcedureCallback);
var
nEvents: Integer;
begin
nEvents := 0;
// Read some events...
Inc(nEvents);
// ...and repeat until end of log file
// Every 10,000 events, let the caller know (so they update
// something like a progress bar)
if ((nEvents mod 10000) = 0) then
callback();
end;
// And the caller uses it like this
public
procedure EventsLoadCallBack();
// Implementation of callback
procedure TfrmLoadEvents.EventsLoadCallBack();
begin
// Update some GUI control...
end;
// And the events are loaded like this
events.ReadEvents(EventsLoadCallBack);
This all works very well...but I'd like to extend this to the TObjectStack container so that we can implement an automatic log off feature. The idea is that as each form is created, it registers a callback (ie. pushes it onto some system-wide stack). And when the form is destroyed, it pops the callback off the stack. If the auto log off occurs, you just unwind the stack and return the user to the main form and then do the rest of work associated with an automatic log off.
But, I cannot get it working...when I try and push a TProcedureCallback object onto the stack I get compiler errors:
// Using generic containers unit from Delphi 7
uses
Contnrs;
// Declare stack
stackAutoLogOff: TObjectStack;
// Initialise stack
stackAutoLogOff := TObjectStack.Create();
// Attempt to use stack
stackAutoLogOff.Push(callback);
stackAutoLogOff.Push(TObject(callback));
// Clean up...
stackstackAutoLogOff.Free();
The 1st returns Incompatible types and the 2nd Invalid typecast. What is the correct way to implement a stack of function pointers?
The problem is that TObjectStack expects to contain objects of type TObject and your callback is a TMethod type, which is a record containing two pointers.
If you are using a modern version of Delphi a simple solution is to use generics. For example:
TObjectProc = procedure of object;
TMyCallbackStack = TStack<TObjectProc>;
Without generics, you would need to build your own stack class to manage storage of the callbacks. This is a reasonably simple class to build and, at its most basic, might look something like this :
program Project1;
{$APPTYPE CONSOLE}
uses
SysUtils;
type
TMyClass = class
procedure foo;
end;
TObjProc = procedure of object;
TObjProcStack = class(TObject)
private
FList: array of TObjProc;
public
function Count: Integer;
procedure Push(AItem: TObjProc);
function Pop: TObjProc; inline;
function Peek: TObjProc; inline;
end;
function TObjProcStack.Peek: TObjProc;
begin
Result := FList[Length(FList)-1];
end;
function TObjProcStack.Pop: TObjProc;
begin
Result := Peek();
SetLength(FList, Length(FList) - 1);
end;
procedure TObjProcStack.Push(AItem: TObjProc);
begin
SetLength(FList, Length(FList) + 1);
FList[Length(FList)-1] := AItem;
end;
function TObjProcStack.Count: Integer;
begin
Result := Length(FList);
end;
{TMyClass}
procedure TMyClass.Foo;
begin
WriteLn('foo');
end;
var
LMyClass : TMyClass;
LStack : TObjProcStack;
begin
LStack := TObjProcStack.Create;
LMyClass := TMyClass.Create;
try
LStack.Push(LMyClass.foo);
LStack.Pop; {executes TMyClass.Foo - outputs 'foo' to console}
finally
LStack.Free;
LMyClass.Free;
end;
ReadLn;
end.
You can wrap the callback in an object and then use the standard Stack options. By wrapping that in your own class, you have a complete solution, like this:
unit UnitCallbackStack;
interface
uses
Contnrs;
type
TProcedureCallback = procedure() of object;
type
TMyCallbackObject = class // wrapper for callback
private
FCallBack : TProcedureCallback;
protected
public
constructor Create( ACallback : TProcedureCallback ); reintroduce;
property CallBack : TProcedureCallback
read FCallBack;
end;
type
TCallBackStack = class( TObjectStack)
private
public
function Push(ACallback: TProcedureCallback): TProcedureCallback; reintroduce;
function Pop: TProcedureCallback; reintroduce;
function Peek: TProcedureCallback; reintroduce;
end;
implementation
{ TCallBackStack }
function TCallBackStack.Peek: TProcedureCallback;
var
iObject : TMyCallbackObject;
begin
iObject := inherited Peek as TMyCallbackObject;
if assigned( iObject ) then
begin
Result := iObject.CallBack; // no delete here as reference not removed
end
else
begin
Result := nil;
end;
end;
function TCallBackStack.Pop: TProcedureCallback;
var
iObject : TMyCallbackObject;
begin
iObject := inherited Pop as TMyCallbackObject;
if assigned( iObject ) then
begin
Result := iObject.CallBack;
iObject.Free; // popped, so no longer needed
end
else
begin
Result := nil;
end;
end;
function TCallBackStack.Push(ACallback: TProcedureCallback): TProcedureCallback;
begin
inherited Push( TMyCallbackObject.Create( ACallBack ));
end;
{ TMyCallbackObject }
constructor TMyCallbackObject.Create(ACallback: TProcedureCallback);
begin
inherited Create;
fCallBack := ACallBack;
end;
end.
You can then use TCallBackStack the way you are trying to use TStack.

How to check if a instance was already freed in this case?

In our application framework we have some kind of instance handler class that in resume it's responsible for capture the instances create by our others controllers/components/forms/etc.
Here's the declaration:
TInstanceHandler = class(TFrameworkClass)
strict private
FInstances : TList<TObject>;
procedure FreeInstances();
protected
procedure Initialize(); override;
procedure Finalize(); override;
public
function Delegate<T : class>(const AInstance : T) : T;
end;
And the implementation:
procedure TInstanceHandler.FreeInstances();
var AInstance : TObject;
begin
for AInstance in FInstances do
if(Assigned(AInstance)) then AInstance.Free();
FInstances.Free();
end;
procedure TInstanceHandler.Initialize();
begin
inherited;
FInstances := TList<TObject>.Create();
end;
procedure TInstanceHandler.Finalize();
begin
FreeInstances();
inherited;
end;
function TInstanceHandler.Delegate<T>(const AInstance : T) : T;
begin
FInstances.Add(AInstance);
end;
what happen sometimes is that our programmers forgot the existence of this class or his purpose and they free their instances.
Like this:
with InstanceHandler.Delegate(TStringList.Create()) do
try
//...
finally
Free();
end;
what happens next is that when TInstanceHandler is finalized it will try to free the delegated instance again and this will lead to a error.
I know the season why Assigned fail in this case and as far i can see i cant use FreeAndNil.
so the question is: how i can correctly check if the reference was already freed?
How I can correctly check if the reference was already freed?
You cannot.

Generics and Marshal / UnMarshal. What am I missing here? PART #2 :-)

Following up on my earlier question :
Generics and Marshal / UnMarshal. What am I missing here?
In "part #1" (the link above) TOndrej provided a nice solution - that failed on XE2.
Here I provide corrected source to correct that.
And I feel the need to expand this issue a bit more.
So I would like to hear you all how to do this :
First - To get the source running on XE2 and XE2 update 1 make these changes :
Marshal.RegisterConverter(TTestObject,
function (Data: TObject): String // <-- String here
begin
Result := T(Data).Marshal.ToString; // <-- ToString here
end
);
Why ??
The only reason I can see must be related to XE2 is having a lot more RTTI information available. And hence it will try and marshal the TObject returned.
Am I on the right track here? Please feel free to comment.
More important - the example does not implement an UnMarshal method.
If anyone can produce one and post it here I would love it :-)
I hope that you still have interest in this subject.
Kind Regards
Bjarne
In addition to the answer to this question, I've posted a workaround to your previous question here: Generics and Marshal / UnMarshal. What am I missing here?
For some reason, using the non-default constructor of the TJsonobject causes the issue in XE2 - using the default constructor "fixed" the problem.
First, you need to move your TTestobject to its own unit - otherwise, RTTI won't be able to find/create your object when trying to unmarshal.
unit uTestObject;
interface
uses
SysUtils, Classes, Contnrs, Generics.Defaults, Generics.Collections, DbxJson, DbxJsonReflect;
type
{$RTTI EXPLICIT METHODS([]) PROPERTIES([vcPublished]) FIELDS([vcPrivate])}
TTestObject=class(TObject)
private
aList:TStringList;
public
constructor Create; overload;
constructor Create(list: array of string); overload;
constructor Create(list:TStringList); overload;
destructor Destroy; override;
function Marshal:TJSonObject;
class function Unmarshal(value: TJSONObject): TTestObject;
published
property List: TStringList read aList write aList;
end;
implementation
{ TTestObject }
constructor TTestObject.Create;
begin
inherited Create;
aList:=TStringList.Create;
end;
constructor TTestObject.Create(list: array of string);
var
I:Integer;
begin
Create;
for I:=low(list) to high(list) do
begin
aList.Add(list[I]);
end;
end;
constructor TTestObject.Create(list:TStringList);
begin
Create;
aList.Assign(list);
end;
destructor TTestObject.Destroy;
begin
aList.Free;
inherited;
end;
function TTestObject.Marshal:TJSonObject;
var
Mar:TJSONMarshal;
begin
Mar:=TJSONMarshal.Create();
try
Mar.RegisterConverter(TStringList,
function(Data:TObject):TListOfStrings
var
I, Count:Integer;
begin
Count:=TStringList(Data).Count;
SetLength(Result, Count);
for I:=0 to Count-1 do
Result[I]:=TStringList(Data)[I];
end);
Result:=Mar.Marshal(Self) as TJSonObject;
finally
Mar.Free;
end;
end;
class function TTestObject.Unmarshal(value: TJSONObject): TTestObject;
var
Mar: TJSONUnMarshal;
L: TStringList;
begin
Mar := TJSONUnMarshal.Create();
try
Mar.RegisterReverter(TStringList,
function(Data: TListOfStrings): TObject
var
I, Count: Integer;
begin
Count := Length(Data);
Result:=TStringList.Create;
for I := 0 to Count - 1 do
TStringList(Result).Add(string(Data[I]));
end
);
//UnMarshal will attempt to create a TTestObject from the TJSONObject data
//using RTTI lookup - for that to function, the type MUST be defined in a unit
Result:=Mar.UnMarshal(Value) as TTestObject;
finally
Mar.Free;
end;
end;
end.
Also note that the constructor has been overloaded - this allows you to see that the code is functional without pre-pouplating the data in the object during creation.
Here is the implementation for the generic class list object
unit uTestObjectList;
interface
uses
SysUtils, Classes, Contnrs, Generics.Defaults, Generics.Collections,
DbxJson, DbxJsonReflect, uTestObject;
type
{$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])}
TTestObjectList<T:TTestObject,constructor> = class(TObjectList<T>)
public
function Marshal: TJSonObject;
constructor Create;
class function Unmarshal(value: TJSONObject): TTestObjectList<T>; static;
end;
//Note: this MUST be present and initialized/finalized so that
//delphi will keep the RTTI information for the generic class available
//also, it MUST be "project global" - not "module global"
var
X:TTestObjectList<TTestObject>;
implementation
{ TTestObjectList<T> }
constructor TTestObjectList<T>.Create;
begin
inherited Create;
//removed the add for test data - it corrupts unmarshaling because the data is already present at creation
end;
function TTestObjectList<T>.Marshal: TJSonObject;
var
Marshal: TJsonMarshal;
begin
Marshal := TJSONMarshal.Create;
try
Marshal.RegisterConverter(TTestObjectList<T>,
function(Data: TObject): TListOfObjects
var
I: integer;
begin
SetLength(Result,TTestObjectlist<T>(Data).Count);
for I:=0 to TTestObjectlist<T>(Data).Count-1 do
Result[I]:=TTestObjectlist<T>(Data)[I];
end
);
Result := Marshal.Marshal(Self) as TJSONObject;
finally
Marshal.Free;
end;
end;
class function TTestObjectList<T>.Unmarshal(value: TJSONObject): TTestObjectList<T>;
var
Mar: TJSONUnMarshal;
L: TStringList;
begin
Mar := TJSONUnMarshal.Create();
try
Mar.RegisterReverter(TTestObjectList<T>,
function(Data: TListOfObjects): TObject
var
I, Count: Integer;
begin
Count := Length(Data);
Result:=TTestObjectList<T>.Create;
for I := 0 to Count - 1 do
TTestObjectList<T>(Result).Unmarshal(TJSONObject(Data[I]));
end
);
//UnMarshal will attempt to create a TTestObjectList<TTestObject> from the TJSONObject data
//using RTTI lookup - for that to function, the type MUST be defined in a unit,
//and, because it is generic, there must be a GLOBAL VARIABLE instantiated
//so that Delphi keeps the RTTI information avaialble
Result:=Mar.UnMarshal(Value) as TTestObjectList<T>;
finally
Mar.Free;
end;
end;
initialization
//force delphi RTTI into maintaining the Generic class information in memory
x:=TTestObjectList<TTestObject>.Create;
finalization
X.Free;
end.
There are several things that are important to note:
If a generic class is created at runtime, RTTI information is NOT kept unless there is a globally accessible object reference to that class in memory. See here: Delphi: RTTI and TObjectList<TObject>
So, the above unit creates such a variable and leaves it instantiated as discussed in the linked article.
The main procedure has been updated that shows both marshaling and unmarshaling the data for both objects:
procedure Main;
var
aTestobj,
bTestObj,
cTestObj : TTestObject;
aList,
bList : TTestObjectList<TTestObject>;
aJsonObject,
bJsonObject,
cJsonObject : TJsonObject;
s: string;
begin
aTestObj := TTestObject.Create(['one','two','three','four']);
aJsonObject := aTestObj.Marshal;
s:=aJsonObject.ToString;
Writeln(s);
bJsonObject:=TJsonObject.Create;
bJsonObject.Parse(BytesOf(s),0,length(s));
bTestObj:=TTestObject.Unmarshal(bJsonObject) as TTestObject;
writeln(bTestObj.List.Text);
writeln('TTestObject marshaling complete.');
readln;
aList := TTestObjectList<TTestObject>.Create;
aList.Add(TTestObject.Create(['one','two']));
aList.Add(TTestObject.Create(['three']));
aJsonObject := aList.Marshal;
s:=aJsonObject.ToString;
Writeln(s);
cJSonObject:=TJsonObject.Create;
cJSonObject.Parse(BytesOf(s),0,length(s));
bList:=TTestObjectList<TTestObject>.Unmarshal(cJSonObject) as TTestObjectList<TTestObject>;
for cTestObj in bList do
begin
writeln(cTestObj.List.Text);
end;
writeln('TTestObjectList<TTestObject> marshaling complete.');
Readln;
end;
Here is my own solution.
As I am very fond of polymorphism, I actually also want a solution that can be built into an object hierarchy. Lets say TTestObject and TTestObjectList is our BASE object. And from that we descend to TMyObject and also TMyObjectList. And furthermore I've made changes to both Object and List - added properties for Marshaller/UnMarshaller
TMyObject = class(TTestObject) and TMyObjectList<T:TMyObject> = class(TTestObjectList)
With this we now introduce some new problems. Ie. how to handle marshalling of different types between lines in the hierarchy and how to handle TJsonMarshal and TJsonUnMarshal as properties on TTestObject and List.
This can be overcome by introducing two new methods on TTestObject level. Two class functions called RegisterConverters and RegisterReverters. Then we go about and change the marshal function of TTestObjectList into a more simpel marshalling.
Two class functions and properties for both object and List.
class procedure RegisterConverters(aClass: TClass; aMar: TJSONMarshal); virtual;
class procedure RegisterReverters(aClass: TClass; aUnMar: TJSONUnMarshal); virtual;
property Mar: TJSONMarshal read FMar write SetMar;
property UnMar: TJSONUnMarshal read FUnMar write SetUnMar;
The Marshal function of List can now be done like this:
function TObjectList<T>.Marshal: TJSONObject;
begin
if FMar = nil then
FMar := TJSONMarshal.Create(); // thx. to SilverKnight
try
RegisterConverters; // Virtual class method !!!!
try
Result := FMar.Marshal(Self) as TJSONObject;
except
on e: Exception do
raise Exception.Create('Marshal Error : ' + e.Message);
end;
finally
ClearMarshal; // FreeAndNil FMar and FUnMar if assigned.
end;
end;
Sure we can still have a marshaller for our TTestObject - but the Marshal function of TTestObjectList will NOT use it. This way only ONE Marshaller will get created when calling Marshal of TTestObjectList (or descendants). And this way we end up getting marshalled ONLY the information we need to recreate our structure when doing it all backwards - UnMarshalling :-)
Now this actually works - but I wonder if anyone has any comments on this ?
Lets add a property "TimeOfCreation" to TMyTestObject:
property TimeOfCreation : TDateTime read FTimeOfCreation write FTimeOfCreation;
And set the property in the constructor.
FTimeofCreation := now;
And then we need a Converter so we override the virtual RegisterConverters of TTestObject.
class procedure TMyTestObject.RegisterConverters(aClass: TClass; aMar: TJSONMarshal);
begin
inherited; // instanciate marshaller and register TTestObject converters
aMar.RegisterConverter(aClass, 'FTimeOfCreation',
function(Data: TObject; Field: String): string
var
ctx: TRttiContext;
date: TDateTime;
begin
date := ctx.GetType(Data.ClassType).GetField(Field).GetValue(Data).AsType<TDateTime>;
Result := FormatDateTime('yyyy-mm-dd hh:nn:ss', date);
end);
end;
I end up with Very simple source like using TTestObject ie.
aList := TMyTestObjectList<TMyTestObject>.Create;
aList.Add(TMyTestObject.Create(['one','two']));
aList.Add(TMyTestObject.Create(['three']));
s := (aList.Marshal).ToString;
Writeln(s);
And now I have succeded in marshalling with polymorphism :-)
This also works with UnMarshalling btw. And Im in the process of rebuilding my FireBird ORM to produce source for all my objects like this.
The current OLD version can be found here :
http://code.google.com/p/objectgenerator/
Remember that it only works for FireBird :-)

Delphi Enterprise: how can I apply the Visitor Pattern without circular references?

With Delphi 2009 Enterprise I created code for the GoF Visitor Pattern in the model view, and separated the code in two units: one for the domain model classes, one for the visitor (because I might need other units for different visitor implementations, everything in one unit? 'Big ball of mud' ahead!).
unit VisitorUnit;
interface
uses
ConcreteElementUnit;
type
IVisitor = interface;
IElement = interface
procedure Accept(AVisitor :IVisitor);
end;
IVisitor = interface
procedure VisitTConcreteElement(AElement :TConcreteElement);
end;
TConcreteVisitor = class(TInterfacedObject, IVisitor)
public
procedure VisitTConcreteElement(AElement :TConcreteElement);
end;
implementation
procedure TConcreteVisitor.VisitTConcreteElement(AElement :TConcreteElement);
begin
{ provide implementation here }
end;
end.
and the second unit for the business model classes
unit ConcreteElementUnit;
interface
uses
VisitorUnit;
type
TConcreteElement = class(TInterfacedObject, IElement)
public
procedure Accept(AVisitor :IVisitor); virtual;
end;
Class1 = class(TConcreteElement)
public
procedure Accept(AVisitor :IVisitor);
end;
implementation
{ Class1 }
procedure Class1.Accept(AVisitor: IVisitor);
begin
AVisitor.VisitTConcreteElement(Self);
end;
end.
See the problem? A circular unit reference. Is there an elegant solution? I guess it requires "n+1" additional units with base interface / base class definitions to avoid the CR problem, and tricks like hard casts?
I use the following scheme to implement a flexible visitor pattern:
Declaration of base visitor types
unit uVisitorTypes;
type
IVisited = interface
{ GUID }
procedure Accept(Visitor: IInterface);
end;
IVisitor = interface
{ GUID }
procedure Visit(Instance: IInterface);
end;
TVisitor = class(..., IVisitor)
procedure Visit(Instance: IInterface);
end;
procedure TVisitor.Visit(Instance: IInterface);
var
visited: IVisited;
begin
if Supports(Instance, IVisited, visited) then
visited.Accept(Self)
else
// raise exception or handle error elsewise
end;
The unit for of the element class
unit uElement;
type
TElement = class(..., IVisited)
procedure Accept(Visitor: IInterface);
end;
// declare the visitor interface next to the class-to-be-visited declaration
IElementVisitor = interface
{ GUID }
procedure VisitElement(Instance: TElement);
end;
procedure TElement.Accept(Visitor: IInterface);
var
elementVisitor: IElementVisitor;
begin
if Supports(Visitor, IElementVisitor, elementVisitor) then
elementVisitor.VisitElement(Self)
else
// if override call inherited, handle error or simply ignore
end;
The actual visitor implementation
unit MyVisitorImpl;
uses
uVisitorTypes, uElement;
type
TMyVisitor = class(TVisitor, IElementVisitor)
procedure VisitElement(Instance: TElement);
end;
procedure TMyVisitor.VisitElement(Instance: TElement);
begin
// Do whatever you want with Instance
end;
Calling the visitor
uses
uElement, uMyElementVisitor;
var
visitor: TMyVisitor;
element: TElement;
begin
// get hands on some element
visitor := TMyVisitor.Create;
try
visitor.Visit(element);
finally
visitor.Free;
end;
end;
Why not define IVisitor
IVisitor = interface
procedure VisitElement(AElement :IElement);
end;
then TConcreteElement in its own unit :
unit ConcreteElementUnit;
interface
uses
VisitorUnit;
type
TConcreteElement = class(TInterfacedObject, IElement)
public
procedure Accept(AVisitor :IVisitor); virtual;
end;
Class1 = class(TConcreteElement)
public
procedure Accept(AVisitor :IVisitor);
end;
implementation
{ Class1 }
procedure Class1.Accept(AVisitor: IVisitor);
begin
AVisitor.VisitElement(Self);
end;
end.
That way you are not mixing class and interface references (always a bad idea)
The following implementation using generic type on Visitor interface to solve the circular reference issue of Visitor pattern:
Visitor.Intf.pas:
unit Visitor.Intf;
interface
type
IVisitor<T> = interface
procedure Visit_Element(o: T);
end;
implementation
end.
Element.pas:
unit Element;
interface
uses Visitor.Intf;
type
TElement = class
procedure Accept(const V: IVisitor<TElement>);
end;
implementation
procedure TElement.Accept(const V: IVisitor<TElement>);
begin
V.Visit_Element(Self);
end;
end.
Visitor.Concrete.pas:
unit Visitor.Concrete;
interface
uses Element, Visitor.Intf;
type
TConcreteVisitor = class(TInterfacedObject, IVisitor<TElement>)
protected
procedure Visit_Element(o: TElement);
end;
implementation
procedure TConcreteVisitor.Visit_Element(o: TElement);
begin
// write implementation here
end;
end.
Using the TElement and TConcreteVisitor class:
var E: TElement;
begin
E := TElement.Create;
E.Accept(TConcreteVisitor.Create as IVisitor<TElement>);
E.Free;
end;
The decleration of TConcreteElement shoud be in VisitorUnit (or a third unit)
or better
The IVisitator should be changed to:
IVisitor = interface
procedure VisitTConcreteElement(AElement :IElement);
end;

Passing Interface's method as parameter

Is it possible to pass interface's method as parameters?
I'm trying something like this:
interface
type
TMoveProc = procedure of object;
// also tested with TMoveProc = procedure;
// procedure of interface is not working ;)
ISomeInterface = interface
procedure Pred;
procedure Next;
end;
TSomeObject = class(TObject)
public
procedure Move(MoveProc: TMoveProc);
end;
implementation
procedure TSomeObject.Move(MoveProc: TMoveProc);
begin
while True do
begin
// Some common code that works for both procedures
MoveProc;
// More code...
end;
end;
procedure Usage;
var
o: TSomeObject;
i: ISomeInterface;
begin
o := TSomeObject.Create;
i := GetSomeInterface;
o.Move(i.Next);
// somewhere else: o.Move(i.Prev);
// tested with o.Move(#i.Next), ##... with no luck
o.Free;
end;
But it is not working because:
E2010 Incompatible types: 'TMoveProc' and 'procedure, untyped pointer or untyped parameter'
Of course I can do private method for each call, but that is ugly. Is there any better way?
Delphi 2006
Edit:
I know that I can pass whole interface, but then I have to specify which function use. I don't want two exactly same procedures with one different call.
I can use second parameter, but that is ugly too.
type
SomeInterfaceMethod = (siPred, siNext)
procedure Move(SomeInt: ISomeInterface; Direction: SomeInterfaceMethod)
begin
case Direction of:
siPred: SomeInt.Pred;
siNext: SomeInt.Next
end;
end;
Thanks all for help and ideas. Clean solution (for my Delphi 2006) is Diego's Visitor. Now I'm using simple ("ugly") wrapper (my own, same solution by TOndrej and Aikislave).
But true answer is "there is no (direct) way to pass interface's methods as parameters without some kind of provider.
If you were using Delphi 2009, you could do this with an anonymous method:
TSomeObject = class(TObject)
public
procedure Move(MoveProc: TProc);
end;
procedure Usage;
var
o: TSomeObject;
i: ISomeInterface;
begin
o := TSomeObject.Create;
i := GetSomeInterface;
o.Move(procedure() begin i.Next end);
The problem with trying to pass a reference to just the interface method is that you are not passing a reference to the interface itself, so the interface cannot be reference counted. But anonymous methods are themselves reference counted, so the interface reference inside the anonymous method here can be reference counted as well. That is why this method works.
I don't know the exact reason why you need to do that, but, personally, I think it would be better to pass the whole "Mover" object instead of one of its methods. I used this approach in the past, it's called "Visitor" pattern.
tiOPF, an object persistence framework, uses it extensively and gives you a good example of how it works: The Visitor Pattern and the tiOPF.
It's relatively long, but it proved very useful to me, even when I didn't use tiOPF. Note step 3 in the document, titled "Step #3. Instead of passing a method pointer, we will pass an object".
DiGi, to answer your comment: If you use Visitor pattern, then you don't have an interface implementing multiple methods, but just one (Execute). Then you'd have a class for each action, like TPred, TNext, TSomething, and you pass an instance of such classes to the object to be processed. In such way, you don't have to know what to call, you just call "Visitor.Execute", and it will do the job.
Here you can find a basic example:
interface
type
TVisited = class;
TVisitor = class
procedure Execute(Visited: TVisited); virtual; abstract;
end;
TNext = class(TVisitor)
procedure Execute (Visited: TVisited); override;
end;
TPred = class(TVisitor)
procedure Execute (Visited: TVisited); override;
end;
TVisited = class(TPersistent)
public
procedure Iterate(pVisitor: TVisitor); virtual;
end;
implementation
procedure TVisited.Iterate(pVisitor: TVisitor);
begin
pVisitor.Execute(self);
end;
procedure TNext.Execute(Visited: TVisited);
begin
// Implement action "NEXT"
end;
procedure TPred.Execute(Visited: TVisited);
begin
// Implement action "PRED"
end;
procedure Usage;
var
Visited: TVisited;
Visitor: TVisitor;
begin
Visited := TVisited.Create;
Visitor := TNext.Create;
Visited.Iterate(Visitor);
Visited.Free;
end;
Although the wrapper class solution works, I think that's an overkill. It's too much code, and you have to manually manage the lifetime of the new object.
Perhaps a simpler solution would be to create methods in the interface that returns TMoveProc
ISomeInterface = interface
...
function GetPredMeth: TMoveProc;
function GetNextMeth: TMoveProc;
...
end;
The class that implements the interface can provide the procedure of object and it will be accessible through the interface.
TImplementation = class(TInterfaceObject, ISomeInterface)
procedure Pred;
procedure Next;
function GetPredMeth: TMoveProc;
function GetNextMeth: TMoveProc;
end;
...
function TImplementation.GetPredMeth: TMoveProc;
begin
Result := Self.Pred;
end;
function TImplementation.GetNextMeth: TMoveProc;
begin
Result := Self.Next;
end;
How about this:
type
TMoveProc = procedure(const SomeIntf: ISomeInterface);
TSomeObject = class
public
procedure Move(const SomeIntf: ISomeInterface; MoveProc: TMoveProc);
end;
procedure TSomeObject.Move(const SomeIntf: ISomeInterface; MoveProc: TMoveProc);
begin
MoveProc(SomeIntf);
end;
procedure MoveProcNext(const SomeIntf: ISomeInterface);
begin
SomeIntf.Next;
end;
procedure MoveProcPred(const SomeIntf: ISomeInterface);
begin
SomeIntf.Pred;
end;
procedure Usage;
var
SomeObj: TSomeObject;
SomeIntf: ISomeInterface;
begin
SomeIntf := GetSomeInterface;
SomeObj := TSomeObject.Create;
try
SomeObj.Move(SomeIntf, MoveProcNext);
SomeObj.Move(SomeIntf, MoveProcPred);
finally
SomeObj.Free;
end;
end;
Here is another solution that is working in Delphi 20006. It is similar to the idea of #Rafael, but using interfaces:
interface
type
ISomeInterface = interface
//...
end;
IMoveProc = interface
procedure Move;
end;
IMoveProcPred = interface(IMoveProc)
['{4A9A14DD-ED01-4903-B625-67C36692E158}']
end;
IMoveProcNext = interface(IMoveProc)
['{D9FDDFF9-E74E-4F33-9CB7-401C51E7FF1F}']
end;
TSomeObject = class(TObject)
public
procedure Move(MoveProc: IMoveProc);
end;
TImplementation = class(TInterfacedObject,
ISomeInterface, IMoveProcNext, IMoveProcPred)
procedure IMoveProcNext.Move = Next;
procedure IMoveProcPred.Move = Pred;
procedure Pred;
procedure Next;
end;
implementation
procedure TSomeObject.Move(MoveProc: IMoveProc);
begin
while True do
begin
// Some common code that works for both procedures
MoveProc.Move;
// More code...
end;
end;
procedure Usage;
var
o: TSomeObject;
i: ISomeInterface;
begin
o := TSomeObject.Create;
i := TImplementation.Create;
o.Move(i as IMoveProcPred);
// somewhere else: o.Move(i as IMoveProcNext);
o.Free;
end;
You can't. Because of the scoping of Interfaces it would be possible (perhaps?) for the Interface to be released before you called the .Next function. If you want to do this you should pass the whole interface to your method rather than just a method.
Edited...
Sorry, this next bit, specifically the "Of Interface" bit was meant in jest.
Also, and I could be wrong here, i.Next is not a method Of Object, as per your type def, it would be a method Of Interface!
Redefine your function
TSomeObject = class(TObject)
public
procedure Move(Const AMoveIntf: ISomeInterface);
end;
Procedure TSomeObject.Move(Const AMoveIntf : ISomeInterface);
Begin
....;
AMoveIntf.Next;
end;
O.Move(I);
Hope this helps.
You currently have TMoveProc defined as
TMoveProc = procedure of object;
Try taking out the "of object" which implies a hidden "this" pointer as first parameter.
TMoveProc = procedure;
That should allow a normal procedure to be called.

Resources