when implementing an Event with the definition below Spring4D will add and invoke method but will not remove handler ( with IEvent<TaskItemChangeEvent>.Remove(MyProc) ) when asked as it does not identify it.
{$M+}
TaskItemChangeEvent = reference to procedure(const TaskItem: ITaskItem; Event: TTaskListEvent);
The following does work but I do not want to be forced to be bound to an object.
{$M+}
TaskItemChangeEvent = procedure(const TaskItem: ITaskItem; Event: TTaskListEvent) of Object;
I believe the issue is this line in TEventBase.Remove as a reference to procedure is not a TMethod?
if TMethod(handlers[i]) = TMethod(handler) then
The reason is the compiler possibly creating different instances of the anonymous method between the place where you add and where you remove them.
Look at the following code:
var
proc: TProc;
procedure Add(p: TProc);
begin
proc := p;
end;
procedure Remove(p: TProc);
begin
Writeln(PPointer(#proc)^ = PPointer(#p)^);
end;
procedure A;
var
p: TProc;
begin
p := procedure begin end;
Add(p);
Remove(p);
end;
procedure B;
begin
Add(procedure begin end);
Remove(procedure begin end);
end;
procedure C;
begin
Add(A);
Remove(A);
end;
begin
A;
B;
C;
Readln;
end.
You will notice that in B and C it will print False because the two anonymous methods being passed to Add and Remove differ from each other. While in B it's obvious in C it is not but the compiler actually transforms the code into this:
procedure C;
begin
Add(procedure begin A(); end);
Remove(procedure begin A(); end);
end;
That means if you want to use IEvent<> with a method reference type and be able to remove you need to keep the reference that you added in order for them to be equal and thus be able to be found when calling Remove.
The fact that internally in TEventBase the references are all handled as TMethod has nothing to do with that - when passing an anonymous method it is being transformed into a TMethod. After all an anonymous method type is an interface being backed by an object which the compiler creates which makes it possible to do such conversion and causes the necessity to keep the reference that was added in order to remove it.
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;
Delphi XE6 - I have a Unit (EMAIL1.pas) which does related processing. This is meant to be a standalone unit I can incorporate into multiple programs. My initial procedure is called GetDetailsFromEmailAddress. It has two parameters, an email address which I lookup and a "group of data" which will get updated, currently defined as a var. This can be a record or a class, I don't really care. It is just a group of related strings (firstname, last name, city, etc). Let's call this EmpRec.
My challenge is that this procedure creates an instance of a class (JEDI VCL HTMLParser) which uses a method pointer to call a method (TableKeyFound). This routine needs to update EmpRec. I do not want to change this code (HTMLPArser routine) to add additional parameters. There are several other procedures that my UNIT creates. All of them need to read/update EmpRec. How do I do this?
I need a way to "promote" the variable EmpRec which is passed in this one routine (GetDetailsFromEmailAddress) to be GLOBAL within this UNIT so that all the routines can access or change the various elements. How do I go about this? I do NOT really want to have to define this as a GLOBAL / Application wide variable.
Code sample below. So.. How does the routine TableKeyFoundEx get access to the EmpRec variable?
procedure GetDetailsFromEmailAddress(Email: string; var EmpRec: TEmpRec);
begin
...
// Now create the HTML Parser...
JvHtmlParser1 := TJvHTMLParser.Create(nil);
// On event KeyFoundEx, call Parsehandlers.TableKeyFoundEx;
JvHtmlParser1.OnKeyFoundEx := ParseHandlers.TableKeyFoundEx;
...
end.
procedure TParseHandlers.TableKeyFoundEx(Sender: TObject; Key, Results, OriginalLine: String; TagInfo: TTagInfo;
Attributes: TStrings);
begin
..
// NEED ACCESS to EmpRec here, but can't change procedure definition
end;
There are two different ways I would approach this:
use the parser's Tag property:
procedure GetDetailsFromEmailAddress(Email: string; var EmpRec: TEmpRec);
begin
...
JvHtmlParser1 := TJvHTMLParser.Create(nil);
JvHtmlParser1.OnKeyFoundEx := ParseHandlers.TableKeyFoundEx;
JvHtmlParser1.Tag := NativeInt(#EmpRec);
...
end;
procedure TParseHandlers.TableKeyFoundEx(Sender: TObject; Key, Results, OriginalLine: String; TagInfo: TTagInfo; Attributes: TStrings);
var
EmpRec: PEmpRec; // assuming PEmpRec = ^TEmpRec
begin
EmpRec := PEmpRec(TJvHTMLParser(Sender).Tag);
...
end;
use a little TMethod hack to pass the record DIRECTLY to the event handler:
// Note: this is declared as a STANDALONE procedure instead of a class method.
// The extra DATA parameter is where a method would normally pass its 'Self' pointer...
procedure TableKeyFoundEx(Data: Pointer: Sender: TObject; Key, Results, OriginalLine: String; TagInfo: TTagInfo; Attributes: TStrings);
var
EmpRec: PEmpRec; // assuming PEmpRec = ^TEmpRec
begin
EmpRec := PEmpRec(Data);
...
end;
procedure GetDetailsFromEmailAddress(Email: string; var EmpRec: TEmpRec);
var
M: TMethod;
begin
...
JvHtmlParser1 := TJvHTMLParser.Create(nil);
M.Code := #TableKeyFoundEx;
M.Data := #EmpRec;
JvHtmlParser1.OnKeyFoundEx := TJvKeyFoundExEvent(M);
...
end;
In addition to the two options that Remy offers, you could derive a sub-class of TJvHTMLParser.
type
PEmpRec = ^TEmpRec;
TMyJvHTMLParser = class(TJvHTMLParser)
private
FEmpRec: PEmpRec;
public
constructor Create(EmpRec: PEmpRec);
end;
....
constructor TMyJvHTMLParser.Create(EmpRec: PEmpRec);
begin
inherited Create(nil);
FEmpRec := EmpRec;
end;
When you create the parser, do so like this:
procedure GetDetailsFromEmailAddress(Email: string; var EmpRec: TEmpRec);
var
Parser: TMyJvHTMLParser;
begin
Parser := TMyJvHTMLParser.Create(#EmpRec);
try
Parser.OnKeyFoundEx := ParseHandlers.TableKeyFoundEx;
....
finally
Parser.Free;
end;
end.
And in your OnKeyFoundEx you cast Sender back to the parser type to gain access to the record:
procedure TParseHandlers.TableKeyFoundEx(Sender: TObject; ...);
var
EmpRec: PEmpRec;
begin
EmpRec := (Sender as TMyJvHTMLParser).FEmpRec;
....
end;
procedure DoSomething;
var
MyAnonymousProcedure : TProc;
begin
//assign an anonymous procedure to a variable.
MyAnonymousProcedure := procedure
begin
Foo;
end;
MyAnonymousProcedure(); //Call the newly assigned procedure.
// do the same thing again but with a different anonymous method.
MyAnonymousProcedure := procedure
begin
Bar;
end;
MyAnonymousProcedure();
end;
In the above code there are two anonymous procedures. They are assigned to the same TProc variable in turn. The code in each anonymous procedure is clearly different. Is there a way to find the executable code that the MyAnonymousProcedure variable references? I guess that would be a memory location. From there is it possible to then calculate the hash of the executable code found at that memory location?
Is there a way to find the executable code that the
MyAnonymousProcedure variable references?
There is always "a way" but it is tricky in this case.
First an anonymous method can be treated as a reference to interface with a single Invoke method as explained by Barry Kelly.
Applying the idea to your code we get:
procedure MethRefToProcPtr(const MethRef; var ProcPtr);
type
TVtable = array[0..3] of Pointer;
PVtable = ^TVtable;
PPVtable = ^PVtable;
begin
// 3 is offset of Invoke, after QI, AddRef, Release
TMethod(ProcPtr).Code := PPVtable(MethRef)^^[3];
end;
Unfortunately the ProcPtr value returned is not what you probably want - it is an address of a stub code that fixes an interface reference (converts an interface reference to an object reference) and jumps to the address we are looking for. If you trace the code pointed by ProcPtr you will find something like this (Delphi XE, 32-bits):
add eax,-$10
jmp FooBar
and at the FooBar address you will find
call Foo
or
call Bar
dependent of the current value of your anonymous method.
I guess the only way to get the FooBar address now is to parse the assembler jmp instruction.
Here is the code I used for my experiments:
procedure Foo;
begin
Writeln('Foo');
end;
procedure Bar;
begin
Writeln('Bar');
end;
procedure MethRefToProcPtr(const MethRef; var ProcPtr);
type
TVtable = array[0..3] of Pointer;
PVtable = ^TVtable;
PPVtable = ^PVtable;
begin
// 3 is offset of Invoke, after QI, AddRef, Release
TMethod(ProcPtr).Code := PPVtable(MethRef)^^[3];
end;
procedure DoSomething;
var
MyAnonymousProcedure : TProc;
MyProc : procedure;
begin
//assign an anonymous procedure to a variable.
MyAnonymousProcedure := procedure
begin
Foo;
end;
// MyAnonymousProcedure(); //Call the newly assigned procedure.
MethRefToProcPtr(MyAnonymousProcedure, MyProc);
Writeln(Format('%p', [#MyProc]));
Writeln(Format('%p', [#Foo]));
MyProc;
// do the same thing again but with a different anonymous method.
MyAnonymousProcedure := procedure
begin
Bar;
end;
// MyAnonymousProcedure();
MethRefToProcPtr(MyAnonymousProcedure, MyProc);
Writeln(Format('%p', [#MyProc]));
Writeln(Format('%p', [#Bar]));
MyProc;
end;
In addition to the other answer here is a routine that converts the compiler generated method stub that fixes the eax to the "real" method of the compiler generated class for the anonymous method.
procedure MethodStubToMethod(const Method; var Result);
var
offset: ShortInt;
begin
offset := PByte(TMethod(Method).Code)[2];
TMethod(Result).Code := PByte(TMethod(Method).Code) + 3;
TMethod(Result).Data := PByte(TMethod(Method).Data) + offset;
end;
It's a simple and naive implementation that assumes that the offset will never get bigger than one byte (which only would happen if you have hundred different anonymous methods within the same routine (like you have 2 in the original source in the question).
It assumes the layout of the stub is like this (which it for anonymous methods afaik)
add eax, offset
jmp address
Then you can write:
procedure MethRefToProcPtr(const MethRef; var ProcPtr);
type
TVtable = array[0..3] of Pointer;
PVtable = ^TVtable;
PPVtable = ^PVtable;
begin
// 3 is offset of Invoke, after QI, AddRef, Release
TMethod(ProcPtr).Code := PPVtable(MethRef)^^[3];
TMethod(ProcPtr).Data := Pointer(MethRef);
end;
procedure DoSomething;
var
MyAnonymousProcedure: TProc;
Method: procedure of object;
begin
//assign an anonymous procedure to a variable.
MyAnonymousProcedure := procedure
begin
Foo;
end;
MyAnonymousProcedure(); //Call the newly assigned procedure.
MethRefToProcPtr(MyAnonymousProcedure, Method); //
Method(); //same as calling the anonymous method
MethodStubToMethod(Method, Method)
Method(); // now we are calling the method directly on the object
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 :-)
Consider the following test-case:
{ CompilerVersion = 21 }
procedure Global();
procedure Local();
begin
end;
type
TProcedure = procedure ();
var
Proc: TProcedure;
begin
Proc := Local; { E2094 Local procedure/function 'Local' assigned to procedure variable }
end;
At line 13 compiler emits message with ERROR level, prohibiting all of the cases of such local procedures usage. "Official" resolution is to promote Local symbol to the outer scope (ie: make it a sibling of Global) which would have negative impact on code "structuredness".
I'm seeking the way to circumvent it in most graceful manner, preferably causing compiler to emit WARNING level message.
Your best bet is to declare it as reference to procedure using the new anonymous methods feature and then you can keep everything nicely encapsulated.
type
TProc = reference to procedure;
procedure Outer;
var
Local: TProc;
begin
Local := procedure
begin
DoStuff;
end;
Local;
end;
This gets around the issues that Mason describes by capturing any variables local to the anonymous function.
Here's why you can't do it:
type
TProcedure = procedure ();
function Global(): TProcedure;
var
localint: integer;
procedure Local();
begin
localint := localint + 5;
end;
begin
result := Local;
end;
Local procedures have access to the outer routine's variable scope. Those variables are declared on the stack, though, and become invalid once the outer procedure returns.
However, if you're using CompilerVersion 21 (Delphi 2010), you've got anonymous methods available, which should be able to do what you're looking for; you just need a slightly different syntax.
If one really needs to use local procedures in D7 or earlier one could use this trick:
procedure GlobalProc;
var t,maxx:integer; itr,flag1,flag2:boolean; iterat10n:pointer;
//Local procs:
procedure iterat10n_01;begin {code #1 here} end;
procedure iterat10n_10;begin {code #2 here} end;
procedure iterat10n_11;begin {code #1+#2 here} end;
begin
//...
t:=ord(flag2)*$10 or ord(flag1);
if t=$11 then iterat10n:=#iterat10n_11
else if t=$10 then iterat10n:=#iterat10n_10
else if t=$01 then iterat10n:=#iterat10n_01
else iterat10n:=nil;
itr:=(iterat10n<>nil);
//...
for t:=1 to maxx do begin
//...
if(itr)then asm
push ebp;
call iterat10n;
pop ecx;
end;
//...
end;
//...
end;
However the problem is that adress-registers could differ on different machines - so it's needed to write some code using local proc call and look via breakpoint which registers are used there...
And yeah - in most real production cases this trick is just some kind of palliative.
For the records, my homebrewn closure:
{ this type looks "leaked" }
type TFunction = function (): Integer;
function MyFunction(): TFunction;
{$J+ move it outside the stack segment!}
const Answer: Integer = 42;
function Local(): Integer;
begin
Result := Answer;
{ just some side effect }
Answer := Answer + Answer div 2;
end;
begin
Result := #Local;
end;
procedure TForm1.FormClick(Sender: TObject);
var
Func: TFunction;
N: Integer;
begin
{ unfolded for clarity }
Func := MyFunction();
N := Func();
ShowMessageFmt('Answer: %d', [N]);
end;