When using Interfaces in Delphi and overriding reference counting, it is possible to bypass the_Release calls Delphi makes when an interface reaches a reference count of zero.
But - when mixing classes and interfaces (which is very useful) the _Release method is ALWAYS called no matter what. The problem is that in the sample code below, the local object is nill-ed, but _Release is still called - except on invalid memory. Depending on memory operations in the application, an exception can result when _Release is called on the nilled localObject's old location or no exception if the memory was not re-used.
So, can the compiler generated call to _Release be "removed/blocked/avoided/killed/redirected/vmt hijacked/terminated/smacked/etc etc etc"? If this can be achieved you have proper pure interfaces in Delphi.
unit TestInterfaces;
interface
uses
Classes,
SysUtils;
type
ITestInterface = interface
['{92D4D6E4-A67F-4DB4-96A9-9E1C40825F9C}']
procedure Run;
end;
TTestClass = class(TInterfacedObject, ITestInterface)
protected
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
public
procedure Run;
end;
TRunTestClass = class(TObject)
protected
FlocalInterface : ITestInterface;
FlocalObject : TTestClass;
public
constructor Create;
destructor Destroy; override;
procedure Test;
end;
procedure RunTest;
procedure RunTestOnClass;
var
globalInterface : ITestInterface;
implementation
procedure RunTest;
var
localInterface : ITestInterface;
localObject : TTestClass;
begin
try
//create an object
localObject := TTestClass.Create;
//local scope
// causes _Release call when object is nilled
localInterface := localObject;
localInterface.Run;
//or global scope
// causes _Release call when exe shuts down - possibly on invalid memory location
globalInterface := localObject;
globalInterface.Run;
finally
//localInterface := nil; //--> forces _Release to be called
FreeAndNil( localObject );
end;
end;
procedure RunTestOnClass;
var
FRunTestClass : TRunTestClass;
begin
FRunTestClass := TRunTestClass.Create;
FRunTestClass.Test;
FRunTestClass.Free;
end;
{ TTheClass }
procedure TTestClass.Run;
begin
beep;
end;
function TTestClass._AddRef: Integer;
begin
result := -1;
end;
function TTestClass._Release: integer;
begin
result := -1;
end;
{ TRunTestClass }
constructor TRunTestClass.Create;
begin
FlocalObject := TTestClass.Create;
FlocalInterface := FlocalObject;
end;
destructor TRunTestClass.Destroy;
begin
//..
FlocalObject.Free;
//FlocalObject := nil;
inherited;
end;
procedure TRunTestClass.Test;
begin
FlocalInterface.Run;
end;
end.
There's no practical way to achieve what you are looking for. The compiler is going to emit the calls to _Release and in order to whack them you would need to find all the call sites. That's not practical.
I'm afraid the only viable approach when reference counted lifetime management is disabled is to ensure that you finalize (i.e. set to nil) all your interface references before calling Free.
When you use Interfaces you do not need to free your objects any more. interfaced objects will released automatically when there is no any references to same object.
In your sample you must delete _Release and _Addref functions in TTestClass they are defined in TInterfacedObject class.
In RunTest procedure you not need to Free the localObject only in finally section set globalInterface to nil. after end of procedure localInterface will destroy the local object automatically.
try
... use your code
...
finnaly
globalInnterface := nil;
end;
And about TTestRun.Destroy just left this destructor blank. you must not Free the FlocalObject.
TTestRun.Destroy;
begin
inherited;
end;
Related
unit example;
interface
type
ILettersSettings = interface
function Letters: String;
end;
INumbersSettings = interface
function Numbers: String;
end;
TSettings = class(TInterfacedObject, ILettersSettings, INumbersSettings)
private
fLoadedLetters: String;
fLoadedNumbers: String;
public
procedure LoadFromFile;
private {ILettersSettings}
function Letters: String;
private {INumbersSettings}
function Numbers: String;
end;
TNumbers = class
private
fNumbers: String;
public
constructor Create(settings: INumbersSettings);
end;
TLetters = class
private
fLetters: String;
public
constructor Create(settings: ILettersSettings);
end;
implementation
{ TSettings }
procedure TSettings.LoadFromFile;
begin
fLoadedLetters := 'abc';
fLoadedNumbers := '123';
end;
function TSettings.Letters: String;
begin
result := fLoadedLetters;
end;
function TSettings.Numbers: String;
begin
result := fLoadedNumbers;
end;
{ TNumbers }
constructor TNumbers.Create(settings: INumbersSettings);
begin
fNumbers := settings.Numbers;
end;
{ TLetters }
constructor TLetters.Create(settings: ILettersSettings);
begin
fLetters := settings.Letters;
end;
var
settings: TSettings;
letters: TLetters;
numbers: TNumbers;
begin
settings := TSettings.Create;
settings.LoadFromFile;
letters := TLetters.Create(settings);
numbers := TNumbers.Create(settings);
end.
I have object with settings for whole project.
settings := TSettings.Create;
settings.LoadFromFile;
I use this object to create two objects: numbers and letters, by inject it by constructor.
letters := TLetters.Create(settings);
numbers := TNumbers.Create(settings);
But I dont assign it to any variable inside constructor, just use it.
{ TNumbers }
constructor TNumbers.Create(settings: INumbersSettings);
begin
fNumbers := settings.Numbers;
end;
{ TLetters }
constructor TLetters.Create(settings: ILettersSettings);
begin
fLetters := settings.Letters;
end;
So at the begin of constructor there is made reference count = 1, and on the end of constructor reference count is decreace to 0, and object is destroyed.
So in line:
numbers := TNumbers.Create(settings);
There is inject nil and Runtime Error is raised.
How fix it?
The problem is that you are mixing two different approaches to lifetime management. You have a mix of reference counted lifetime management, and programmer controlled lifetime management.
Your variable settings is declared to be of type TSettings. Although you did not show that declaration, we know this to be so because you are able to call LoadFromFile. That's only possible if settings is declared to be of type TSettings.
Because settings is a class, this means that your code is responsible for its lifetime. As such, the compiler does not emit reference counting code when you assign to settings.
However, when you call TLetters.Create and TNumbers.Create, you pass interface references, to ILetters and INumbers respectively. For this code, the compiler does emit reference counting code. The reference count goes up to 1 when you obtain an interface reference, and then down to zero when that reference leaves scope. At which point the implementing object is destroyed.
The fundamental problem in all of this is that you have broken the lifetime management rules. You must not mix the two different approaches as you have done.
The usual policy that people adopt is to either use programmer controlled management always, or reference counted management always. The choice is yours.
If you wish to use reference counted management exclusively then you would need to ensure that all functionality of your settings class was available via interfaces. That would mean making sure that LoadFromFile could be called via an interface. Or perhaps arranging for it to be called by the constructor.
Alternatively you could switch to programmer controlled management. In that case you must not derive from TInterfacedObject. You might instead derive from a class like this:
type
TInterfacedObjectWithoutReferenceCounting = class(TObject, IInterface)
protected
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
end;
function TInterfacedObjectWithoutReferenceCounting.QueryInterface(const IID: TGUID;
out Obj): HResult;
begin
if GetInterface(IID, Obj) then begin
Result := S_OK;
end else begin
Result := E_NOINTERFACE;
end;
end;
function TInterfacedObjectWithoutReferenceCounting._AddRef: Integer;
begin
Result := -1;
end;
function TInterfacedObjectWithoutReferenceCounting._Release: Integer;
begin
Result := -1;
end;
But that comes with its own risks. You must make sure that you do not hold any references to the object after the object has been destroyed.
There are many ways to fix that... The simplest would probably be to have TSettings inherit from TComponent instead of TInterfacedObject.
TComponent implements IInterface but doesn't not implement the reference counting by default, so when the refcount is decremented, the object won't be destroyed. That also means you have to destroy it yourself.
TSettings = class(TComponent, ILettersSettings, INumbersSettings)
[...]
settings := TSettings.Create;
try
settings.LoadFromFile;
letters := TLetters.Create(settings);
numbers := TNumbers.Create(settings);
finally
Settings.Free;
end;
I want to assign an event handler in constructor, if it does not have one assigned. Consequentially I want to remove the eventually assigned event handler in destructor. I wrote the code as follows, but cannot be compiled.
constructor TSomeControl.Create(Panel: TPanel);
begin
inherited Create;
FPanel := Panel;
if not Assigned(FPanel.OnResize) then
FPanel.OnResize := HandlePanelResize;
end;
destructor TSomeControl.Destroy;
begin
if #FPanel.OnResize = #HandlePanelResize then // [dcc32 Error] E2036 Variable required
FPanel.OnResize := nil;
FPanel := nil;
inherited;
end;
How to test it properly? I know a solution is to use a variable to record, whether I have assigned OnResize. But I do not want this as solution.
No need to write any custom code here as you can use the already existing comparers from Generics.Defaults:
destructor TSomeControl.Destroy;
begin
if Assigned(FPanel) and TEqualityComparer<TNotifyEvent>.Default.Equals(
FPanel.OnResize, HandlePanelResize) then
FPanel.OnResize := nil;
FPanel := nil;
inherited;
end;
This is complicated by the fact that OnResize is a property rather than a variable. And it's quite hard to refer to a method directly without the compiler thinking you want to call the method. This is the big drawback of Pascal's convenience of allowing you to call a procedure without using parens.
All this makes it rather hard to do it in a one-liner. As far as I can see you will need to do something like this:
destructor TSomeControl.Destroy;
var
Method1, Method2: TNotifyEvent;
begin
if Assigned(FPanel) then
begin
Method1 := FPanel.OnResize;
Method2 := HandlePanelResize;
if TMethod(Method1) = TMethod(Method2) then
FPanel.OnResize := nil;
end;
FPanel := nil;
inherited;
end;
This relies on modern Delphi's TMethod record which includes an overloaded equality operator to make the = test work.
I would wrap this all up in a generic method if I was doing it more than once. It might look like this:
type
TEventComparer = class
class function Equal<T>(const lhs, rhs: T): Boolean; static;
end;
class function TEventComparer.Equal<T>(const lhs, rhs: T): Boolean;
begin
Assert(SizeOf(T)=SizeOf(TMethod));
Result := TMethod((#lhs)^)=TMethod((#rhs)^);
end;
You'd call it like this:
destructor TSomeControl.Destroy;
begin
if Assigned(FPanel) and TEventComparer.Equal<TNotifyEvent>(FPanel.OnResize,
HandlePanelResize) then
FPanel.OnResize := nil;
FPanel := nil;
inherited;
end;
One thing that this highlights is that the generic constraints available to you do not allow you to constraint a type to being a method pointer. Hence the basic sanity check that the size of T is the same as the size of a method. This doesn't offer much safety though. You can call this method passing Int64, or Double. I'd be interested to see if anyone can come up with a cleaner variant.
There is no need to use Generics.Defaults or any generics at all. There is TMethod record declared in System unit, so this is probably the simplest one:
destructor TSomeControl.Destroy;
var
Event: TNotifyEvent;
begin
Event := HandlePanelResize;
if TMethod(FPanel.OnResize).Code = Addr(Event) then
FPanel.OnResize := nil;
FPanel := nil;
inherited;
end;
I'm trying to resolve this problem. It's weird because it doesn't throw a Stack Overflow error but an Access Violation error. (See code below.)
Whenever CallDestructor function is called, DestroyChildren is called. So it's a recursive function.
When I'm handling only a few objects it works fine. My trouble is when I have a lot of instances to destroy.
unit AggregationObject;
interface
uses
System.Classes, System.Generics.Collections, System.Contnrs;
type
IParentObject = Interface;
IChildObject = Interface
['{061A8518-0B3A-4A1C-AA3A-4F42B81FB4B5}']
procedure CallDestructor();
procedure ChangeParent(Parent: IParentObject);
End;
IParentObject = Interface
['{86162E3B-6A82-4198-AD5B-77C4623481CB}']
procedure AddChild(ChildObject: IChildObject);
function RemoveChild(ChildObject: IChildObject): Integer;
function ChildrenCount(): Integer;
procedure DestroyChildren();
End;
TName = type String;
TChildObject = class(TInterfacedPersistent, IChildObject)
protected
FParentObject: IParentObject;
public
constructor Create( AParent: IParentObject ); virtual;
{IChildObject}
procedure CallDestructor();
procedure ChangeParent(Parent: IParentObject);
end;
TParentObject = class(TInterfacedPersistent, IParentObject)
strict private
FChildren: TInterfaceList;
private
FName: TName;
public
constructor Create();
{Polimórficos}
procedure BeforeDestruction; override;
{IParentObject}
procedure AddChild(AChildObject: IChildObject);
function RemoveChild(AChildObject: IChildObject): Integer;
function ChildrenCount(): Integer;
procedure DestroyChildren();
property Name: TName read FName write FName;
end;
TAggregationObject = class(TChildObject, IParentObject)
private
FController: IParentObject;
function GetController: IParentObject;
public
constructor Create( AParent: IParentObject ); override;
destructor Destroy(); override;
{Controller implementation}
public
property Controller: IParentObject read GetController implements IParentObject;
end;
implementation
uses
System.SysUtils, Exceptions;
{ TChildObject }
procedure TChildObject.CallDestructor;
begin
Self.Free;
end;
procedure TChildObject.ChangeParent(Parent: IParentObject);
begin
if Self.FParentObject <> nil then
IParentObject( Self.FParentObject ).RemoveChild( Self );
Self.FParentObject := Parent;
if Parent <> nil then
Parent.AddChild( Self );
end;
constructor TChildObject.Create(AParent: IParentObject);
begin
if not (AParent = nil) then
begin
FParentObject := AParent;
FParentObject.AddChild( Self );
end;
end;
{ TParentObject }
procedure TParentObject.AddChild(AChildObject: IChildObject);
begin
if (FChildren = nil) then FChildren := TInterfaceList.Create();
FChildren.Add( AChildObject );
end;
procedure TParentObject.BeforeDestruction;
begin
inherited;
DestroyChildren();
end;
function TParentObject.ChildrenCount: Integer;
begin
Result := -1;
if Assigned(FChildren) then
Result := FChildren.Count;
end;
constructor TParentObject.Create;
begin
FName := 'NoName';
end;
procedure TParentObject.DestroyChildren;
var
Instance: IChildObject;
begin
while FChildren <> nil do
begin
Instance := FChildren.Last as IChildObject;
if Instance <> nil then
begin
if RemoveChild( Instance ) > -1 then
begin
try
Instance.CallDestructor();
except on E: Exception do
raise EChildAlReadyDestroyed.Create('Parent: ' + Self.FName + #13#10 + E.Message);
end;
end;
end;
end;
end;
function TParentObject.RemoveChild(AChildObject: IChildObject): Integer;
begin
Result := -1;{if has no children}
if (FChildren <> nil) then
begin
Result := 0;{ Index 0}
if ( ( FChildren.Items[0] as IChildObject) = AChildObject) then
FChildren.Delete(0)
else
Result := FChildren.RemoveItem( AChildObject, TList.TDirection.FromEnd );
if (FChildren.Count = 0) then
begin
FreeAndNil( FChildren );
end;
end;
end;
{ TAggregationObject }
constructor TAggregationObject.Create(AParent: IParentObject);
begin
inherited Create(AParent);
FController := TParentObject.Create();
( FController as TParentObject ).Name := Self.ClassName + '_Parent';
end;
destructor TAggregationObject.Destroy;
begin
( FController as TParentObject ).Free;
inherited;
end;
function TAggregationObject.GetController: IParentObject;
begin
Result := FController;
end;
end.
OP managed to identify the problem, but hasn't posted an answer. I provide an edited version of his comment and add a more detailed explanation.
I think the problem was with mixing object reference and interface. Even though my objects aren't controlled by RefCount something hapens backstage: "However, due to the nature of interface references, _AddRef and _Release are still going to be called when the reference goes out of scope. If the class has been destroyed prior to that time, then you have an AV in _IntfClear." My last call in stack is _IntfClear or _IntfCopy. I think this is the problem. I'm not sure about how to correct that, so I've changed to an abstract class.
The Access Violations aren't caused by mixing object references and interfaces; there are ways to do this safely.
But they are caused by the fact that Delphi attempts to _Release a reference on an object that has already been destroyed.
However this raises the question: "Why does the AV only happen sometimes, and not all the time?"
To explain, I'm going to talk about an illegal memory operation. By this I mean a piece of code (or object) that accesses memory it is not supposed to.
You don't get an AV every time your program performs an illegal memory operation. An AV will only be raised if the illegal memory operation is noticed! There are 2 main reasons it might be unnoticed:
It may be "illegal" for one object in your program to access certain memory, but if it is legal for another instance to access that memory - then there is no way for the system to notice that you've actually committed an illegal memory operation.
Most of the time, FastMem requests memory from the OS in larger "pages" than what you actually request from FastMem. It then keeps track of multiple smaller allocations on the page. The page is only returned to the OS when there are no smaller allocations left on the page. Therefore again, the OS won't notice any illegal memory operations on a page still allocated to your program.
The second reason above is why a small number of objects doesn't cause an AV: The page on which the object was allocated is still allocated to your program.
But when you have a large number of instances: sometimes when you destroy an object, it the last one on a page; and the page is returned to the OS... Therefore you get AV when _Release is called on that page.
So, how do you fix it?
Well, the option you chose (use an abstract class instead of an interface) works. But you lose the benefits of interfaces. However, I would suggest not trying to manually control the destruction of interface objects. One of the benefits of interface references is that the underlying objects will self-destruct (if you let them).
I suspect you're doing this because you're mixing object references and interface references. So instead of forcing your interfaces behave like objects (and you've gone to a lot of trouble to do so), rather simply let each of your object references manually add a reference to the interface. You can do this with the following code:
(ObjectRef as IUnkown)._AddRef;
//Do stuff with ObjectRef
(ObjectRef as IUnkown)._Release;
SIDE NOTE:
You found it weird that no Stack Overflow error was raised. (And obviously you figured out why the AV was raised.) I'd like to point out that typically recursion will only trigger SO errors: if the recursion is very deep (and I mean very); or if each recursion allocates a rather large amount of memory on the stack.
The detail was the difference.
TValueObject is a specialization of TAggregationObject and it implements IMasterValue, something like this:
IMasterValue = interface
//GUID Here
function MasterValue: variant;
end;
TValueObject = class(TAggregationObject , IMasterValue)
public
function MasterValue: variant;
end;
So I have:
TSomeService = class
public
function Find(AMasterValue: IMasterValue): TValueObject;
end;
procedure DoSome(AValueObject: TValueObject);
begin
with TSomeService.Create() do
begin
try
Find(AValueObject); //This will get cleared when method exits
finally
AValueObject.Free(); //But the object is destroyed before that
end;
end;
end;
//Occurs on great concurrency because the memory will be reused, otherwise the memory is still there hidding the problem. The threads running loop for destruction will show the problem.
The workaround for that, is:
procedure DoSome(AValueObject: TValueObject);
var
LMasterValue: IMasterValue;
begin
with TSomeService.Create() do
begin
try
LMasterValue := AValueObject;
try
Find(LMasterValue);
finally
LMasterValue := nil;
end;
finally
AValueObject.Free();
end;
end;
end;
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 :-)
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.