Delphi/delphimvcframework
1
0
Fork 0
mirror of https://github.com/danieleteti/delphimvcframework.git synced 2024-11-15 07:45:54 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

CustomTypesSerialiers

Browse Source
This commit is contained in:
Daniele Teti 2017-02-09 19:33:59 +01:00
parent 3e9c914b20
commit 4cc5b6560c
14 changed files with 863 additions and 359 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
sources/MVCFramework.Commons.pas
View File

@ -30,13 +30,8 @@ interface
uses
System.SysUtils, Generics.Collections
{$IFDEF SYSTEMJSON} // XE6
, System.JSON
{$ELSE}
, Data.DBXJSON
{$ENDIF}
, System.Generics.Collections, MVCFramework.Session, LoggerPro,
System.SysUtils, Generics.Collections, MVCFramework.TypesAliases,
System.Generics.Collections, MVCFramework.Session, LoggerPro,
System.SyncObjs;
{$I dmvcframeworkbuildconsts.inc}
@ -47,6 +42,16 @@ type
httpOPTIONS, httpPATCH, httpTRACE);
TMVCHTTPMethods = set of TMVCHTTPMethodType;
TMVCPair<TKey, TVal> = class
private
FKey: TKey;
FValue: TVal;
public
constructor Create(const Key: TKey; const Value: TVal);
property Key: TKey read FKey;
property Value: TVal read FValue;
end;
TMVCMimeType = class sealed
public const
APPLICATION_JSON = 'application/json';
@ -648,6 +653,15 @@ begin
end;
end;
{ TMVCPair<TKey, TVal> }
constructor TMVCPair<TKey, TVal>.Create(const Key: TKey; const Value: TVal);
begin
inherited Create;
FKey := Key;
FValue := Value;
end;
initialization
Lock := TObject.Create;

11
sources/MVCFramework.DuckTyping.pas
View File

@ -83,7 +83,8 @@ type
private
FOwnsObject: boolean;
protected
class var CTX: TRTTIContext;
class var
CTX: TRTTIContext;
FObjectAsDuck: TObject;
FAddMethod: TRttiMethod;
FClearMethod: TRttiMethod;
@ -272,6 +273,9 @@ end;
class function TDuckTypedList.Wrap(const AObjectAsDuck: TObject): IMVCList;
var
lRttiType: TRttiType;
{$IF CompilerVersion >= 23}
lRTTIIndexedProperty: TRTTIIndexedProperty;
{$IFEND}
begin
lRttiType := CTX.GetType(AObjectAsDuck.ClassInfo);
FAddMethod := lRttiType.GetMethod('Add');
@ -283,7 +287,10 @@ begin
FGetItemMethod := nil;
{$IF CompilerVersion >= 23}
FGetItemMethod := lRttiType.GetIndexedProperty('Items').ReadMethod;
lRTTIIndexedProperty := lRttiType.GetIndexedProperty('Items');
if lRTTIIndexedProperty = nil then
Exit(nil);
FGetItemMethod := lRTTIIndexedProperty.ReadMethod;
{$IFEND}
if not Assigned(FGetItemMethod) then
FGetItemMethod := lRttiType.GetMethod('GetItem');

136
sources/MVCFramework.Serializer.Commons.pas
View File

@ -1,10 +1,34 @@
// ***************************************************************************
//
// Delphi MVC Framework
//
// Copyright (c) 2010-2017 Daniele Teti and the DMVCFramework Team
//
// https://github.com/danieleteti/delphimvcframework
//
// ***************************************************************************
//
// Licensed under the Apache License, Version 2.0 (the "License");
// you may not use this file except in compliance with the License.
// You may obtain a copy of the License at
//
// http://www.apache.org/licenses/LICENSE-2.0
//
// Unless required by applicable law or agreed to in writing, software
// distributed under the License is distributed on an "AS IS" BASIS,
// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
// See the License for the specific language governing permissions and
// limitations under the License.
//
// *************************************************************************** }
unit MVCFramework.Serializer.Commons;
interface
uses
System.Rtti, System.Classes, System.SysUtils, System.Generics.Collections, MVCFramework.Serializer.Intf,
System.TypInfo;
System.TypInfo, MVCFramework.MultiMap, MVCFramework.Commons;
type
TSerializerHelpers = class sealed
@ -37,13 +61,18 @@ type
end;
TMVCSerUnSerRegistry = class sealed
TMVCSerializersRegistry = class sealed
strict private
class var SStorage: TDictionary<string, IMVCSerUnSer>;
class var SSerializers: TDictionary<string, IMVCSerializer>;
class var SCustomTypeSerializers: IMVCObjectMultiMap<TMVCPair<PTypeInfo, IMVCTypeSerializer>>;
public
class function GetSerUnSer(aContentType: String): IMVCSerUnSer;
class procedure RegisterSerializer(aContentType: string; aMVCSerUnSer: IMVCSerUnSer);
class function GetSerializer(aContentType: String): IMVCSerializer;
class procedure RegisterSerializer(aContentType: string; aMVCSerUnSer: IMVCSerializer);
class procedure UnRegisterSerializer(aContentType: string);
class procedure RegisterTypeSerializer(aContentType: string; aTypeInfo: PTypeInfo;
aMVCTypeSerializer: IMVCTypeSerializer);
class procedure UnRegisterTypeSerializer(aContentType: string; aTypeInfo: PTypeInfo);
class function GetTypeSerializer(aContentType: String; aTypeInfo: PTypeInfo): IMVCTypeSerializer;
class constructor Create;
class destructor Destroy;
end;
@ -56,6 +85,20 @@ type
function TValueTypeInfo: PTypeInfo;
end;
MVCSerializeAsString = class(TCustomAttribute)
strict private
FEncoding: string;
procedure SetEncoding(const Value: string);
const
DefaultEncoding = 'utf8';
private
function GetEncoding: string;
public
constructor Create(aEncoding: string = DefaultEncoding);
property Encoding: string read GetEncoding write SetEncoding;
end;
implementation
uses
@ -218,6 +261,8 @@ var
begin
Result := false;
attrs := ARTTIMember.GetAttributes;
if Length(attrs) = 0 then
Exit(false);
for attr in attrs do
if attr is T then
Exit(True);
@ -248,32 +293,69 @@ end;
{ TMVCSerUnSerRegistry }
class constructor TMVCSerUnSerRegistry.Create;
class constructor TMVCSerializersRegistry.Create;
begin
SStorage := TDictionary<String, IMVCSerUnSer>.Create;
SSerializers := TDictionary<String, IMVCSerializer>.Create;
SCustomTypeSerializers := TMVCObjectMultiMap < TMVCPair < PTypeInfo, IMVCTypeSerializer >>.Create;
end;
class destructor TMVCSerUnSerRegistry.Destroy;
class destructor TMVCSerializersRegistry.Destroy;
begin
SStorage.Free;
SSerializers.Free;
end;
class function TMVCSerUnSerRegistry.GetSerUnSer(
aContentType: String): IMVCSerUnSer;
class function TMVCSerializersRegistry.GetSerializer(
aContentType: String): IMVCSerializer;
begin
if not SStorage.TryGetValue(aContentType, Result) then
if not SSerializers.TryGetValue(aContentType, Result) then
raise EMVCSerializationException.CreateFmt('Cannot find a suitable serializer for %s', [aContentType]);
end;
class procedure TMVCSerUnSerRegistry.RegisterSerializer(aContentType: string;
aMVCSerUnSer: IMVCSerUnSer);
class function TMVCSerializersRegistry.GetTypeSerializer(aContentType: String;
aTypeInfo: PTypeInfo): IMVCTypeSerializer;
var
lList: TList<TMVCPair<PTypeInfo, IMVCTypeSerializer>>;
I: Integer;
begin
TMVCSerUnSerRegistry.SStorage.Add(aContentType, aMVCSerUnSer);
Result := nil;
lList := SCustomTypeSerializers.GetItems(aContentType);
if lList = nil then
Exit;
for I := 0 to lList.Count - 1 do
begin
if lList[I].Key = aTypeInfo then
begin
Result := lList[I].Value;
Break;
end;
end;
end;
class procedure TMVCSerUnSerRegistry.UnRegisterSerializer(aContentType: string);
class procedure TMVCSerializersRegistry.RegisterSerializer(aContentType: string;
aMVCSerUnSer: IMVCSerializer);
begin
TMVCSerUnSerRegistry.SStorage.Remove(aContentType);
TMVCSerializersRegistry.SSerializers.Add(aContentType, aMVCSerUnSer);
end;
class procedure TMVCSerializersRegistry.RegisterTypeSerializer(
aContentType: string; aTypeInfo: PTypeInfo;
aMVCTypeSerializer: IMVCTypeSerializer);
begin
SCustomTypeSerializers.Add(aContentType,
TMVCPair<PTypeInfo, IMVCTypeSerializer>.Create(aTypeInfo, aMVCTypeSerializer));
end;
class procedure TMVCSerializersRegistry.UnRegisterSerializer(aContentType: string);
begin
TMVCSerializersRegistry.SSerializers.Remove(aContentType);
end;
class procedure TMVCSerializersRegistry.UnRegisterTypeSerializer(
aContentType: string; aTypeInfo: PTypeInfo);
begin
raise Exception.Create('Not implemented');
// SCustomTypeSerializers.Add(aContentType,
// TMVCPair<PTypeInfo, IMVCTypeSerializer>.Create(aTypeInfo, aMVCTypeSerializer));
end;
{ TValueAsType }
@ -289,4 +371,24 @@ begin
Result := FTValueTypeInfo;
end;
{ MVCSerializeAsString }
constructor MVCSerializeAsString.Create(aEncoding: string);
begin
inherited Create;
FEncoding := aEncoding;
end;
function MVCSerializeAsString.GetEncoding: string;
begin
if FEncoding.IsEmpty then
FEncoding := DefaultEncoding;
Result := FEncoding;
end;
procedure MVCSerializeAsString.SetEncoding(const Value: string);
begin
FEncoding := Value;
end;
end.

21
sources/MVCFramework.Serializer.Intf.pas
View File

@ -3,7 +3,7 @@ unit MVCFramework.Serializer.Intf;
interface
uses
Data.DB, MVCFramework.DuckTyping;
Data.DB, MVCFramework.DuckTyping, System.Rtti;
const
DMVC_CLASSNAME = '$dmvc_classname';
@ -11,13 +11,13 @@ const
type
TMVCSerializationType = (Properties, Fields);
IMVCSerUnSerListener = interface
IMVCSerializerListener = interface
['{5976F9DA-1B89-4F8C-B333-C3612071DEE0}']
procedure BeforeSerialize(const AObject: TObject);
procedure AfterDeserialize(const AObject: TObject);
end;
IMVCSerUnSer = interface
IMVCSerializer = interface
['{1ECA942A-E3C4-45DD-9D23-C00363B5E334}']
function SerializeObject(AObject: TObject; AIgnoredProperties: array of string): String;
function SerializeObjectStrict(AObject: TObject): String;
@ -25,9 +25,24 @@ type
function SerializeCollection(AList: TObject; AIgnoredProperties: array of string): String;
function SerializeCollectionStrict(AList: TObject): String;
procedure DeserializeObject(ASerializedObject: String; AObject: TObject);
procedure DeserializeObjectStrict(ASerializedObject: String; AObject: TObject);
procedure DeserializeCollection(ASerializedObjectList: string; AList: IMVCList; AClazz: TClass);
end;
IMVCTypeSerializer = interface
['{806EC547-D1CB-4DA9-92D3-A8A7C0BD4009}']
procedure SerializeInstance(
const ElementType: TRTTIType;
const ElementAttributes: TArray<TCustomAttribute>;
const InputValue: TValue;
out OutputObject: TObject);
procedure DeserializeInstance(
const ElementType: TRTTIType;
const ElementAttributes: TArray<TCustomAttribute>;
const InputObject: TObject;
out OutputValue: TValue);
end;
implementation
end.

612
sources/MVCFramework.Serializer.JSON.pas
View File

@ -1,3 +1,27 @@
// ***************************************************************************
//
// Delphi MVC Framework
//
// Copyright (c) 2010-2017 Daniele Teti and the DMVCFramework Team
//
// https://github.com/danieleteti/delphimvcframework
//
// ***************************************************************************
//
// Licensed under the Apache License, Version 2.0 (the "License");
// you may not use this file except in compliance with the License.
// You may obtain a copy of the License at
//
// http://www.apache.org/licenses/LICENSE-2.0
//
// Unless required by applicable law or agreed to in writing, software
// distributed under the License is distributed on an "AS IS" BASIS,
// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
// See the License for the specific language governing permissions and
// limitations under the License.
//
// *************************************************************************** }
unit MVCFramework.Serializer.JSON;
interface
@ -10,12 +34,11 @@ uses MVCFramework.Serializer.Intf
, System.Rtti
, System.SysUtils
, System.Classes
, MVCFramework.Serializer.Commons
, MVCFramework.TypesAliases, MVCFramework.DuckTyping, System.TypInfo
;
type
TMVCJSONSerUnSer = class(TInterfacedObject, IMVCSerUnSer)
TMVCJSONSerUnSer = class(TInterfacedObject, IMVCSerializer)
private
class var CTX: TRTTIContext;
{ following methods are used internally by the serializer/unserializer to handle with the ser/unser logic }
@ -30,8 +53,12 @@ type
: TJSONValue;
function SerializeEnumerationField(AObject: TObject;
ARttiField: TRttiField): TJSONValue;
function DeserializeTValue(AJValue: TJSONValue; AAttributes: TArray<TCustomAttribute>): TValue;
function DeserializeTValueWithDynamicType(AJValue: TJSONValue): TValue;
function DeserializeFloat(ARTTIType: TRTTIType; AJSONValue: TJSONValue): TValue;
function DeserializeEnumeration(ARTTIType: TRTTIType; AJSONValue: TJSONValue; AItemName: String): TValue;
function DeserializeRecord(ARTTIType: TRTTIType; AJSONValue: TJSONValue;
AAttributes: TArray<TCustomAttribute>; AItemName: String): TValue;
function DeserializeTValue(AJValue: TJSONValue; AAttributes: TArray<TCustomAttribute>; AItemName: String): TValue;
function DeserializeTValueWithDynamicType(AJValue: TJSONValue; AItemName: String): TValue;
procedure DeSerializeStringStream(aStream: TStream;
const aSerializedString: string; aEncoding: string);
procedure DeSerializeBase64StringStream(aStream: TStream;
@ -45,10 +72,11 @@ type
function JSONObjectToObject(Clazz: TClass;
AJSONObject: TJSONObject): TObject;
function SerializeRTTIElement(ElementType: TRTTIType;
ElementAttributes: TArray<TCustomAttribute>; Value: TValue): TJSONValue;
ElementAttributes: TArray<TCustomAttribute>; Value: TValue; out OutputValue: TJSONValue): boolean;
procedure InternalJSONObjectToObject(AJSONObject: TJSONObject; AObject: TObject);
function SerializeTValueAsFixedNullableType(AValue: TValue;
AValueTypeInfo: PTypeInfo): TJSONValue;
procedure InternalDeserializeObject(ASerializedObject: string; AObject: TObject; AStrict: boolean);
protected
{ IMVCSerializer }
function SerializeObject(AObject: TObject;
@ -61,13 +89,15 @@ type
function SerializeCollectionStrict(AList: TObject): String;
{ IMVCDeserializer }
procedure DeserializeObject(ASerializedObject: string; AObject: TObject);
procedure DeserializeObjectStrict(ASerializedObject: String; AObject: TObject);
procedure DeserializeCollection(ASerializedObjectList: string; AList: IMVCList; AClazz: TClass);
end;
implementation
uses
ObjectsMappers, MVCFramework.Patches, MVCFramework.RTTIUtils;
ObjectsMappers, MVCFramework.Patches, MVCFramework.RTTIUtils,
MVCFramework.Serializer.Commons, Winapi.Windows;
{ TMVCJSONSerializer }
@ -77,8 +107,8 @@ begin
end;
function TMVCJSONSerUnSer.DeserializeTValue(AJValue: TJSONValue;
AAttributes: TArray<TCustomAttribute>): TValue;
function TMVCJSONSerUnSer.DeserializeTValue(AJValue: TJSONValue; AAttributes: TArray<TCustomAttribute>;
AItemName: String): TValue;
var
lAttr: TValueAsType;
begin
@ -102,17 +132,17 @@ begin
raise EMVCDeserializationException.Create('Booleans and enumerations are not supported');
end;
else
raise EMVCDeserializationException.Create('Type non supported for TValue');
raise EMVCDeserializationException.CreateFmt('Type non supported for TValue at item: ', [AItemName]);
end;
end
else
begin
Result := DeserializeTValueWithDynamicType(AJValue);
Result := DeserializeTValueWithDynamicType(AJValue, AItemName);
end;
end;
function TMVCJSONSerUnSer.DeserializeTValueWithDynamicType(
AJValue: TJSONValue): TValue;
AJValue: TJSONValue; AItemName: String): TValue;
var
lJTValueValue: TJSONValue;
lTypeKind: TTypeKind;
@ -143,7 +173,7 @@ begin
Result := (lJTValueValue as TJSONNumber).AsInt64;
end;
else
raise EMVCDeserializationException.CreateFmt('Type non supported for TValue %s', [lStrType]);
raise EMVCDeserializationException.CreateFmt('Type non supported for TValue %s at: ', [lStrType, AItemName]);
end;
end;
@ -157,11 +187,44 @@ begin
Result := pair;
end;
procedure TMVCJSONSerUnSer.InternalDeserializeObject(ASerializedObject: string;
AObject: TObject; AStrict: boolean);
var
lJSON: TJSONValue;
begin
lJSON := TJSONObject.ParseJSONValue(ASerializedObject);
try
if lJSON <> nil then
begin
if lJSON is TJSONObject then
begin
if AStrict then
begin
// InternalJSONObjectToObjectFields(TJSONObject(lJSON), AObject)
end
else
InternalJSONObjectToObject(TJSONObject(lJSON), AObject)
end
else
begin
raise EMVCDeserializationException.CreateFmt('Serialized string is a %s, expected JSON Object',
[lJSON.ClassName]);
end;
end
else
begin
raise EMVCDeserializationException.Create('Serialized string is not a valid JSON');
end;
finally
lJSON.Free;
end;
end;
procedure TMVCJSONSerUnSer.InternalJSONObjectToObject(AJSONObject: TJSONObject; AObject: TObject);
var
lRttiType: TRTTIType;
lRttiProperties: TArray<TRttiProperty>;
lRttiProp: TRttiProperty;
lProperties: TArray<TRttiProperty>;
lProperty: TRttiProperty;
f: string;
jvalue: TJSONValue;
v: TValue;
@ -177,194 +240,154 @@ var
ListMethod: TRttiMethod;
ListItem: TValue;
ListParam: TRttiParameter;
lPropName: string;
lTypeSerializer: IMVCTypeSerializer;
lOutputValue: TValue;
begin
{ TODO -oDaniele -cGeneral : Refactor this method }
if not Assigned(AJSONObject) then
raise EMapperException.Create('JSON Object cannot be nil');
lRttiType := CTX.GetType(AObject.ClassInfo);
lRttiProperties := lRttiType.GetProperties;
for lRttiProp in lRttiProperties do
lProperties := lRttiType.GetProperties;
for lProperty in lProperties do
begin
if ((not lRttiProp.IsWritable) and (lRttiProp.PropertyType.TypeKind <> tkClass))
or (TSerializerHelpers.HasAttribute<MapperTransientAttribute>(lRttiProp)) then
if ((not lProperty.IsWritable) and (lProperty.PropertyType.TypeKind <> tkClass))
or (TSerializerHelpers.HasAttribute<MapperTransientAttribute>(lProperty)) then
Continue;
f := TSerializerHelpers.GetKeyName(lRttiProp, lRttiType);
lPropName := lProperty.Name;
f := TSerializerHelpers.GetKeyName(lProperty, lRttiType);
if Assigned(AJSONObject.Get(f)) then
jvalue := AJSONObject.Get(f).JsonValue
else
Continue;
case lRttiProp.PropertyType.TypeKind of
tkEnumeration:
begin
if lRttiProp.PropertyType.QualifiedName = 'System.Boolean' then
begin
if jvalue is TJSONTrue then
lRttiProp.SetValue(TObject(AObject), True)
else if jvalue is TJSONFalse then
lRttiProp.SetValue(TObject(AObject), false)
else
raise EMapperException.Create('Invalid value for property ' +
lRttiProp.Name);
end
else // it is an enumerated value but it's not a boolean.
begin
TValue.Make((jvalue as TJSONNumber).AsInt,
lRttiProp.PropertyType.Handle, v);
lRttiProp.SetValue(TObject(AObject), v);
end;
end;
tkInteger, tkInt64:
lRttiProp.SetValue(TObject(AObject), StrToIntDef(jvalue.Value, 0));
tkFloat:
begin
if lRttiProp.PropertyType.QualifiedName = 'System.TDate' then
begin
if jvalue is TJSONNull then
lRttiProp.SetValue(TObject(AObject), 0)
else
lRttiProp.SetValue(TObject(AObject),
ISOStrToDateTime(jvalue.Value + ' 00:00:00'))
end
else if lRttiProp.PropertyType.QualifiedName = 'System.TDateTime' then
begin
if jvalue is TJSONNull then
lRttiProp.SetValue(TObject(AObject), 0)
else
lRttiProp.SetValue(TObject(AObject), ISOStrToDateTime(jvalue.Value))
end
else if lRttiProp.PropertyType.QualifiedName = 'System.TTime' then
begin
if not(jvalue is TJSONNull) then
if jvalue is TJSONString then
lRttiProp.SetValue(TObject(AObject), ISOStrToTime(jvalue.Value))
else
raise EMapperException.CreateFmt
('Cannot deserialize [%s], expected [%s] got [%s]',
[lRttiProp.Name, 'TJSONString', jvalue.ClassName]);
end
else { if _field.PropertyType.QualifiedName = 'System.Currency' then }
begin
if not(jvalue is TJSONNull) then
if jvalue is TJSONNumber then
lRttiProp.SetValue(TObject(AObject), TJSONNumber(jvalue).AsDouble)
else
raise EMapperException.CreateFmt
('Cannot deserialize [%s], expected [%s] got [%s]',
[lRttiProp.Name, 'TJSONNumber', jvalue.ClassName]);
end;
end;
tkString, tkLString, tkWString, tkUString:
begin
lRttiProp.SetValue(TObject(AObject), jvalue.Value);
end;
tkRecord:
begin
if lRttiProp.PropertyType.QualifiedName = 'System.Rtti.TValue' then
begin
lRttiProp.SetValue(TObject(AObject), DeserializeTValue(jvalue, lRttiProp.GetAttributes));
end
else if lRttiProp.PropertyType.QualifiedName = 'System.SysUtils.TTimeStamp'
then
begin
n := jvalue as TJSONNumber;
lRttiProp.SetValue(TObject(AObject),
TValue.From<TTimeStamp>(MSecsToTimeStamp(n.AsInt64)));
end;
end;
tkClass: // try to restore child properties... but only if the collection is not nil!!!
begin
o := lRttiProp.GetValue(TObject(AObject)).AsObject;
if Assigned(o) then
begin
if jvalue is TJSONNull then
begin
FreeAndNil(o);
lRttiProp.SetValue(AObject, nil);
end
else if o is TStream then
begin
if jvalue is TJSONString then
begin
SerStreamASString := TJSONString(jvalue).Value;
end
else
raise EMapperException.Create('Expected JSONString in ' +
AJSONObject.Get(f).JsonString.Value);
if TSerializerHelpers.HasAttribute<MapperSerializeAsString>(lRttiProp, _attrser) then
lTypeSerializer := TMVCSerializersRegistry.GetTypeSerializer('application/json', lProperty.PropertyType.Handle);
if lTypeSerializer <> nil then
begin
lTypeSerializer.DeserializeInstance(
lProperty.PropertyType, lProperty.GetAttributes, TObject(jvalue), lOutputValue);
lProperty.SetValue(TObject(AObject), lOutputValue);
end
else
begin
case lProperty.PropertyType.TypeKind of
tkEnumeration:
begin
lProperty.SetValue(TObject(AObject),
DeserializeEnumeration(lProperty.PropertyType, jvalue, lPropName));
end;
tkInteger, tkInt64:
lProperty.SetValue(TObject(AObject), StrToIntDef(jvalue.Value, 0));
tkFloat:
begin
lProperty.SetValue(TObject(AObject),
DeserializeFloat(lProperty.PropertyType, jvalue));
end;
tkString, tkLString, tkWString, tkUString:
begin
lProperty.SetValue(TObject(AObject), jvalue.Value);
end;
tkRecord:
begin
lProperty.SetValue(TObject(AObject),
DeserializeRecord(lProperty.PropertyType, jvalue, lProperty.GetAttributes, lPropName));
end;
tkClass: // try to restore child properties... but only if the collection is not nil!!!
begin
o := lProperty.GetValue(TObject(AObject)).AsObject;
if Assigned(o) then
begin
if jvalue is TJSONNull then
begin
TSerializerHelpers.DeSerializeStringStream(TStream(o), SerStreamASString,
_attrser.Encoding);
{ TODO -oDaniele -cGeneral : How to handle this case at best? }
// FreeAndNil(o);
// lRttiProp.SetValue(AObject, nil);
end
else
else if o is TStream then
begin
TSerializerHelpers.DeSerializeBase64StringStream(TStream(o), SerStreamASString);
end;
end
else if TDuckTypedList.CanBeWrappedAsList(o) then
begin // restore collection
if jvalue is TJSONArray then
begin
Arr := TJSONArray(jvalue);
// look for the MapperItemsClassType on the property itself or on the property type
if Mapper.HasAttribute<MapperItemsClassType>(lRttiProp, attr) or
Mapper.HasAttribute<MapperItemsClassType>(lRttiProp.PropertyType,
attr) then
if jvalue is TJSONString then
begin
cref := attr.Value;
list := WrapAsList(o);
for I := 0 to Arr.Count - 1 do
begin
list.Add(Mapper.JSONObjectToObject(cref,
Arr.Items[I] as TJSONObject));
end;
SerStreamASString := TJSONString(jvalue).Value;
end
else // Ezequiel J. Müller convert regular list
else
raise EMapperException.Create('Expected JSONString in ' +
AJSONObject.Get(f).JsonString.Value);
if TSerializerHelpers.HasAttribute<MapperSerializeAsString>(lProperty, _attrser) then
begin
ListMethod := CTX.GetType(o.ClassInfo).GetMethod('Add');
if (ListMethod <> nil) then
begin
for I := 0 to Arr.Count - 1 do
begin
ListItem := TValue.Empty;
for ListParam in ListMethod.GetParameters do
case ListParam.ParamType.TypeKind of
tkInteger, tkInt64:
ListItem := StrToIntDef(Arr.Items[I].Value, 0);
tkFloat:
ListItem := TJSONNumber(Arr.Items[I].Value).AsDouble;
tkString, tkLString, tkWString, tkUString:
ListItem := Arr.Items[I].Value;
end;
if not ListItem.IsEmpty then
ListMethod.Invoke(o, [ListItem]);
end;
end;
TSerializerHelpers.DeSerializeStringStream(TStream(o), SerStreamASString,
_attrser.Encoding);
end
else
begin
TSerializerHelpers.DeSerializeBase64StringStream(TStream(o), SerStreamASString);
end;
end
else
raise EMapperException.Create('Cannot restore ' + f +
' because the related json property is not an array');
end
else // try to deserialize into the property... but the json MUST be an object
begin
if jvalue is TJSONObject then
begin
InternalJSONObjectToObject(TJSONObject(jvalue), o);
else if TDuckTypedList.CanBeWrappedAsList(o) then
begin // restore collection
if jvalue is TJSONArray then
begin
Arr := TJSONArray(jvalue);
// look for the MapperItemsClassType on the property itself or on the property type
if Mapper.HasAttribute<MapperItemsClassType>(lProperty, attr) or
Mapper.HasAttribute<MapperItemsClassType>(lProperty.PropertyType,
attr) then
begin
cref := attr.Value;
list := WrapAsList(o);
for I := 0 to Arr.Count - 1 do
begin
list.Add(Mapper.JSONObjectToObject(cref,
Arr.Items[I] as TJSONObject));
end;
end
else // Ezequiel J. Müller convert regular list
begin
ListMethod := CTX.GetType(o.ClassInfo).GetMethod('Add');
if (ListMethod <> nil) then
begin
for I := 0 to Arr.Count - 1 do
begin
ListItem := TValue.Empty;
for ListParam in ListMethod.GetParameters do
case ListParam.ParamType.TypeKind of
tkInteger, tkInt64:
ListItem := StrToIntDef(Arr.Items[I].Value, 0);
tkFloat:
ListItem := TJSONNumber(Arr.Items[I].Value).AsDouble;
tkString, tkLString, tkWString, tkUString:
ListItem := Arr.Items[I].Value;
end;
if not ListItem.IsEmpty then
ListMethod.Invoke(o, [ListItem]);
end;
end;
end;
end
else
raise EMapperException.Create('Cannot restore ' + f +
' because the related json property is not an array');
end
else if jvalue is TJSONNull then
else // try to deserialize into the property... but the json MUST be an object
begin
FreeAndNil(o);
lRttiProp.SetValue(AObject, nil);
end
else
raise EMapperException.Create('Cannot deserialize property ' +
lRttiProp.Name);
if jvalue is TJSONObject then
begin
InternalJSONObjectToObject(TJSONObject(jvalue), o);
end
else if jvalue is TJSONNull then
begin
FreeAndNil(o);
lProperty.SetValue(AObject, nil);
end
else
raise EMapperException.Create('Cannot deserialize property ' +
lProperty.Name);
end;
end;
end;
end;
end; // case
end;
end;
end;
@ -405,6 +428,9 @@ var
SS: TStringStream;
_attrser: MapperSerializeAsString;
SerEnc: TEncoding;
lTypeSerializer: IMVCTypeSerializer;
lJSONValue: TJSONValue;
lSerializedJValue: TJSONValue;
begin
ThereAreIgnoredProperties := Length(AIgnoredProperties) > 0;
JSONObject := TJSONObject.Create;
@ -414,6 +440,7 @@ begin
begin
// f := LowerCase(_property.Name);
f := TSerializerHelpers.GetKeyName(lProperty, lType);
outputdebugstring(pchar(f));
// Delete(f, 1, 1);
if ThereAreIgnoredProperties then
begin
@ -430,8 +457,21 @@ begin
if TSerializerHelpers.HasAttribute<DoNotSerializeAttribute>(lProperty) then
Continue;
JSONObject.AddPair(f, SerializeRTTIElement(lProperty.PropertyType, lProperty.GetAttributes,
lProperty.GetValue(AObject)));
lTypeSerializer := TMVCSerializersRegistry.GetTypeSerializer('application/json', lProperty.PropertyType.Handle);
if lTypeSerializer <> nil then
begin
lJSONValue := nil;
lTypeSerializer.SerializeInstance(
lProperty.PropertyType, lProperty.GetAttributes, lProperty.GetValue(AObject), TObject(lJSONValue));
JSONObject.AddPair(f, lJSONValue);
end
else
begin
{ if serializable then serialize, otherwise ignore it }
if SerializeRTTIElement(lProperty.PropertyType, lProperty.GetAttributes,
lProperty.GetValue(AObject), lSerializedJValue) then
JSONObject.AddPair(f, lSerializedJValue);
end;
end;
Result := JSONObject;
@ -450,6 +490,7 @@ var
DoNotSerializeThis: boolean;
I: Integer;
JObj: TJSONObject;
lSerializedJValue: TJSONValue;
begin
JSONObject := TJSONObject.Create;
try
@ -460,7 +501,8 @@ begin
for _field in _fields do
begin
f := TSerializerHelpers.GetKeyName(_field, _type);
JSONObject.AddPair(f, SerializeRTTIElement(_field.FieldType, _field.GetAttributes, _field.GetValue(AObject)));
if SerializeRTTIElement(_field.FieldType, _field.GetAttributes, _field.GetValue(AObject), lSerializedJValue) then
JSONObject.AddPair(f, lSerializedJValue);
// case _field.FieldType.TypeKind of
// tkInteger, tkInt64:
@ -557,7 +599,7 @@ begin
end;
function TMVCJSONSerUnSer.SerializeRTTIElement(ElementType: TRTTIType;
ElementAttributes: TArray<TCustomAttribute>; Value: TValue): TJSONValue;
ElementAttributes: TArray<TCustomAttribute>; Value: TValue; out OutputValue: TJSONValue): boolean;
var
ts: TTimeStamp;
o: TObject;
@ -574,29 +616,35 @@ var
buff: TBytes;
lStreamAsString: string;
begin
OutputValue := nil;
Result := false;
case ElementType.TypeKind of
tkInteger, tkInt64:
Result := TJSONNumber.Create(Value.AsInteger);
begin
OutputValue := TJSONNumber.Create(Value.AsInteger);
end;
tkFloat:
begin
Result := SerializeFloatProperty(ElementType, Value);
OutputValue := SerializeFloatProperty(ElementType, Value);
end;
tkString, tkLString, tkWString, tkUString:
Result := TJSONString.Create(Value.AsString);
begin
OutputValue := TJSONString.Create(Value.AsString);
end;
tkEnumeration:
begin
Result := SerializeEnumerationProperty(ElementType, Value);
OutputValue := SerializeEnumerationProperty(ElementType, Value);
end;
tkRecord:
begin
if ElementType.QualifiedName = 'System.Rtti.TValue' then
begin
Result := SerializeTValue(ElementType, Value, ElementAttributes);
OutputValue := SerializeTValue(ElementType, Value, ElementAttributes);
end
else if ElementType.QualifiedName = 'System.SysUtils.TTimeStamp' then
begin
ts := Value.AsType<System.SysUtils.TTimeStamp>;
Result := TJSONNumber.Create(TimeStampToMsecs(ts));
OutputValue := TJSONNumber.Create(TimeStampToMsecs(ts));
end;
end;
tkClass:
@ -607,57 +655,58 @@ begin
list := TDuckTypedList.Wrap(o);
if Assigned(list) then
begin
Result := TJSONArray.Create;
OutputValue := TJSONArray.Create;
for Obj in list do
if Assigned(Obj) then
// nil element into the list are not serialized
TJSONArray(Result).AddElement(ObjectToJSONObject(Obj, []));
end
else if o is TStream then
begin
if TSerializerHelpers.AttributeExists<MapperSerializeAsString>(ElementAttributes, _attrser) then
begin
// serialize the stream as a normal string...
TStream(o).Position := 0;
lEncodingName := _attrser.Encoding;
SerEnc := TEncoding.GetEncoding(lEncodingName);
try
SetLength(buff, TStream(o).Size);
TStream(o).Read(buff, TStream(o).Size);
lStreamAsString := SerEnc.GetString(buff);
SetLength(buff, 0);
Result := TJSONString.Create(UTF8Encode(lStreamAsString));
finally
SerEnc.Free;
end;
end
else
begin
// serialize the stream as Base64 encoded string...
TStream(o).Position := 0;
SS := TStringStream.Create;
try
TSerializerHelpers.EncodeStream(TStream(o), SS);
Result := TJSONString.Create(SS.DataString);
finally
SS.Free;
end;
end;
TJSONArray(OutputValue).AddElement(ObjectToJSONObject(Obj, []));
end
// else if o is TStream then
// begin
// if TSerializerHelpers.AttributeExists<MapperSerializeAsString>(ElementAttributes, _attrser) then
// begin
// // serialize the stream as a normal string...
// TStream(o).Position := 0;
// lEncodingName := _attrser.Encoding;
// SerEnc := TEncoding.GetEncoding(lEncodingName);
// try
// SetLength(buff, TStream(o).Size);
// TStream(o).Read(buff, TStream(o).Size);
// lStreamAsString := SerEnc.GetString(buff);
// SetLength(buff, 0);
// Result := TJSONString.Create(UTF8Encode(lStreamAsString));
// finally
// SerEnc.Free;
// end;
// end
// else
// begin
// // serialize the stream as Base64 encoded string...
// TStream(o).Position := 0;
// SS := TStringStream.Create;
// try
// TSerializerHelpers.EncodeStream(TStream(o), SS);
// Result := TJSONString.Create(SS.DataString);
// finally
// SS.Free;
// end;
// end;
// end
else
begin
Result := ObjectToJSONObject(Value.AsObject, []);
OutputValue := ObjectToJSONObject(Value.AsObject, []);
end;
end
else
begin
if TSerializerHelpers.HasAttribute<MapperSerializeAsString>(ElementType) then
Result := TJSONString.Create('')
OutputValue := TJSONString.Create('')
else
Result := TJSONNull.Create;
OutputValue := TJSONNull.Create;
end;
end; // tkClass
end;
Result := OutputValue <> nil;
end;
function TMVCJSONSerUnSer.SerializeTValueAsFixedNullableType(AValue: TValue; AValueTypeInfo: PTypeInfo): TJSONValue;
@ -710,7 +759,8 @@ begin
else
begin
lTValueDataRTTIType := CTX.GetType(lValue.TypeInfo);
lJSONValue := SerializeRTTIElement(lTValueDataRTTIType, [], lValue);
if not SerializeRTTIElement(lTValueDataRTTIType, [], lValue, lJSONValue) then
raise EMVCSerializationException.Create('Cannot serialize TValue');
TJSONObject(Result).AddPair('type', TSerializerHelpers.GetTypeKindAsString(lValue.TypeInfo.Kind));
end;
TJSONObject(Result).AddPair('value', lJSONValue);
@ -919,6 +969,65 @@ begin
end;
end;
function TMVCJSONSerUnSer.DeserializeEnumeration(ARTTIType: TRTTIType; AJSONValue: TJSONValue;
AItemName: String): TValue;
var
lOutputValue: TValue;
begin
if ARTTIType.QualifiedName = 'System.Boolean' then
begin
if AJSONValue is TJSONTrue then
Result := True
else if AJSONValue is TJSONFalse then
Result := false
else
raise EMapperException.CreateFmt('Invalid value for property %s', [AItemName]);
end
else // it is an enumerated value but it's not a boolean.
begin
TValue.Make((AJSONValue as TJSONNumber).AsInt, ARTTIType.Handle, lOutputValue);
Result := lOutputValue;
end;
end;
function TMVCJSONSerUnSer.DeserializeFloat(ARTTIType: TRTTIType; AJSONValue: TJSONValue): TValue;
begin
if ARTTIType.QualifiedName = 'System.TDate' then
begin
if AJSONValue is TJSONNull then
Result := 0
else
Result := ISOStrToDateTime(AJSONValue.Value + ' 00:00:00');
end
else if ARTTIType.QualifiedName = 'System.TDateTime' then
begin
if AJSONValue is TJSONNull then
Result := 0
else
Result := ISOStrToDateTime(AJSONValue.Value);
end
else if ARTTIType.QualifiedName = 'System.TTime' then
begin
if not(AJSONValue is TJSONNull) then
if AJSONValue is TJSONString then
Result := ISOStrToTime(AJSONValue.Value)
else
raise EMVCDeserializationException.CreateFmt
('Cannot deserialize [%s], expected [%s] got [%s]',
[ARTTIType.QualifiedName, 'TJSONString', AJSONValue.ClassName]);
end
else { if _field.PropertyType.QualifiedName = 'System.Currency' then }
begin
if not(AJSONValue is TJSONNull) then
if AJSONValue is TJSONNumber then
Result := TJSONNumber(AJSONValue).AsDouble
else
raise EMVCDeserializationException.CreateFmt
('Cannot deserialize [%s], expected [%s] got [%s]',
[ARTTIType.QualifiedName, 'TJSONNumber', AJSONValue.ClassName]);
end;
end;
procedure TMVCJSONSerUnSer.DeSerializeBase64StringStream(aStream: TStream;
const aBase64SerializedString: string);
begin
@ -926,38 +1035,41 @@ begin
end;
procedure TMVCJSONSerUnSer.DeserializeObject(ASerializedObject: string; AObject: TObject);
var
lJSON: TJSONValue;
begin
lJSON := TJSONObject.ParseJSONValue(ASerializedObject);
try
if lJSON <> nil then
begin
if lJSON is TJSONObject then
begin
InternalJSONObjectToObject(TJSONObject(lJSON), AObject)
end
else
begin
raise EMVCDeserializationException.CreateFmt('Serialized string is a %s, expected JSON Object',
[lJSON.ClassName]);
end;
end
else
begin
raise EMVCDeserializationException.Create('Serialized string is not a valid JSON');
end;
finally
lJSON.Free;
end;
InternalDeserializeObject(ASerializedObject, AObject, false);
end;
procedure TMVCJSONSerUnSer.DeserializeObjectStrict(ASerializedObject: String;
AObject: TObject);
begin
InternalDeserializeObject(ASerializedObject, AObject, True);
end;
function TMVCJSONSerUnSer.DeserializeRecord(ARTTIType: TRTTIType; AJSONValue: TJSONValue;
AAttributes: TArray<TCustomAttribute>; AItemName: String): TValue;
var
lJNumber: TJSONNumber;
begin
if ARTTIType.QualifiedName = 'System.Rtti.TValue' then
begin
Result := DeserializeTValue(AJSONValue, AAttributes, AItemName);
end
else if ARTTIType.QualifiedName = 'System.SysUtils.TTimeStamp'
then
begin
lJNumber := AJSONValue as TJSONNumber;
Result := TValue.From<TTimeStamp>(MSecsToTimeStamp(lJNumber.AsInt64));
end
else
raise EMVCDeserializationException.CreateFmt('Type %s not supported for %s', [ARTTIType.QualifiedName, AItemName]);
end;
initialization
TMVCSerUnSerRegistry.RegisterSerializer('application/json', TMVCJSONSerUnSer.Create);
TMVCSerializersRegistry.RegisterSerializer('application/json', TMVCJSONSerUnSer.Create);
finalization
TMVCSerUnSerRegistry.UnRegisterSerializer('application/json');
TMVCSerializersRegistry.UnRegisterSerializer('application/json');
end.

24
sources/MVCFramework.TypesAliases.pas
View File

@ -1,3 +1,27 @@
// ***************************************************************************
//
// Delphi MVC Framework
//
// Copyright (c) 2010-2017 Daniele Teti and the DMVCFramework Team
//
// https://github.com/danieleteti/delphimvcframework
//
// ***************************************************************************
//
// Licensed under the Apache License, Version 2.0 (the "License");
// you may not use this file except in compliance with the License.
// You may obtain a copy of the License at
//
// http://www.apache.org/licenses/LICENSE-2.0
//
// Unless required by applicable law or agreed to in writing, software
// distributed under the License is distributed on an "AS IS" BASIS,
// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
// See the License for the specific language governing permissions and
// limitations under the License.
//
// *************************************************************************** }
unit MVCFramework.TypesAliases;
interface

10
sources/MVCFramework.pas
View File

@ -345,7 +345,7 @@ type
FContext: TWebContext;
FResponseStream: TStringBuilder;
FContentCharset: string;
FRenderer: IMVCSerUnSer;
FRenderer: IMVCSerializer;
procedure SetContext(const Value: TWebContext);
procedure SetWebSession(const Value: TWebSession);
procedure SetContentType(const Value: string);
@ -353,7 +353,7 @@ type
function GetWebSession: TWebSession;
function GetContentCharset: string;
procedure SetContentCharset(const Value: string);
function GetRenderer: IMVCSerUnSer;
function GetRenderer: IMVCSerializer;
protected const
CLIENTID_KEY = '__clientid';
protected
@ -451,7 +451,7 @@ type
property Config: TMVCConfig read GetMVCConfig;
property StatusCode: UInt16 read GetStatusCode write SetStatusCode;
property Renderer: IMVCSerUnSer read GetRenderer;
property Renderer: IMVCSerializer read GetRenderer;
public
// property ViewCache: TViewCache read FViewCache write SetViewCache;
procedure PushJSONToView(const AModelName: string; AModel: TJSONValue);
@ -1982,12 +1982,12 @@ begin
end;
end;
function TMVCController.GetRenderer: IMVCSerUnSer;
function TMVCController.GetRenderer: IMVCSerializer;
begin
{ TODO -oDaniele -cPluggableMapper : Check if the available renderer is compatible with the controller current content-type }
if FRenderer = nil then
begin
FRenderer := TMVCSerUnSerRegistry.GetSerUnSer(ContentType);
FRenderer := TMVCSerializersRegistry.GetSerializer(ContentType);
end;
Result := FRenderer;
end;

67
sources/ObjectsMappers.pas
View File

@ -49,7 +49,7 @@ uses
{$ELSE}
, Data.DBXJSON
{$IFEND}
, MVCFramework.Patches
, MVCFramework.Patches, MVCFramework.Serializer.Commons
;
type
@ -350,19 +350,20 @@ type
end;
MapperSerializeAsString = class(TCustomAttribute)
strict private
FEncoding: string;
procedure SetEncoding(const Value: string);
const
DefaultEncoding = 'utf8';
private
function GetEncoding: string;
public
constructor Create(aEncoding: string = DefaultEncoding);
property Encoding: string read GetEncoding write SetEncoding;
end;
MapperSerializeAsString = MVCSerializeAsString;
// MapperSerializeAsString = class(TCustomAttribute)
// strict private
// FEncoding: string;
// procedure SetEncoding(const Value: string);
//
// const
// DefaultEncoding = 'utf8';
// private
// function GetEncoding: string;
// public
// constructor Create(aEncoding: string = DefaultEncoding);
// property Encoding: string read GetEncoding write SetEncoding;
// end;
MapperJSONNaming = class(TCustomAttribute)
private
@ -3240,24 +3241,24 @@ begin
LoadFromJSONObjectString(AJSONObjectString, TArray<string>.Create());
end;
{ MapperSerializeAsString }
constructor MapperSerializeAsString.Create(aEncoding: string);
begin
inherited Create;
FEncoding := aEncoding;
end;
function MapperSerializeAsString.GetEncoding: string;
begin
if FEncoding.IsEmpty then
FEncoding := DefaultEncoding;
Result := FEncoding;
end;
procedure MapperSerializeAsString.SetEncoding(const Value: string);
begin
FEncoding := Value;
end;
// { MapperSerializeAsString }
//
// constructor MapperSerializeAsString.Create(aEncoding: string);
// begin
// inherited Create;
// FEncoding := aEncoding;
// end;
//
// function MapperSerializeAsString.GetEncoding: string;
// begin
// if FEncoding.IsEmpty then
// FEncoding := DefaultEncoding;
// Result := FEncoding;
// end;
//
// procedure MapperSerializeAsString.SetEncoding(const Value: string);
// begin
// FEncoding := Value;
// end;
end.

78
unittests/Several/BOs.pas
View File

@ -124,15 +124,18 @@ type
FProp1: string;
FChildObjectList: TMyChildObjectList;
FChildObject: TMyChildObject;
FPropStringList: TStringList;
procedure SetChildObject(const Value: TMyChildObject);
procedure SetChildObjectList(const Value: TMyChildObjectList);
procedure SetProp1(const Value: string);
procedure SetPropStringList(const Value: TStringList);
public
constructor Create;
destructor Destroy; override;
function Equals(Obj: TObject): boolean; override;
property Prop1: string read FProp1 write SetProp1;
property PropStringList: TStringList read FPropStringList write SetPropStringList;
property ChildObject: TMyChildObject read FChildObject write SetChildObject;
property ChildObjectList: TMyChildObjectList read FChildObjectList
write SetChildObjectList;
@ -190,6 +193,22 @@ type
constructor Create(ID: Integer; Description: string); overload;
end;
IMyInterface = interface
['{B36E786B-5871-4211-88AD-365B453DC408}']
function GetID: Integer;
function GetDescription: String;
end;
TMyIntfObject = class(TInterfacedObject, IMyInterface)
private
FID: Integer;
FValue: string;
public
constructor Create(const ID: Integer; const Value: String);
function GetDescription: string;
function GetID: Integer;
end;
TResponseWrapper<T: class> = class
private
FTotalItems: Integer;
@ -203,6 +222,16 @@ type
destructor Destroy; override;
end;
TObjectWithCustomType = class
private
FPropStringList: TStringList;
procedure SetPropStringList(const Value: TStringList);
public
constructor Create; virtual;
destructor Destroy; override;
property PropStringList: TStringList read FPropStringList write SetPropStringList;
end;
function GetMyObject: TMyObject;
function GetMyObjectWithTValue: TMyObjectWithTValue;
function GetMyObjectWithStream: TMyStreamObject;
@ -242,6 +271,11 @@ var
begin
Result := TMyComplexObject.Create;
Result.Prop1 := 'property1';
Result.PropStringList := TStringList.Create;
Result.PropStringList.Add('item 1');
Result.PropStringList.Add('item 2');
Result.PropStringList.Add('item 3');
Result.PropStringList.Add('item 4');
Result.ChildObject.MyChildProperty1 := 'MySingleChildProperty1';
co := TMyChildObject.Create;
co.MyChildProperty1 := 'MyChildProperty1';
@ -392,6 +426,7 @@ destructor TMyComplexObject.Destroy;
begin
FChildObjectList.Free;
FChildObject.Free;
FPropStringList.Free;
inherited;
end;
@ -441,6 +476,11 @@ begin
FProp1 := Value;
end;
procedure TMyComplexObject.SetPropStringList(const Value: TStringList);
begin
FPropStringList := Value;
end;
{ TMyChildObject }
constructor TMyChildObject.Create;
@ -642,4 +682,42 @@ begin
FValueAsString := Value;
end;
{ TMyIntfObject }
constructor TMyIntfObject.Create(const ID: Integer; const Value: String);
begin
inherited Create;
FID := ID;
FValue := Value;
end;
function TMyIntfObject.GetDescription: string;
begin
Result := FValue;
end;
function TMyIntfObject.GetID: Integer;
begin
Result := FID;
end;
{ TObjectWithCustomType }
constructor TObjectWithCustomType.Create;
begin
inherited;
FPropStringList := TStringList.Create;
end;
destructor TObjectWithCustomType.Destroy;
begin
FPropStringList.Free;
inherited;
end;
procedure TObjectWithCustomType.SetPropStringList(const Value: TStringList);
begin
FPropStringList.Assign(Value);
end;
end.

3
unittests/Several/DMVCFrameworkTests.dpr
View File

@ -35,7 +35,8 @@ uses
ObjectsMappers in '..\..\sources\ObjectsMappers.pas',
MVCFramework.Serializer.Commons in '..\..\sources\MVCFramework.Serializer.Commons.pas',
MVCFramework.TypesAliases in '..\..\sources\MVCFramework.TypesAliases.pas',
MVCFramework.Commons in '..\..\sources\MVCFramework.Commons.pas';
MVCFramework.Commons in '..\..\sources\MVCFramework.Commons.pas',
MVCFramework.Serializer.JSON.CustomTypes in '..\..\sources\MVCFramework.Serializer.JSON.CustomTypes.pas';
{$R *.RES}

23
unittests/Several/DMVCFrameworkTests.dproj
View File

@ -150,6 +150,7 @@
<DCCReference Include="..\..\sources\MVCFramework.Serializer.Commons.pas"/>
<DCCReference Include="..\..\sources\MVCFramework.TypesAliases.pas"/>
<DCCReference Include="..\..\sources\MVCFramework.Commons.pas"/>
<DCCReference Include="..\..\sources\MVCFramework.Serializer.JSON.CustomTypes.pas"/>
<BuildConfiguration Include="Base">
<Key>Base</Key>
</BuildConfiguration>
@ -254,7 +255,16 @@
<Overwrite>true</Overwrite>
</Platform>
</DeployFile>
<DeployClass Name="ProjectiOSDeviceResourceRules"/>
<DeployClass Name="DependencyModule">
<Platform Name="Win32">
<Operation>0</Operation>
<Extensions>.dll;.bpl</Extensions>
</Platform>
<Platform Name="OSX32">
<Operation>1</Operation>
<Extensions>.dylib</Extensions>
</Platform>
</DeployClass>
<DeployClass Name="ProjectOSXResource">
<Platform Name="OSX32">
<RemoteDir>Contents\Resources</RemoteDir>
@ -596,16 +606,7 @@
<Operation>1</Operation>
</Platform>
</DeployClass>
<DeployClass Name="DependencyModule">
<Platform Name="Win32">
<Operation>0</Operation>
<Extensions>.dll;.bpl</Extensions>
</Platform>
<Platform Name="OSX32">
<Operation>1</Operation>
<Extensions>.dylib</Extensions>
</Platform>
</DeployClass>
<DeployClass Name="ProjectiOSDeviceResourceRules"/>
<ProjectRoot Platform="Win64" Name="$(PROJECTNAME)"/>
<ProjectRoot Platform="iOSDevice64" Name="$(PROJECTNAME).app"/>
<ProjectRoot Platform="iOSDevice32" Name="$(PROJECTNAME).app"/>

108
unittests/Several/FrameworkTestsU.pas
View File

@ -32,7 +32,7 @@ uses
System.Generics.Collections,
BOs,
MVCFramework, Data.DB, System.SysUtils, MVCFramework.JWT,
MVCFramework.Serializer.Intf;
MVCFramework.Serializer.Intf, MVCFramework.MultiMap;
type
TTestMappers = class(TTestCase)
@ -112,14 +112,14 @@ type
check 'SerializationFrameworkTestU.pas' }
TMVCSerUnSerTestCase = class abstract(TTestCase)
private
FSerUnSer: IMVCSerUnSer;
FSerializer: IMVCSerializer;
protected
procedure SetSerUnSer(const SerUnSer: IMVCSerUnSer);
procedure SetSerializer(const ASerializer: IMVCSerializer);
procedure SetUp; override;
function GetObjectsList: TObjectList<TMyObject>;
function GetObjectsWithStreamsList: TObjectList<TMyStreamObject>;
function GetObjectsWithTValueList: TObjectList<TMyObjectWithTValue>;
property SerUnSer: IMVCSerUnSer read FSerUnSer;
property Serializer: IMVCSerializer read FSerializer;
published
procedure TestSerUnSerObject; virtual; abstract;
procedure TestSerUnSerObjectList; virtual; abstract;
@ -127,6 +127,19 @@ type
procedure TestSerUnSerObjectListWithStream; virtual; abstract;
procedure TestSerUnSerObjectWithTValue; virtual; abstract;
procedure TestSerUnSerObjectListWithTValue; virtual; abstract;
procedure TestSerUnSerObjectStrict; virtual; abstract;
procedure TestSerUnSerObjectBuiltInCustomTypes; virtual; abstract;
end;
TTestMultiMap = class(TTestCase)
protected
procedure SetUp; override;
procedure TearDown; override;
published
procedure TestObjectMultiMapAdd;
procedure TestObjectMultiMapRemove;
procedure TestInterfaceMultiMapAdd;
procedure TestInterfaceMultiMapRemove;
end;
implementation
@ -1500,9 +1513,9 @@ begin
end;
end;
procedure TMVCSerUnSerTestCase.SetSerUnSer(const SerUnSer: IMVCSerUnSer);
procedure TMVCSerUnSerTestCase.SetSerializer(const ASerializer: IMVCSerializer);
begin
FSerUnSer := SerUnSer;
FSerializer := ASerializer;
end;
procedure TMVCSerUnSerTestCase.SetUp;
@ -1510,11 +1523,94 @@ begin
raise Exception.Create('You should override this to use a specific MVCSerUnSer');
end;
{ TTestMultiMap }
procedure TTestMultiMap.SetUp;
begin
inherited;
end;
procedure TTestMultiMap.TearDown;
begin
inherited;
end;
procedure TTestMultiMap.TestInterfaceMultiMapAdd;
var
lMultiMap: IMVCInterfaceMultiMap<IMyInterface>;
begin
lMultiMap := TMVCInterfaceMultiMap<IMyInterface>.Create;
CheckEquals(0, Length(lMultiMap.Keys));
lMultiMap.Clear;
CheckFalse(lMultiMap.Contains('key1'));
lMultiMap.Add('key1', TMyIntfObject.Create(1, 'value1'));
CheckTrue(lMultiMap.Contains('key1'));
CheckEquals(1, lMultiMap.GetItems('key1').Count);
lMultiMap.Add('key1', TMyIntfObject.Create(2, 'value2'));
CheckEquals(2, lMultiMap.GetItems('key1').Count);
CheckEquals('value1', lMultiMap.GetItems('key1')[0].GetDescription);
CheckEquals('value2', lMultiMap.GetItems('key1')[1].GetDescription);
lMultiMap.Add('key2', TMyIntfObject.Create(1, 'value3'));
CheckEquals(2, lMultiMap.GetItems('key1').Count);
CheckEquals(1, lMultiMap.GetItems('key2').Count);
end;
procedure TTestMultiMap.TestInterfaceMultiMapRemove;
var
lMultiMap: IMVCInterfaceMultiMap<IMyInterface>;
begin
lMultiMap := TMVCInterfaceMultiMap<IMyInterface>.Create;
lMultiMap.Remove('not valid');
lMultiMap.Add('key1', TMyIntfObject.Create(1, 'value1'));
lMultiMap.Add('key1', TMyIntfObject.Create(2, 'value2'));
CheckEquals(2, lMultiMap.GetItems('key1').Count);
CheckTrue(lMultiMap.Contains('key1'));
lMultiMap.Remove('key1');
CheckFalse(lMultiMap.Contains('key1'));
end;
procedure TTestMultiMap.TestObjectMultiMapAdd;
var
lMultiMap: IMVCObjectMultiMap<TMyClass>;
begin
lMultiMap := TMVCObjectMultiMap<TMyClass>.Create;
CheckEquals(0, Length(lMultiMap.Keys));
lMultiMap.Clear;
CheckFalse(lMultiMap.Contains('key1'));
lMultiMap.Add('key1', TMyClass.Create(1, 'value1'));
CheckTrue(lMultiMap.Contains('key1'));
CheckEquals(1, lMultiMap.GetItems('key1').Count);
lMultiMap.Add('key1', TMyClass.Create(2, 'value2'));
CheckEquals(2, lMultiMap.GetItems('key1').Count);
CheckEquals('value1', lMultiMap.GetItems('key1')[0].Description);
CheckEquals('value2', lMultiMap.GetItems('key1')[1].Description);
lMultiMap.Add('key2', TMyClass.Create(1, 'value3'));
CheckEquals(2, lMultiMap.GetItems('key1').Count);
CheckEquals(1, lMultiMap.GetItems('key2').Count);
end;
procedure TTestMultiMap.TestObjectMultiMapRemove;
var
lMultiMap: IMVCObjectMultiMap<TMyClass>;
begin
lMultiMap := TMVCObjectMultiMap<TMyClass>.Create;
lMultiMap.Remove('not valid');
lMultiMap.Add('key1', TMyClass.Create(1, 'value1'));
lMultiMap.Add('key1', TMyClass.Create(2, 'value2'));
CheckEquals(2, lMultiMap.GetItems('key1').Count);
CheckTrue(lMultiMap.Contains('key1'));
lMultiMap.Remove('key1');
CheckFalse(lMultiMap.Contains('key1'));
end;
initialization
RegisterTest(TTestRouting.suite);
RegisterTest(TTestMappers.suite);
RegisterTest(TTestJWT.suite);
RegisterTest(TTestMultiMap.suite);
finalization

79
unittests/Several/SerializationFrameworkTestsU.pas
View File

@ -45,6 +45,8 @@ type
procedure TestSerUnSerObjectListWithStream; override;
procedure TestSerUnSerObjectWithTValue; override;
procedure TestSerUnSerObjectListWithTValue; override;
procedure TestSerUnSerObjectStrict; override;
procedure TestSerUnSerObjectBuiltInCustomTypes; override;
end;
implementation
@ -55,11 +57,20 @@ implementation
uses BOs, MVCFramework.Serializer.JSON, MVCFramework.DuckTyping,
System.Classes, Winapi.Windows;
function GetMyObjectWithCustomType: TObjectWithCustomType;
begin
Result := TObjectWithCustomType.Create;
Result.PropStringList.Add('item 1');
Result.PropStringList.Add('item 2');
Result.PropStringList.Add('item 3');
Result.PropStringList.Add('item 4');
end;
{ TTestJSONSerializer }
procedure TTestJSONSerializer.SetUp;
begin
SetSerUnSer(TMVCJSONSerUnSer.Create);
SetSerializer(TMVCJSONSerUnSer.Create);
end;
procedure TTestJSONSerializer.TestSerUnSerObject;
@ -70,10 +81,31 @@ var
begin
Obj := GetMyObject;
try
JSON := SerUnSer.SerializeObject(Obj, []);
JSON := Serializer.SerializeObject(Obj, []);
Obj2 := TMyObject.Create;
try
SerUnSer.DeserializeObject(JSON, Obj2);
Serializer.DeserializeObject(JSON, Obj2);
CheckTrue(Obj.Equals(Obj2));
finally
Obj2.Free;
end;
finally
Obj.Free;
end;
end;
procedure TTestJSONSerializer.TestSerUnSerObjectBuiltInCustomTypes;
var
Obj: TObjectWithCustomType;
JSON: string;
Obj2: TObjectWithCustomType;
begin
Obj := GetMyObjectWithCustomType;
try
JSON := Serializer.SerializeObject(Obj, []);
Obj2 := TObjectWithCustomType.Create;
try
Serializer.DeserializeObject(JSON, Obj2);
CheckTrue(Obj.Equals(Obj2));
finally
Obj2.Free;
@ -91,10 +123,10 @@ var
begin
ObjList := GetObjectsList;
try
lJSON := SerUnSer.SerializeCollection(ObjList, []);
lJSON := Serializer.SerializeCollection(ObjList, []);
Obj2List := TObjectList<TMyObject>.Create(True);
try
SerUnSer.DeserializeCollection(lJSON, WrapAsList(Obj2List), TMyObject);
Serializer.DeserializeCollection(lJSON, WrapAsList(Obj2List), TMyObject);
CheckEquals(ObjList.Count, Obj2List.Count);
for I := 0 to 9 do
begin
@ -116,10 +148,10 @@ var
begin
ObjList := GetObjectsWithStreamsList;
try
lJSON := SerUnSer.SerializeCollection(ObjList, []);
lJSON := Serializer.SerializeCollection(ObjList, []);
Obj2List := TObjectList<TMyStreamObject>.Create(True);
try
SerUnSer.DeserializeCollection(lJSON, WrapAsList(Obj2List), TMyStreamObject);
Serializer.DeserializeCollection(lJSON, WrapAsList(Obj2List), TMyStreamObject);
CheckEquals(ObjList.Count, Obj2List.Count);
for I := 0 to 9 do
begin
@ -141,10 +173,10 @@ var
begin
ObjList := GetObjectsWithTValueList;
try
lJSON := SerUnSer.SerializeCollection(ObjList, []);
lJSON := Serializer.SerializeCollection(ObjList, []);
Obj2List := TObjectList<TMyObjectWithTValue>.Create(True);
try
SerUnSer.DeserializeCollection(lJSON, WrapAsList(Obj2List), TMyObjectWithTValue);
Serializer.DeserializeCollection(lJSON, WrapAsList(Obj2List), TMyObjectWithTValue);
CheckEquals(ObjList.Count, Obj2List.Count);
for I := 0 to 9 do
begin
@ -158,6 +190,27 @@ begin
end;
end;
procedure TTestJSONSerializer.TestSerUnSerObjectStrict;
var
Obj: TMyObject;
JSON: string;
Obj2: TMyObject;
begin
Obj := GetMyObject;
try
JSON := Serializer.SerializeObjectStrict(Obj);
Obj2 := TMyObject.Create;
try
Serializer.DeserializeObjectStrict(JSON, Obj2);
CheckTrue(Obj.Equals(Obj2));
finally
Obj2.Free;
end;
finally
Obj.Free;
end;
end;
procedure TTestJSONSerializer.TestSerUnSerObjectWithStream;
var
Obj: TMyStreamObject;
@ -169,10 +222,10 @@ begin
Obj := GetMyObjectWithStream;
try
// ACT
JSON := SerUnSer.SerializeObject(Obj, []);
JSON := Serializer.SerializeObject(Obj, []);
Obj2 := TMyStreamObject.Create;
try
SerUnSer.DeserializeObject(JSON, Obj2);
Serializer.DeserializeObject(JSON, Obj2);
// ASSERT
CheckEquals('This is an UTF16 String', TStringStream(Obj2.PropStream).DataString);
CheckEquals('This is an UTF8 String', TStringStream(Obj2.Prop8Stream).DataString);
@ -194,10 +247,10 @@ var
begin
lObj := GetMyObjectWithTValue;
try
JSON := SerUnSer.SerializeObject(lObj, []);
JSON := Serializer.SerializeObject(lObj, []);
Obj2 := TMyObjectWithTValue.Create;
try
SerUnSer.DeserializeObject(JSON, Obj2);
Serializer.DeserializeObject(JSON, Obj2);
CheckTrue(lObj.Equals(Obj2));
finally
Obj2.Free;

22
unittests/TestServer/TestServer.dproj
View File

@ -218,16 +218,7 @@
<Overwrite>true</Overwrite>
</Platform>
</DeployFile>
<DeployClass Name="DependencyModule">
<Platform Name="Win32">
<Operation>0</Operation>
<Extensions>.dll;.bpl</Extensions>
</Platform>
<Platform Name="OSX32">
<Operation>1</Operation>
<Extensions>.dylib</Extensions>
</Platform>
</DeployClass>
<DeployClass Name="ProjectiOSDeviceResourceRules"/>
<DeployClass Name="ProjectOSXResource">
<Platform Name="OSX32">
<RemoteDir>Contents\Resources</RemoteDir>
@ -567,7 +558,16 @@
<Operation>1</Operation>
</Platform>
</DeployClass>
<DeployClass Name="ProjectiOSDeviceResourceRules"/>
<DeployClass Name="DependencyModule">
<Platform Name="Win32">
<Operation>0</Operation>
<Extensions>.dll;.bpl</Extensions>
</Platform>
<Platform Name="OSX32">
<Operation>1</Operation>
<Extensions>.dylib</Extensions>
</Platform>
</DeployClass>
<ProjectRoot Platform="iOSDevice64" Name="$(PROJECTNAME).app"/>
<ProjectRoot Platform="Win64" Name="$(PROJECTNAME)"/>
<ProjectRoot Platform="iOSDevice32" Name="$(PROJECTNAME).app"/>