I'm trying to write a marshaller for a TPicture so that I can send objects classes containing a TPicture though datasnap methods.
I'm having difficulties finding an appropriate way of doing that, I have tried to send TMemoryStream as TObject but it appears that the "data from the picture is lost". I have tried to put the picture into a string - but that would, I guess, give me all kind's of troubles putting binary data into a string.
Does anyone have any ideas on how to marshal TPicture properly?
Here's what I'm doing, so far it looks like I get the picture into the result tobject, but I get a leak since I create an instance of the PictureMarshal class.
Don't mind the FChildren, that works fine.
type
TPictureMarshall = class
FPictureName : string;
FPictureSize : Integer;
FPictureData : TBytes;
end;
TPersonMar = class(TObject)
private
FStringList : TStringList; // complex object that needs marshalling
FChildren: array of TPerson; // complex object that needs marshalling
FMar : TJsonMarshal;
FPicture : TPicture;
procedure RegisterConverters;
procedure SetStringlist(const Value: TStringList);
public
function Marshal : string; // should handle marshalling
property Stringlist : TStringList read FStringlist write SetStringlist;
constructor Create;
destructor Destroy; override;
procedure AddChild(AKid: TPerson);
end;
procedure TPersonMar.RegisterConverters;
begin
FMar.RegisterConverter(ClassType, 'FPicture', function(Data: TObject; Field: String): TObject
var
AMemoryStream: TMemoryStream;
APic : TPictureMarshall;
begin
AMemoryStream := TMemoryStream.Create;
try
result := TPictureMarshall.Create; // but who frees this?
FPicture.Graphic.SaveToStream(AMemoryStream);
TPictureMarshall(Result).FPictureName := 'Somepicturefilename.png';
TPictureMarshall(Result).FPictureSize := AMemoryStream.Size;
SetLength(TPictureMarshall(Result).FPictureData, TPictureMarshall(Result).FPictureSize);
ZeroMemory(TPictureMarshall(Result).FPictureData, TPictureMarshall(Result).FPictureSize);
AMemoryStream.Position := 0; // reset position
AMemoryStream.ReadBuffer(TPictureMarshall(Result).FPictureData, AMemoryStream.Size);
finally
AMemoryStream.Free;
end;
end);
end;
"FMar":null,"FPicture":{"type":"TestObjU.TPictureMarshall","id":14,"fields":{"FPictureName":"Somepicturefilename.png","FPictureSize":71290,"FPictureData":[137,80,78,71,13,...snip]}}}}
Related
I am trying to write a spec utility library.
One of the Specification is a TExpressionSpecification. Basically, it implements the Specification pattern by evaluating an inner TExpression.
One of the TExpression is a TPropertyExpression. It's simply an expression that gets the value of a property by its name with Rtti.
I implemented it the simplest way I could, but really cannot understand why it throws an AV at me.
I stepped throrouly with the debugger. All types are what they are supposed to be. I just dont know why the TRttiProperty.GetValue is wrecking havoc.
Can anybody help?
unit Spec;
interface
uses
Classes;
type
TPropertyExpression<TObjectType, TResultType> = class
private
FPropertyName: string;
public
constructor Create(aPropertyName: string); reintroduce;
function Evaluate(aObject: TObjectType): TResultType;
property PropertyName: string read FPropertyName write FPropertyName;
end;
procedure TestIt;
implementation
uses
Rtti;
constructor TPropertyExpression<TObjectType, TResultType>.Create(aPropertyName:
string);
begin
inherited Create;
PropertyName := aPropertyName;
end;
function TPropertyExpression<TObjectType, TResultType>.Evaluate(aObject:
TObjectType): TResultType;
var
aCtx : TRttiContext;
aModelType : TRttiType;
aResultType : TRttiType;
aProperty : TRttiProperty;
aValue : TValue;
begin
aCtx := TRttiContext.Create;
aModelType := aCtx.GetType(System.TypeInfo(TObjectType));
aResultType := aCtx.GetType(System.TypeInfo(TResultType));
aProperty := aModelType.GetProperty(PropertyName);
aValue := aProperty.GetValue(Addr(aObject));
Result := aValue.AsType<TResultType>;
end;
procedure TestIt;
var
aComponent : TComponent;
aSpec : TPropertyExpression<TComponent, string>;
begin
aComponent := TComponent.Create(nil);
aComponent.Name := 'ABC';
aSpec := TPropertyExpression<TComponent, string>.Create('Name');
WriteLn(aSpec.Evaluate(aComponent));
Readln;
end;
end.
GetValue expects the instance pointer (aObject) but you are passing it the address of the pointer variable (#aObject).
Constrain your TObjectType to a class type:
type
TPropertyExpression<TObjectType: class; TResultType> = class...
Then, instead of Addr(aObject), pass the instance directly:
aValue := aProperty.GetValue(Pointer(aObject));
I am using RemObjects DataAbstract along with Spring4d. RemObjects generates a SchemaServer_Intf.pas file that contains interfaces for every kind of table that exists in it's schema. It allows for "Strongly typed" datasets, allowing one to access a field using
(aDataSet as IMyDataSet).MyField := aValue
Here is a snapshot of one of the interfaces generated by DataAbstract
IEntiteType = interface(IDAStronglyTypedDataTable)
['{96B82FF7-D087-403C-821A-0323034B4B99}']
{ Property getters and setters }
function GetEntiteIdValue: String;
procedure SetEntiteIdValue(const aValue: String);
function GetEntiteIdIsNull: Boolean;
procedure SetEntiteIdIsNull(const aValue: Boolean);
function GetNameValue: WideString;
procedure SetNameValue(const aValue: WideString);
function GetNameIsNull: Boolean;
procedure SetNameIsNull(const aValue: Boolean);
function GetIsSystemValue: SmallInt;
procedure SetIsSystemValue(const aValue: SmallInt);
function GetIsSystemIsNull: Boolean;
procedure SetIsSystemIsNull(const aValue: Boolean);
{ Properties }
property EntiteId: String read GetEntiteIdValue write SetEntiteIdValue;
property EntiteIdIsNull: Boolean read GetEntiteIdIsNull write SetEntiteIdIsNull;
property Name: WideString read GetNameValue write SetNameValue;
property NameIsNull: Boolean read GetNameIsNull write SetNameIsNull;
property IsSystem: SmallInt read GetIsSystemValue write SetIsSystemValue;
property IsSystemIsNull: Boolean read GetIsSystemIsNull write SetIsSystemIsNull;
end;
Though, there is one problem. If you cast a dataTable like so:
aDataTable := IEntiteType(TDAMemDataTable.Create(nil));
You'll have an "Interface not supported error"
But, as soon as you do:
aDataTable.LogicalName := 'EntiteType';
aDataTable.BusinessRulesId := MyBusinessRuleID;
You can safely write
aDataTable := IEntiteType(TDAMemDataTable.Create(nil));
And you don't get any error.
So, with Spring4d, I thought of writing this in my registration unit:
aContainer.RegisterType<TDAMemDataTable>.Implements<IEntiteType>.DelegateTo(
function : TDAMemDataTable
var aDataTable : TDAMemDataTable;
begin
Result:= TDAMemDataTable.Create(nil);
Result.LogicalName := 'EntiteType';
Result.BusinessRulesId := MyBusinessRuleId;
end
)
But then, Spring4d throws (with reason) error :
Exception 'first chance' à $762D5B68. Classe d'exception ERegistrationException avec un message 'Component type "uDAMemDataTable.TDAMemDataTable" incompatible with service type "SchemaClient_Intf.IEntiteType".'. Processus EntiteREM2.exe (3088)
Is there a way to override this check?
Ok I've found a way to do that. Super simple actually :
aContainer.RegisterType<IAddress>.DelegateTo(
function : IAddress
var aTable : TDAMemDataTable;
begin
aTable := TDAMemDataTable.Create(nil);
aTable.LogicalName := nme_Address;
aTable.BusinessRulesID := RID_Address;
Result := aTable as IAddress;
end
);
Also, for people interested in registering many tables in an elegant fashion :
aContainer.RegisterType<IAddress>.DelegateTo(TableConfigurator.GetTableDelegate<IAddress>(nme_Address, RID_Address));
// Registering other tables here...
Just create some "Helper" class with this method :
class function TableConfigurator.GetTableDelegate<T>(aLogicalName, aBusinessRulesId: string): TActivatorDelegate<T>;
begin
Result := (function: T
var
aTable: TDAMemDataTable;
begin
aTable := TDAMemDataTable.Create(nil);
aTable.LogicalName := aLogicalName;
aTable.BusinessRulesID := aBusinessRulesId;
Result := T(TValue.From(aTable).AsInterface);
end);
end;
The program receives product information datas through window message.
Incoming datas processed in TProductInstance.PutProductData procedure.
Product information contains date, name, price.
I want to store datas as TObjectDictionary. The key is same date of the product and value is product information data list as TObjectList.
Also I want to maintain datas only in latest 7 days.
By the way, when I remove the item from TObjectDictionary for maintaining, error occurs like below.
First chance exception at $75214598.Exception class EInvalidPointer with message 'Invalid pointer operation'. Process product.exe (3848).
This is caused by FProductDictionary.Remove(StringKey);.
How can I avoid EInvalidPointer error with maintain latest 7 days datas?
type
TProductItem = class(TObject)
private
FDate: String;
FName: String;
FPrice: Integer;
procedure SetDate(const value: String);
procedure SetName(const value: String);
procedure SetPrice(const value: Integer);
public
property Date: String read FDate write SetDate;
property Name: String read FName write SetName;
property Price: Integer read FPrice write SetPrice;
constructor Create(const date, name: String; const price: Integer);
end;
TProductItemList = class(TObjectList<TProductItem>);
type
TProductInstance = class(TObject)
private
public
FLatestDate: String;
FProductList: TProductItemList;
FProductDictionary: TObjectDictionary<String, TProductItemList>;
constructor Create;
destructor Destroy; override;
procedure PutProductData(var Data: LP_Data);
end;
implementation
constructor TProductInstance.Create;
begin
FLatestDate := '';
FProductList := TProductItemList.Create;
FProductDictionary := TObjectDictionary<String, TProductItemList>.Create([doOwnsValues]);
end;
procedure TProductInstance.PutProductData(var Data: LP_Data);
var
StringKey: String;
begin
if (Trim(LP_Data^.date) <> FLatestDate) then
begin
FProductDictionary.AddOrSetValue(Trim(LP_Data^.date), FProductList);
for StringKey in FProductDictionary.Keys do
begin
if (GetDateToInt(Trim(LP_Data^.date)) - GetDateToInt(FLatestDate) > 7) then
FProductDictionary.Remove(StringKey);
end;
FProductList.Free;
end;
FProductList.Add(TProductItem.Create(Trim(LP_Data^.date), Trim(LP_Data^.name), Trim(LP_Data^.price)));
FLatestDate := Trim(LP_Data^.date);
end;
UPDATED
type
TProductItem = class(TObject)
private
FDate: String;
FName: String;
FPrice: Integer;
procedure SetDate(const value: String);
procedure SetName(const value: String);
procedure SetPrice(const value: Integer);
public
property Date: String read FDate write SetDate;
property Name: String read FName write SetName;
property Price: Integer read FPrice write SetPrice;
constructor Create(const date, name: String; const price: Integer);
end;
type
TProductInstance = class(TObject)
private
public
FLatestDate: String;
FProductList: TObjectList<TProductItem>;
FProductDictionary: TObjectDictionary<String, TObjectList<TProductItem>>;
constructor Create;
destructor Destroy; override;
procedure PutProductData(var Data: LP_Data);
end;
implementation
constructor TProductInstance.Create;
var
LProductItem: TProductItem;
LProductItemList: TObjectList<TProductItem>;
LStringList: TStringList;
begin
FLatestDate := '';
FProductList := TObjectList<TProductItem>.Create;
FProductDictionary := TObjectDictionary<String, TObjectList<TProductItem>>.Create([doOwnsValues]);
end;
procedure TProductInstance.PutProductData(var Data: LP_Data);
var
StringKey: String;
begin
FProductList.Add(TProductItem.Create(Trim(LP_Data^.date), Trim(LP_Data^.name), Trim(LP_Data^.price)));
if (Trim(LP_Data^.date) <> FLatestDate) then
begin
LProductItemList := TObjectList<ProductItem>.Create;
for LProductItem in FProductList do
begin
LProductItemList.Add(LProductItem);
end;
FProductDictionary.AddOrSetValue(Trim(LP_Data^.date), LProductItemList);
FProductList.Clear;
LStringList := TStringList.Create;
for StringKey in FProductDictionary.Keys do
begin
if (GetDateToInt(Trim(LP_Data^.date)) - GetDateToInt(FLatestDate) > 7) then
begin
LStringList.Add(StringKey);
end;
end;
for StringKey in LStringList do
begin
FProductDictionary.Remove(StringKey);
end;
FreeAndNil(LStringList);
end;
end;
Updated code occurs EInvalidPointer error on FProductDictionary.Remove(StringKey); What did I wrong?
The code you present is incomplete. You did not show the destructor for TProductInstance. For a question such as this you should always supply a simple MCVE. This is quite easy to achieve in a single console .dpr file.
Looking at what we can see, it is clear that the lifetime management in the code is broken. Let us critique this method.
procedure TProductInstance.PutProductData(var Data: LP_Data);
var
StringKey: String;
begin
if (Trim(LP_Data^.date) <> FLatestDate) then
begin
FProductDictionary.AddOrSetValue(Trim(LP_Data^.date), FProductList);
for StringKey in FProductDictionary.Keys do
begin
if (GetDateToInt(Trim(LP_Data^.date)) - GetDateToInt(FLatestDate) > 7) then
FProductDictionary.Remove(StringKey);
end;
FProductList.Free;
end;
FProductList.Add(TProductItem.Create(Trim(LP_Data^.date), Trim(LP_Data^.name),
Trim(LP_Data^.price)));
FLatestDate := Trim(LP_Data^.date);
end;
Because FProductDictionary owns its values, when you do
FProductDictionary.AddOrSetValue(Trim(LP_Data^.date), FProductList);
then FProductDictionary becomes the owner of FProductList. That means that you should not destroy FProductList ever. However, you do exactly that:
FProductList.Free;
So you are going to be destroying FProductList multiple times which is a clear error.
What to do next? You need to deal with the lifetime issues. I cannot know from the code presented here what you are trying to achieve, and how the lifetime should be managed. You will need to work out who is responsible for owning what, and make sure that you stick to a clear lifetime management policy.
On the face of it, my best guess would be that you need to remove the FProductList field. When you need to add a new item to FProductDictionary, instantiate a new instance of TProductItemList, populate it, and add it to the dictionary. At that point the dictionary takes control of the lifetime of the TProductItemList.
As one final comment, I would suggest that the type TProductItemList is pointless. I would remove it. Use TObjectList<TProductItem> to make the code clearer to the reader. The reader can look at TObjectList<TProductItem> and know immediately what it is, since TObjectList<T> is such a ubiquitous type.
I'm updating some properties in a component. In order to avoid missing property errors I'm using DefineProperties to read the old properties from the stream. Most properties work fine e.g. Integer, but I can't get properties based on TPersistent to work. The ReadProperty(TPersistent) procedure in TReader is protected, not public and requires a hack to access it. Even then, the ReadFontProperty procedure is never called and the missing property exception occurs.
How do I read the TFont property?
Here's some sample code of how I'm trying to do it.
...
type
TMyComponent = class(TComponent)
strict private
// Removed
//FIntegerProperty: Integer;
//FFontProperty: TFont;
// New
FNewIntegerProperty: Integer;
FNewFontProperty: TFont;
procedure ReadIntegerProperty(Reader: TReader);
procedure ReadFontProperty(Reader: TReader);
protected
procedure DefineProperties(Filer: TFiler); override;
published
// Removed properties
//property IntegerProperty: Integer read FIntegerProperty write FIntegerProperty;
//property FontProperty: TFont read FFontProperty write SetFontProperty;
// New properties
property NewIntegerProperty: Integer read FNewIntegerProperty write FNewIntegerProperty;
property NewFontProperty: TFont read FNewFontProperty write SetNewFontProperty;
end;
implementation
procedure TMyComponent.DefineProperties(Filer: TFiler);
begin
inherited;
// This works
Filer.DefineProperty('IntegerProperty', ReadIntegerProperty, nil, FALSE);
// This doesn't
Filer.DefineProperty('FontProperty', ReadFontProperty, nil, FALSE);
end;
procedure TMyComponent.ReadIntegerProperty(Reader: TReader);
begin
FNewIntegerProperty:= Reader.ReadInteger;
end;
type
THackReader = class(TReader);
procedure TMyComponent.ReadFontProperty(Reader: TReader);
begin
{ TODO : This doesn't work. How do we read fonts? }
THackReader(Reader).ReadProperty(FNewFontProperty);
end;
...
Update 1
Tried David's suggestion using the following code:
Filer.DefineProperty('Font.CharSet', ReadFontCharSet, nil, False);
...
procedure TMyComponent.ReadFontCharSet(Reader: TReader);
begin
Reader.ReadInteger;
end;
I get an Invalid Property Value error. I guess it's something to do with Charset being of type TFontCharset (= System.UITypes.TFontCharset = 0..255). How do I read this type of property?
In order to do this you need to work with each individual published property of TFont and you will need to use fully qualified names.
Filer.DefineProperty('FontProperty.Name', ReadFontName, nil, False);
Filer.DefineProperty('FontProperty.Height', ReadFontHeight, nil, False);
Filer.DefineProperty('FontProperty.Size', ReadFontSize, nil, False);
// and so on for all the other published properties of TFont
ReadFontName, ReadFontHeight etc. should read the old property values into the newly named component.
procedure TMyComponent.ReadFontName(Reader: TReader);
begin
FNewFontProperty.Name := Reader.ReadString;
end;
// etc. etc.
Update
You ask how to read the Charset property. This is complex because it can be written either as a textual identifier (see the FontCharsets constant in Graphics.pas), or as a plain integer value. Here is some rapidly hacked together code that will read your Charset.
procedure TMyComponent.ReadFontCharset(Reader: TReader);
function ReadIdent: string;
var
L: Byte;
LResult: AnsiString;
begin
Reader.Read(L, SizeOf(Byte));
SetString(LResult, PAnsiChar(nil), L);
Reader.Read(LResult[1], L);
Result := UTF8ToString(LResult);
end;
function ReadInt8: Shortint;
begin
Reader.Read(Result, SizeOf(Result));
end;
function ReadInt16: Smallint;
begin
Reader.Read(Result, SizeOf(Result));
end;
var
Ident: string;
CharsetOrdinal: Integer;
begin
Beep;
case Reader.ReadValue of
vaIdent:
begin
Ident := ReadIdent;
if not IdentToCharset(Ident, CharsetOrdinal) then begin
raise EReadError.Create('Could not read MyFont.Charset');
end;
FNewFontProperty.Charset := CharsetOrdinal;
end;
vaInt8:
FNewFontProperty.Charset := ReadInt8;
vaInt16:
FNewFontProperty.Charset := ReadInt16;
else
raise EReadError.Create('Could not read FontProperty.Charset');
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 :-)