david
2824855ea7
- Recompilación en Delphi10 de todos los paquetes de RO para generar las DCU's en Lib\D10 - Recompilación en Delphi10 de todos los paquetes de DA para generar las DCU's en Lib\D10 git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.RemObjects@9 b6239004-a887-0f4b-9937-50029ccdca16
727 lines
31 KiB
ObjectPascal
727 lines
31 KiB
ObjectPascal
unit uROSerializer;
|
|
|
|
{----------------------------------------------------------------------------}
|
|
{ RemObjects SDK Library - Core Library }
|
|
{ }
|
|
{ compiler: Delphi 5 and up, Kylix 2 and up }
|
|
{ platform: Win32, Linux }
|
|
{ }
|
|
{ (c)opyright RemObjects Software. all rights reserved. }
|
|
{ }
|
|
{ Using this code requires a valid license of the RemObjects SDK }
|
|
{ which can be obtained at http://www.remobjects.com. }
|
|
{----------------------------------------------------------------------------}
|
|
|
|
{$I RemObjects.inc}
|
|
|
|
{$IFDEF DOTNET}
|
|
{$MESSAGE error 'This unit will not be used in .NET, use RemObjects.SDK.Serializer instead' }
|
|
{$ENDIF}
|
|
|
|
interface
|
|
|
|
uses
|
|
{$IFDEF REMOBJECTS_TRIAL}uROTrial,{$ENDIF}
|
|
Classes, TypInfo, uROTypes;
|
|
|
|
const RO_ArrayItemName = 'item';
|
|
StreamClsName = 'Binary';
|
|
|
|
type TROSerializer = class;
|
|
|
|
IROCustomStreamableType = interface
|
|
['{BD8FB0B8-3F7E-4E6E-A9B1-80C3FF39878D}']
|
|
procedure Write(aSerializer: TROSerializer; const aName: string);
|
|
procedure Read(aSerializer: TROSerializer; const aName: string);
|
|
end;
|
|
|
|
IROCustomStreamableClass = interface(IROCustomStreamableType)
|
|
['{10D1288B-D679-42E8-B4C0-5CA772647582}']
|
|
function GetTypeName: string;
|
|
procedure SetTypeName(const aValue:string);
|
|
property TypeName:string read GetTypeName write SetTypeName;
|
|
|
|
function CanImplementType(const aName: string):boolean;
|
|
|
|
procedure SetNull(aIsNull: boolean);
|
|
function IsNull: boolean;
|
|
end;
|
|
|
|
IROCustomStreamableEnum = interface
|
|
['{5CE37B53-839A-48C4-89D7-8A0FDAFC2C4A}']
|
|
procedure SetValue(aValue: byte);
|
|
function GetValue: byte;
|
|
property Value: byte read GetValue write SetValue;
|
|
|
|
procedure Write(aSerializer: TROSerializer; const aName: string);
|
|
procedure Read(aSerializer: TROSerializer; const aName: string);
|
|
end;
|
|
|
|
IROCustomStreamableStruct = interface(IROCustomStreamableClass)
|
|
['{0DAA29FE-2E54-477C-AA4B-996FBFE1F9A6}']
|
|
end;
|
|
|
|
IROCustomStreamableArray = interface(IROCustomStreamableClass)
|
|
['{8B043EB4-F628-4581-884D-C636D9DDED0E}']
|
|
function GetCount: integer;
|
|
procedure SetCount(aElementCount: integer);
|
|
property Count: integer read GetCount write SetCount;
|
|
|
|
end;
|
|
|
|
IROObjectStreamExtender = interface
|
|
['{2A73D437-FDFC-4765-BA9A-07FD5F61D991}']
|
|
procedure Write(aSerializer: TROSerializer);
|
|
procedure Read(aSerializer: TROSerializer);
|
|
end;
|
|
|
|
TROSerializer = class
|
|
private
|
|
procedure ReadObject(obj: TObject);
|
|
procedure WriteObject(obj: TObject);
|
|
protected
|
|
function GetRecordStrictOrder: Boolean; virtual;
|
|
function IsROCustomStreamable(aClass : TClass):Boolean;
|
|
procedure BeginWriteObject(const aName: string; aClass : TClass; anObject: TObject; var LevelRef : IUnknown;
|
|
var IsValidType : boolean; out IsAssigned:Boolean; ArrayElementId : integer = -1); virtual;
|
|
procedure EndWriteObject(const aName: string; aClass : TClass; anObject: TObject; const LevelRef : IUnknown); virtual;
|
|
procedure CustomWriteObject(const aName : string; aClass : TClass; const Ref; ArrayElementId : integer = -1); virtual;
|
|
procedure CustomReadObject(const aName: string; aClass: TClass;var Ref; ArrayElementId: integer);virtual;
|
|
procedure BeginReadObject(const aName : string; aClass : TClass; var anObject : TObject; var LevelRef : IUnknown;
|
|
var IsValidType : boolean; ArrayElementId : integer = -1); virtual;
|
|
procedure EndReadObject(const aName : string; aClass : TClass; var anObject : TObject; const LevelRef : IUnknown); virtual;
|
|
procedure ReadROCustomStreamable(const aName : string; aClass : TClass; var Ref; ArrayElementId : integer = -1);
|
|
procedure WriteROCustomStreamable(const aName : string; aClass : TClass; const Ref; ArrayElementId : integer = -1);
|
|
{ Internal }
|
|
public
|
|
{ Writers }
|
|
procedure WriteInteger(const aName : string; anOrdType : TOrdType; const Ref; ArrayElementId : integer = -1); virtual; abstract;
|
|
procedure WriteInt64(const aName : string; const Ref; ArrayElementId : integer = -1); virtual; abstract;
|
|
procedure WriteEnumerated(const aName : string; anEnumTypeInfo : PTypeInfo; const Ref; ArrayElementId : integer = -1); virtual; abstract;
|
|
procedure WriteUTF8String(const aName : string; const Ref; ArrayElementId : integer = -1); virtual; abstract;
|
|
procedure WriteWideString(const aName : string; const Ref; ArrayElementId : integer = -1); virtual; abstract;
|
|
procedure WriteDateTime(const aName : string; const Ref; ArrayElementId : integer = -1); virtual; abstract;
|
|
procedure WriteDouble(const aName : string; aFloatType : TFloatType; const Ref; ArrayElementId : integer = -1); virtual; abstract;
|
|
procedure WriteVariant(const aName : string; const Ref; ArrayElementId : integer = -1); virtual; abstract;
|
|
procedure WriteXml(const aName : string; const Ref; ArrayElementId : integer = -1); virtual; abstract;
|
|
procedure WriteGuid(const aName : string; const Ref; ArrayElementId : integer = -1); virtual; abstract;
|
|
procedure WriteDecimal(const aName : string; const Ref; ArrayElementId : integer = -1); virtual; abstract;
|
|
procedure WriteBinary(const aName : string; const Ref; ArrayElementId : integer = -1);virtual; abstract;
|
|
procedure WriteStruct(const aName : string; const Ref; ArrayElementId : integer = -1);virtual; abstract;
|
|
procedure WriteArray(const aName : string; const Ref; ArrayElementId : integer = -1);virtual; abstract;
|
|
procedure WriteException(const aName : string; const Ref; ArrayElementId : integer = -1); virtual; abstract;
|
|
{ Readers }
|
|
procedure ReadInteger(const aName : string; anOrdType : TOrdType; var Ref; ArrayElementId : integer = -1); virtual; abstract;
|
|
procedure ReadInt64(const aName : string; var Ref; ArrayElementId : integer = -1); virtual; abstract;
|
|
procedure ReadEnumerated(const aName : string; anEnumTypeInfo : PTypeInfo; var Ref; ArrayElementId : integer = -1); virtual; abstract;
|
|
procedure ReadUTF8String(const aName : string; var Ref; ArrayElementId : integer = -1; iMaxLength:integer=-1); virtual; abstract;
|
|
procedure ReadWideString(const aName : string; var Ref; ArrayElementId : integer = -1; iMaxLength:integer=-1); virtual; abstract;
|
|
procedure ReadDateTime(const aName : string; var Ref; ArrayElementId : integer = -1); virtual; abstract;
|
|
procedure ReadDouble(const aName : string; aFloatType : TFloatType; var Ref; ArrayElementId : integer = -1); virtual; abstract;
|
|
procedure ReadVariant(const aName : string; var Ref; ArrayElementId : integer = -1); virtual; abstract;
|
|
procedure ReadXml(const aName : string; var Ref; ArrayElementId : integer = -1); virtual; abstract;
|
|
procedure ReadGuid(const aName : string; var Ref; ArrayElementId : integer = -1); virtual; abstract;
|
|
procedure ReadDecimal(const aName : string; var Ref; ArrayElementId : integer = -1); virtual; abstract;
|
|
procedure ReadBinary(const aName : string; var Ref; ArrayElementId : integer = -1);virtual; abstract;
|
|
function ReadStruct(const aName : string; aClass : TClass; var Ref; ArrayElementId : integer = -1): Boolean; virtual; abstract;
|
|
function ReadArray(const aName : string; aClass : TClass; var Ref; ArrayElementId : integer = -1): Boolean; virtual; abstract;
|
|
procedure ReadException(const aName : string; var Ref; ArrayElementId : integer = -1); virtual; abstract;
|
|
public
|
|
constructor Create();//aStorageRef: pointer); virtual;
|
|
destructor Destroy; override;
|
|
|
|
procedure Write(const aName : string; aTypeInfo : PTypeInfo; const Ref; ArrayElementId : integer = -1);
|
|
procedure Read(const aName : string; aTypeInfo : PTypeInfo; var Ptr; ArrayElementId : integer = -1); {$IFDEF DEBUG_REMOBJECTS}virtual;{$ENDIF}
|
|
function GetArrayElementName(anItemType : PTypeInfo; anItemReference: pointer): string; virtual;
|
|
property RecordStrictOrder: Boolean read GetRecordStrictOrder;
|
|
end;
|
|
|
|
TROSerializerClass = class of TROSerializer;
|
|
|
|
procedure ReadObjectFromSerializer(const ASerializer: TROSerializer; anObject : TObject);
|
|
procedure WriteObjectToSerializer(const ASerializer: TROSerializer; anObject: TObject);
|
|
implementation
|
|
|
|
uses
|
|
Variants, RTLConsts,
|
|
uRORes, SysUtils, uROClasses, uROBinaryHelpers, uROClient,
|
|
uROXMLIntf;
|
|
|
|
function RO_GetIntfProp(Instance: TObject; const PropName: string): IInterface;
|
|
{$IFDEF FPC}
|
|
var
|
|
lPropInfo: PPropInfo;
|
|
{$ENDIF}
|
|
begin
|
|
{$IFDEF FPC}
|
|
lPropInfo := GetPropInfo(Instance, PropName);
|
|
if lPropInfo = nil then begin
|
|
Result:=nil;
|
|
exit;
|
|
end;
|
|
Result := IInterface(Pointer(GetOrdProp(Instance, lPropInfo)));
|
|
{$ELSE}
|
|
Result := GetInterfaceProp(Instance, PropName);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
|
|
procedure RO_SetIntfProp(Instance: TObject; const PropName: string; const Value: IInterface);
|
|
{$IFDEF FPC}
|
|
var
|
|
lPropInfo: PPropInfo;
|
|
{$ENDIF}
|
|
begin
|
|
{$IFDEF FPC}
|
|
lPropInfo := GetPropInfo(Instance, PropName);
|
|
if lPropInfo = nil then Exit;
|
|
if Value <> nil then Value._AddRef;
|
|
SetOrdProp(Instance, lPropInfo, PtrInt(Value));
|
|
{$ELSE}
|
|
SetInterfaceProp(Instance, PropName, Value);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
|
|
{ TROSerializer }
|
|
|
|
procedure TROSerializer.BeginReadObject(const aName: string;
|
|
aClass : TClass; var anObject: TObject; var LevelRef : IUnknown; var IsValidType : boolean; ArrayElementId : integer = -1);
|
|
begin
|
|
//IsValidType := Assigned(anObject) or (anObject is TROComplexType);
|
|
IsValidType := aClass.InheritsFrom(TROComplexType) or aClass.InheritsFrom(EROException)
|
|
end;
|
|
|
|
procedure TROSerializer.BeginWriteObject(const aName: string; aClass : TClass; anObject: TObject; var LevelRef : IUnknown; var IsValidType : boolean; out IsAssigned:Boolean; ArrayElementId : integer = -1);
|
|
begin
|
|
//IsValidType := Assigned(anObject) or (anObject is TROComplexType);
|
|
IsValidType := aClass.InheritsFrom(TROComplexType) or aClass.InheritsFrom(EROException)
|
|
end;
|
|
|
|
constructor TROSerializer.Create;//(aStorageRef: pointer);
|
|
begin
|
|
inherited Create;
|
|
|
|
{if (pointer(aStorageRef)<>NIL) and not SetStorageRef(aStorageRef)
|
|
then RaiseError(err_InvalidStorage, []);}
|
|
end;
|
|
|
|
procedure TROSerializer.CustomReadObject(const aName: string; aClass : TClass; var Ref;
|
|
ArrayElementId: integer);
|
|
var obj : TObject absolute Ref;
|
|
i, cnt : integer;
|
|
itemref : pointer;
|
|
lCustomObject: IROCustomStreamableType;
|
|
|
|
begin
|
|
if Assigned(Obj) then begin
|
|
|
|
{ handle reading of arrays. any other custom types (like Streams) must
|
|
be handled by the base classes. }
|
|
|
|
if Obj.GetInterface(IROCustomStreamableType, lCustomObject) then begin
|
|
lCustomObject.Read(Self, aName);
|
|
end
|
|
else if (obj is TROArray) then with TROArray(obj) do begin
|
|
cnt := TROArray(obj).Count;
|
|
if (GetItemClass<>NIL) then begin
|
|
for i := 0 to (cnt-1) do begin
|
|
itemref := NIL;
|
|
Read(RO_ArrayItemName, GetItemType, itemref, i);
|
|
SetItemRef(i, itemref);
|
|
end;
|
|
end
|
|
else begin
|
|
for i := 0 to (cnt-1) do begin
|
|
itemref := GetItemRef(i);
|
|
Read(RO_ArrayItemName, GetItemType, itemref^, i);
|
|
end;
|
|
end;
|
|
end
|
|
|
|
end;
|
|
end;
|
|
|
|
procedure TROSerializer.CustomWriteObject(const aName: string; aClass : TClass; const Ref; ArrayElementId : integer = -1);
|
|
var obj : TObject absolute Ref;
|
|
i : integer;
|
|
itemref : pointer;
|
|
lCustomObject: IROCustomStreamableType;
|
|
begin
|
|
if Assigned(obj) then begin
|
|
|
|
{ handle reading of arrays. any other custom types (like Streams) must
|
|
be handled by the base classes. }
|
|
if Obj.GetInterface(IROCustomStreamableType, lCustomObject) then begin
|
|
lCustomObject.Write(Self, aName);
|
|
end
|
|
else if (obj is TROArray) then with TROArray(obj) do begin
|
|
if (GetItemClass<>NIL) then begin
|
|
for i := 0 to (Count-1) do begin
|
|
itemref := GetItemRef(i);
|
|
Write(GetArrayElementName(GetItemType, itemref), GetItemType, itemref, i);
|
|
//Write(TObject(itemref).ClassName, GetItemType, itemref, i);
|
|
end;
|
|
end
|
|
else begin
|
|
for i := 0 to (Count-1) do begin
|
|
itemref := GetItemRef(i);
|
|
Write(GetArrayElementName(GetItemType, itemref), GetItemType, itemref^, i);
|
|
//Write(RO_ArrayItemName, GetItemType, itemref^, i);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
end;
|
|
end;
|
|
|
|
destructor TROSerializer.Destroy;
|
|
begin
|
|
inherited;
|
|
end;
|
|
|
|
procedure TROSerializer.EndReadObject(const aName: string;
|
|
aClass : TClass; var anObject: TObject; const LevelRef : IUnknown);
|
|
begin
|
|
end;
|
|
|
|
procedure TROSerializer.EndWriteObject(const aName: string;
|
|
aClass : TClass; anObject: TObject; const LevelRef : IUnknown);
|
|
begin
|
|
end;
|
|
|
|
procedure TROSerializer.ReadROCustomStreamable(const aName: string; aClass : TClass; var Ref; ArrayElementId : integer = -1);
|
|
var obj : TObject absolute Ref;
|
|
LevelRef : IUnknown;
|
|
validtype : boolean;
|
|
begin
|
|
//obj := nil; { no matter what's passed in, we wanna start fresh }
|
|
|
|
BeginReadObject(aName, aClass, obj, levelref, validtype, ArrayElementId);
|
|
|
|
//if not Assigned(obj) then Exit; { we got outselves a nil object } // RaiseError(err_ObjectExpectedInStream, []);
|
|
if Assigned(obj) and (not validtype) then
|
|
raise EROUnknownType.CreateFmt(err_TypeNotSupported, [obj.ClassName]);
|
|
|
|
if Assigned(obj) then ReadObject(obj);
|
|
|
|
CustomReadObject(aName, aClass, obj, ArrayElementId);
|
|
|
|
EndReadObject(aName, aClass, obj, levelref);
|
|
end;
|
|
|
|
procedure TROSerializer.Write(const aName: string; aTypeInfo: PTypeInfo;
|
|
const Ref; ArrayElementId : integer = -1);
|
|
begin
|
|
case aTypeInfo^.Kind of
|
|
{$IFDEF FPC}tkBool,{$ENDIF}
|
|
tkEnumeration : WriteEnumerated(aName, aTypeInfo, Ref, ArrayElementId);
|
|
tkInteger : WriteInteger(aName, GetTypeData(aTypeInfo)^.OrdType, Ref, ArrayElementId);
|
|
|
|
tkFloat : if (aTypeInfo=TypeInfo(TDateTime))
|
|
then WriteDateTime(aName, Ref, ArrayElementId)
|
|
else WriteDouble(aName, GetTypeData(aTypeInfo)^.FloatType, Ref, ArrayElementId);
|
|
|
|
tkWString : WriteWideString(aName, Ref, ArrayElementId);
|
|
tkLString,
|
|
{$IFDEF FPC}tkAString,{$ENDIF}
|
|
tkString : if (aTypeInfo=TypeInfo(TGuidString)) then
|
|
WriteGuid(aName, Ref, ArrayElementId)
|
|
else
|
|
WriteUTF8String(aName, Ref, ArrayElementId);
|
|
tkInt64 : WriteInt64(aName, Ref, ArrayElementId);
|
|
|
|
tkClass : if GetTypeData(aTypeInfo).ClassType.InheritsFrom(TROArray) then
|
|
WriteArray(aName, Ref, ArrayElementId)
|
|
else if GetTypeData(aTypeInfo).ClassType.InheritsFrom(TROComplexType) then
|
|
WriteStruct(aName, Ref, ArrayElementId)
|
|
else if GetTypeData(aTypeInfo).ClassType.InheritsFrom(Binary) then
|
|
WriteBinary(aName, Ref, ArrayElementId)
|
|
else if GetTypeData(aTypeInfo).ClassType.InheritsFrom(Exception) then
|
|
WriteException(aName, Ref, ArrayElementId)
|
|
else
|
|
raise EROUnknownType.CreateFmt(err_TypeNotSupported, [GetEnumName(TypeInfo(TTypeKind), Ord(aTypeInfo^.Kind))]);
|
|
|
|
tkVariant : if aTypeInfo = TypeInfo(TDecimalVariant) then
|
|
WriteDecimal(aName, Ref, ArrayElementId)
|
|
else
|
|
WriteVariant(aName, Ref, ArrayElementId);
|
|
tkInterface :
|
|
begin
|
|
if aTypeInfo = TypeInfo(IXmlNode) then begin
|
|
WriteXml(aName, Ref, ArrayElementId);
|
|
end else raise EROUnknownType.CreateFmt(err_TypeNotSupported, [GetEnumName(TypeInfo(TTypeKind), Ord(aTypeInfo^.Kind))]);
|
|
end;
|
|
|
|
else raise EROUnknownType.CreateFmt(err_TypeNotSupported, [GetEnumName(TypeInfo(TTypeKind), Ord(aTypeInfo^.Kind))]);
|
|
end;
|
|
end;
|
|
|
|
procedure TROSerializer.Read(const aName: string; aTypeInfo: PTypeInfo;
|
|
var Ptr; ArrayElementId : integer = -1);
|
|
begin
|
|
case aTypeInfo^.Kind of
|
|
{$IFDEF FPC}tkBool,{$ENDIF}
|
|
tkEnumeration : ReadEnumerated(aName, aTypeInfo, byte(Ptr), ArrayElementId);
|
|
tkInteger : ReadInteger(aName, GetTypeData(aTypeInfo)^.OrdType, Ptr, ArrayElementId);
|
|
tkInt64 : ReadInt64(aName, Ptr, ArrayElementId);
|
|
|
|
tkFloat : if (aTypeInfo=TypeInfo(TDateTime))
|
|
then ReadDateTime(aName, Ptr, ArrayElementId)
|
|
else ReadDouble(aName, GetTypeData(aTypeInfo)^.FloatType, Ptr, ArrayElementId);
|
|
|
|
tkWString : ReadWideString(aName, Ptr, ArrayElementId);
|
|
tkLString,
|
|
{$IFDEF FPC}tkAString,{$ENDIF}
|
|
tkString :
|
|
if aTypeInfo = TypeInfo(TGuidString) then
|
|
ReadGuid(aName, Ptr, ArrayElementId)
|
|
else
|
|
ReadUTF8String(aName, Ptr, ArrayElementId);
|
|
|
|
tkClass : if isROCustomStreamable(GetTypeData(aTypeInfo).ClassType) then
|
|
ReadROCustomStreamable(aName, GetTypeData(aTypeInfo).ClassType, Ptr, ArrayElementId)
|
|
else if GetTypeData(aTypeInfo).ClassType.InheritsFrom(TROArray) then
|
|
ReadArray(aName, GetTypeData(aTypeInfo).ClassType, Ptr, ArrayElementId)
|
|
else if GetTypeData(aTypeInfo).ClassType.InheritsFrom(TROComplexType) then
|
|
ReadStruct(aName, GetTypeData(aTypeInfo).ClassType, Ptr, ArrayElementId)
|
|
else if GetTypeData(aTypeInfo).ClassType.InheritsFrom(Binary) then
|
|
ReadBinary(aName, Ptr, ArrayElementId)
|
|
else if GetTypeData(aTypeInfo).ClassType.InheritsFrom(Exception) then
|
|
ReadException(aName, Ptr, ArrayElementId)
|
|
else
|
|
raise EROUnknownType.CreateFmt(err_TypeNotSupported, [GetEnumName(TypeInfo(TTypeKind), Ord(aTypeInfo^.Kind))]);
|
|
|
|
tkVariant : if aTypeInfo = TypeInfo(TDecimalVariant) then
|
|
ReadDecimal(aName, Ptr, ArrayElementId)
|
|
else
|
|
ReadVariant(aName, Ptr, ArrayElementId);
|
|
|
|
tkInterface :
|
|
begin
|
|
if aTypeInfo = TypeInfo(IXmlNode) then begin
|
|
ReadXml(aName, Ptr, ArrayElementId);
|
|
end else raise EROUnknownType.CreateFmt(err_TypeNotSupported, [GetEnumName(TypeInfo(TTypeKind), Ord(aTypeInfo^.Kind))]);
|
|
end;
|
|
else RaiseError(err_TypeNotSupported, [GetEnumName(TypeInfo(TTypeKind), Ord(aTypeInfo^.Kind))]);
|
|
end;
|
|
end;
|
|
|
|
procedure TROSerializer.WriteROCustomStreamable(const aName: string; aClass : TClass; const Ref; ArrayElementId : integer = -1);
|
|
var obj : TObject absolute Ref;
|
|
validtype, IsAssigned : boolean;
|
|
LevelRef : IUnknown;
|
|
begin
|
|
BeginWriteObject(aName, aClass, obj, levelref, validtype, IsAssigned, ArrayElementId);
|
|
//if (not IsAssigned) or (not Assigned(obj)) then Exit; // no more streaming to do for a nil object.
|
|
|
|
if Assigned(obj) and (not validtype) then RaiseError(err_TypeNotSupported, [obj.ClassName]);
|
|
if Assigned(obj) then WriteObject(obj);
|
|
CustomWriteObject(aName, aClass, obj);
|
|
|
|
EndWriteObject(aName, aClass, obj, levelref);
|
|
end;
|
|
|
|
function TROSerializer.GetArrayElementName(anItemType: PTypeInfo; anItemReference: pointer): string;
|
|
begin
|
|
result := RO_ArrayItemName;
|
|
end;
|
|
|
|
function TROSerializer.GetRecordStrictOrder: Boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
function TROSerializer.IsROCustomStreamable(aClass : TClass): Boolean;
|
|
begin
|
|
Result:=Supports(aClass, IROCustomStreamableType);
|
|
end;
|
|
|
|
procedure ReadObjectFromSerializer(const ASerializer: TROSerializer; anObject : TObject);
|
|
begin
|
|
ASerializer.ReadObject(anObject);
|
|
end;
|
|
|
|
procedure WriteObjectToSerializer(const ASerializer: TROSerializer; anObject: TObject);
|
|
begin
|
|
ASerializer.WriteObject(anObject);
|
|
end;
|
|
|
|
procedure TROSerializer.ReadObject(obj: TObject);
|
|
var
|
|
props : PPropList;
|
|
cnt, i : integer;
|
|
propInf: PPropInfo;
|
|
|
|
// Temporary variables
|
|
node : IXMLNode;
|
|
int64val : int64;
|
|
intval : integer;
|
|
enuval : byte;
|
|
dblval : double;
|
|
currval : Currency;
|
|
extval : Extended;
|
|
singleval : Single;
|
|
compval : Comp;
|
|
varval : variant;
|
|
datetimeval : TDateTime;
|
|
//extval : extended;
|
|
strval : string;
|
|
{$IFNDEF DELPHI5}wstrval : widestring;{$ENDIF}
|
|
objval : TObject;
|
|
lObjectStreamExtender:IROObjectStreamExtender;
|
|
begin
|
|
if Assigned(obj) and (obj.ClassInfo <> nil) then begin
|
|
cnt := GetTypeData(obj.ClassInfo).PropCount;
|
|
|
|
if (cnt>0) then begin
|
|
GetMem(props, cnt*SizeOf(PPropInfo));
|
|
try
|
|
cnt := GetPropList(PTypeInfo(obj.ClassInfo), tkProperties, props, not GetRecordStrictOrder);
|
|
|
|
for i := 0 to (cnt-1) do begin
|
|
with props^[i]^ do begin
|
|
|
|
case PropType^.Kind of
|
|
{$IFDEF FPC}tkBool,{$ENDIF}
|
|
tkEnumeration : begin
|
|
ReadEnumerated(Name, PropType{$IFNDEF FPC}^{$ENDIF}, enuval);
|
|
SetOrdProp(obj, Name, enuval);
|
|
end;
|
|
|
|
tkInteger : begin
|
|
ReadInteger(Name, GetTypeData(PropType{$IFNDEF FPC}^{$ENDIF}).OrdType, intval);
|
|
SetOrdProp(obj, Name, intval);
|
|
end;
|
|
|
|
tkFloat : begin
|
|
if (PropType{$IFNDEF FPC}^{$ENDIF}=TypeInfo(TDateTime)) then begin
|
|
ReadDateTime(props^[i]^.Name, datetimeval);//, ArrayElementId);
|
|
SetPropValue(obj, Name, datetimeval);
|
|
end
|
|
else case GetTypeData(PropType{$IFNDEF FPC}^{$ENDIF})^.FloatType of
|
|
ftSingle : begin
|
|
ReadDouble(props^[i]^.Name, GetTypeData(PropType{$IFNDEF FPC}^{$ENDIF})^.FloatType, singleval);
|
|
SetFloatProp(obj, Name, singleval);
|
|
end;
|
|
ftDouble : begin
|
|
ReadDouble(props^[i]^.Name, GetTypeData(PropType{$IFNDEF FPC}^{$ENDIF})^.FloatType, dblval);
|
|
SetFloatProp(obj, Name, dblval);
|
|
end;
|
|
ftExtended : begin
|
|
ReadDouble(props^[i]^.Name, GetTypeData(PropType{$IFNDEF FPC}^{$ENDIF})^.FloatType, extval);
|
|
SetFloatProp(obj, Name, extval);
|
|
end;
|
|
ftComp : begin
|
|
ReadDouble(props^[i]^.Name, GetTypeData(PropType{$IFNDEF FPC}^{$ENDIF})^.FloatType, compval);
|
|
SetFloatProp(obj, Name, compval);
|
|
end;
|
|
ftCurr : begin
|
|
ReadDouble(props^[i]^.Name, GetTypeData(PropType{$IFNDEF FPC}^{$ENDIF})^.FloatType, currval);
|
|
SetFloatProp(obj, Name, currval);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
tkLString,
|
|
{$IFDEF FPC}tkAString,{$ENDIF}
|
|
tkString : begin
|
|
if PropType{$IFNDEF FPC}^{$ENDIF}=TypeInfo(TGuidString) then
|
|
ReadGuid(Name, strval)
|
|
else
|
|
ReadUTF8String(Name, strval);
|
|
SetStrProp(obj, Name, strval);
|
|
end;
|
|
|
|
tkInt64 : begin
|
|
ReadInt64(Name, int64val);
|
|
SetInt64Prop(obj, Name, int64val);
|
|
end;
|
|
|
|
tkWString : begin
|
|
{$IFDEF DELPHI5}
|
|
//RaiseError(err_TypeNotSupported, ['tkWString']);
|
|
ReadUTF8String(Name, strval);
|
|
SetStrProp(obj, Name, strval);
|
|
{$ELSE}
|
|
ReadWideString(Name, wstrval);
|
|
propInf := GetPropInfo(obj, Name);
|
|
if propInf = nil then
|
|
raise EPropertyError.CreateResFmt(@SUnknownProperty, [Name]);
|
|
SetWideStrProp(obj, propInf, wstrval);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
tkVariant : begin
|
|
if (PropType{$IFNDEF FPC}^{$ENDIF}=TypeInfo(TDecimalVariant)) then
|
|
ReadDecimal(Name, varval)
|
|
else
|
|
ReadVariant(Name, varval);
|
|
SetVariantProp(obj, Name, varval);
|
|
end;
|
|
|
|
tkClass : begin
|
|
objval := nil;
|
|
Read(Name, PropType{$IFNDEF FPC}^{$ENDIF}, objval);
|
|
SetObjectProp(obj, Name, objval);
|
|
end;
|
|
|
|
tkInterface: begin
|
|
if PropType{$IFNDEF FPC}^{$ENDIF}=TypeInfo(IXmlNode) then begin
|
|
ReadXml(Name, node);
|
|
RO_SetIntfProp(obj, Name, node);
|
|
end else raise EROUnknownType.CreateFmt(err_TypeNotSupported, [GetEnumName(TypeInfo(TTypeKind), Ord(props^[i].PropType^.Kind))])
|
|
end;
|
|
else raise EROUnknownType.CreateFmt(err_TypeNotSupported, [GetEnumName(TypeInfo(TTypeKind), Ord(props^[i].PropType^.Kind))])
|
|
end; { case }
|
|
end; { with }
|
|
end; { for }
|
|
finally
|
|
FreeMem(props, cnt*SizeOf(PPropInfo));
|
|
end;
|
|
end; { if Count > 0 }
|
|
if Obj.GetInterface(IROObjectStreamExtender, lObjectStreamExtender) then begin
|
|
lObjectStreamExtender.Read(Self);
|
|
end
|
|
end; { if Assigned }
|
|
end;
|
|
|
|
procedure TROSerializer.WriteObject(obj: TObject);
|
|
var
|
|
props : PPropList;
|
|
cnt, i : integer;
|
|
|
|
// Temporary variables
|
|
int64val : int64;
|
|
intval : integer;
|
|
enuval : byte;
|
|
dblval : double;
|
|
currval : Currency;
|
|
extval : Extended;
|
|
singleval : Single;
|
|
datetimeval : TDateTime;
|
|
compval : Comp;
|
|
strval : string;
|
|
varval : Variant;
|
|
{$IFNDEF DELPHI5}wstrval : widestring;{$ENDIF}
|
|
objval : TObject;
|
|
pdata : PTypeData;
|
|
lObjectStreamExtender:IROObjectStreamExtender;
|
|
node: IXMLNode;
|
|
begin
|
|
if (obj<>NIL) and (obj.ClassInfo<>NIL) then begin
|
|
pdata := GetTypeData(obj.ClassInfo);
|
|
if (pdata<>NIL) then begin
|
|
cnt := pdata .PropCount;
|
|
if (cnt>0) then begin
|
|
GetMem(props, cnt*SizeOf(PPropInfo));
|
|
try
|
|
cnt := GetPropList(PTypeInfo(obj.ClassInfo), tkProperties, props, not GetRecordStrictOrder);
|
|
|
|
for i := 0 to (cnt-1) do begin
|
|
with props^[i]^ do
|
|
|
|
case PropType^.Kind of
|
|
{$IFDEF FPC}tkBool,{$ENDIF}
|
|
tkEnumeration : begin
|
|
enuval := GetOrdProp(obj, Name);
|
|
WriteEnumerated(props^[i]^.Name, PropType{$IFNDEF FPC}^{$ENDIF}, enuval);
|
|
end;
|
|
|
|
tkInteger : begin
|
|
intval := GetOrdProp(obj, Name);
|
|
WriteInteger(props^[i]^.Name, GetTypeData(PropType{$IFNDEF FPC}^{$ENDIF})^.OrdType, intval);
|
|
end;
|
|
|
|
tkFloat : begin
|
|
if (PropType{$IFNDEF FPC}^{$ENDIF}=TypeInfo(TDateTime)) then begin
|
|
datetimeval := GetPropValue(obj, Name);
|
|
WriteDateTime(props^[i]^.Name, datetimeval);
|
|
end
|
|
else case GetTypeData(PropType{$IFNDEF FPC}^{$ENDIF})^.FloatType of
|
|
ftSingle : begin
|
|
singleval := GetFloatProp(obj, Name);
|
|
WriteDouble(props^[i]^.Name, GetTypeData(PropType{$IFNDEF FPC}^{$ENDIF})^.FloatType, singleval);
|
|
end;
|
|
ftDouble : begin
|
|
dblval := GetFloatProp(obj, Name);
|
|
WriteDouble(props^[i]^.Name, GetTypeData(PropType{$IFNDEF FPC}^{$ENDIF})^.FloatType, dblval);
|
|
end;
|
|
ftExtended : begin
|
|
extval := GetFloatProp(obj, Name);
|
|
WriteDouble(props^[i]^.Name, GetTypeData(PropType{$IFNDEF FPC}^{$ENDIF})^.FloatType, extval);
|
|
end;
|
|
ftComp : begin
|
|
compval := GetFloatProp(obj, Name);
|
|
WriteDouble(props^[i]^.Name, GetTypeData(PropType{$IFNDEF FPC}^{$ENDIF})^.FloatType, compval);
|
|
end;
|
|
ftCurr : begin
|
|
currval := GetFloatProp(obj, Name);
|
|
WriteDouble(props^[i]^.Name, GetTypeData(PropType{$IFNDEF FPC}^{$ENDIF})^.FloatType, currval);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
tkLString,
|
|
{$IFDEF FPC}tkAString,{$ENDIF}
|
|
tkString : begin
|
|
strval := GetStrProp(obj, Name);
|
|
if (PropType{$IFNDEF FPC}^{$ENDIF}=TypeInfo(TGuidString)) then
|
|
WriteGuid(name, strval)
|
|
else
|
|
WriteUTF8String(Name, strval);
|
|
end;
|
|
|
|
tkInt64 : begin
|
|
int64val := GetInt64Prop(obj, Name);
|
|
WriteInt64(Name, int64val);
|
|
end;
|
|
|
|
tkWString : begin
|
|
{$IFDEF DELPHI5}
|
|
//RaiseError(err_TypeNotSupported, ['tkWString']);
|
|
strval := GetStrProp(obj, Name);
|
|
WriteUTF8String(Name, strval);
|
|
{$ELSE}
|
|
wstrval := GetWideStrProp(obj, Name);
|
|
WriteWideString(Name, wstrval);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
tkVariant : begin
|
|
varval := GetVariantProp(obj, Name);
|
|
if (PropType{$IFNDEF FPC}^{$ENDIF}=TypeInfo(TDecimalVariant)) then
|
|
WriteDecimal(Name, varval)
|
|
else
|
|
WriteVariant(Name, varval);
|
|
end;
|
|
|
|
tkClass : begin
|
|
objval := GetObjectProp(obj, Name);
|
|
Write(Name, PropType{$IFNDEF FPC}^{$ENDIF}, objval);
|
|
end;
|
|
tkInterface : begin
|
|
if PropType{$IFNDEF FPC}^{$ENDIF}=TypeInfo(IXmlNode) then begin
|
|
// if props^[i] = TypeInfo(IXmlNode) then begin
|
|
node := RO_GetIntfProp(obj, name) as IXMLNode;
|
|
WriteXml(Name, node);
|
|
end else RaiseError(err_TypeNotSupported, [GetEnumName(TypeInfo(TTypeKind), Ord(props^[i].PropType^.Kind))])
|
|
end;
|
|
|
|
else RaiseError(err_TypeNotSupported, [GetEnumName(TypeInfo(TTypeKind), Ord(props^[i].PropType^.Kind))])
|
|
end;
|
|
end;
|
|
finally
|
|
FreeMem(props, cnt*SizeOf(PPropInfo));
|
|
end;
|
|
end;
|
|
end;
|
|
if Obj.GetInterface(IROObjectStreamExtender, lObjectStreamExtender) then begin
|
|
lObjectStreamExtender.Write(Self);
|
|
end
|
|
end;
|
|
end;
|
|
|
|
end.
|
|
|