12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147 |
- { ***************************************************************************
- Copyright (c) 2015-2022 Kike Pérez
- Unit : Quick.JSON.Serializer
- Description : Json Serializer
- Author : Kike Pérez
- Version : 1.12
- Created : 21/05/2018
- Modified : 17/05/2022
- This file is part of QuickLib: https://github.com/exilon/QuickLib
- ***************************************************************************
- 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 Quick.Json.Serializer;
- {$i QuickLib.inc}
- interface
- uses
- {$IFDEF DEBUG_SERIALIZER}
- Quick.Debug.Utils,
- {$ENDIF}
- Classes,
- SysUtils,
- Rtti,
- TypInfo,
- Quick.Serializer.Intf,
- Quick.Base64,
- {$IFDEF FPC}
- rttiutils,
- fpjson,
- jsonparser,
- strUtils,
- //jsonreader,
- //fpjsonrtti,
- Quick.Json.fpc.Compatibility,
- {$ELSE}
- {$IFDEF DELPHIXE7_UP}
- System.Json,
- {$ELSE}
- Data.DBXJSON,
- {$ENDIF}
- {$IFDEF DELPHIRX10_UP}
-
- {$ENDIF}
- Variants,
- {$ENDIF}
- Generics.Collections,
- Quick.RTTI.Utils,
- DateUtils,
- Quick.Commons,
- Quick.JSON.Utils;
- type
- IJsonSerializer = ISerializer;
- EJsonSerializeError = class(Exception);
- EJsonDeserializeError = class(Exception);
- {$IFNDEF FPC}
- TNotSerializableProperty = class(TCustomAttribute);
- TCommentProperty = class(TCustomAttribute)
- private
- fComment : string;
- public
- constructor Create(const aComment: string);
- property Comment : string read fComment;
- end;
- TSerializerOptions = Quick.Serializer.Intf.TSerializerOptions;
- TCustomNameProperty = class(TCustomAttribute)
- private
- fName : string;
- public
- constructor Create(const aName: string);
- property Name : string read fName;
- end;
- {$IFNDEF DELPHIXE7_UP}
- TJSONArrayHelper = class helper for Data.DBXJson.TJSONArray
- private
- function GetItem(aValue : Integer) : TJSONValue;
- public
- function Count : Integer;
- property Items[index : Integer] : TJSONValue read GetItem;
- procedure SetElements(aElements : TList<TJSONValue>);
- end;
- TJSONValueHelper = class helper for Data.DBXJson.TJSONValue
- public
- function ToJson : string;
- end;
- TJSONObjectHelper = class helper for Data.DBXJson.TJSONObject
- private
- function GetPair(aValue : Integer) : TJSONPair;
- public
- function Count : Integer;
- function GetValue(const aName : string) : TJSONValue;
- property Pairs[index : Integer] : TJSONPair read GetPair;
- end;
- {$ENDIF}
- {$ENDIF}
- TSerializeLevel = (slPublicProperty, slPublishedProperty);
- TRTTIJson = class
- type
- TGenericListType = (gtNone, gtList, gtObjectList);
- private
- fSerializeLevel : TSerializeLevel;
- fUseEnumNames : Boolean;
- fUseJsonCaseSense : Boolean;
- fUseBase64Stream : Boolean;
- fUseNullStringsAsEmpty : Boolean;
- fUseGUIDWithBrackets : Boolean;
- fUseGUIDLowercase : Boolean;
- fOptions : TSerializerOptions;
- function GetValue(aAddr: Pointer; aType: TRTTIType): TValue; overload;
- {$IFDEF FPC}
- function GetValue(aAddr: Pointer; aTypeInfo: PTypeInfo): TValue; overload;
- {$ENDIF}
- function IsAllowedProperty(aObject : TObject; const aPropertyName : string) : Boolean;
- //function GetPropertyValue(Instance : TObject; const PropertyName : string) : TValue;
- function GetPropertyValueFromObject(Instance : TObject; const PropertyName : string) : TValue;
- {$IFNDEF FPC}
- function GetFieldValueFromRecord(const aValue : TValue; const FieldName : string) : TValue;
- {$ENDIF}
- {$IFDEF FPC}
- procedure SetPropertyValue(Instance : TObject; aPropInfo : PPropInfo; aValue : TValue); overload;
- procedure SetPropertyValue(Instance : TObject; const PropertyName : string; aValue : TValue); overload;
- function FloatProperty(aObject : TObject; aPropInfo: PPropInfo): string;
- function GetPropType(aPropInfo: PPropInfo): PTypeInfo;
- procedure LoadSetProperty(aInstance : TObject; aPropInfo: PPropInfo; const aValue: string);
- {$ENDIF}
- {$IFNDEF FPC}
- function CreateInstance(aClass: TClass): TValue; overload;
- function CreateInstance(aType: TRttiType): TValue; overload;
- {$ENDIF}
- function GUIDToStringFormated(const aGUID : TGUID) : string;
- public
- constructor Create(aSerializeLevel : TSerializeLevel; aUseEnumNames : Boolean = True);
- destructor Destroy; override;
- property UseEnumNames : Boolean read fUseEnumNames write fUseEnumNames;
- property UseJsonCaseSense : Boolean read fUseJsonCaseSense write fUseJsonCaseSense;
- property UseBase64Stream : Boolean read fUseBase64Stream write fUseBase64Stream;
- property UseNullStringsAsEmpty : Boolean read fUseNullStringsAsEmpty write fUseNullStringsAsEmpty;
- property UseGUIDWithBrackets : Boolean read fUseGUIDWithBrackets write fUseGUIDWithBrackets;
- property UseGUIDLowercase : Boolean read fUseGUIDLowercase write fUseGUIDLowercase;
- property Options : TSerializerOptions read fOptions write fOptions;
- function GetJsonPairValueByName(aJson : TJSONObject; const aName : string) : TJsonValue;
- function GetJsonPairByName(aJson : TJSONObject; const aName : string) : TJSONPair;
- function IsGenericList(aObject : TObject) : Boolean;
- function IsStream(aObject : TObject) : Boolean;
- function IsGenericXArray(const aClassName : string) : Boolean;
- function GetGenericListType(aObject : TObject) : TGenericListType;
- //serialize methods
- function SerializeValue(const aValue : TValue) : TJSONValue;
- function SerializeObject(aObject : TObject) : TJSONObject; overload;
- function SerializeStream(aObject : TObject) : TJSONValue;
- {$IFNDEF FPC}
- function SerializeDynArray(const aValue: TValue; aMaxElements : Integer = -1) : TJsonArray;
- function SerializeRecord(const aValue : TValue) : TJSONValue;
- {$ELSE}
- function SerializeObject(aObject : TObject; aType : TTypeKind; const aPropertyName : string) : TJSONPair;
- {$ENDIF}
- //deserialize methods
- function DeserializeClass(aType : TClass; const aJson : TJSONObject) : TObject;
- function DeserializeObject(aObject : TObject; const aJson : TJSONObject) : TObject; overload;
- function DeserializeProperty(aObject : TObject; const aName : string; aProperty : TRttiProperty; const aJson : TJSONObject) : TObject; overload;
- function DeserializeStream(aObject : TObject; const aJson : TJSONValue) : TObject;
- {$IFNDEF FPC}
- function DeserializeType(aObject : TObject; aType : TTypeKind; aTypeInfo : PTypeInfo; const aValue: string) : TValue;
- function DeserializeDynArray(aTypeInfo : PTypeInfo; aObject : TObject; const aJsonArray: TJSONArray) : TValue;
- function DeserializeRecord(const aRecord : TValue; aObject : TObject; const aJson : TJSONObject) : TValue;
- function DeserializeList(aObject: TObject; const aName : string; const aJson: TJSONObject) : TObject;
- procedure DeserializeXArray(Instance : TObject; aRecord : TValue; aProperty : TRttiProperty; const aPropertyName : string; aJson : TJsonObject);
- {$ELSE}
- function DeserializeType(aObject : TObject; aType : TTypeKind; const aPropertyName, aValue: string) : TValue;
- procedure DeserializeDynArray(aTypeInfo: PTypeInfo; const aPropertyName : string; aObject: TObject; const aJsonArray: TJSONArray);
- {$ENDIF}
- end;
- TJsonSerializer = class(TInterfacedObject,IJsonSerializer)
- strict private
- fSerializeLevel : TSerializeLevel;
- fUseEnumNames : Boolean;
- fUseJsonCaseSense : Boolean;
- fUseBase64Stream : Boolean;
- fUseNullStringsAsEmpty : Boolean;
- fUseGUIDWithBrackets: Boolean;
- fUseGUIDLowercase: Boolean;
- fRTTIJson : TRTTIJson;
- private
- procedure SetUseEnumNames(const Value: Boolean);
- procedure SetUseJsonCaseSense(const Value: Boolean);
- procedure SetSerializeLevel(const Value: TSerializeLevel);
- procedure SetUseBase64Stream(const Value: Boolean);
- //Only Delphi -> Workaround, use this when something passes : {Test : "Null"} but we expect : {Test : ""}
- procedure SetUseNullStringsAsEmpty(const Value : Boolean);
- procedure SetUseGUIDLowerCase(const Value: Boolean);
- procedure SetUseGUIDWithBrackets(const Value: Boolean);
- public
- constructor Create(aSerializeLevel: TSerializeLevel; aUseEnumNames : Boolean = True; aUseNullStringsAsEmpty : Boolean = False);
- destructor Destroy; override;
- property SerializeLevel : TSerializeLevel read fSerializeLevel write SetSerializeLevel;
- property UseEnumNames : Boolean read fUseEnumNames write SetUseEnumNames;
- property UseJsonCaseSense : Boolean read fUseJsonCaseSense write SetUseJsonCaseSense;
- property UseBase64Stream : Boolean read fUseBase64Stream write SetUseBase64Stream;
- property UseNullStringsAsEmpty : Boolean read fUseNullStringsAsEmpty write SetUseNullStringsAsEmpty;
- property UseGUIDWithBrackets : Boolean read fUseGUIDWithBrackets write SetUseGUIDWithBrackets;
- property UseGUIDLowerCase : Boolean read fUseGUIDLowercase write SetUseGUIDLowerCase;
- function JsonToObject(aType : TClass; const aJson: string) : TObject; overload;
- function JsonToObject(aObject : TObject; const aJson: string) : TObject; overload;
- function JsonStreamToObject(aObject : TObject; aJsonStream : TStream) : TObject;
- function ObjectToJson(aObject : TObject; aIndent : Boolean = False): string;
- function ObjectToJsonString(aObject : TObject; aIndent : Boolean = False): string;
- procedure ObjectToJsonStream(aObject : TObject; aStream : TStream);
- function ValueToJson(const aValue : TValue; aIndent : Boolean = False) : string;
- function ValueToJsonString(const aValue : TValue; aIndent : Boolean = False) : string;
- function ArrayToJson<T>(aArray : TArray<T>; aIndent : Boolean = False) : string;
- function ArrayToJsonString<T>(aArray : TArray<T>; aIndent : Boolean = False) : string;
- {$IFNDEF FPC}
- function JsonToArray<T>(const aJson : string) : TArray<T>;
- function JsonToValue(const aJson: string): TValue;
- {$ENDIF}
- function Options : TSerializerOptions;
- end;
- EJsonSerializerError = class(Exception);
- PPByte = ^PByte;
- resourcestring
- cNotSupportedDataType = 'Not supported data type "%s"';
- cSerializeObjectError = 'Serialize object "%s" error: %s';
- cSerializePropertyError = 'Property "%s" ("%s")';
- cNotSerializable = 'Object is not serializable';
- cNotValidJson = 'Not a valid Json';
- implementation
- { TRTTIJson }
- {$IFNDEF FPC}
- function TRTTIJson.DeserializeDynArray(aTypeInfo: PTypeInfo; aObject: TObject; const aJsonArray: TJSONArray) : TValue;
- var
- rType: PTypeInfo;
- len: NativeInt;
- pArr: Pointer;
- rItemValue: TValue;
- i: Integer;
- objClass: TClass;
- ctx : TRttiContext;
- json : TJSONObject;
- rDynArray : TRttiDynamicArrayType;
- propObj : TObject;
- begin
- if GetTypeData(aTypeInfo).DynArrElType = nil then Exit;
- if not assigned(aJsonArray) then Exit;
- len := aJsonArray.Count;
- rType := GetTypeData(aTypeInfo).DynArrElType^;
- pArr := nil;
- DynArraySetLength(pArr,aTypeInfo, 1, @len);
- try
- TValue.Make(@pArr,aTypeInfo, Result);
- rDynArray := ctx.GetType(Result.TypeInfo) as TRTTIDynamicArrayType;
- for i := 0 to aJsonArray.Count - 1 do
- begin
- rItemValue := nil;
- case rType.Kind of
- tkClass :
- begin
- if aJsonArray.Items[i] is TJSONObject then
- begin
- propObj := GetValue(PPByte(Result.GetReferenceToRawData)^ +rDynArray.ElementType.TypeSize * i, rDynArray.ElementType).AsObject;
- if propObj = nil then
- begin
- objClass := rType.TypeData.ClassType;
- rItemValue := DeserializeClass(objClass, TJSONObject(aJsonArray.Items[i]));
- end
- else
- begin
- DeserializeObject(propObj,TJSONObject(aJsonArray.Items[i]));
- end;
- end;
- end;
- tkRecord :
- begin
- json := TJSONObject(aJsonArray.Items[i]);
- rItemValue := DeserializeRecord(GetValue(PPByte(Result.GetReferenceToRawData)^ +rDynArray.ElementType.TypeSize * i,
- rDynArray.ElementType),aObject,json);
- end;
- tkMethod, tkPointer, tkClassRef ,tkInterface, tkProcedure :
- begin
- //skip these properties
- end
- else
- begin
- rItemValue := DeserializeType(aObject,rType.Kind,rType,aJsonArray.Items[i].Value);
- end;
- end;
- if not rItemValue.IsEmpty then Result.SetArrayElement(i,rItemValue);
- end;
- //aProperty.SetValue(aObject,rValue);
- finally
- DynArrayClear(pArr,aTypeInfo);
- end;
- end;
- {$ELSE}
- procedure TRTTIJson.DeserializeDynArray(aTypeInfo: PTypeInfo; const aPropertyName : string; aObject: TObject; const aJsonArray: TJSONArray);
- var
- rType: PTypeInfo;
- len: NativeInt;
- pArr: Pointer;
- rItemValue: TValue;
- i: Integer;
- objClass: TClass;
- propObj : TObject;
- rValue : TValue;
- begin
- if GetTypeData(aTypeInfo).ElType2 = nil then Exit;
- len := aJsonArray.Count;
- rType := GetTypeData(aTypeInfo).ElType2;
- pArr := nil;
- DynArraySetLength(pArr,aTypeInfo, 1, @len);
- try
- TValue.Make(@pArr,aTypeInfo, rValue);
- for i := 0 to aJsonArray.Count - 1 do
- begin
- rItemValue := nil;
- case rType.Kind of
- tkClass :
- begin
- if aJsonArray.Items[i] is TJSONObject then
- begin
- propObj := GetValue(PPByte(rValue.GetReferenceToRawData)^ +GetTypeData(aTypeInfo).elSize * i, GetTypeData(aTypeInfo).ElType2).AsObject;
- if propObj = nil then
- begin
- objClass := GetTypeData(aTypeInfo).ClassType;
- rItemValue := DeserializeClass(objClass, TJSONObject(aJsonArray.Items[i]));
- end
- else
- begin
- DeserializeObject(propObj,TJSONObject(aJsonArray.Items[i]));
- end;
- end;
- end;
- tkRecord :
- begin
- {json := TJSONObject(aJsonArray.Items[i]);
- rItemValue := DeserializeRecord(GetValue(PPByte(Result.GetReferenceToRawData)^ +rDynArray.ElementType.TypeSize * i,
- rDynArray.ElementType),aObject,json); }
- end;
- tkMethod, tkPointer, tkClassRef ,tkInterface, tkProcedure :
- begin
- //skip these properties
- end
- else
- begin
- rItemValue := DeserializeType(aObject,GetTypeData(aTypeInfo).ElType2.Kind,aPropertyName,aJsonArray.Items[i].Value);
- end;
- end;
- if not rItemValue.IsEmpty then rValue.SetArrayElement(i,rItemValue);
- end;
- //aProperty.SetValue(aObject,rValue);
- SetDynArrayProp(aObject,GetPropInfo(aObject,aPropertyName),pArr);
- finally
- DynArrayClear(pArr,aTypeInfo);
- end;
- end;
- {$ENDIF}
- {$IFNDEF FPC}
- function TRTTIJson.DeserializeRecord(const aRecord : TValue; aObject : TObject; const aJson : TJSONObject) : TValue;
- var
- ctx : TRttiContext;
- rRec : TRttiRecordType;
- rField : TRttiField;
- rValue : TValue;
- member : TJsonValue;
- jArray : TJSONArray;
- json : TJSONObject;
- objClass : TClass;
- propobj : TObject;
- begin
- rRec := ctx.GetType(aRecord.TypeInfo).AsRecord;
- for rField in rRec.GetFields do
- begin
- rValue := nil;
- //member := TJSONPair(aJson.GetValue(rField.Name));
- member := GetJsonPairValueByName(aJson,rField.Name);
- if member <> nil then
- case rField.FieldType.TypeKind of
- tkDynArray :
- begin
- jArray := TJSONObject.ParseJSONValue(member.ToJSON) as TJSONArray;
- try
- rValue := DeserializeDynArray(rField.FieldType.Handle,aObject,jArray);
- finally
- jArray.Free;
- end;
- end;
- tkClass :
- begin
- //if (member.JsonValue is TJSONObject) then
- begin
- propobj := rField.GetValue(@aRecord).AsObject;
- json := TJSONObject.ParseJSONValue(member.ToJson) as TJSONObject;
- try
- if propobj = nil then
- begin
- objClass := rField.FieldType.Handle^.TypeData.ClassType;// aProperty.PropertyType.Handle^.TypeData.ClassType;
- rValue := DeserializeClass(objClass,json);
- end
- else
- begin
- DeserializeObject(propobj,json);
- end;
- finally
- json.Free;
- end;
- end
- end;
- tkRecord :
- begin
- json := TJSONObject.ParseJSONValue(member.ToJson) as TJSONObject;
- try
- rValue := DeserializeRecord(rField.GetValue(aRecord.GetReferenceToRawData),aObject,json);
- finally
- json.Free;
- end;
- end
- else
- begin
- //rValue := DeserializeType(aObject,rField.FieldType.TypeKind,rField.FieldType.Handle,member.ToJson);
- //avoid return unicode escaped chars if string
- if rField.FieldType.TypeKind in [tkString, tkLString, tkWString, tkUString] then
- {$IFDEF DELPHIRX10_UP}
- rValue := DeserializeType(aObject,rField.FieldType.TypeKind,rField.FieldType.Handle,TJsonValue(member).value)
- {$ELSE}
- rValue := DeserializeType(aObject,rField.FieldType.TypeKind,rField.FieldType.Handle,member.Value)
- {$ENDIF}
- else rValue := DeserializeType(aObject,rField.FieldType.TypeKind,rField.FieldType.Handle,member.ToJSON);
- end;
- end;
- if not rValue.IsEmpty then rField.SetValue(aRecord.GetReferenceToRawData,rValue);
- end;
- Result := aRecord;
- end;
- {$ENDIF}
- function TRTTIJson.DeserializeStream(aObject: TObject; const aJson: TJSONValue): TObject;
- var
- stream : TStringStream;
- begin
- if fOptions.UseBase64Stream then stream := TStringStream.Create(Base64Decode(aJson.Value),TEncoding.Ansi)
- else stream := TStringStream.Create({$IFNDEF FPC}aJson.Value{$ELSE}string(aJson.Value){$ENDIF},TEncoding.Ansi);
- try
- TStream(aObject).CopyFrom(stream,stream.Size);
- finally
- stream.Free;
- end;
- Result := aObject;
- end;
- constructor TRTTIJson.Create(aSerializeLevel : TSerializeLevel; aUseEnumNames : Boolean = True);
- begin
- fOptions := TSerializerOptions.Create;
- fSerializeLevel := aSerializeLevel;
- fUseEnumNames := aUseEnumNames;
- fUseJsonCaseSense := False;
- fUseBase64Stream := True;
- fUseGUIDWithBrackets := False;
- fUseGUIDLowerCase := True;
- fOptions.UseEnumNames := aUseEnumNames;
- fOptions.UseJsonCaseSense := False;
- fOptions.UseBase64Stream := True;
- fOptions.UseGUIDLowercase := False;
- fOptions.UseGUIDLowercase := True;
- end;
- destructor TRTTIJson.Destroy;
- begin
- fOptions.Free;
- inherited;
- end;
- {$IFNDEF FPC}
- function TRTTIJson.CreateInstance(aClass: TClass): TValue;
- var
- ctx : TRttiContext;
- rtype : TRttiType;
- begin
- Result := nil;
- rtype := ctx.GetType(aClass);
- Result := CreateInstance(rtype);
- end;
- {$ENDIF}
- {$IFNDEF FPC}
- function TRTTIJson.CreateInstance(aType: TRttiType): TValue;
- var
- rmethod : TRttiMethod;
- begin
- Result := nil;
- if atype = nil then Exit;
- for rmethod in TRttiInstanceType(atype).GetMethods do
- begin
- if rmethod.IsConstructor then
- begin
- //create if don't have parameters
- if Length(rmethod.GetParameters) = 0 then
- begin
- Result := rmethod.Invoke(TRttiInstanceType(atype).MetaclassType,[]);
- Break;
- end;
- end;
- end;
- end;
- {$ENDIF}
- function TRTTIJson.DeserializeClass(aType: TClass; const aJson: TJSONObject): TObject;
- begin
- Result := nil;
- if (aJson = nil) or ((aJson as TJSONValue) is TJSONNull) or (aJson.Count = 0) then Exit;
- {$IFNDEF FPC}
- Result := CreateInstance(aType).AsObject;
- {$ELSE}
- Result := aType.Create;
- {$ENDIF}
- try
- Result := DeserializeObject(Result,aJson);
- except
- on E : Exception do
- begin
- Result.Free;
- raise EJsonDeserializeError.CreateFmt('Deserialize error class "%s" : %s',[aType.ClassName,e.Message]);
- end;
- end;
- end;
- function TRTTIJson.DeserializeObject(aObject: TObject; const aJson: TJSONObject): TObject;
- var
- ctx: TRttiContext;
- rType: TRttiType;
- rProp: TRttiProperty;
- {$IFNDEF FPC}
- attr: TCustomAttribute;
- propvalue : TValue;
- {$ENDIF}
- propertyname : string;
- begin
- Result := aObject;
- if (aJson = nil) or ((aJson as TJSONValue) is TJSONNull) or (aJson.Count = 0) or (Result = nil) then Exit;
- try
- //if generic list
- {$IFNDEF FPC}
- if IsGenericList(aObject) then
- begin
- DeserializeList(aObject,'List',aJson);
- Exit;
- end
- else
- {$ENDIF}
- if IsStream(aObject) then
- begin
- DeserializeStream(aObject,aJson);
- Exit;
- end;
- //if standard object
- rType := ctx.GetType(aObject.ClassInfo);
- for rProp in rType.GetProperties do
- begin
- {$IFNDEF FPC}
- if ((fSerializeLevel = slPublicProperty) and (rProp.PropertyType.IsPublicType))
- or ((fSerializeLevel = slPublishedProperty) and ((IsPublishedProp(aObject,rProp.Name)) or (rProp.Name = 'List'))) then
- {$ENDIF}
- begin
- if ((rProp.IsWritable) or (rProp.Name = 'List')) and (IsAllowedProperty(aObject,rProp.Name)) then
- begin
- propertyname := rProp.Name;
- {$IFNDEF FPC}
- for attr in rProp.GetAttributes do if attr is TCustomNameProperty then propertyname := TCustomNameProperty(attr).Name;
- propvalue := rProp.GetValue(aObject);
- if rProp.Name = 'List' then
- begin
- Result := DeserializeList(Result,propertyname,aJson);
- end
- else if propvalue.IsObject then
- begin
- if propvalue.AsObject = nil then
- begin
- propvalue := CreateInstance(rProp.PropertyType);
- rProp.SetValue(aObject,propvalue);
- end;
- if IsGenericList(propvalue.AsObject) then DeserializeList(propvalue.AsObject,'List',TJSONObject(aJson.GetValue(propertyname)))
- else Result := DeserializeProperty(Result,propertyname,rProp,aJson);
- end
- else if IsGenericXArray(string(propvalue{$IFNDEF NEXTGEN}.TypeInfo.Name{$ELSE}.TypeInfo.NameFld.ToString{$ENDIF})) then
- begin
- DeserializeXArray(Result,propvalue,rProp,propertyname,aJson);
- end
- else
- {$ENDIF}
- Result := DeserializeProperty(Result,propertyname,rProp,aJson);
- end;
- end;
- end;
- except
- on E : Exception do
- begin
- Result.Free;
- raise EJsonDeserializeError.CreateFmt('Deserialize error for object "%s" : %s',[aObject.ClassName,e.Message]);
- end;
- end;
- end;
- {$IFNDEF FPC}
- function TRTTIJson.DeserializeList(aObject: TObject; const aName : string; const aJson: TJSONObject) : TObject;
- var
- ctx : TRttiContext;
- rType : TRttiType;
- jarray : TJSONArray;
- member : TJsonValue;
- rvalue : TValue;
- i : Integer;
- n : Integer;
- rProp : TRttiProperty;
- {$IFDEF DELPHIRX10_UP}
- rMethod: TRttiMethod;
- {$ELSE}
- rfield : TRttiField;
- {$ENDIF}
- begin
- Result := aObject;
- rType := ctx.GetType(aObject.ClassInfo);
- rProp := rType.GetProperty('List');
- if (rProp = nil) or (aJson = nil) or (aJson.ClassType = TJSONNull) then Exit;
- member := nil;
- //check if exists List (denotes delphi json serialized) or not (normal json serialized)
- if aJson.ClassType = TJSONObject then member := GetJsonPairValueByName(aJson,aName);
- if member = nil then
- begin
- if aJson.ClassType <> TJSONArray then raise EJsonDeserializeError.CreateFmt('Not valid value for "%s" List',[aName]);
- jArray := TJSONObject.ParseJSONValue(aJson.ToJSON) as TJSONArray;
- end
- else
- begin
- if member.ClassType <> TJSONArray then raise EJsonDeserializeError.CreateFmt('Not valid value for "%s" List',[aName]);
- jArray := TJSONObject.ParseJSONValue(member.ToJSON) as TJSONArray;
- end;
- try
- rvalue := DeserializeDynArray(rProp.PropertyType.Handle,Result,jArray);
- //i := jarray.Count;
- finally
- jArray.Free;
- end;
- if not rValue.IsEmpty then
- begin
- {$IFDEF DELPHIRX10_UP}
- if (aObject <> nil) and (rvalue.IsArray) then
- begin
- rMethod := ctx.GetType(aObject.ClassType).GetMethod('Clear');
- if rMethod = nil then
- raise EJsonDeserializeError.Create('Unable to find RTTI method');
- rMethod.Invoke(aObject, []);
- rMethod := ctx.GetType(aObject.ClassType).GetMethod('Add');
- if rMethod = nil then
- raise EJsonDeserializeError.Create('Unable to find RTTI method');
- n := rvalue.GetArrayLength - 1;
- for i := 0 to n do
- rMethod.Invoke(aObject, [rvalue.GetArrayElement(i)]);
- end;
- {$ELSE}
- n := 0;
- for rfield in rType.GetFields do
- begin
- if rfield.Name = 'FOwnsObjects' then rfield.SetValue(aObject,True);
- //if rfield.Name = 'FCount' then rfield.SetValue(aObject,i);
- if rfield.Name = 'FItems' then
- begin
- //if TList(aObject) <> nil then TList(aObject).Clear;
- //rfield.GetValue(aObject).AsObject.Free;// aValue.GetReferenceToRawData)
- rfield.SetValue(aObject,rValue);// .SetDynArrayProp(aObject,'fItems',Result);
- Break;
- end;
- end;
- rProp := rType.GetProperty('Count');
- rProp.SetValue(aObject,n);
- {$ENDIF}
- end;
- end;
- {$ENDIF}
- {$IFNDEF FPC}
- procedure TRTTIJson.DeserializeXArray(Instance : TObject; aRecord : TValue; aProperty : TRttiProperty; const aPropertyName : string; aJson : TJsonObject);
- var
- ctx : TRttiContext;
- rRec : TRttiRecordType;
- rfield : TRttiField;
- rValue : TValue;
- member : TJsonValue;
- jArray : TJSONArray;
- begin
- rRec := ctx.GetType(aRecord.TypeInfo).AsRecord;
- rfield := rRec.GetField('fArray');
- if rfield <> nil then
- begin
- rValue := nil;
- //member := TJSONPair(aJson.GetValue(rField.Name));
- member := GetJsonPairValueByName(aJson,aPropertyName);
- if (member <> nil) and (rField.FieldType.TypeKind = tkDynArray) then
- begin
- jArray := TJSONObject.ParseJSONValue(member.ToJSON) as TJSONArray;
- try
- rValue := DeserializeDynArray(rField.FieldType.Handle,nil,jArray);
- finally
- jArray.Free;
- end;
- end;
- end;
- if not rValue.IsEmpty then rField.SetValue(aRecord.GetReferenceToRawData,rValue);
- aProperty.SetValue(Instance,aRecord);
- end;
- {$ENDIF}
- function StringToGUIDEx(const aGUID : string) : TGUID;
- begin
- if not aGUID.StartsWith('{') then Result := System.SysUtils.StringToGUID('{' + aGUID + '}')
- else Result := System.SysUtils.StringToGUID(aGUID);
- end;
- function TRTTIJson.GUIDToStringFormated(const aGUID : TGUID) : string;
- begin
- if fOptions.UseGUIDWithBrackets then Result := System.SysUtils.GUIDToString(aGUID)
- else Result := GetSubString(System.SysUtils.GUIDToString(aGUID),'{','}');
- if fOptions.UseGUIDLowercase then Result := Result.ToLower;
- end;
- function TRTTIJson.DeserializeProperty(aObject : TObject; const aName : string; aProperty : TRttiProperty; const aJson : TJSONObject) : TObject;
- var
- rValue : TValue;
- {$IFNDEF FPC}
- member : TJsonValue;
- {$ELSE}
- member : TJsonObject;
- {$ENDIF}
- objClass: TClass;
- jArray : TJSONArray;
- json : TJSONObject;
- begin
- Result := aObject;
- rValue := nil;
- {$IFNDEF FPC}
- //member := TJSONPair(aJson.GetValue(aName));
- member := GetJsonPairValueByName(aJson,aName);
- {$ELSE}
- member := TJsonObject(aJson.Find(aName));
- {$ENDIF}
- if member <> nil then
- begin
- case aProperty.PropertyType.TypeKind of
- tkDynArray :
- begin
- {$IFNDEF FPC}
- if member is TJSONNull then Exit;
- jArray := TJSONObject.ParseJSONValue(member.ToJSON) as TJSONArray;
- {$ELSE}
- if member.ClassType = TJSONNull.ClassType then Exit;
- jArray := TJSONArray(TJSONObject.ParseJSONValue(member.ToJSON));
- {$ENDIF}
- try
- {$IFNDEF FPC}
- aProperty.SetValue(aObject,DeserializeDynArray(aProperty.PropertyType.Handle,Result,jArray));
- {$ELSE}
- DeserializeDynArray(aProperty.PropertyType.Handle,aName,Result,jArray);
- {$ENDIF}
- Exit;
- finally
- jArray.Free;
- end;
- end;
- tkClass :
- begin
- //if (member.JsonValue is TJSONObject) then
- begin
- json := TJsonObject(TJSONObject.ParseJSONValue(member.ToJson));
- try
- if aProperty.GetValue(aObject).AsObject = nil then
- begin
- {$IFNDEF FPC}
- objClass := aProperty.PropertyType.Handle^.TypeData.ClassType;
- rValue := DeserializeClass(objClass,json);
- {$ELSE}
- objClass := GetObjectPropClass(aObject,aName);
- //objClass := GetTypeData(aProperty.PropertyType.Handle)^.ClassType;
- rValue := DeserializeClass(objClass,json);
- SetObjectProp(aObject,aName,rValue.AsObject);
- Exit;
- {$ENDIF}
- end
- else
- begin
- rValue := DeserializeObject(aProperty.GetValue(aObject).AsObject,json);
- Exit;
- end;
- finally
- json.Free;
- end;
- end
- end;
- {$IFNDEF FPC}
- tkRecord :
- begin
- if aProperty.GetValue(aObject).TypeInfo = System.TypeInfo(TGUID) then
- begin
- //get value from TGUID string with and without {} (more compatibility)
- rValue:=TValue.From<TGUID>(StringToGUIDEx(UnQuotedStr(member.ToJSON,'"')));
- end
- else
- begin
- json := TJSONObject.ParseJSONValue(member.ToJson) as TJSONObject;
- try
- rValue := DeserializeRecord(aProperty.GetValue(aObject),aObject,json);
- finally
- json.Free;
- end;
- end;
- end;
- {$ENDIF}
- else
- begin
- {$IFNDEF FPC}
- //avoid return unicode escaped chars if string
- if aProperty.PropertyType.TypeKind in [tkString, tkLString, tkWString, tkUString] then
- {$IFDEF DELPHIRX10_UP}
- rValue := DeserializeType(aObject,aProperty.PropertyType.TypeKind,aProperty.GetValue(aObject).TypeInfo,TJsonValue(member).value)
- {$ELSE}
- rValue := DeserializeType(aObject,aProperty.PropertyType.TypeKind,aProperty.GetValue(aObject).TypeInfo,member.Value)
- {$ENDIF}
- else rValue := DeserializeType(aObject,aProperty.PropertyType.TypeKind,aProperty.GetValue(aObject).TypeInfo,member.ToJSON);
- {$ELSE}
- rValue := DeserializeType(aObject,aProperty.PropertyType.TypeKind,aName,member.ToJSON);
- if not rValue.IsEmpty then SetPropertyValue(aObject,aName,rValue);
- {$ENDIF}
- end;
- end;
- {$IFNDEF FPC}
- if not rValue.IsEmpty then aProperty.SetValue(Result,rValue);
- {$ENDIF}
- end;
- end;
- {$IFNDEF FPC}
- function TRTTIJson.DeserializeType(aObject : TObject; aType : TTypeKind; aTypeInfo : PTypeInfo; const aValue: string) : TValue;
- var
- i : Integer;
- value : string;
- fsettings : TFormatSettings;
- begin
- try
- value := UnQuotedStr(aValue,'"');
- case aType of
- tkString, tkLString, tkWString, tkUString :
- begin
- if fOptions.UseNullStringsAsEmpty and (CompareText(value, 'null') = 0) then
- Result := ''
- else
- Result := value;
- end;
- tkChar, tkWChar :
- begin
- Result := value;
- end;
- tkInteger :
- begin
- if CompareText(value,'null') <> 0 then Result := StrToIntDef(value,0)
- else Result := 0;
- end;
- tkInt64 :
- begin
- if CompareText(value,'null') <> 0 then Result := StrToInt64Def(value,0)
- else Result := 0;
- end;
- tkFloat :
- begin
- if aTypeInfo = TypeInfo(TDateTime) then
- begin
- if CompareText(value,'null') <> 0 then Result := JsonDateToDateTime(value);
- end
- else if aTypeInfo = TypeInfo(TDate) then
- begin
- if CompareText(value,'null') <> 0 then Result := StrToDate(value);
- end
- else if aTypeInfo = TypeInfo(TTime) then
- begin
- Result := StrToTime(value);
- end
- else
- begin
- fsettings := TFormatSettings.Create;
- Result := StrToFloat(StringReplace(value,'.',fsettings.DecimalSeparator,[]));
- end;
- end;
- tkEnumeration :
- begin
- if aTypeInfo = System.TypeInfo(Boolean) then
- begin
- Result := StrToBool(value);
- end
- else
- begin
- //if fUseEnumNames then TValue.Make(GetEnumValue(aTypeInfo,value),aTypeInfo, Result)
- // else TValue.Make(StrToInt(value),aTypeInfo, Result);
- if not TryStrToInt(value,i) then TValue.Make(GetEnumValue(aTypeInfo,value),aTypeInfo, Result)
- else TValue.Make(StrToInt(value),aTypeInfo, Result);
- end;
- end;
- tkSet :
- begin
- i := StringToSet(aTypeInfo,value);
- TValue.Make(@i,aTypeInfo,Result);
- end;
- else
- begin
- //raise EclJsonSerializerError.Create('Not supported data type!');
- end;
- end;
- except
- on E : Exception do
- begin
- raise EJsonDeserializeError.CreateFmt('Deserialize error type "%s.%s" : %s',[aObject.ClassName,GetTypeName(aTypeInfo),e.Message]);
- end;
- end;
- end;
- {$ELSE}
- function TRTTIJson.DeserializeType(aObject : TObject; aType : TTypeKind; const aPropertyName, aValue: string) : TValue;
- var
- value : string;
- propinfo : PPropInfo;
- fsettings : TFormatSettings;
- begin
- try
- value := UnQuotedStr(aValue,'"');
- if value = '' then
- begin
- Result := nil;
- Exit;
- end;
- propinfo := GetPropInfo(aObject,aPropertyName);
- //case propinfo.PropType.Kind of
- case aType of
- tkString, tkLString, tkWString, tkUString, tkAString :
- begin
- Result := value;
- //SetStrProp(aObject,propinfo,value);
- end;
- tkChar, tkWChar :
- begin
- Result := value;
- end;
- tkInteger :
- begin
- if CompareText(value,'null') <> 0 then Result := StrToInt(value)
- else Result := 0;
- end;
- tkInt64 :
- begin
- if CompareText(value,'null') <> 0 then Result := StrToInt64(value)
- else Result := 0;
- end;
- tkFloat :
- begin
- if propinfo.PropType = TypeInfo(TDateTime) then
- begin
- if CompareText(value,'null') <> 0 then Result := JsonDateToDateTime(value);
- end
- else if propinfo.PropType = TypeInfo(TDate) then
- begin
- if CompareText(value,'null') <> 0 then Result := StrToDate(value);
- end
- else if propinfo.PropType = TypeInfo(TTime) then
- begin
- Result := StrToTime(value);
- end
- else
- begin
- fsettings := DefaultFormatSettings;
- Result := StrToFloat(StringReplace(value,'.',fsettings.DecimalSeparator,[]));
- end;
- end;
- tkEnumeration:
- begin
- Result := value;
- end;
- tkBool :
- begin
- Result := StrToBool(value);
- end;
- tkSet :
- begin
- Result := value;
- end;
- else
- begin
- //raise EclJsonSerializerError.Create('Not supported data type!');
- end;
- end;
- //if not Result.IsEmpty then SetPropertyValue(aObject,propinfo,Result);
- except
- on E : Exception do
- begin
- raise EJsonDeserializeError.CreateFmt('Deserialize error type "%s" : %s',[aObject.ClassName,e.Message]);
- end;
- end;
- end;
- {$ENDIF}
- function TRTTIJson.IsAllowedProperty(aObject : TObject; const aPropertyName : string) : Boolean;
- var
- propname : string;
- begin
- Result := True;
- propname := aPropertyName.ToLower;
- if IsGenericList(aObject) then
- begin
- if (propname = 'capacity') or (propname = 'count') or (propname = 'ownsobjects') then Result := False;
- end
- else if (propname = 'refcount') then Result := False;
- end;
- function TRTTIJson.IsGenericList(aObject : TObject) : Boolean;
- var
- cname : string;
- begin
- if aObject = nil then Exit(False);
- cname := aObject.ClassName;
- Result := (cname.StartsWith('TObjectList')) or (cname.StartsWith('TList'));
- end;
- function TRTTIJson.IsStream(aObject : TObject) : Boolean;
- begin
- if aObject = nil then Exit(False);
- Result := aObject.InheritsFrom(TStream);
- end;
- function TRTTIJson.GetGenericListType(aObject : TObject) : TGenericListType;
- var
- cname : string;
- begin
- if aObject = nil then Exit(TGenericListType.gtNone);
- cname := aObject.ClassName;
- if cname.StartsWith('TObjectList') then Result := TGenericListType.gtObjectList
- else if cname.StartsWith('TList') then Result := TGenericListType.gtList
- else Result := TGenericListType.gtNone;
- end;
- function TRTTIJson.IsGenericXArray(const aClassName : string) : Boolean;
- begin
- Result := aClassName.StartsWith('TXArray');
- end;
- function TRTTIJson.GetJsonPairValueByName(aJson: TJSONObject; const aName: string): TJsonValue;
- var
- candidate : TJSONPair;
- i : Integer;
- begin
- if fOptions.UseJsonCaseSense then
- begin
- Result := aJson.GetValue(aName);
- Exit;
- end
- else
- begin
- for i := 0 to aJson.Count - 1 do
- begin
- candidate := aJson.Pairs[I];
- if candidate.JsonValue = nil then continue;
- if CompareText(candidate.JsonString{$IFNDEF FPC}.Value{$ENDIF},aName) = 0 then Exit(candidate.JsonValue);
- end;
- end;
- Result := nil;
- end;
- function TRTTIJson.GetJsonPairByName(aJson: TJSONObject; const aName: string): TJSONPair;
- var
- i : Integer;
- begin
- if fOptions.UseJsonCaseSense then
- begin
- Result := TJSONPair(aJson.GetValue(aName));
- Exit;
- end
- else
- begin
- if aJson <> nil then
- begin
- for i := 0 to aJson.Count - 1 do
- begin
- Result := aJson.Pairs[I];
- if Result.JsonValue = nil then continue;
- if CompareText(Result.JsonString{$IFNDEF FPC}.Value{$ENDIF},aName) = 0 then Exit;
- end;
- end;
- end;
- Result := nil;
- end;
- //function TRTTIJson.GetPropertyValue(Instance : TObject; const PropertyName : string) : TValue;
- //var
- // pinfo : PPropInfo;
- //begin
- // Result := nil;
- // pinfo := GetPropInfo(Instance,PropertyName);
- // if pinfo = nil then raise EJsonSerializeError.CreateFmt('Property "%s" not found!',[PropertyName]);
- // case pinfo.PropType^.Kind of
- // tkInteger : Result := GetOrdProp(Instance,pinfo);
- // tkInt64 : Result := GetInt64Prop(Instance,PropertyName);
- // tkFloat : Result := GetFloatProp(Instance,PropertyName);
- // tkChar : Result := Char(GetOrdProp(Instance,PropertyName));
- // {$IFDEF FPC}
- // tkWString : Result := GetWideStrProp(Instance,PropertyName);
- // tkSString,
- // tkAString,
- // {$ELSE}
- // tkWString,
- // {$ENDIF}
- // tkLString : Result := GetStrProp(Instance,pinfo);
- // {$IFDEF FPC}
- // tkEnumeration :
- // begin
- // if fUseEnumNames then Result := GetEnumName(pinfo.PropType,GetOrdProp(Instance,PropertyName))
- // else Result := GetOrdProp(Instance,PropertyName);
- // end;
- // {$ELSE}
- // tkEnumeration :
- // begin
- // if fUseEnumNames then Result := GetEnumName(@pinfo.PropType,GetOrdProp(Instance,PropertyName))
- // else Result := GetOrdProp(Instance,PropertyName);
- // end;
- // {$ENDIF}
- // tkSet : Result := GetSetProp(Instance,pinfo,True);
- // {$IFNDEF FPC}
- // tkClass :
- // {$ELSE}
- // tkBool : Result := Boolean(GetOrdProp(Instance,pinfo));
- // tkObject :
- // {$ENDIF} Result := GetObjectProp(Instance,pinfo);
- // tkDynArray : Result := GetDynArrayProp(Instance,pinfo);
- // end;
- //end;
- function TRTTIJson.GetPropertyValueFromObject(Instance : TObject; const PropertyName : string) : TValue;
- var
- ctx : TRttiContext;
- rprop : TRttiProperty;
- begin
- rprop := ctx.GetType(Instance.ClassInfo).GetProperty(PropertyName);
- Result := rprop.GetValue(Instance);
- end;
- {$IFNDEF FPC}
- function TRTTIJson.GetFieldValueFromRecord(const aValue : TValue; const FieldName : string) : TValue;
- var
- ctx : TRttiContext;
- rec : TRttiRecordType;
- rfield : TRttiField;
- begin
- rec := ctx.GetType(aValue.TypeInfo).AsRecord;
- rfield := rec.GetField(FieldName);
- if rfield <> nil then Result := rField.GetValue(aValue.GetReferenceToRawData)
- else Result := nil;
- end;
- {$ENDIF}
- {$IFDEF FPC}
- procedure TRTTIJson.SetPropertyValue(Instance : TObject; const PropertyName : string; aValue : TValue);
- var
- pinfo : PPropInfo;
- begin
- pinfo := GetPropInfo(Instance,PropertyName);
- SetPropertyValue(Instance,pinfo,aValue);
- end;
- procedure TRTTIJson.SetPropertyValue(Instance : TObject; aPropInfo : PPropInfo; aValue : TValue);
- begin
- case aPropInfo.PropType^.Kind of
- tkInteger : SetOrdProp(Instance,aPropInfo,aValue.AsInteger);
- tkInt64 : SetInt64Prop(Instance,aPropInfo,aValue.AsInt64);
- tkFloat : SetFloatProp(Instance,aPropInfo,aValue.AsExtended);
- tkChar : SetOrdProp(Instance,aPropInfo,aValue.AsOrdinal);
- {$IFDEF FPC}
- tkWString : SetWideStrProp(Instance,aPropInfo,aValue.AsString);
- tkSString,
- tkAString,
- {$ELSE}
- tkWString,
- {$ENDIF}
- tkLString : SetStrProp(Instance,aPropInfo,aValue.AsString);
- {$IFDEF FPC}
- tkBool : SetOrdProp(Instance,aPropInfo,aValue.AsOrdinal);
- tkSet : LoadSetProperty(Instance,aPropInfo,aValue.AsString);
- {$ENDIF}
- tkEnumeration : SetEnumProp(Instance,aPropInfo,aValue.AsString);
- {$IFNDEF FPC}
- tkClass :
- {$ELSE}
- tkObject :
- {$ENDIF} SetObjectProp(Instance,aPropInfo,aValue.AsObject);
- end;
- end;
- procedure TRTTIJson.LoadSetProperty(aInstance : TObject; aPropInfo: PPropInfo; const aValue: string);
- type
- TCardinalSet = set of 0..SizeOf(Cardinal) * 8 - 1;
- const
- Delims = [' ', ',', '[', ']'];
- var
- TypeInfo: PTypeInfo;
- W: Cardinal;
- I, N: Integer;
- Count: Integer;
- EnumName: string;
- begin
- W := 0;
- TypeInfo := GetTypeData(GetPropType(aPropInfo))^.CompType;
- Count := WordCount(aValue, Delims);
- for N := 1 to Count do
- begin
- EnumName := ExtractWord(N, aValue, Delims);
- try
- I := GetEnumValue(TypeInfo, EnumName);
- if I >= 0 then Include(TCardinalSet(W),I);
- except
- end;
- end;
- SetOrdProp(aInstance,aPropInfo,W);
- end;
- {$ENDIF}
- function TRTTIJson.SerializeObject(aObject: TObject): TJSONObject;
- var
- ctx: TRttiContext;
- {$IFNDEF FPC}
- attr : TCustomAttribute;
- comment : string;
- {$ENDIF}
- rType: TRttiType;
- rProp: TRttiProperty;
- jpair : TJSONPair;
- ExcludeSerialize : Boolean;
- propertyname : string;
- propvalue : TValue;
- begin
- if (aObject = nil) then
- begin
- Result := nil;
- Exit;
- end;
- Result := nil;
- try
- //if is GenericList
- if IsGenericList(aObject) then
- begin
- //get list array
- propvalue := GetPropertyValueFromObject(aObject,'List');
- {$IFDEF DELPHIRX10_UP}
- Result := TJSONObject(SerializeDynArray(propvalue));
- {$ELSE}
- Result := TJSONObject(SerializeValue(propvalue));
- {$ENDIF}
- Exit;
- end
- {$IFNDEF FPC}
- else if IsStream(aObject) then
- begin
- Result := TJSONObject(SerializeStream(aObject));
- Exit;
- end
- {$ENDIF}
- else Result := TJSONObject.Create;
- //if is standard object
- propertyname := '';
- rType := ctx.GetType(aObject.ClassInfo);
- for rProp in TRTTI.GetProperties(rType,roFirstBase) do
- begin
- ExcludeSerialize := False;
- propertyname := rProp.Name;
- {$IFNDEF FPC}
- comment := '';
- if not rProp.IsReadable then Continue;
- for attr in rProp.GetAttributes do
- begin
- if attr is TNotSerializableProperty then ExcludeSerialize := True
- else if attr is TCommentProperty then comment := TCommentProperty(attr).Comment
- else if attr is TCustomNameProperty then propertyname := TCustomNameProperty(attr).Name;
- end;
- if ((fSerializeLevel = slPublicProperty) and (rProp.PropertyType.IsPublicType))
- or ((fSerializeLevel = slPublishedProperty) and ((IsPublishedProp(aObject,rProp.Name)) or (rProp.Name = 'List'))) then
- {$ENDIF}
- begin
- if (IsAllowedProperty(aObject,propertyname)) and (not ExcludeSerialize) then
- begin
- //add comment as pair
- {$IFNDEF FPC}
- if comment <> '' then Result.AddPair(TJSONPair.Create('#Comment#->'+propertyname,Comment));
- {$ENDIF}
- begin
- propvalue := rProp.GetValue(aObject);
- jpair := TJSONPair.Create(propertyName,nil);
- // if (propvalue.IsObject) and (IsGenericList(propvalue.AsObject)) then
- // begin
- // jpair.JsonValue := SerializeValue(GetPropertyValueFromObject(propvalue.AsObject,'List'));
- // end
- if propvalue.IsObject then jpair.JsonValue := SerializeObject(propvalue.AsObject)
- {$IFNDEF FPC}
- else if (not propvalue.IsObject) and (IsGenericXArray(string(propvalue{$IFNDEF NEXTGEN}.TypeInfo.Name{$ELSE}.TypeInfo.NameFld.ToString{$ENDIF}))) then
- begin
- jpair.JsonValue := SerializeValue(GetFieldValueFromRecord(propvalue,'fArray'));
- end
- {$ENDIF}
- else
- begin
- {$IFNDEF FPC}
- jpair.JsonValue := SerializeValue(propvalue);
- {$ELSE}
- jpair.JsonValue := SerializeValue(propvalue);// SerializeObject(aObject,rProp.PropertyType.TypeKind,propertyname);
- {$ENDIF}
- end;
- //s := jpair.JsonValue.ToString;
- if jpair.JsonValue <> nil then
- begin
- Result.AddPair(jpair);
- end
- else jpair.Free;
- end;
- end;
- end;
- end;
- except
- on E : Exception do
- begin
- if Result <> nil then Result.Free;
- if not propertyname.IsEmpty then raise EJsonSerializeError.CreateFmt('Serialize Error -> Object property: "%s" (%s)',[propertyname,e.Message])
- else raise EJsonSerializeError.CreateFmt('Serialize Error -> Object (%s)',[e.Message]);
- end;
- end;
- end;
- function TRTTIJson.GetValue(aAddr: Pointer; aType: TRTTIType): TValue;
- begin
- TValue.Make(aAddr,aType.Handle,Result);
- end;
- {$IFDEF FPC}
- function TRTTIJson.GetValue(aAddr: Pointer; aTypeInfo: PTypeInfo): TValue;
- begin
- TValue.Make(aAddr,aTypeInfo,Result);
- end;
- {$ENDIF}
- function TRTTIJson.SerializeValue(const aValue : TValue) : TJSONValue;
- begin
- Result := nil;
- case avalue.Kind of
- tkDynArray :
- begin
- {$IFNDEF FPC}
- Result := SerializeDynArray(aValue);
- {$ENDIF}
- end;
- tkClass :
- begin
- Result := TJSONValue(SerializeObject(aValue.AsObject));
- end;
- tkInterface :
- begin
- {$IFDEF DELPHIRX10_UP}
- // Would not work with iOS/Android native interfaces
- Result := TJSONValue(SerializeObject(aValue.AsInterface as TObject));
- {$ENDIF}
- end;
- tkString, tkLString, tkWString, tkUString :
- begin
- Result := TJSONString.Create(aValue.AsString);
- end;
- tkChar, tkWChar :
- begin
- Result := TJSONString.Create(aValue.AsString);
- end;
- tkInteger :
- begin
- Result := TJSONNumber.Create(aValue.AsInteger);
- end;
- tkInt64 :
- begin
- Result := TJSONNumber.Create(aValue.AsInt64);
- end;
- tkFloat :
- begin
- if aValue.TypeInfo = TypeInfo(TDateTime) then
- begin
- if aValue.AsExtended <> 0.0 then Result := TJSONString.Create(DateTimeToJsonDate(aValue.AsExtended));
- end
- else if aValue.TypeInfo = TypeInfo(TDate) then
- begin
- if aValue.AsExtended <> 0.0 then Result := TJSONString.Create(DateToStr(aValue.AsExtended));
- end
- else if aValue.TypeInfo = TypeInfo(TTime) then
- begin
- Result := TJSONString.Create(TimeToStr(aValue.AsExtended));
- end
- else
- begin
- Result := TJSONNumber.Create(aValue.AsExtended);
- end;
- end;
- tkEnumeration :
- begin
- if (aValue.TypeInfo = System.TypeInfo(Boolean)) then
- begin
- {$IF Defined(DELPHIRX10_UP) OR Defined(FPC)}
- Result := TJSONBool.Create(aValue.AsBoolean);
- {$ELSE}
- if aValue.AsBoolean then Result := TJsonTrue.Create
- else Result := TJsonFalse.Create;
- {$ENDIF}
- end
- else
- begin
- //Result.JsonValue := TJSONString.Create(GetEnumName(aValue.TypeInfo,aValue.AsOrdinal));
- if fUseEnumNames then Result := TJSONString.Create(aValue.ToString)
- else Result := TJSONNumber.Create(GetEnumValue(aValue.TypeInfo,aValue.ToString));
- end;
- end;
- {$IFDEF FPC}
- tkBool :
- begin
- Result := TJSONBool.Create(aValue.AsBoolean);
- end;
- {$ENDIF}
- tkSet :
- begin
- Result := TJSONString.Create(aValue.ToString);
- end;
- tkRecord :
- begin
- {$IFNDEF FPC}
- Result := SerializeRecord(aValue);
- {$ENDIF}
- end;
- tkVariant :
- begin
- {$IFNDEF FPC}
- case VarType(aValue.AsVariant) and VarTypeMask of
- varInteger, varInt64 : Result := TJSONNumber.Create(aValue.AsInteger);
- varString, varUString, varEmpty : Result := TJSONString.Create(aValue.AsString);
- varDouble : Result := TJSONNumber.Create(aValue.AsExtended);
- end;
- {$ENDIF}
- end;
- tkMethod, tkPointer, tkClassRef, tkProcedure, tkUnknown :
- begin
- //skip these properties
- end
- else
- begin
- {$IFNDEF FPC}
- raise EJsonSerializeError.CreateFmt(cNotSupportedDataType,[GetTypeName(aValue.TypeInfo)]);
- {$ELSE}
- raise EJsonSerializeError.Create('Not supported Data Type');
- {$ENDIF}
- end;
- end;
- if Result = nil then Result := TJSONNull.Create;
- end;
- function TRTTIJson.SerializeStream(aObject: TObject): TJSONValue;
- var
- stream : TStream;
- begin
- Result := nil;
- try
- stream := TStream(aObject);
- if fOptions.UseBase64Stream then Result := TJSONString.Create(Base64Encode(StreamToString(stream,TEncoding.Ansi)))
- else Result := TJSONString.Create(StreamToString(stream,TEncoding.Ansi));
- except
- on E : Exception do
- begin
- EJsonSerializeError.CreateFmt('Serialize Error -> Stream (%s)',[e.Message]);
- end;
- end;
- end;
- {$IFNDEF FPC}
- function TRTTIJson.SerializeDynArray(const aValue: TValue; aMaxElements : Integer = -1) : TJsonArray;
- var
- ctx : TRttiContext;
- rDynArray : TRTTIDynamicArrayType;
- i : Integer;
- jValue : TJSONValue;
- element : Integer;
- list : TList<TJSONValue>;
- len : Integer;
- begin
- element := -1;
- Result := TJSONArray.Create;
- try
- rDynArray := ctx.GetType(aValue.TypeInfo) as TRTTIDynamicArrayType;
- //if aValue.IsObjectInstance then TList<TObject>(aValue.AsObject).TrimExcess;
- list := TList<TJSONValue>.Create;
- if aMaxElements = -1 then len := aValue.GetArrayLength
- else len := aMaxElements;
- list.Capacity := len;
- for i := 0 to len - 1 do
- begin
- if not GetValue(PPByte(aValue.GetReferenceToRawData)^ + rDynArray.ElementType.TypeSize * i, rDynArray.ElementType).IsEmpty then
- begin
- element := i;
- jValue := SerializeValue(GetValue(PPByte(aValue.GetReferenceToRawData)^ + rDynArray.ElementType.TypeSize * i, rDynArray.ElementType));
- if jValue = nil then jValue := TJSONNull.Create;
- list.Add(jValue);
- end;
- end;
- Result.SetElements(list);
- except
- on E : Exception do
- begin
- if element > -1 then raise EJsonSerializeError.CreateFmt('Serialize Error -> Array[%d] (%s)',[element,e.Message])
- else raise EJsonSerializeError.CreateFmt('Serialize Error -> Array (%s)',[e.Message]);
- end;
- end;
- end;
- function TRTTIJson.SerializeRecord(const aValue : TValue) : TJSONValue;
- var
- ctx : TRttiContext;
- json : TJSONObject;
- rRec : TRttiRecordType;
- rField : TRttiField;
- begin
- rField := nil;
- try
- rRec := ctx.GetType(aValue.TypeInfo).AsRecord;
- if aValue.TypeInfo = System.TypeInfo(TGUID) then
- begin
- Result := TJSONString.Create(GUIDToStringFormated(aValue.AsType<TGUID>));
- end
- else
- begin
- json := TJSONObject.Create;
- for rField in rRec.GetFields do
- begin
- json.AddPair(rField.Name,SerializeValue(rField.GetValue(aValue.GetReferenceToRawData)));
- end;
- Result := json;
- end;
- except
- on E : Exception do
- begin
- if rField <> nil then raise EJsonSerializeError.CreateFmt('Serialize Error -> Record property "%s" (%s)',[rField.Name,e.Message])
- else raise EJsonSerializeError.CreateFmt('Serialize Error -> Record (%s)',[e.Message]);
- end;
- end;
- end;
- {$ELSE}
- function TRTTIJson.GetPropType(aPropInfo: PPropInfo): PTypeInfo;
- begin
- Result := aPropInfo^.PropType;
- end;
- function TRTTIJson.FloatProperty(aObject : TObject; aPropInfo: PPropInfo): string;
- const
- Precisions: array[TFloatType] of Integer = (7, 15, 18, 18, 19);
- var
- fsettings : TFormatSettings;
- begin
- fsettings := FormatSettings;
- Result := StringReplace(FloatToStrF(GetFloatProp(aObject, aPropInfo), ffGeneral,
- Precisions[GetTypeData(GetPropType(aPropInfo))^.FloatType],0),
- '.',fsettings.DecimalSeparator,[rfReplaceAll]);
- end;
- function TRTTIJson.SerializeObject(aObject : TObject; aType : TTypeKind; const aPropertyName : string) : TJSONPair;
- var
- propinfo : PPropInfo;
- jArray : TJsonArray;
- jPair : TJsonPair;
- jValue : TJsonValue;
- i : Integer;
- pArr : Pointer;
- rValue : TValue;
- rItemValue : TValue;
- len : Integer;
- begin
- try
- Result := TJSONPair.Create(aPropertyName,nil);
- propinfo := GetPropInfo(aObject,aPropertyName);
- //case propinfo.PropType.Kind of
- case aType of
- tkDynArray :
- begin
- len := 0;
- jArray := TJSONArray.Create;
- try
- pArr := GetDynArrayProp(aObject,aPropertyName);
- TValue.Make(@pArr,propinfo.PropType, rValue);
- if rValue.IsArray then
- begin
- len := rValue.GetArrayLength;
- for i := 0 to len - 1 do
- begin
- rItemValue := rValue.GetArrayElement(i);
- jValue := SerializeValue(rItemValue);
- jArray.Add(jValue);
- end;
- end;
- Result.JsonValue := jArray;
- finally
- //DynArrayClear(pArr,propinfo.PropType);
- pArr := nil;
- end;
- end;
- tkClass :
- begin
- Result.JsonValue := TJSONValue(SerializeObject(GetObjectProp(aObject,aPropertyName)));
- end;
- tkString, tkLString, tkWString, tkUString, tkAString :
- begin
- Result.JsonValue := TJSONString.Create(GetStrProp(aObject,aPropertyName));
- end;
- tkChar, tkWChar :
- begin
- Result.JsonValue := TJSONString.Create(Char(GetOrdProp(aObject,aPropertyName)));
- end;
- tkInteger :
- begin
- Result.JsonValue := TJSONNumber.Create(GetOrdProp(aObject,aPropertyName));
- end;
- tkInt64 :
- begin
- Result.JsonValue := TJSONNumber.Create(GetOrdProp(aObject,aPropertyName));
- end;
- tkFloat :
- begin
- if propinfo.PropType = TypeInfo(TDateTime) then
- begin
- Result.JsonValue := TJSONString.Create(DateTimeToJsonDate(GetFloatProp(aObject,aPropertyName)));
- end
- else if propinfo.PropType = TypeInfo(TDate) then
- begin
- Result.JsonValue := TJSONString.Create(DateToStr(GetFloatProp(aObject,aPropertyName)));
- end
- else if propinfo.PropType = TypeInfo(TTime) then
- begin
- Result.JsonValue := TJSONString.Create(TimeToStr(GetFloatProp(aObject,aPropertyName)));
- end
- else
- begin
- //Result.JsonValue := TJsonFloatNumber.Create(GetFloatProp(aObject,aPropertyName));
- Result.JsonValue := TJsonFloatNumber.Create(StrToFloat(FloatProperty(aObject,propinfo)));
- end;
- end;
- tkEnumeration,tkBool :
- begin
- if (propinfo.PropType = System.TypeInfo(Boolean)) then
- begin
- Result.JsonValue := TJSONBool.Create(Boolean(GetOrdProp(aObject,aPropertyName)));
- end
- else
- begin
- if fUseEnumNames then Result.JsonValue := TJSONString.Create(GetEnumName(propinfo.PropType,GetOrdProp(aObject,aPropertyName)))
- else Result.JsonValue := TJSONNumber.Create(GetOrdProp(aObject,aPropertyName));
- //Result.JsonValue := TJSONString.Create(aValue.ToString);
- end;
- end;
- tkSet :
- begin
- Result.JsonValue := TJSONString.Create(GetSetProp(aObject,aPropertyName));
- end;
- {$IFNDEF FPC}
- tkRecord :
- begin
- Result.JsonValue := SerializeRecord(aValue);
- end;
- {$ENDIF}
- tkMethod, tkPointer, tkClassRef ,tkInterface, tkProcedure :
- begin
- //skip these properties
- //FreeAndNil(Result);
- end
- else
- begin
- //raise EJsonDeserializeError.CreateFmt('Not supported type "%s":%d',[aName,Integer(aValue.Kind)]);
- end;
- end;
- if Result.JsonValue = nil then Result.JsonValue := TJSONNull.Create;
- except
- on E : Exception do
- begin
- Result.Free;
- {$IFNDEF FPC}
- raise EJsonSerializeError.CreateFmt('Serialize error class "%s.%s" : %s',[aName,aValue.ToString,e.Message]);
- {$ENDIF}
- end;
- end;
- end;
- {$ENDIF}
- { TJsonSerializer}
- constructor TJsonSerializer.Create(aSerializeLevel: TSerializeLevel; aUseEnumNames : Boolean = True; aUseNullStringsAsEmpty : Boolean = False);
- begin
- {$IFDEF FPC}
- if aSerializeLevel = TSerializeLevel.slPublicProperty then raise EJsonSerializeError.Create('FreePascal RTTI only supports published properties');
- {$ENDIF}
- fSerializeLevel := aSerializeLevel;
- fUseEnumNames := aUseEnumNames;
- fUseJsonCaseSense := False;
- fUseBase64Stream := True;
- fUseNullStringsAsEmpty := aUseNullStringsAsEmpty;
- fRTTIJson := TRTTIJson.Create(aSerializeLevel,aUseEnumNames);
- fRTTIJson.Options.UseJsonCaseSense := fUseJsonCaseSense;
- fRTTIJson.Options.UseBase64Stream := fUseBase64Stream;
- fRTTIJson.Options.UseNullStringsAsEmpty := fUseNullStringsAsEmpty;
- end;
- destructor TJsonSerializer.Destroy;
- begin
- fRTTIJson.Free;
- inherited;
- end;
- function TJsonSerializer.JsonToObject(aType: TClass; const aJson: string): TObject;
- var
- jvalue : TJSONValue;
- json: TJSONObject;
- begin
- {$IFDEF DEBUG_SERIALIZER}
- TDebugger.TimeIt(Self,'JsonToObject',aType.ClassName);
- {$ENDIF}
- try
- {$IFDEF DELPHIRX10_UP}
- jvalue := TJSONObject.ParseJSONValue(aJson,True);
- if jvalue.ClassType = TJSONArray then json := TJSONObject(jvalue)
- else json := jvalue as TJSONObject;
- {$ELSE}
- {$IFDEF FPC}
- json := TJSONObject(TJSONObject.ParseJSONValue(aJson,True));
- {$ELSE}
- json := TJsonObject.ParseJSONValue(TEncoding.UTF8.GetBytes(aJson),0,True) as TJSONObject;
- {$ENDIF}
- {$ENDIF}
- except
- raise EJsonDeserializeError.Create(cNotValidJson);
- end;
- try
- Result := fRTTIJson.DeserializeClass(aType,json);
- finally
- json.Free;
- end;
- end;
- function TJsonSerializer.JsonToObject(aObject: TObject; const aJson: string): TObject;
- var
- jvalue : TJSONValue;
- json: TJSONObject;
- begin;
- if aObject = nil then raise EJsonDeserializeError.Create('Object param cannot be null!');
- {$IFDEF DEBUG_SERIALIZER}
- TDebugger.TimeIt(Self,'JsonToObject',aObject.ClassName);
- {$ENDIF}
- try
- {$IFDEF DELPHIRX10_UP}
- jvalue := TJSONObject.ParseJSONValue(aJson,True);
- if jvalue.ClassType = TJSONArray then json := TJSONObject(jvalue)
- else json := jvalue as TJSONObject;
- //json := TJSONObject.ParseJSONValue(aJson,True) as TJSONObject;
- {$ELSE}
- {$IFDEF FPC}
- json := TJSONObject(TJSONObject.ParseJSONValue(aJson,True));
- {$ELSE}
- json := TJsonObject.ParseJSONValue(TEncoding.UTF8.GetBytes(aJson),0,True) as TJSONObject;
- {$ENDIF}
- {$ENDIF}
- except
- raise EJsonDeserializeError.Create(cNotValidJson);
- end;
- try
- Result := fRTTIJson.DeserializeObject(aObject,json);
- finally
- json.Free;
- end;
- end;
- function TJsonSerializer.ObjectToJson(aObject : TObject; aIndent : Boolean = False): string;
- var
- json: TJSONObject;
- begin
- {$IFDEF DEBUG_SERIALIZER}
- TDebugger.TimeIt(Self,'ObjectToJson',aObject.ClassName);
- {$ENDIF}
- json := fRTTIJson.SerializeObject(aObject);
- try
- if aIndent then Result := TJsonUtils.JsonFormat(json.ToJSON)
- else Result := json.ToJSON;
- finally
- json.Free;
- end;
- end;
- procedure TJsonSerializer.ObjectToJsonStream(aObject: TObject; aStream: TStream);
- var
- json : TJsonObject;
- ss : TStringStream;
- begin
- {$IFDEF DEBUG_SERIALIZER}
- TDebugger.TimeIt(Self,'ObjectToJsonStream',aObject.ClassName);
- {$ENDIF}
- if aStream = nil then raise EJsonSerializeError.Create('stream parameter cannot be nil!');
- json := fRTTIJson.SerializeObject(aObject);
- try
- ss := TStringStream.Create(json.ToString,TEncoding.UTF8);
- try
- aStream.CopyFrom(ss,ss.Size);
- finally
- ss.Free;
- end;
- finally
- json.Free;
- end;
- end;
- function TJsonSerializer.ObjectToJsonString(aObject : TObject; aIndent : Boolean = False): string;
- var
- json: TJSONObject;
- begin
- {$IFDEF DEBUG_SERIALIZER}
- TDebugger.TimeIt(Self,'ObjectToJsonString',aObject.ClassName);
- {$ENDIF}
- json := fRTTIJson.SerializeObject(aObject);
- try
- if aIndent then Result := TJsonUtils.JsonFormat(json.ToString)
- else Result := json.ToString;
- finally
- json.Free;
- end;
- end;
- function TJsonSerializer.Options: TSerializerOptions;
- begin
- Result := fRTTIJson.Options;
- end;
- function TJsonSerializer.ValueToJson(const aValue: TValue; aIndent: Boolean): string;
- var
- json: TJSONValue;
- begin
- {$IFDEF DEBUG_SERIALIZER}
- TDebugger.TimeIt(Self,'ValueToJson',aValue.ToString);
- {$ENDIF}
- json:= fRTTIJson.SerializeValue(aValue);
- if json = nil then raise EJsonSerializerError.Create('Error serializing TValue');
- try
- if aIndent then Result := TJsonUtils.JsonFormat(json{$IFNDEF FPC}.ToJSON{$ELSE}.AsJson{$ENDIF})
- else Result := json{$IFNDEF FPC}.ToJSON{$ELSE}.AsJson{$ENDIF};
- finally
- json.Free;
- end;
- end;
- function TJsonSerializer.ValueToJsonString(const aValue: TValue; aIndent: Boolean): string;
- var
- json: TJSONValue;
- begin
- {$IFDEF DEBUG_SERIALIZER}
- TDebugger.TimeIt(Self,'ValueToJsonString',aValue.ToString);
- {$ENDIF}
- json:= fRTTIJson.SerializeValue(aValue);
- if json = nil then raise EJsonSerializerError.Create('Error serializing TValue');
- try
- if aIndent then Result := TJsonUtils.JsonFormat(json.ToString)
- else Result := json.ToString;
- finally
- json.Free;
- end;
- end;
- function TJsonSerializer.ArrayToJson<T>(aArray: TArray<T>; aIndent: Boolean): string;
- var
- json: TJSONValue;
- begin
- {$IFDEF DEBUG_SERIALIZER}
- TDebugger.TimeIt(Self,'ArrayToJson','');
- {$ENDIF}
- json:= fRTTIJson.SerializeValue(TValue.From<TArray<T>>(aArray));
- if json = nil then raise EJsonSerializerError.Create('Error serializing Array');
- try
- if aIndent then Result := TJsonUtils.JsonFormat(json{$IFNDEF FPC}.ToJSON{$ELSE}.AsJson{$ENDIF})
- else Result := json{$IFNDEF FPC}.ToJSON{$ELSE}.AsJson{$ENDIF};
- finally
- json.Free;
- end;
- end;
- function TJsonSerializer.ArrayToJsonString<T>(aArray: TArray<T>; aIndent: Boolean): string;
- var
- json: TJSONValue;
- begin
- {$IFDEF DEBUG_SERIALIZER}
- TDebugger.TimeIt(Self,'ArrayToJsonString','');
- {$ENDIF}
- json:= fRTTIJson.SerializeValue(TValue.From<TArray<T>>(aArray));
- if json = nil then raise EJsonSerializerError.Create('Error serializing Array');
- try
- if aIndent then Result := TJsonUtils.JsonFormat(json.ToString)
- else Result := json.ToString;
- finally
- json.Free;
- end;
- end;
- function TJsonSerializer.JsonStreamToObject(aObject: TObject; aJsonStream: TStream): TObject;
- var
- json : string;
- begin
- {$IFDEF DEBUG_SERIALIZER}
- TDebugger.TimeIt(Self,'JsonStreamToObject','');
- {$ENDIF}
- if aJsonStream = nil then raise EJsonDeserializeError.Create('JsonStream param cannot be nil!');
- json := StreamToString(aJsonStream,TEncoding.UTF8);
- Result := JsonToObject(aObject,json);
- end;
- {$IFNDEF FPC}
- function TJsonSerializer.JsonToArray<T>(const aJson: string): TArray<T>;
- var
- jarray: TJSONArray;
- value : TValue;
- begin;
- {$IFDEF DEBUG_SERIALIZER}
- TDebugger.TimeIt(Self,'JsonToArray','');
- {$ENDIF}
- try
- {$If Defined(FPC) OR Defined(DELPHIRX10_UP)}
- jarray := TJSONObject.ParseJSONValue(aJson,True) as TJSONArray;
- {$ELSE}
- jarray := TJsonObject.ParseJSONValue(TEncoding.UTF8.GetBytes(aJson),0,True) as TJSONArray;
- {$ENDIF}
- except
- raise EJsonDeserializeError.Create(cNotValidJson);
- end;
- try
- value := fRTTIJson.DeserializeDynArray(PTypeInfo(TypeInfo(TArray<T>)),nil,jarray);
- Result := value.AsType<TArray<T>>;
- finally
- jarray.Free;
- end;
- end;
- function TJsonSerializer.JsonToValue(const aJson: string): TValue;
- var
- json: TJSONObject;
- value : TValue;
- begin;
- {$IFDEF DEBUG_SERIALIZER}
- TDebugger.TimeIt(Self,'JsonToValue','');
- {$ENDIF}
- try
- {$If Defined(FPC) OR Defined(DELPHIRX10_UP)}
- json := TJSONObject.ParseJSONValue(aJson,True) as TJSONObject;
- {$ELSE}
- json := TJsonObject.ParseJSONValue(TEncoding.UTF8.GetBytes(aJson),0,True) as TJSONObject;
- {$ENDIF}
- except
- raise EJsonDeserializeError.Create(cNotValidJson);
- end;
- try
- value := fRTTIJson.DeserializeRecord(value,nil,json);
- Result := value; // value.AsType<TArray<T>>;
- finally
- json.Free;
- end;
- end;
- {$ENDIF}
- procedure TJsonSerializer.SetSerializeLevel(const Value: TSerializeLevel);
- begin
- fSerializeLevel := Value;
- if Assigned(fRTTIJson) then fRTTIJson.fSerializeLevel := Value;
- end;
- procedure TJsonSerializer.SetUseBase64Stream(const Value: Boolean);
- begin
- fUseBase64Stream := Value;
- if Assigned(fRTTIJson) then fRTTIJson.Options.UseBase64Stream := Value;
- end;
- procedure TJsonSerializer.SetUseEnumNames(const Value: Boolean);
- begin
- fUseEnumNames := Value;
- if Assigned(fRTTIJson) then fRTTIJson.Options.UseEnumNames := Value;
- end;
- procedure TJsonSerializer.SetUseGUIDLowerCase(const Value: Boolean);
- begin
- fUseGUIDLowercase := Value;
- if Assigned(fRTTIJson) then fRTTIJson.Options.UseGUIDLowerCase := Value;
- end;
- procedure TJsonSerializer.SetUseGUIDWithBrackets(const Value: Boolean);
- begin
- fUseGUIDWithBrackets := Value;
- if Assigned(fRTTIJson) then fRTTIJson.Options.UseGUIDWithBrackets := Value;
- end;
- procedure TJsonSerializer.SetUseJsonCaseSense(const Value: Boolean);
- begin
- fRTTIJson.Options.UseJsonCaseSense := Value;
- if Assigned(fRTTIJson) then fRTTIJson.Options.UseJsonCaseSense := Value;
- end;
- procedure TJsonSerializer.SetUseNullStringsAsEmpty(const Value: Boolean);
- begin
- fUseNullStringsAsEmpty := Value;
- if Assigned(fRTTIJson) then fRTTIJson.Options.UseNullStringsAsEmpty := Value;
- end;
- {$IFNDEF FPC}
- { TCommentProperty }
- constructor TCommentProperty.Create(const aComment: string);
- begin
- fComment := aComment;
- end;
- { TCustomNameProperty }
- constructor TCustomNameProperty.Create(const aName: string);
- begin
- fName := aName;
- end;
- {$ENDIF}
- {$IF NOT DEFINED(DELPHIXE7_UP) AND NOT DEFINED(FPC)}
- { TJSONArrayHelper }
- function TJSONArrayHelper.Count: Integer;
- begin
- Result := Self.Size;
- end;
- function TJSONArrayHelper.GetItem(aValue: Integer): TJSONValue;
- begin
- Result := Self.Get(aValue);
- end;
- procedure TJSONArrayHelper.SetElements(aElements: TList<TJSONValue>);
- var
- jvalue : TJSONValue;
- begin
- for jvalue in aElements do Self.AddElement(jvalue);
- aElements.Free;
- end;
- { TJSONValueHelper }
- function TJSONValueHelper.ToJson: string;
- begin
- Result := Self.ToString;
- end;
- { TJSONObjectHelper }
- function TJSONObjectHelper.Count: Integer;
- begin
- Result := Self.Size;
- end;
- function TJSONObjectHelper.GetValue(const aName: string): TJSONValue;
- var
- jPair : TJSONPair;
- begin
- Result := nil;
- for jPair in Self do
- begin
- if jPair.JsonString.ToString = aName then Exit(jPair.JsonValue);
- end;
- end;
- function TJSONObjectHelper.GetPair(aValue: Integer) : TJSONPair;
- begin
- Result := Self.Get(aValue);
- end;
- {$ENDIF}
- end.
|