Quick.Json.Serializer.pas 69 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147
  1. { ***************************************************************************
  2. Copyright (c) 2015-2022 Kike Pérez
  3. Unit : Quick.JSON.Serializer
  4. Description : Json Serializer
  5. Author : Kike Pérez
  6. Version : 1.12
  7. Created : 21/05/2018
  8. Modified : 17/05/2022
  9. This file is part of QuickLib: https://github.com/exilon/QuickLib
  10. ***************************************************************************
  11. Licensed under the Apache License, Version 2.0 (the "License");
  12. you may not use this file except in compliance with the License.
  13. You may obtain a copy of the License at
  14. http://www.apache.org/licenses/LICENSE-2.0
  15. Unless required by applicable law or agreed to in writing, software
  16. distributed under the License is distributed on an "AS IS" BASIS,
  17. WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  18. See the License for the specific language governing permissions and
  19. limitations under the License.
  20. *************************************************************************** }
  21. unit Quick.Json.Serializer;
  22. {$i QuickLib.inc}
  23. interface
  24. uses
  25. {$IFDEF DEBUG_SERIALIZER}
  26. Quick.Debug.Utils,
  27. {$ENDIF}
  28. Classes,
  29. SysUtils,
  30. Rtti,
  31. TypInfo,
  32. Quick.Serializer.Intf,
  33. Quick.Base64,
  34. {$IFDEF FPC}
  35. rttiutils,
  36. fpjson,
  37. jsonparser,
  38. strUtils,
  39. //jsonreader,
  40. //fpjsonrtti,
  41. Quick.Json.fpc.Compatibility,
  42. {$ELSE}
  43. {$IFDEF DELPHIXE7_UP}
  44. System.Json,
  45. {$ELSE}
  46. Data.DBXJSON,
  47. {$ENDIF}
  48. {$IFDEF DELPHIRX10_UP}
  49. {$ENDIF}
  50. Variants,
  51. {$ENDIF}
  52. Generics.Collections,
  53. Quick.RTTI.Utils,
  54. DateUtils,
  55. Quick.Commons,
  56. Quick.JSON.Utils;
  57. type
  58. IJsonSerializer = ISerializer;
  59. EJsonSerializeError = class(Exception);
  60. EJsonDeserializeError = class(Exception);
  61. {$IFNDEF FPC}
  62. TNotSerializableProperty = class(TCustomAttribute);
  63. TCommentProperty = class(TCustomAttribute)
  64. private
  65. fComment : string;
  66. public
  67. constructor Create(const aComment: string);
  68. property Comment : string read fComment;
  69. end;
  70. TSerializerOptions = Quick.Serializer.Intf.TSerializerOptions;
  71. TCustomNameProperty = class(TCustomAttribute)
  72. private
  73. fName : string;
  74. public
  75. constructor Create(const aName: string);
  76. property Name : string read fName;
  77. end;
  78. {$IFNDEF DELPHIXE7_UP}
  79. TJSONArrayHelper = class helper for Data.DBXJson.TJSONArray
  80. private
  81. function GetItem(aValue : Integer) : TJSONValue;
  82. public
  83. function Count : Integer;
  84. property Items[index : Integer] : TJSONValue read GetItem;
  85. procedure SetElements(aElements : TList<TJSONValue>);
  86. end;
  87. TJSONValueHelper = class helper for Data.DBXJson.TJSONValue
  88. public
  89. function ToJson : string;
  90. end;
  91. TJSONObjectHelper = class helper for Data.DBXJson.TJSONObject
  92. private
  93. function GetPair(aValue : Integer) : TJSONPair;
  94. public
  95. function Count : Integer;
  96. function GetValue(const aName : string) : TJSONValue;
  97. property Pairs[index : Integer] : TJSONPair read GetPair;
  98. end;
  99. {$ENDIF}
  100. {$ENDIF}
  101. TSerializeLevel = (slPublicProperty, slPublishedProperty);
  102. TRTTIJson = class
  103. type
  104. TGenericListType = (gtNone, gtList, gtObjectList);
  105. private
  106. fSerializeLevel : TSerializeLevel;
  107. fUseEnumNames : Boolean;
  108. fUseJsonCaseSense : Boolean;
  109. fUseBase64Stream : Boolean;
  110. fUseNullStringsAsEmpty : Boolean;
  111. fUseGUIDWithBrackets : Boolean;
  112. fUseGUIDLowercase : Boolean;
  113. fOptions : TSerializerOptions;
  114. function GetValue(aAddr: Pointer; aType: TRTTIType): TValue; overload;
  115. {$IFDEF FPC}
  116. function GetValue(aAddr: Pointer; aTypeInfo: PTypeInfo): TValue; overload;
  117. {$ENDIF}
  118. function IsAllowedProperty(aObject : TObject; const aPropertyName : string) : Boolean;
  119. //function GetPropertyValue(Instance : TObject; const PropertyName : string) : TValue;
  120. function GetPropertyValueFromObject(Instance : TObject; const PropertyName : string) : TValue;
  121. {$IFNDEF FPC}
  122. function GetFieldValueFromRecord(const aValue : TValue; const FieldName : string) : TValue;
  123. {$ENDIF}
  124. {$IFDEF FPC}
  125. procedure SetPropertyValue(Instance : TObject; aPropInfo : PPropInfo; aValue : TValue); overload;
  126. procedure SetPropertyValue(Instance : TObject; const PropertyName : string; aValue : TValue); overload;
  127. function FloatProperty(aObject : TObject; aPropInfo: PPropInfo): string;
  128. function GetPropType(aPropInfo: PPropInfo): PTypeInfo;
  129. procedure LoadSetProperty(aInstance : TObject; aPropInfo: PPropInfo; const aValue: string);
  130. {$ENDIF}
  131. {$IFNDEF FPC}
  132. function CreateInstance(aClass: TClass): TValue; overload;
  133. function CreateInstance(aType: TRttiType): TValue; overload;
  134. {$ENDIF}
  135. function GUIDToStringFormated(const aGUID : TGUID) : string;
  136. public
  137. constructor Create(aSerializeLevel : TSerializeLevel; aUseEnumNames : Boolean = True);
  138. destructor Destroy; override;
  139. property UseEnumNames : Boolean read fUseEnumNames write fUseEnumNames;
  140. property UseJsonCaseSense : Boolean read fUseJsonCaseSense write fUseJsonCaseSense;
  141. property UseBase64Stream : Boolean read fUseBase64Stream write fUseBase64Stream;
  142. property UseNullStringsAsEmpty : Boolean read fUseNullStringsAsEmpty write fUseNullStringsAsEmpty;
  143. property UseGUIDWithBrackets : Boolean read fUseGUIDWithBrackets write fUseGUIDWithBrackets;
  144. property UseGUIDLowercase : Boolean read fUseGUIDLowercase write fUseGUIDLowercase;
  145. property Options : TSerializerOptions read fOptions write fOptions;
  146. function GetJsonPairValueByName(aJson : TJSONObject; const aName : string) : TJsonValue;
  147. function GetJsonPairByName(aJson : TJSONObject; const aName : string) : TJSONPair;
  148. function IsGenericList(aObject : TObject) : Boolean;
  149. function IsStream(aObject : TObject) : Boolean;
  150. function IsGenericXArray(const aClassName : string) : Boolean;
  151. function GetGenericListType(aObject : TObject) : TGenericListType;
  152. //serialize methods
  153. function SerializeValue(const aValue : TValue) : TJSONValue;
  154. function SerializeObject(aObject : TObject) : TJSONObject; overload;
  155. function SerializeStream(aObject : TObject) : TJSONValue;
  156. {$IFNDEF FPC}
  157. function SerializeDynArray(const aValue: TValue; aMaxElements : Integer = -1) : TJsonArray;
  158. function SerializeRecord(const aValue : TValue) : TJSONValue;
  159. {$ELSE}
  160. function SerializeObject(aObject : TObject; aType : TTypeKind; const aPropertyName : string) : TJSONPair;
  161. {$ENDIF}
  162. //deserialize methods
  163. function DeserializeClass(aType : TClass; const aJson : TJSONObject) : TObject;
  164. function DeserializeObject(aObject : TObject; const aJson : TJSONObject) : TObject; overload;
  165. function DeserializeProperty(aObject : TObject; const aName : string; aProperty : TRttiProperty; const aJson : TJSONObject) : TObject; overload;
  166. function DeserializeStream(aObject : TObject; const aJson : TJSONValue) : TObject;
  167. {$IFNDEF FPC}
  168. function DeserializeType(aObject : TObject; aType : TTypeKind; aTypeInfo : PTypeInfo; const aValue: string) : TValue;
  169. function DeserializeDynArray(aTypeInfo : PTypeInfo; aObject : TObject; const aJsonArray: TJSONArray) : TValue;
  170. function DeserializeRecord(const aRecord : TValue; aObject : TObject; const aJson : TJSONObject) : TValue;
  171. function DeserializeList(aObject: TObject; const aName : string; const aJson: TJSONObject) : TObject;
  172. procedure DeserializeXArray(Instance : TObject; aRecord : TValue; aProperty : TRttiProperty; const aPropertyName : string; aJson : TJsonObject);
  173. {$ELSE}
  174. function DeserializeType(aObject : TObject; aType : TTypeKind; const aPropertyName, aValue: string) : TValue;
  175. procedure DeserializeDynArray(aTypeInfo: PTypeInfo; const aPropertyName : string; aObject: TObject; const aJsonArray: TJSONArray);
  176. {$ENDIF}
  177. end;
  178. TJsonSerializer = class(TInterfacedObject,IJsonSerializer)
  179. strict private
  180. fSerializeLevel : TSerializeLevel;
  181. fUseEnumNames : Boolean;
  182. fUseJsonCaseSense : Boolean;
  183. fUseBase64Stream : Boolean;
  184. fUseNullStringsAsEmpty : Boolean;
  185. fUseGUIDWithBrackets: Boolean;
  186. fUseGUIDLowercase: Boolean;
  187. fRTTIJson : TRTTIJson;
  188. private
  189. procedure SetUseEnumNames(const Value: Boolean);
  190. procedure SetUseJsonCaseSense(const Value: Boolean);
  191. procedure SetSerializeLevel(const Value: TSerializeLevel);
  192. procedure SetUseBase64Stream(const Value: Boolean);
  193. //Only Delphi -> Workaround, use this when something passes : {Test : "Null"} but we expect : {Test : ""}
  194. procedure SetUseNullStringsAsEmpty(const Value : Boolean);
  195. procedure SetUseGUIDLowerCase(const Value: Boolean);
  196. procedure SetUseGUIDWithBrackets(const Value: Boolean);
  197. public
  198. constructor Create(aSerializeLevel: TSerializeLevel; aUseEnumNames : Boolean = True; aUseNullStringsAsEmpty : Boolean = False);
  199. destructor Destroy; override;
  200. property SerializeLevel : TSerializeLevel read fSerializeLevel write SetSerializeLevel;
  201. property UseEnumNames : Boolean read fUseEnumNames write SetUseEnumNames;
  202. property UseJsonCaseSense : Boolean read fUseJsonCaseSense write SetUseJsonCaseSense;
  203. property UseBase64Stream : Boolean read fUseBase64Stream write SetUseBase64Stream;
  204. property UseNullStringsAsEmpty : Boolean read fUseNullStringsAsEmpty write SetUseNullStringsAsEmpty;
  205. property UseGUIDWithBrackets : Boolean read fUseGUIDWithBrackets write SetUseGUIDWithBrackets;
  206. property UseGUIDLowerCase : Boolean read fUseGUIDLowercase write SetUseGUIDLowerCase;
  207. function JsonToObject(aType : TClass; const aJson: string) : TObject; overload;
  208. function JsonToObject(aObject : TObject; const aJson: string) : TObject; overload;
  209. function JsonStreamToObject(aObject : TObject; aJsonStream : TStream) : TObject;
  210. function ObjectToJson(aObject : TObject; aIndent : Boolean = False): string;
  211. function ObjectToJsonString(aObject : TObject; aIndent : Boolean = False): string;
  212. procedure ObjectToJsonStream(aObject : TObject; aStream : TStream);
  213. function ValueToJson(const aValue : TValue; aIndent : Boolean = False) : string;
  214. function ValueToJsonString(const aValue : TValue; aIndent : Boolean = False) : string;
  215. function ArrayToJson<T>(aArray : TArray<T>; aIndent : Boolean = False) : string;
  216. function ArrayToJsonString<T>(aArray : TArray<T>; aIndent : Boolean = False) : string;
  217. {$IFNDEF FPC}
  218. function JsonToArray<T>(const aJson : string) : TArray<T>;
  219. function JsonToValue(const aJson: string): TValue;
  220. {$ENDIF}
  221. function Options : TSerializerOptions;
  222. end;
  223. EJsonSerializerError = class(Exception);
  224. PPByte = ^PByte;
  225. resourcestring
  226. cNotSupportedDataType = 'Not supported data type "%s"';
  227. cSerializeObjectError = 'Serialize object "%s" error: %s';
  228. cSerializePropertyError = 'Property "%s" ("%s")';
  229. cNotSerializable = 'Object is not serializable';
  230. cNotValidJson = 'Not a valid Json';
  231. implementation
  232. { TRTTIJson }
  233. {$IFNDEF FPC}
  234. function TRTTIJson.DeserializeDynArray(aTypeInfo: PTypeInfo; aObject: TObject; const aJsonArray: TJSONArray) : TValue;
  235. var
  236. rType: PTypeInfo;
  237. len: NativeInt;
  238. pArr: Pointer;
  239. rItemValue: TValue;
  240. i: Integer;
  241. objClass: TClass;
  242. ctx : TRttiContext;
  243. json : TJSONObject;
  244. rDynArray : TRttiDynamicArrayType;
  245. propObj : TObject;
  246. begin
  247. if GetTypeData(aTypeInfo).DynArrElType = nil then Exit;
  248. if not assigned(aJsonArray) then Exit;
  249. len := aJsonArray.Count;
  250. rType := GetTypeData(aTypeInfo).DynArrElType^;
  251. pArr := nil;
  252. DynArraySetLength(pArr,aTypeInfo, 1, @len);
  253. try
  254. TValue.Make(@pArr,aTypeInfo, Result);
  255. rDynArray := ctx.GetType(Result.TypeInfo) as TRTTIDynamicArrayType;
  256. for i := 0 to aJsonArray.Count - 1 do
  257. begin
  258. rItemValue := nil;
  259. case rType.Kind of
  260. tkClass :
  261. begin
  262. if aJsonArray.Items[i] is TJSONObject then
  263. begin
  264. propObj := GetValue(PPByte(Result.GetReferenceToRawData)^ +rDynArray.ElementType.TypeSize * i, rDynArray.ElementType).AsObject;
  265. if propObj = nil then
  266. begin
  267. objClass := rType.TypeData.ClassType;
  268. rItemValue := DeserializeClass(objClass, TJSONObject(aJsonArray.Items[i]));
  269. end
  270. else
  271. begin
  272. DeserializeObject(propObj,TJSONObject(aJsonArray.Items[i]));
  273. end;
  274. end;
  275. end;
  276. tkRecord :
  277. begin
  278. json := TJSONObject(aJsonArray.Items[i]);
  279. rItemValue := DeserializeRecord(GetValue(PPByte(Result.GetReferenceToRawData)^ +rDynArray.ElementType.TypeSize * i,
  280. rDynArray.ElementType),aObject,json);
  281. end;
  282. tkMethod, tkPointer, tkClassRef ,tkInterface, tkProcedure :
  283. begin
  284. //skip these properties
  285. end
  286. else
  287. begin
  288. rItemValue := DeserializeType(aObject,rType.Kind,rType,aJsonArray.Items[i].Value);
  289. end;
  290. end;
  291. if not rItemValue.IsEmpty then Result.SetArrayElement(i,rItemValue);
  292. end;
  293. //aProperty.SetValue(aObject,rValue);
  294. finally
  295. DynArrayClear(pArr,aTypeInfo);
  296. end;
  297. end;
  298. {$ELSE}
  299. procedure TRTTIJson.DeserializeDynArray(aTypeInfo: PTypeInfo; const aPropertyName : string; aObject: TObject; const aJsonArray: TJSONArray);
  300. var
  301. rType: PTypeInfo;
  302. len: NativeInt;
  303. pArr: Pointer;
  304. rItemValue: TValue;
  305. i: Integer;
  306. objClass: TClass;
  307. propObj : TObject;
  308. rValue : TValue;
  309. begin
  310. if GetTypeData(aTypeInfo).ElType2 = nil then Exit;
  311. len := aJsonArray.Count;
  312. rType := GetTypeData(aTypeInfo).ElType2;
  313. pArr := nil;
  314. DynArraySetLength(pArr,aTypeInfo, 1, @len);
  315. try
  316. TValue.Make(@pArr,aTypeInfo, rValue);
  317. for i := 0 to aJsonArray.Count - 1 do
  318. begin
  319. rItemValue := nil;
  320. case rType.Kind of
  321. tkClass :
  322. begin
  323. if aJsonArray.Items[i] is TJSONObject then
  324. begin
  325. propObj := GetValue(PPByte(rValue.GetReferenceToRawData)^ +GetTypeData(aTypeInfo).elSize * i, GetTypeData(aTypeInfo).ElType2).AsObject;
  326. if propObj = nil then
  327. begin
  328. objClass := GetTypeData(aTypeInfo).ClassType;
  329. rItemValue := DeserializeClass(objClass, TJSONObject(aJsonArray.Items[i]));
  330. end
  331. else
  332. begin
  333. DeserializeObject(propObj,TJSONObject(aJsonArray.Items[i]));
  334. end;
  335. end;
  336. end;
  337. tkRecord :
  338. begin
  339. {json := TJSONObject(aJsonArray.Items[i]);
  340. rItemValue := DeserializeRecord(GetValue(PPByte(Result.GetReferenceToRawData)^ +rDynArray.ElementType.TypeSize * i,
  341. rDynArray.ElementType),aObject,json); }
  342. end;
  343. tkMethod, tkPointer, tkClassRef ,tkInterface, tkProcedure :
  344. begin
  345. //skip these properties
  346. end
  347. else
  348. begin
  349. rItemValue := DeserializeType(aObject,GetTypeData(aTypeInfo).ElType2.Kind,aPropertyName,aJsonArray.Items[i].Value);
  350. end;
  351. end;
  352. if not rItemValue.IsEmpty then rValue.SetArrayElement(i,rItemValue);
  353. end;
  354. //aProperty.SetValue(aObject,rValue);
  355. SetDynArrayProp(aObject,GetPropInfo(aObject,aPropertyName),pArr);
  356. finally
  357. DynArrayClear(pArr,aTypeInfo);
  358. end;
  359. end;
  360. {$ENDIF}
  361. {$IFNDEF FPC}
  362. function TRTTIJson.DeserializeRecord(const aRecord : TValue; aObject : TObject; const aJson : TJSONObject) : TValue;
  363. var
  364. ctx : TRttiContext;
  365. rRec : TRttiRecordType;
  366. rField : TRttiField;
  367. rValue : TValue;
  368. member : TJsonValue;
  369. jArray : TJSONArray;
  370. json : TJSONObject;
  371. objClass : TClass;
  372. propobj : TObject;
  373. begin
  374. rRec := ctx.GetType(aRecord.TypeInfo).AsRecord;
  375. for rField in rRec.GetFields do
  376. begin
  377. rValue := nil;
  378. //member := TJSONPair(aJson.GetValue(rField.Name));
  379. member := GetJsonPairValueByName(aJson,rField.Name);
  380. if member <> nil then
  381. case rField.FieldType.TypeKind of
  382. tkDynArray :
  383. begin
  384. jArray := TJSONObject.ParseJSONValue(member.ToJSON) as TJSONArray;
  385. try
  386. rValue := DeserializeDynArray(rField.FieldType.Handle,aObject,jArray);
  387. finally
  388. jArray.Free;
  389. end;
  390. end;
  391. tkClass :
  392. begin
  393. //if (member.JsonValue is TJSONObject) then
  394. begin
  395. propobj := rField.GetValue(@aRecord).AsObject;
  396. json := TJSONObject.ParseJSONValue(member.ToJson) as TJSONObject;
  397. try
  398. if propobj = nil then
  399. begin
  400. objClass := rField.FieldType.Handle^.TypeData.ClassType;// aProperty.PropertyType.Handle^.TypeData.ClassType;
  401. rValue := DeserializeClass(objClass,json);
  402. end
  403. else
  404. begin
  405. DeserializeObject(propobj,json);
  406. end;
  407. finally
  408. json.Free;
  409. end;
  410. end
  411. end;
  412. tkRecord :
  413. begin
  414. json := TJSONObject.ParseJSONValue(member.ToJson) as TJSONObject;
  415. try
  416. rValue := DeserializeRecord(rField.GetValue(aRecord.GetReferenceToRawData),aObject,json);
  417. finally
  418. json.Free;
  419. end;
  420. end
  421. else
  422. begin
  423. //rValue := DeserializeType(aObject,rField.FieldType.TypeKind,rField.FieldType.Handle,member.ToJson);
  424. //avoid return unicode escaped chars if string
  425. if rField.FieldType.TypeKind in [tkString, tkLString, tkWString, tkUString] then
  426. {$IFDEF DELPHIRX10_UP}
  427. rValue := DeserializeType(aObject,rField.FieldType.TypeKind,rField.FieldType.Handle,TJsonValue(member).value)
  428. {$ELSE}
  429. rValue := DeserializeType(aObject,rField.FieldType.TypeKind,rField.FieldType.Handle,member.Value)
  430. {$ENDIF}
  431. else rValue := DeserializeType(aObject,rField.FieldType.TypeKind,rField.FieldType.Handle,member.ToJSON);
  432. end;
  433. end;
  434. if not rValue.IsEmpty then rField.SetValue(aRecord.GetReferenceToRawData,rValue);
  435. end;
  436. Result := aRecord;
  437. end;
  438. {$ENDIF}
  439. function TRTTIJson.DeserializeStream(aObject: TObject; const aJson: TJSONValue): TObject;
  440. var
  441. stream : TStringStream;
  442. begin
  443. if fOptions.UseBase64Stream then stream := TStringStream.Create(Base64Decode(aJson.Value),TEncoding.Ansi)
  444. else stream := TStringStream.Create({$IFNDEF FPC}aJson.Value{$ELSE}string(aJson.Value){$ENDIF},TEncoding.Ansi);
  445. try
  446. TStream(aObject).CopyFrom(stream,stream.Size);
  447. finally
  448. stream.Free;
  449. end;
  450. Result := aObject;
  451. end;
  452. constructor TRTTIJson.Create(aSerializeLevel : TSerializeLevel; aUseEnumNames : Boolean = True);
  453. begin
  454. fOptions := TSerializerOptions.Create;
  455. fSerializeLevel := aSerializeLevel;
  456. fUseEnumNames := aUseEnumNames;
  457. fUseJsonCaseSense := False;
  458. fUseBase64Stream := True;
  459. fUseGUIDWithBrackets := False;
  460. fUseGUIDLowerCase := True;
  461. fOptions.UseEnumNames := aUseEnumNames;
  462. fOptions.UseJsonCaseSense := False;
  463. fOptions.UseBase64Stream := True;
  464. fOptions.UseGUIDLowercase := False;
  465. fOptions.UseGUIDLowercase := True;
  466. end;
  467. destructor TRTTIJson.Destroy;
  468. begin
  469. fOptions.Free;
  470. inherited;
  471. end;
  472. {$IFNDEF FPC}
  473. function TRTTIJson.CreateInstance(aClass: TClass): TValue;
  474. var
  475. ctx : TRttiContext;
  476. rtype : TRttiType;
  477. begin
  478. Result := nil;
  479. rtype := ctx.GetType(aClass);
  480. Result := CreateInstance(rtype);
  481. end;
  482. {$ENDIF}
  483. {$IFNDEF FPC}
  484. function TRTTIJson.CreateInstance(aType: TRttiType): TValue;
  485. var
  486. rmethod : TRttiMethod;
  487. begin
  488. Result := nil;
  489. if atype = nil then Exit;
  490. for rmethod in TRttiInstanceType(atype).GetMethods do
  491. begin
  492. if rmethod.IsConstructor then
  493. begin
  494. //create if don't have parameters
  495. if Length(rmethod.GetParameters) = 0 then
  496. begin
  497. Result := rmethod.Invoke(TRttiInstanceType(atype).MetaclassType,[]);
  498. Break;
  499. end;
  500. end;
  501. end;
  502. end;
  503. {$ENDIF}
  504. function TRTTIJson.DeserializeClass(aType: TClass; const aJson: TJSONObject): TObject;
  505. begin
  506. Result := nil;
  507. if (aJson = nil) or ((aJson as TJSONValue) is TJSONNull) or (aJson.Count = 0) then Exit;
  508. {$IFNDEF FPC}
  509. Result := CreateInstance(aType).AsObject;
  510. {$ELSE}
  511. Result := aType.Create;
  512. {$ENDIF}
  513. try
  514. Result := DeserializeObject(Result,aJson);
  515. except
  516. on E : Exception do
  517. begin
  518. Result.Free;
  519. raise EJsonDeserializeError.CreateFmt('Deserialize error class "%s" : %s',[aType.ClassName,e.Message]);
  520. end;
  521. end;
  522. end;
  523. function TRTTIJson.DeserializeObject(aObject: TObject; const aJson: TJSONObject): TObject;
  524. var
  525. ctx: TRttiContext;
  526. rType: TRttiType;
  527. rProp: TRttiProperty;
  528. {$IFNDEF FPC}
  529. attr: TCustomAttribute;
  530. propvalue : TValue;
  531. {$ENDIF}
  532. propertyname : string;
  533. begin
  534. Result := aObject;
  535. if (aJson = nil) or ((aJson as TJSONValue) is TJSONNull) or (aJson.Count = 0) or (Result = nil) then Exit;
  536. try
  537. //if generic list
  538. {$IFNDEF FPC}
  539. if IsGenericList(aObject) then
  540. begin
  541. DeserializeList(aObject,'List',aJson);
  542. Exit;
  543. end
  544. else
  545. {$ENDIF}
  546. if IsStream(aObject) then
  547. begin
  548. DeserializeStream(aObject,aJson);
  549. Exit;
  550. end;
  551. //if standard object
  552. rType := ctx.GetType(aObject.ClassInfo);
  553. for rProp in rType.GetProperties do
  554. begin
  555. {$IFNDEF FPC}
  556. if ((fSerializeLevel = slPublicProperty) and (rProp.PropertyType.IsPublicType))
  557. or ((fSerializeLevel = slPublishedProperty) and ((IsPublishedProp(aObject,rProp.Name)) or (rProp.Name = 'List'))) then
  558. {$ENDIF}
  559. begin
  560. if ((rProp.IsWritable) or (rProp.Name = 'List')) and (IsAllowedProperty(aObject,rProp.Name)) then
  561. begin
  562. propertyname := rProp.Name;
  563. {$IFNDEF FPC}
  564. for attr in rProp.GetAttributes do if attr is TCustomNameProperty then propertyname := TCustomNameProperty(attr).Name;
  565. propvalue := rProp.GetValue(aObject);
  566. if rProp.Name = 'List' then
  567. begin
  568. Result := DeserializeList(Result,propertyname,aJson);
  569. end
  570. else if propvalue.IsObject then
  571. begin
  572. if propvalue.AsObject = nil then
  573. begin
  574. propvalue := CreateInstance(rProp.PropertyType);
  575. rProp.SetValue(aObject,propvalue);
  576. end;
  577. if IsGenericList(propvalue.AsObject) then DeserializeList(propvalue.AsObject,'List',TJSONObject(aJson.GetValue(propertyname)))
  578. else Result := DeserializeProperty(Result,propertyname,rProp,aJson);
  579. end
  580. else if IsGenericXArray(string(propvalue{$IFNDEF NEXTGEN}.TypeInfo.Name{$ELSE}.TypeInfo.NameFld.ToString{$ENDIF})) then
  581. begin
  582. DeserializeXArray(Result,propvalue,rProp,propertyname,aJson);
  583. end
  584. else
  585. {$ENDIF}
  586. Result := DeserializeProperty(Result,propertyname,rProp,aJson);
  587. end;
  588. end;
  589. end;
  590. except
  591. on E : Exception do
  592. begin
  593. Result.Free;
  594. raise EJsonDeserializeError.CreateFmt('Deserialize error for object "%s" : %s',[aObject.ClassName,e.Message]);
  595. end;
  596. end;
  597. end;
  598. {$IFNDEF FPC}
  599. function TRTTIJson.DeserializeList(aObject: TObject; const aName : string; const aJson: TJSONObject) : TObject;
  600. var
  601. ctx : TRttiContext;
  602. rType : TRttiType;
  603. jarray : TJSONArray;
  604. member : TJsonValue;
  605. rvalue : TValue;
  606. i : Integer;
  607. n : Integer;
  608. rProp : TRttiProperty;
  609. {$IFDEF DELPHIRX10_UP}
  610. rMethod: TRttiMethod;
  611. {$ELSE}
  612. rfield : TRttiField;
  613. {$ENDIF}
  614. begin
  615. Result := aObject;
  616. rType := ctx.GetType(aObject.ClassInfo);
  617. rProp := rType.GetProperty('List');
  618. if (rProp = nil) or (aJson = nil) or (aJson.ClassType = TJSONNull) then Exit;
  619. member := nil;
  620. //check if exists List (denotes delphi json serialized) or not (normal json serialized)
  621. if aJson.ClassType = TJSONObject then member := GetJsonPairValueByName(aJson,aName);
  622. if member = nil then
  623. begin
  624. if aJson.ClassType <> TJSONArray then raise EJsonDeserializeError.CreateFmt('Not valid value for "%s" List',[aName]);
  625. jArray := TJSONObject.ParseJSONValue(aJson.ToJSON) as TJSONArray;
  626. end
  627. else
  628. begin
  629. if member.ClassType <> TJSONArray then raise EJsonDeserializeError.CreateFmt('Not valid value for "%s" List',[aName]);
  630. jArray := TJSONObject.ParseJSONValue(member.ToJSON) as TJSONArray;
  631. end;
  632. try
  633. rvalue := DeserializeDynArray(rProp.PropertyType.Handle,Result,jArray);
  634. //i := jarray.Count;
  635. finally
  636. jArray.Free;
  637. end;
  638. if not rValue.IsEmpty then
  639. begin
  640. {$IFDEF DELPHIRX10_UP}
  641. if (aObject <> nil) and (rvalue.IsArray) then
  642. begin
  643. rMethod := ctx.GetType(aObject.ClassType).GetMethod('Clear');
  644. if rMethod = nil then
  645. raise EJsonDeserializeError.Create('Unable to find RTTI method');
  646. rMethod.Invoke(aObject, []);
  647. rMethod := ctx.GetType(aObject.ClassType).GetMethod('Add');
  648. if rMethod = nil then
  649. raise EJsonDeserializeError.Create('Unable to find RTTI method');
  650. n := rvalue.GetArrayLength - 1;
  651. for i := 0 to n do
  652. rMethod.Invoke(aObject, [rvalue.GetArrayElement(i)]);
  653. end;
  654. {$ELSE}
  655. n := 0;
  656. for rfield in rType.GetFields do
  657. begin
  658. if rfield.Name = 'FOwnsObjects' then rfield.SetValue(aObject,True);
  659. //if rfield.Name = 'FCount' then rfield.SetValue(aObject,i);
  660. if rfield.Name = 'FItems' then
  661. begin
  662. //if TList(aObject) <> nil then TList(aObject).Clear;
  663. //rfield.GetValue(aObject).AsObject.Free;// aValue.GetReferenceToRawData)
  664. rfield.SetValue(aObject,rValue);// .SetDynArrayProp(aObject,'fItems',Result);
  665. Break;
  666. end;
  667. end;
  668. rProp := rType.GetProperty('Count');
  669. rProp.SetValue(aObject,n);
  670. {$ENDIF}
  671. end;
  672. end;
  673. {$ENDIF}
  674. {$IFNDEF FPC}
  675. procedure TRTTIJson.DeserializeXArray(Instance : TObject; aRecord : TValue; aProperty : TRttiProperty; const aPropertyName : string; aJson : TJsonObject);
  676. var
  677. ctx : TRttiContext;
  678. rRec : TRttiRecordType;
  679. rfield : TRttiField;
  680. rValue : TValue;
  681. member : TJsonValue;
  682. jArray : TJSONArray;
  683. begin
  684. rRec := ctx.GetType(aRecord.TypeInfo).AsRecord;
  685. rfield := rRec.GetField('fArray');
  686. if rfield <> nil then
  687. begin
  688. rValue := nil;
  689. //member := TJSONPair(aJson.GetValue(rField.Name));
  690. member := GetJsonPairValueByName(aJson,aPropertyName);
  691. if (member <> nil) and (rField.FieldType.TypeKind = tkDynArray) then
  692. begin
  693. jArray := TJSONObject.ParseJSONValue(member.ToJSON) as TJSONArray;
  694. try
  695. rValue := DeserializeDynArray(rField.FieldType.Handle,nil,jArray);
  696. finally
  697. jArray.Free;
  698. end;
  699. end;
  700. end;
  701. if not rValue.IsEmpty then rField.SetValue(aRecord.GetReferenceToRawData,rValue);
  702. aProperty.SetValue(Instance,aRecord);
  703. end;
  704. {$ENDIF}
  705. function StringToGUIDEx(const aGUID : string) : TGUID;
  706. begin
  707. if not aGUID.StartsWith('{') then Result := System.SysUtils.StringToGUID('{' + aGUID + '}')
  708. else Result := System.SysUtils.StringToGUID(aGUID);
  709. end;
  710. function TRTTIJson.GUIDToStringFormated(const aGUID : TGUID) : string;
  711. begin
  712. if fOptions.UseGUIDWithBrackets then Result := System.SysUtils.GUIDToString(aGUID)
  713. else Result := GetSubString(System.SysUtils.GUIDToString(aGUID),'{','}');
  714. if fOptions.UseGUIDLowercase then Result := Result.ToLower;
  715. end;
  716. function TRTTIJson.DeserializeProperty(aObject : TObject; const aName : string; aProperty : TRttiProperty; const aJson : TJSONObject) : TObject;
  717. var
  718. rValue : TValue;
  719. {$IFNDEF FPC}
  720. member : TJsonValue;
  721. {$ELSE}
  722. member : TJsonObject;
  723. {$ENDIF}
  724. objClass: TClass;
  725. jArray : TJSONArray;
  726. json : TJSONObject;
  727. begin
  728. Result := aObject;
  729. rValue := nil;
  730. {$IFNDEF FPC}
  731. //member := TJSONPair(aJson.GetValue(aName));
  732. member := GetJsonPairValueByName(aJson,aName);
  733. {$ELSE}
  734. member := TJsonObject(aJson.Find(aName));
  735. {$ENDIF}
  736. if member <> nil then
  737. begin
  738. case aProperty.PropertyType.TypeKind of
  739. tkDynArray :
  740. begin
  741. {$IFNDEF FPC}
  742. if member is TJSONNull then Exit;
  743. jArray := TJSONObject.ParseJSONValue(member.ToJSON) as TJSONArray;
  744. {$ELSE}
  745. if member.ClassType = TJSONNull.ClassType then Exit;
  746. jArray := TJSONArray(TJSONObject.ParseJSONValue(member.ToJSON));
  747. {$ENDIF}
  748. try
  749. {$IFNDEF FPC}
  750. aProperty.SetValue(aObject,DeserializeDynArray(aProperty.PropertyType.Handle,Result,jArray));
  751. {$ELSE}
  752. DeserializeDynArray(aProperty.PropertyType.Handle,aName,Result,jArray);
  753. {$ENDIF}
  754. Exit;
  755. finally
  756. jArray.Free;
  757. end;
  758. end;
  759. tkClass :
  760. begin
  761. //if (member.JsonValue is TJSONObject) then
  762. begin
  763. json := TJsonObject(TJSONObject.ParseJSONValue(member.ToJson));
  764. try
  765. if aProperty.GetValue(aObject).AsObject = nil then
  766. begin
  767. {$IFNDEF FPC}
  768. objClass := aProperty.PropertyType.Handle^.TypeData.ClassType;
  769. rValue := DeserializeClass(objClass,json);
  770. {$ELSE}
  771. objClass := GetObjectPropClass(aObject,aName);
  772. //objClass := GetTypeData(aProperty.PropertyType.Handle)^.ClassType;
  773. rValue := DeserializeClass(objClass,json);
  774. SetObjectProp(aObject,aName,rValue.AsObject);
  775. Exit;
  776. {$ENDIF}
  777. end
  778. else
  779. begin
  780. rValue := DeserializeObject(aProperty.GetValue(aObject).AsObject,json);
  781. Exit;
  782. end;
  783. finally
  784. json.Free;
  785. end;
  786. end
  787. end;
  788. {$IFNDEF FPC}
  789. tkRecord :
  790. begin
  791. if aProperty.GetValue(aObject).TypeInfo = System.TypeInfo(TGUID) then
  792. begin
  793. //get value from TGUID string with and without {} (more compatibility)
  794. rValue:=TValue.From<TGUID>(StringToGUIDEx(UnQuotedStr(member.ToJSON,'"')));
  795. end
  796. else
  797. begin
  798. json := TJSONObject.ParseJSONValue(member.ToJson) as TJSONObject;
  799. try
  800. rValue := DeserializeRecord(aProperty.GetValue(aObject),aObject,json);
  801. finally
  802. json.Free;
  803. end;
  804. end;
  805. end;
  806. {$ENDIF}
  807. else
  808. begin
  809. {$IFNDEF FPC}
  810. //avoid return unicode escaped chars if string
  811. if aProperty.PropertyType.TypeKind in [tkString, tkLString, tkWString, tkUString] then
  812. {$IFDEF DELPHIRX10_UP}
  813. rValue := DeserializeType(aObject,aProperty.PropertyType.TypeKind,aProperty.GetValue(aObject).TypeInfo,TJsonValue(member).value)
  814. {$ELSE}
  815. rValue := DeserializeType(aObject,aProperty.PropertyType.TypeKind,aProperty.GetValue(aObject).TypeInfo,member.Value)
  816. {$ENDIF}
  817. else rValue := DeserializeType(aObject,aProperty.PropertyType.TypeKind,aProperty.GetValue(aObject).TypeInfo,member.ToJSON);
  818. {$ELSE}
  819. rValue := DeserializeType(aObject,aProperty.PropertyType.TypeKind,aName,member.ToJSON);
  820. if not rValue.IsEmpty then SetPropertyValue(aObject,aName,rValue);
  821. {$ENDIF}
  822. end;
  823. end;
  824. {$IFNDEF FPC}
  825. if not rValue.IsEmpty then aProperty.SetValue(Result,rValue);
  826. {$ENDIF}
  827. end;
  828. end;
  829. {$IFNDEF FPC}
  830. function TRTTIJson.DeserializeType(aObject : TObject; aType : TTypeKind; aTypeInfo : PTypeInfo; const aValue: string) : TValue;
  831. var
  832. i : Integer;
  833. value : string;
  834. fsettings : TFormatSettings;
  835. begin
  836. try
  837. value := UnQuotedStr(aValue,'"');
  838. case aType of
  839. tkString, tkLString, tkWString, tkUString :
  840. begin
  841. if fOptions.UseNullStringsAsEmpty and (CompareText(value, 'null') = 0) then
  842. Result := ''
  843. else
  844. Result := value;
  845. end;
  846. tkChar, tkWChar :
  847. begin
  848. Result := value;
  849. end;
  850. tkInteger :
  851. begin
  852. if CompareText(value,'null') <> 0 then Result := StrToIntDef(value,0)
  853. else Result := 0;
  854. end;
  855. tkInt64 :
  856. begin
  857. if CompareText(value,'null') <> 0 then Result := StrToInt64Def(value,0)
  858. else Result := 0;
  859. end;
  860. tkFloat :
  861. begin
  862. if aTypeInfo = TypeInfo(TDateTime) then
  863. begin
  864. if CompareText(value,'null') <> 0 then Result := JsonDateToDateTime(value);
  865. end
  866. else if aTypeInfo = TypeInfo(TDate) then
  867. begin
  868. if CompareText(value,'null') <> 0 then Result := StrToDate(value);
  869. end
  870. else if aTypeInfo = TypeInfo(TTime) then
  871. begin
  872. Result := StrToTime(value);
  873. end
  874. else
  875. begin
  876. fsettings := TFormatSettings.Create;
  877. Result := StrToFloat(StringReplace(value,'.',fsettings.DecimalSeparator,[]));
  878. end;
  879. end;
  880. tkEnumeration :
  881. begin
  882. if aTypeInfo = System.TypeInfo(Boolean) then
  883. begin
  884. Result := StrToBool(value);
  885. end
  886. else
  887. begin
  888. //if fUseEnumNames then TValue.Make(GetEnumValue(aTypeInfo,value),aTypeInfo, Result)
  889. // else TValue.Make(StrToInt(value),aTypeInfo, Result);
  890. if not TryStrToInt(value,i) then TValue.Make(GetEnumValue(aTypeInfo,value),aTypeInfo, Result)
  891. else TValue.Make(StrToInt(value),aTypeInfo, Result);
  892. end;
  893. end;
  894. tkSet :
  895. begin
  896. i := StringToSet(aTypeInfo,value);
  897. TValue.Make(@i,aTypeInfo,Result);
  898. end;
  899. else
  900. begin
  901. //raise EclJsonSerializerError.Create('Not supported data type!');
  902. end;
  903. end;
  904. except
  905. on E : Exception do
  906. begin
  907. raise EJsonDeserializeError.CreateFmt('Deserialize error type "%s.%s" : %s',[aObject.ClassName,GetTypeName(aTypeInfo),e.Message]);
  908. end;
  909. end;
  910. end;
  911. {$ELSE}
  912. function TRTTIJson.DeserializeType(aObject : TObject; aType : TTypeKind; const aPropertyName, aValue: string) : TValue;
  913. var
  914. value : string;
  915. propinfo : PPropInfo;
  916. fsettings : TFormatSettings;
  917. begin
  918. try
  919. value := UnQuotedStr(aValue,'"');
  920. if value = '' then
  921. begin
  922. Result := nil;
  923. Exit;
  924. end;
  925. propinfo := GetPropInfo(aObject,aPropertyName);
  926. //case propinfo.PropType.Kind of
  927. case aType of
  928. tkString, tkLString, tkWString, tkUString, tkAString :
  929. begin
  930. Result := value;
  931. //SetStrProp(aObject,propinfo,value);
  932. end;
  933. tkChar, tkWChar :
  934. begin
  935. Result := value;
  936. end;
  937. tkInteger :
  938. begin
  939. if CompareText(value,'null') <> 0 then Result := StrToInt(value)
  940. else Result := 0;
  941. end;
  942. tkInt64 :
  943. begin
  944. if CompareText(value,'null') <> 0 then Result := StrToInt64(value)
  945. else Result := 0;
  946. end;
  947. tkFloat :
  948. begin
  949. if propinfo.PropType = TypeInfo(TDateTime) then
  950. begin
  951. if CompareText(value,'null') <> 0 then Result := JsonDateToDateTime(value);
  952. end
  953. else if propinfo.PropType = TypeInfo(TDate) then
  954. begin
  955. if CompareText(value,'null') <> 0 then Result := StrToDate(value);
  956. end
  957. else if propinfo.PropType = TypeInfo(TTime) then
  958. begin
  959. Result := StrToTime(value);
  960. end
  961. else
  962. begin
  963. fsettings := DefaultFormatSettings;
  964. Result := StrToFloat(StringReplace(value,'.',fsettings.DecimalSeparator,[]));
  965. end;
  966. end;
  967. tkEnumeration:
  968. begin
  969. Result := value;
  970. end;
  971. tkBool :
  972. begin
  973. Result := StrToBool(value);
  974. end;
  975. tkSet :
  976. begin
  977. Result := value;
  978. end;
  979. else
  980. begin
  981. //raise EclJsonSerializerError.Create('Not supported data type!');
  982. end;
  983. end;
  984. //if not Result.IsEmpty then SetPropertyValue(aObject,propinfo,Result);
  985. except
  986. on E : Exception do
  987. begin
  988. raise EJsonDeserializeError.CreateFmt('Deserialize error type "%s" : %s',[aObject.ClassName,e.Message]);
  989. end;
  990. end;
  991. end;
  992. {$ENDIF}
  993. function TRTTIJson.IsAllowedProperty(aObject : TObject; const aPropertyName : string) : Boolean;
  994. var
  995. propname : string;
  996. begin
  997. Result := True;
  998. propname := aPropertyName.ToLower;
  999. if IsGenericList(aObject) then
  1000. begin
  1001. if (propname = 'capacity') or (propname = 'count') or (propname = 'ownsobjects') then Result := False;
  1002. end
  1003. else if (propname = 'refcount') then Result := False;
  1004. end;
  1005. function TRTTIJson.IsGenericList(aObject : TObject) : Boolean;
  1006. var
  1007. cname : string;
  1008. begin
  1009. if aObject = nil then Exit(False);
  1010. cname := aObject.ClassName;
  1011. Result := (cname.StartsWith('TObjectList')) or (cname.StartsWith('TList'));
  1012. end;
  1013. function TRTTIJson.IsStream(aObject : TObject) : Boolean;
  1014. begin
  1015. if aObject = nil then Exit(False);
  1016. Result := aObject.InheritsFrom(TStream);
  1017. end;
  1018. function TRTTIJson.GetGenericListType(aObject : TObject) : TGenericListType;
  1019. var
  1020. cname : string;
  1021. begin
  1022. if aObject = nil then Exit(TGenericListType.gtNone);
  1023. cname := aObject.ClassName;
  1024. if cname.StartsWith('TObjectList') then Result := TGenericListType.gtObjectList
  1025. else if cname.StartsWith('TList') then Result := TGenericListType.gtList
  1026. else Result := TGenericListType.gtNone;
  1027. end;
  1028. function TRTTIJson.IsGenericXArray(const aClassName : string) : Boolean;
  1029. begin
  1030. Result := aClassName.StartsWith('TXArray');
  1031. end;
  1032. function TRTTIJson.GetJsonPairValueByName(aJson: TJSONObject; const aName: string): TJsonValue;
  1033. var
  1034. candidate : TJSONPair;
  1035. i : Integer;
  1036. begin
  1037. if fOptions.UseJsonCaseSense then
  1038. begin
  1039. Result := aJson.GetValue(aName);
  1040. Exit;
  1041. end
  1042. else
  1043. begin
  1044. for i := 0 to aJson.Count - 1 do
  1045. begin
  1046. candidate := aJson.Pairs[I];
  1047. if candidate.JsonValue = nil then continue;
  1048. if CompareText(candidate.JsonString{$IFNDEF FPC}.Value{$ENDIF},aName) = 0 then Exit(candidate.JsonValue);
  1049. end;
  1050. end;
  1051. Result := nil;
  1052. end;
  1053. function TRTTIJson.GetJsonPairByName(aJson: TJSONObject; const aName: string): TJSONPair;
  1054. var
  1055. i : Integer;
  1056. begin
  1057. if fOptions.UseJsonCaseSense then
  1058. begin
  1059. Result := TJSONPair(aJson.GetValue(aName));
  1060. Exit;
  1061. end
  1062. else
  1063. begin
  1064. if aJson <> nil then
  1065. begin
  1066. for i := 0 to aJson.Count - 1 do
  1067. begin
  1068. Result := aJson.Pairs[I];
  1069. if Result.JsonValue = nil then continue;
  1070. if CompareText(Result.JsonString{$IFNDEF FPC}.Value{$ENDIF},aName) = 0 then Exit;
  1071. end;
  1072. end;
  1073. end;
  1074. Result := nil;
  1075. end;
  1076. //function TRTTIJson.GetPropertyValue(Instance : TObject; const PropertyName : string) : TValue;
  1077. //var
  1078. // pinfo : PPropInfo;
  1079. //begin
  1080. // Result := nil;
  1081. // pinfo := GetPropInfo(Instance,PropertyName);
  1082. // if pinfo = nil then raise EJsonSerializeError.CreateFmt('Property "%s" not found!',[PropertyName]);
  1083. // case pinfo.PropType^.Kind of
  1084. // tkInteger : Result := GetOrdProp(Instance,pinfo);
  1085. // tkInt64 : Result := GetInt64Prop(Instance,PropertyName);
  1086. // tkFloat : Result := GetFloatProp(Instance,PropertyName);
  1087. // tkChar : Result := Char(GetOrdProp(Instance,PropertyName));
  1088. // {$IFDEF FPC}
  1089. // tkWString : Result := GetWideStrProp(Instance,PropertyName);
  1090. // tkSString,
  1091. // tkAString,
  1092. // {$ELSE}
  1093. // tkWString,
  1094. // {$ENDIF}
  1095. // tkLString : Result := GetStrProp(Instance,pinfo);
  1096. // {$IFDEF FPC}
  1097. // tkEnumeration :
  1098. // begin
  1099. // if fUseEnumNames then Result := GetEnumName(pinfo.PropType,GetOrdProp(Instance,PropertyName))
  1100. // else Result := GetOrdProp(Instance,PropertyName);
  1101. // end;
  1102. // {$ELSE}
  1103. // tkEnumeration :
  1104. // begin
  1105. // if fUseEnumNames then Result := GetEnumName(@pinfo.PropType,GetOrdProp(Instance,PropertyName))
  1106. // else Result := GetOrdProp(Instance,PropertyName);
  1107. // end;
  1108. // {$ENDIF}
  1109. // tkSet : Result := GetSetProp(Instance,pinfo,True);
  1110. // {$IFNDEF FPC}
  1111. // tkClass :
  1112. // {$ELSE}
  1113. // tkBool : Result := Boolean(GetOrdProp(Instance,pinfo));
  1114. // tkObject :
  1115. // {$ENDIF} Result := GetObjectProp(Instance,pinfo);
  1116. // tkDynArray : Result := GetDynArrayProp(Instance,pinfo);
  1117. // end;
  1118. //end;
  1119. function TRTTIJson.GetPropertyValueFromObject(Instance : TObject; const PropertyName : string) : TValue;
  1120. var
  1121. ctx : TRttiContext;
  1122. rprop : TRttiProperty;
  1123. begin
  1124. rprop := ctx.GetType(Instance.ClassInfo).GetProperty(PropertyName);
  1125. Result := rprop.GetValue(Instance);
  1126. end;
  1127. {$IFNDEF FPC}
  1128. function TRTTIJson.GetFieldValueFromRecord(const aValue : TValue; const FieldName : string) : TValue;
  1129. var
  1130. ctx : TRttiContext;
  1131. rec : TRttiRecordType;
  1132. rfield : TRttiField;
  1133. begin
  1134. rec := ctx.GetType(aValue.TypeInfo).AsRecord;
  1135. rfield := rec.GetField(FieldName);
  1136. if rfield <> nil then Result := rField.GetValue(aValue.GetReferenceToRawData)
  1137. else Result := nil;
  1138. end;
  1139. {$ENDIF}
  1140. {$IFDEF FPC}
  1141. procedure TRTTIJson.SetPropertyValue(Instance : TObject; const PropertyName : string; aValue : TValue);
  1142. var
  1143. pinfo : PPropInfo;
  1144. begin
  1145. pinfo := GetPropInfo(Instance,PropertyName);
  1146. SetPropertyValue(Instance,pinfo,aValue);
  1147. end;
  1148. procedure TRTTIJson.SetPropertyValue(Instance : TObject; aPropInfo : PPropInfo; aValue : TValue);
  1149. begin
  1150. case aPropInfo.PropType^.Kind of
  1151. tkInteger : SetOrdProp(Instance,aPropInfo,aValue.AsInteger);
  1152. tkInt64 : SetInt64Prop(Instance,aPropInfo,aValue.AsInt64);
  1153. tkFloat : SetFloatProp(Instance,aPropInfo,aValue.AsExtended);
  1154. tkChar : SetOrdProp(Instance,aPropInfo,aValue.AsOrdinal);
  1155. {$IFDEF FPC}
  1156. tkWString : SetWideStrProp(Instance,aPropInfo,aValue.AsString);
  1157. tkSString,
  1158. tkAString,
  1159. {$ELSE}
  1160. tkWString,
  1161. {$ENDIF}
  1162. tkLString : SetStrProp(Instance,aPropInfo,aValue.AsString);
  1163. {$IFDEF FPC}
  1164. tkBool : SetOrdProp(Instance,aPropInfo,aValue.AsOrdinal);
  1165. tkSet : LoadSetProperty(Instance,aPropInfo,aValue.AsString);
  1166. {$ENDIF}
  1167. tkEnumeration : SetEnumProp(Instance,aPropInfo,aValue.AsString);
  1168. {$IFNDEF FPC}
  1169. tkClass :
  1170. {$ELSE}
  1171. tkObject :
  1172. {$ENDIF} SetObjectProp(Instance,aPropInfo,aValue.AsObject);
  1173. end;
  1174. end;
  1175. procedure TRTTIJson.LoadSetProperty(aInstance : TObject; aPropInfo: PPropInfo; const aValue: string);
  1176. type
  1177. TCardinalSet = set of 0..SizeOf(Cardinal) * 8 - 1;
  1178. const
  1179. Delims = [' ', ',', '[', ']'];
  1180. var
  1181. TypeInfo: PTypeInfo;
  1182. W: Cardinal;
  1183. I, N: Integer;
  1184. Count: Integer;
  1185. EnumName: string;
  1186. begin
  1187. W := 0;
  1188. TypeInfo := GetTypeData(GetPropType(aPropInfo))^.CompType;
  1189. Count := WordCount(aValue, Delims);
  1190. for N := 1 to Count do
  1191. begin
  1192. EnumName := ExtractWord(N, aValue, Delims);
  1193. try
  1194. I := GetEnumValue(TypeInfo, EnumName);
  1195. if I >= 0 then Include(TCardinalSet(W),I);
  1196. except
  1197. end;
  1198. end;
  1199. SetOrdProp(aInstance,aPropInfo,W);
  1200. end;
  1201. {$ENDIF}
  1202. function TRTTIJson.SerializeObject(aObject: TObject): TJSONObject;
  1203. var
  1204. ctx: TRttiContext;
  1205. {$IFNDEF FPC}
  1206. attr : TCustomAttribute;
  1207. comment : string;
  1208. {$ENDIF}
  1209. rType: TRttiType;
  1210. rProp: TRttiProperty;
  1211. jpair : TJSONPair;
  1212. ExcludeSerialize : Boolean;
  1213. propertyname : string;
  1214. propvalue : TValue;
  1215. begin
  1216. if (aObject = nil) then
  1217. begin
  1218. Result := nil;
  1219. Exit;
  1220. end;
  1221. Result := nil;
  1222. try
  1223. //if is GenericList
  1224. if IsGenericList(aObject) then
  1225. begin
  1226. //get list array
  1227. propvalue := GetPropertyValueFromObject(aObject,'List');
  1228. {$IFDEF DELPHIRX10_UP}
  1229. Result := TJSONObject(SerializeDynArray(propvalue));
  1230. {$ELSE}
  1231. Result := TJSONObject(SerializeValue(propvalue));
  1232. {$ENDIF}
  1233. Exit;
  1234. end
  1235. {$IFNDEF FPC}
  1236. else if IsStream(aObject) then
  1237. begin
  1238. Result := TJSONObject(SerializeStream(aObject));
  1239. Exit;
  1240. end
  1241. {$ENDIF}
  1242. else Result := TJSONObject.Create;
  1243. //if is standard object
  1244. propertyname := '';
  1245. rType := ctx.GetType(aObject.ClassInfo);
  1246. for rProp in TRTTI.GetProperties(rType,roFirstBase) do
  1247. begin
  1248. ExcludeSerialize := False;
  1249. propertyname := rProp.Name;
  1250. {$IFNDEF FPC}
  1251. comment := '';
  1252. if not rProp.IsReadable then Continue;
  1253. for attr in rProp.GetAttributes do
  1254. begin
  1255. if attr is TNotSerializableProperty then ExcludeSerialize := True
  1256. else if attr is TCommentProperty then comment := TCommentProperty(attr).Comment
  1257. else if attr is TCustomNameProperty then propertyname := TCustomNameProperty(attr).Name;
  1258. end;
  1259. if ((fSerializeLevel = slPublicProperty) and (rProp.PropertyType.IsPublicType))
  1260. or ((fSerializeLevel = slPublishedProperty) and ((IsPublishedProp(aObject,rProp.Name)) or (rProp.Name = 'List'))) then
  1261. {$ENDIF}
  1262. begin
  1263. if (IsAllowedProperty(aObject,propertyname)) and (not ExcludeSerialize) then
  1264. begin
  1265. //add comment as pair
  1266. {$IFNDEF FPC}
  1267. if comment <> '' then Result.AddPair(TJSONPair.Create('#Comment#->'+propertyname,Comment));
  1268. {$ENDIF}
  1269. begin
  1270. propvalue := rProp.GetValue(aObject);
  1271. jpair := TJSONPair.Create(propertyName,nil);
  1272. // if (propvalue.IsObject) and (IsGenericList(propvalue.AsObject)) then
  1273. // begin
  1274. // jpair.JsonValue := SerializeValue(GetPropertyValueFromObject(propvalue.AsObject,'List'));
  1275. // end
  1276. if propvalue.IsObject then jpair.JsonValue := SerializeObject(propvalue.AsObject)
  1277. {$IFNDEF FPC}
  1278. else if (not propvalue.IsObject) and (IsGenericXArray(string(propvalue{$IFNDEF NEXTGEN}.TypeInfo.Name{$ELSE}.TypeInfo.NameFld.ToString{$ENDIF}))) then
  1279. begin
  1280. jpair.JsonValue := SerializeValue(GetFieldValueFromRecord(propvalue,'fArray'));
  1281. end
  1282. {$ENDIF}
  1283. else
  1284. begin
  1285. {$IFNDEF FPC}
  1286. jpair.JsonValue := SerializeValue(propvalue);
  1287. {$ELSE}
  1288. jpair.JsonValue := SerializeValue(propvalue);// SerializeObject(aObject,rProp.PropertyType.TypeKind,propertyname);
  1289. {$ENDIF}
  1290. end;
  1291. //s := jpair.JsonValue.ToString;
  1292. if jpair.JsonValue <> nil then
  1293. begin
  1294. Result.AddPair(jpair);
  1295. end
  1296. else jpair.Free;
  1297. end;
  1298. end;
  1299. end;
  1300. end;
  1301. except
  1302. on E : Exception do
  1303. begin
  1304. if Result <> nil then Result.Free;
  1305. if not propertyname.IsEmpty then raise EJsonSerializeError.CreateFmt('Serialize Error -> Object property: "%s" (%s)',[propertyname,e.Message])
  1306. else raise EJsonSerializeError.CreateFmt('Serialize Error -> Object (%s)',[e.Message]);
  1307. end;
  1308. end;
  1309. end;
  1310. function TRTTIJson.GetValue(aAddr: Pointer; aType: TRTTIType): TValue;
  1311. begin
  1312. TValue.Make(aAddr,aType.Handle,Result);
  1313. end;
  1314. {$IFDEF FPC}
  1315. function TRTTIJson.GetValue(aAddr: Pointer; aTypeInfo: PTypeInfo): TValue;
  1316. begin
  1317. TValue.Make(aAddr,aTypeInfo,Result);
  1318. end;
  1319. {$ENDIF}
  1320. function TRTTIJson.SerializeValue(const aValue : TValue) : TJSONValue;
  1321. begin
  1322. Result := nil;
  1323. case avalue.Kind of
  1324. tkDynArray :
  1325. begin
  1326. {$IFNDEF FPC}
  1327. Result := SerializeDynArray(aValue);
  1328. {$ENDIF}
  1329. end;
  1330. tkClass :
  1331. begin
  1332. Result := TJSONValue(SerializeObject(aValue.AsObject));
  1333. end;
  1334. tkInterface :
  1335. begin
  1336. {$IFDEF DELPHIRX10_UP}
  1337. // Would not work with iOS/Android native interfaces
  1338. Result := TJSONValue(SerializeObject(aValue.AsInterface as TObject));
  1339. {$ENDIF}
  1340. end;
  1341. tkString, tkLString, tkWString, tkUString :
  1342. begin
  1343. Result := TJSONString.Create(aValue.AsString);
  1344. end;
  1345. tkChar, tkWChar :
  1346. begin
  1347. Result := TJSONString.Create(aValue.AsString);
  1348. end;
  1349. tkInteger :
  1350. begin
  1351. Result := TJSONNumber.Create(aValue.AsInteger);
  1352. end;
  1353. tkInt64 :
  1354. begin
  1355. Result := TJSONNumber.Create(aValue.AsInt64);
  1356. end;
  1357. tkFloat :
  1358. begin
  1359. if aValue.TypeInfo = TypeInfo(TDateTime) then
  1360. begin
  1361. if aValue.AsExtended <> 0.0 then Result := TJSONString.Create(DateTimeToJsonDate(aValue.AsExtended));
  1362. end
  1363. else if aValue.TypeInfo = TypeInfo(TDate) then
  1364. begin
  1365. if aValue.AsExtended <> 0.0 then Result := TJSONString.Create(DateToStr(aValue.AsExtended));
  1366. end
  1367. else if aValue.TypeInfo = TypeInfo(TTime) then
  1368. begin
  1369. Result := TJSONString.Create(TimeToStr(aValue.AsExtended));
  1370. end
  1371. else
  1372. begin
  1373. Result := TJSONNumber.Create(aValue.AsExtended);
  1374. end;
  1375. end;
  1376. tkEnumeration :
  1377. begin
  1378. if (aValue.TypeInfo = System.TypeInfo(Boolean)) then
  1379. begin
  1380. {$IF Defined(DELPHIRX10_UP) OR Defined(FPC)}
  1381. Result := TJSONBool.Create(aValue.AsBoolean);
  1382. {$ELSE}
  1383. if aValue.AsBoolean then Result := TJsonTrue.Create
  1384. else Result := TJsonFalse.Create;
  1385. {$ENDIF}
  1386. end
  1387. else
  1388. begin
  1389. //Result.JsonValue := TJSONString.Create(GetEnumName(aValue.TypeInfo,aValue.AsOrdinal));
  1390. if fUseEnumNames then Result := TJSONString.Create(aValue.ToString)
  1391. else Result := TJSONNumber.Create(GetEnumValue(aValue.TypeInfo,aValue.ToString));
  1392. end;
  1393. end;
  1394. {$IFDEF FPC}
  1395. tkBool :
  1396. begin
  1397. Result := TJSONBool.Create(aValue.AsBoolean);
  1398. end;
  1399. {$ENDIF}
  1400. tkSet :
  1401. begin
  1402. Result := TJSONString.Create(aValue.ToString);
  1403. end;
  1404. tkRecord :
  1405. begin
  1406. {$IFNDEF FPC}
  1407. Result := SerializeRecord(aValue);
  1408. {$ENDIF}
  1409. end;
  1410. tkVariant :
  1411. begin
  1412. {$IFNDEF FPC}
  1413. case VarType(aValue.AsVariant) and VarTypeMask of
  1414. varInteger, varInt64 : Result := TJSONNumber.Create(aValue.AsInteger);
  1415. varString, varUString, varEmpty : Result := TJSONString.Create(aValue.AsString);
  1416. varDouble : Result := TJSONNumber.Create(aValue.AsExtended);
  1417. end;
  1418. {$ENDIF}
  1419. end;
  1420. tkMethod, tkPointer, tkClassRef, tkProcedure, tkUnknown :
  1421. begin
  1422. //skip these properties
  1423. end
  1424. else
  1425. begin
  1426. {$IFNDEF FPC}
  1427. raise EJsonSerializeError.CreateFmt(cNotSupportedDataType,[GetTypeName(aValue.TypeInfo)]);
  1428. {$ELSE}
  1429. raise EJsonSerializeError.Create('Not supported Data Type');
  1430. {$ENDIF}
  1431. end;
  1432. end;
  1433. if Result = nil then Result := TJSONNull.Create;
  1434. end;
  1435. function TRTTIJson.SerializeStream(aObject: TObject): TJSONValue;
  1436. var
  1437. stream : TStream;
  1438. begin
  1439. Result := nil;
  1440. try
  1441. stream := TStream(aObject);
  1442. if fOptions.UseBase64Stream then Result := TJSONString.Create(Base64Encode(StreamToString(stream,TEncoding.Ansi)))
  1443. else Result := TJSONString.Create(StreamToString(stream,TEncoding.Ansi));
  1444. except
  1445. on E : Exception do
  1446. begin
  1447. EJsonSerializeError.CreateFmt('Serialize Error -> Stream (%s)',[e.Message]);
  1448. end;
  1449. end;
  1450. end;
  1451. {$IFNDEF FPC}
  1452. function TRTTIJson.SerializeDynArray(const aValue: TValue; aMaxElements : Integer = -1) : TJsonArray;
  1453. var
  1454. ctx : TRttiContext;
  1455. rDynArray : TRTTIDynamicArrayType;
  1456. i : Integer;
  1457. jValue : TJSONValue;
  1458. element : Integer;
  1459. list : TList<TJSONValue>;
  1460. len : Integer;
  1461. begin
  1462. element := -1;
  1463. Result := TJSONArray.Create;
  1464. try
  1465. rDynArray := ctx.GetType(aValue.TypeInfo) as TRTTIDynamicArrayType;
  1466. //if aValue.IsObjectInstance then TList<TObject>(aValue.AsObject).TrimExcess;
  1467. list := TList<TJSONValue>.Create;
  1468. if aMaxElements = -1 then len := aValue.GetArrayLength
  1469. else len := aMaxElements;
  1470. list.Capacity := len;
  1471. for i := 0 to len - 1 do
  1472. begin
  1473. if not GetValue(PPByte(aValue.GetReferenceToRawData)^ + rDynArray.ElementType.TypeSize * i, rDynArray.ElementType).IsEmpty then
  1474. begin
  1475. element := i;
  1476. jValue := SerializeValue(GetValue(PPByte(aValue.GetReferenceToRawData)^ + rDynArray.ElementType.TypeSize * i, rDynArray.ElementType));
  1477. if jValue = nil then jValue := TJSONNull.Create;
  1478. list.Add(jValue);
  1479. end;
  1480. end;
  1481. Result.SetElements(list);
  1482. except
  1483. on E : Exception do
  1484. begin
  1485. if element > -1 then raise EJsonSerializeError.CreateFmt('Serialize Error -> Array[%d] (%s)',[element,e.Message])
  1486. else raise EJsonSerializeError.CreateFmt('Serialize Error -> Array (%s)',[e.Message]);
  1487. end;
  1488. end;
  1489. end;
  1490. function TRTTIJson.SerializeRecord(const aValue : TValue) : TJSONValue;
  1491. var
  1492. ctx : TRttiContext;
  1493. json : TJSONObject;
  1494. rRec : TRttiRecordType;
  1495. rField : TRttiField;
  1496. begin
  1497. rField := nil;
  1498. try
  1499. rRec := ctx.GetType(aValue.TypeInfo).AsRecord;
  1500. if aValue.TypeInfo = System.TypeInfo(TGUID) then
  1501. begin
  1502. Result := TJSONString.Create(GUIDToStringFormated(aValue.AsType<TGUID>));
  1503. end
  1504. else
  1505. begin
  1506. json := TJSONObject.Create;
  1507. for rField in rRec.GetFields do
  1508. begin
  1509. json.AddPair(rField.Name,SerializeValue(rField.GetValue(aValue.GetReferenceToRawData)));
  1510. end;
  1511. Result := json;
  1512. end;
  1513. except
  1514. on E : Exception do
  1515. begin
  1516. if rField <> nil then raise EJsonSerializeError.CreateFmt('Serialize Error -> Record property "%s" (%s)',[rField.Name,e.Message])
  1517. else raise EJsonSerializeError.CreateFmt('Serialize Error -> Record (%s)',[e.Message]);
  1518. end;
  1519. end;
  1520. end;
  1521. {$ELSE}
  1522. function TRTTIJson.GetPropType(aPropInfo: PPropInfo): PTypeInfo;
  1523. begin
  1524. Result := aPropInfo^.PropType;
  1525. end;
  1526. function TRTTIJson.FloatProperty(aObject : TObject; aPropInfo: PPropInfo): string;
  1527. const
  1528. Precisions: array[TFloatType] of Integer = (7, 15, 18, 18, 19);
  1529. var
  1530. fsettings : TFormatSettings;
  1531. begin
  1532. fsettings := FormatSettings;
  1533. Result := StringReplace(FloatToStrF(GetFloatProp(aObject, aPropInfo), ffGeneral,
  1534. Precisions[GetTypeData(GetPropType(aPropInfo))^.FloatType],0),
  1535. '.',fsettings.DecimalSeparator,[rfReplaceAll]);
  1536. end;
  1537. function TRTTIJson.SerializeObject(aObject : TObject; aType : TTypeKind; const aPropertyName : string) : TJSONPair;
  1538. var
  1539. propinfo : PPropInfo;
  1540. jArray : TJsonArray;
  1541. jPair : TJsonPair;
  1542. jValue : TJsonValue;
  1543. i : Integer;
  1544. pArr : Pointer;
  1545. rValue : TValue;
  1546. rItemValue : TValue;
  1547. len : Integer;
  1548. begin
  1549. try
  1550. Result := TJSONPair.Create(aPropertyName,nil);
  1551. propinfo := GetPropInfo(aObject,aPropertyName);
  1552. //case propinfo.PropType.Kind of
  1553. case aType of
  1554. tkDynArray :
  1555. begin
  1556. len := 0;
  1557. jArray := TJSONArray.Create;
  1558. try
  1559. pArr := GetDynArrayProp(aObject,aPropertyName);
  1560. TValue.Make(@pArr,propinfo.PropType, rValue);
  1561. if rValue.IsArray then
  1562. begin
  1563. len := rValue.GetArrayLength;
  1564. for i := 0 to len - 1 do
  1565. begin
  1566. rItemValue := rValue.GetArrayElement(i);
  1567. jValue := SerializeValue(rItemValue);
  1568. jArray.Add(jValue);
  1569. end;
  1570. end;
  1571. Result.JsonValue := jArray;
  1572. finally
  1573. //DynArrayClear(pArr,propinfo.PropType);
  1574. pArr := nil;
  1575. end;
  1576. end;
  1577. tkClass :
  1578. begin
  1579. Result.JsonValue := TJSONValue(SerializeObject(GetObjectProp(aObject,aPropertyName)));
  1580. end;
  1581. tkString, tkLString, tkWString, tkUString, tkAString :
  1582. begin
  1583. Result.JsonValue := TJSONString.Create(GetStrProp(aObject,aPropertyName));
  1584. end;
  1585. tkChar, tkWChar :
  1586. begin
  1587. Result.JsonValue := TJSONString.Create(Char(GetOrdProp(aObject,aPropertyName)));
  1588. end;
  1589. tkInteger :
  1590. begin
  1591. Result.JsonValue := TJSONNumber.Create(GetOrdProp(aObject,aPropertyName));
  1592. end;
  1593. tkInt64 :
  1594. begin
  1595. Result.JsonValue := TJSONNumber.Create(GetOrdProp(aObject,aPropertyName));
  1596. end;
  1597. tkFloat :
  1598. begin
  1599. if propinfo.PropType = TypeInfo(TDateTime) then
  1600. begin
  1601. Result.JsonValue := TJSONString.Create(DateTimeToJsonDate(GetFloatProp(aObject,aPropertyName)));
  1602. end
  1603. else if propinfo.PropType = TypeInfo(TDate) then
  1604. begin
  1605. Result.JsonValue := TJSONString.Create(DateToStr(GetFloatProp(aObject,aPropertyName)));
  1606. end
  1607. else if propinfo.PropType = TypeInfo(TTime) then
  1608. begin
  1609. Result.JsonValue := TJSONString.Create(TimeToStr(GetFloatProp(aObject,aPropertyName)));
  1610. end
  1611. else
  1612. begin
  1613. //Result.JsonValue := TJsonFloatNumber.Create(GetFloatProp(aObject,aPropertyName));
  1614. Result.JsonValue := TJsonFloatNumber.Create(StrToFloat(FloatProperty(aObject,propinfo)));
  1615. end;
  1616. end;
  1617. tkEnumeration,tkBool :
  1618. begin
  1619. if (propinfo.PropType = System.TypeInfo(Boolean)) then
  1620. begin
  1621. Result.JsonValue := TJSONBool.Create(Boolean(GetOrdProp(aObject,aPropertyName)));
  1622. end
  1623. else
  1624. begin
  1625. if fUseEnumNames then Result.JsonValue := TJSONString.Create(GetEnumName(propinfo.PropType,GetOrdProp(aObject,aPropertyName)))
  1626. else Result.JsonValue := TJSONNumber.Create(GetOrdProp(aObject,aPropertyName));
  1627. //Result.JsonValue := TJSONString.Create(aValue.ToString);
  1628. end;
  1629. end;
  1630. tkSet :
  1631. begin
  1632. Result.JsonValue := TJSONString.Create(GetSetProp(aObject,aPropertyName));
  1633. end;
  1634. {$IFNDEF FPC}
  1635. tkRecord :
  1636. begin
  1637. Result.JsonValue := SerializeRecord(aValue);
  1638. end;
  1639. {$ENDIF}
  1640. tkMethod, tkPointer, tkClassRef ,tkInterface, tkProcedure :
  1641. begin
  1642. //skip these properties
  1643. //FreeAndNil(Result);
  1644. end
  1645. else
  1646. begin
  1647. //raise EJsonDeserializeError.CreateFmt('Not supported type "%s":%d',[aName,Integer(aValue.Kind)]);
  1648. end;
  1649. end;
  1650. if Result.JsonValue = nil then Result.JsonValue := TJSONNull.Create;
  1651. except
  1652. on E : Exception do
  1653. begin
  1654. Result.Free;
  1655. {$IFNDEF FPC}
  1656. raise EJsonSerializeError.CreateFmt('Serialize error class "%s.%s" : %s',[aName,aValue.ToString,e.Message]);
  1657. {$ENDIF}
  1658. end;
  1659. end;
  1660. end;
  1661. {$ENDIF}
  1662. { TJsonSerializer}
  1663. constructor TJsonSerializer.Create(aSerializeLevel: TSerializeLevel; aUseEnumNames : Boolean = True; aUseNullStringsAsEmpty : Boolean = False);
  1664. begin
  1665. {$IFDEF FPC}
  1666. if aSerializeLevel = TSerializeLevel.slPublicProperty then raise EJsonSerializeError.Create('FreePascal RTTI only supports published properties');
  1667. {$ENDIF}
  1668. fSerializeLevel := aSerializeLevel;
  1669. fUseEnumNames := aUseEnumNames;
  1670. fUseJsonCaseSense := False;
  1671. fUseBase64Stream := True;
  1672. fUseNullStringsAsEmpty := aUseNullStringsAsEmpty;
  1673. fRTTIJson := TRTTIJson.Create(aSerializeLevel,aUseEnumNames);
  1674. fRTTIJson.Options.UseJsonCaseSense := fUseJsonCaseSense;
  1675. fRTTIJson.Options.UseBase64Stream := fUseBase64Stream;
  1676. fRTTIJson.Options.UseNullStringsAsEmpty := fUseNullStringsAsEmpty;
  1677. end;
  1678. destructor TJsonSerializer.Destroy;
  1679. begin
  1680. fRTTIJson.Free;
  1681. inherited;
  1682. end;
  1683. function TJsonSerializer.JsonToObject(aType: TClass; const aJson: string): TObject;
  1684. var
  1685. jvalue : TJSONValue;
  1686. json: TJSONObject;
  1687. begin
  1688. {$IFDEF DEBUG_SERIALIZER}
  1689. TDebugger.TimeIt(Self,'JsonToObject',aType.ClassName);
  1690. {$ENDIF}
  1691. try
  1692. {$IFDEF DELPHIRX10_UP}
  1693. jvalue := TJSONObject.ParseJSONValue(aJson,True);
  1694. if jvalue.ClassType = TJSONArray then json := TJSONObject(jvalue)
  1695. else json := jvalue as TJSONObject;
  1696. {$ELSE}
  1697. {$IFDEF FPC}
  1698. json := TJSONObject(TJSONObject.ParseJSONValue(aJson,True));
  1699. {$ELSE}
  1700. json := TJsonObject.ParseJSONValue(TEncoding.UTF8.GetBytes(aJson),0,True) as TJSONObject;
  1701. {$ENDIF}
  1702. {$ENDIF}
  1703. except
  1704. raise EJsonDeserializeError.Create(cNotValidJson);
  1705. end;
  1706. try
  1707. Result := fRTTIJson.DeserializeClass(aType,json);
  1708. finally
  1709. json.Free;
  1710. end;
  1711. end;
  1712. function TJsonSerializer.JsonToObject(aObject: TObject; const aJson: string): TObject;
  1713. var
  1714. jvalue : TJSONValue;
  1715. json: TJSONObject;
  1716. begin;
  1717. if aObject = nil then raise EJsonDeserializeError.Create('Object param cannot be null!');
  1718. {$IFDEF DEBUG_SERIALIZER}
  1719. TDebugger.TimeIt(Self,'JsonToObject',aObject.ClassName);
  1720. {$ENDIF}
  1721. try
  1722. {$IFDEF DELPHIRX10_UP}
  1723. jvalue := TJSONObject.ParseJSONValue(aJson,True);
  1724. if jvalue.ClassType = TJSONArray then json := TJSONObject(jvalue)
  1725. else json := jvalue as TJSONObject;
  1726. //json := TJSONObject.ParseJSONValue(aJson,True) as TJSONObject;
  1727. {$ELSE}
  1728. {$IFDEF FPC}
  1729. json := TJSONObject(TJSONObject.ParseJSONValue(aJson,True));
  1730. {$ELSE}
  1731. json := TJsonObject.ParseJSONValue(TEncoding.UTF8.GetBytes(aJson),0,True) as TJSONObject;
  1732. {$ENDIF}
  1733. {$ENDIF}
  1734. except
  1735. raise EJsonDeserializeError.Create(cNotValidJson);
  1736. end;
  1737. try
  1738. Result := fRTTIJson.DeserializeObject(aObject,json);
  1739. finally
  1740. json.Free;
  1741. end;
  1742. end;
  1743. function TJsonSerializer.ObjectToJson(aObject : TObject; aIndent : Boolean = False): string;
  1744. var
  1745. json: TJSONObject;
  1746. begin
  1747. {$IFDEF DEBUG_SERIALIZER}
  1748. TDebugger.TimeIt(Self,'ObjectToJson',aObject.ClassName);
  1749. {$ENDIF}
  1750. json := fRTTIJson.SerializeObject(aObject);
  1751. try
  1752. if aIndent then Result := TJsonUtils.JsonFormat(json.ToJSON)
  1753. else Result := json.ToJSON;
  1754. finally
  1755. json.Free;
  1756. end;
  1757. end;
  1758. procedure TJsonSerializer.ObjectToJsonStream(aObject: TObject; aStream: TStream);
  1759. var
  1760. json : TJsonObject;
  1761. ss : TStringStream;
  1762. begin
  1763. {$IFDEF DEBUG_SERIALIZER}
  1764. TDebugger.TimeIt(Self,'ObjectToJsonStream',aObject.ClassName);
  1765. {$ENDIF}
  1766. if aStream = nil then raise EJsonSerializeError.Create('stream parameter cannot be nil!');
  1767. json := fRTTIJson.SerializeObject(aObject);
  1768. try
  1769. ss := TStringStream.Create(json.ToString,TEncoding.UTF8);
  1770. try
  1771. aStream.CopyFrom(ss,ss.Size);
  1772. finally
  1773. ss.Free;
  1774. end;
  1775. finally
  1776. json.Free;
  1777. end;
  1778. end;
  1779. function TJsonSerializer.ObjectToJsonString(aObject : TObject; aIndent : Boolean = False): string;
  1780. var
  1781. json: TJSONObject;
  1782. begin
  1783. {$IFDEF DEBUG_SERIALIZER}
  1784. TDebugger.TimeIt(Self,'ObjectToJsonString',aObject.ClassName);
  1785. {$ENDIF}
  1786. json := fRTTIJson.SerializeObject(aObject);
  1787. try
  1788. if aIndent then Result := TJsonUtils.JsonFormat(json.ToString)
  1789. else Result := json.ToString;
  1790. finally
  1791. json.Free;
  1792. end;
  1793. end;
  1794. function TJsonSerializer.Options: TSerializerOptions;
  1795. begin
  1796. Result := fRTTIJson.Options;
  1797. end;
  1798. function TJsonSerializer.ValueToJson(const aValue: TValue; aIndent: Boolean): string;
  1799. var
  1800. json: TJSONValue;
  1801. begin
  1802. {$IFDEF DEBUG_SERIALIZER}
  1803. TDebugger.TimeIt(Self,'ValueToJson',aValue.ToString);
  1804. {$ENDIF}
  1805. json:= fRTTIJson.SerializeValue(aValue);
  1806. if json = nil then raise EJsonSerializerError.Create('Error serializing TValue');
  1807. try
  1808. if aIndent then Result := TJsonUtils.JsonFormat(json{$IFNDEF FPC}.ToJSON{$ELSE}.AsJson{$ENDIF})
  1809. else Result := json{$IFNDEF FPC}.ToJSON{$ELSE}.AsJson{$ENDIF};
  1810. finally
  1811. json.Free;
  1812. end;
  1813. end;
  1814. function TJsonSerializer.ValueToJsonString(const aValue: TValue; aIndent: Boolean): string;
  1815. var
  1816. json: TJSONValue;
  1817. begin
  1818. {$IFDEF DEBUG_SERIALIZER}
  1819. TDebugger.TimeIt(Self,'ValueToJsonString',aValue.ToString);
  1820. {$ENDIF}
  1821. json:= fRTTIJson.SerializeValue(aValue);
  1822. if json = nil then raise EJsonSerializerError.Create('Error serializing TValue');
  1823. try
  1824. if aIndent then Result := TJsonUtils.JsonFormat(json.ToString)
  1825. else Result := json.ToString;
  1826. finally
  1827. json.Free;
  1828. end;
  1829. end;
  1830. function TJsonSerializer.ArrayToJson<T>(aArray: TArray<T>; aIndent: Boolean): string;
  1831. var
  1832. json: TJSONValue;
  1833. begin
  1834. {$IFDEF DEBUG_SERIALIZER}
  1835. TDebugger.TimeIt(Self,'ArrayToJson','');
  1836. {$ENDIF}
  1837. json:= fRTTIJson.SerializeValue(TValue.From<TArray<T>>(aArray));
  1838. if json = nil then raise EJsonSerializerError.Create('Error serializing Array');
  1839. try
  1840. if aIndent then Result := TJsonUtils.JsonFormat(json{$IFNDEF FPC}.ToJSON{$ELSE}.AsJson{$ENDIF})
  1841. else Result := json{$IFNDEF FPC}.ToJSON{$ELSE}.AsJson{$ENDIF};
  1842. finally
  1843. json.Free;
  1844. end;
  1845. end;
  1846. function TJsonSerializer.ArrayToJsonString<T>(aArray: TArray<T>; aIndent: Boolean): string;
  1847. var
  1848. json: TJSONValue;
  1849. begin
  1850. {$IFDEF DEBUG_SERIALIZER}
  1851. TDebugger.TimeIt(Self,'ArrayToJsonString','');
  1852. {$ENDIF}
  1853. json:= fRTTIJson.SerializeValue(TValue.From<TArray<T>>(aArray));
  1854. if json = nil then raise EJsonSerializerError.Create('Error serializing Array');
  1855. try
  1856. if aIndent then Result := TJsonUtils.JsonFormat(json.ToString)
  1857. else Result := json.ToString;
  1858. finally
  1859. json.Free;
  1860. end;
  1861. end;
  1862. function TJsonSerializer.JsonStreamToObject(aObject: TObject; aJsonStream: TStream): TObject;
  1863. var
  1864. json : string;
  1865. begin
  1866. {$IFDEF DEBUG_SERIALIZER}
  1867. TDebugger.TimeIt(Self,'JsonStreamToObject','');
  1868. {$ENDIF}
  1869. if aJsonStream = nil then raise EJsonDeserializeError.Create('JsonStream param cannot be nil!');
  1870. json := StreamToString(aJsonStream,TEncoding.UTF8);
  1871. Result := JsonToObject(aObject,json);
  1872. end;
  1873. {$IFNDEF FPC}
  1874. function TJsonSerializer.JsonToArray<T>(const aJson: string): TArray<T>;
  1875. var
  1876. jarray: TJSONArray;
  1877. value : TValue;
  1878. begin;
  1879. {$IFDEF DEBUG_SERIALIZER}
  1880. TDebugger.TimeIt(Self,'JsonToArray','');
  1881. {$ENDIF}
  1882. try
  1883. {$If Defined(FPC) OR Defined(DELPHIRX10_UP)}
  1884. jarray := TJSONObject.ParseJSONValue(aJson,True) as TJSONArray;
  1885. {$ELSE}
  1886. jarray := TJsonObject.ParseJSONValue(TEncoding.UTF8.GetBytes(aJson),0,True) as TJSONArray;
  1887. {$ENDIF}
  1888. except
  1889. raise EJsonDeserializeError.Create(cNotValidJson);
  1890. end;
  1891. try
  1892. value := fRTTIJson.DeserializeDynArray(PTypeInfo(TypeInfo(TArray<T>)),nil,jarray);
  1893. Result := value.AsType<TArray<T>>;
  1894. finally
  1895. jarray.Free;
  1896. end;
  1897. end;
  1898. function TJsonSerializer.JsonToValue(const aJson: string): TValue;
  1899. var
  1900. json: TJSONObject;
  1901. value : TValue;
  1902. begin;
  1903. {$IFDEF DEBUG_SERIALIZER}
  1904. TDebugger.TimeIt(Self,'JsonToValue','');
  1905. {$ENDIF}
  1906. try
  1907. {$If Defined(FPC) OR Defined(DELPHIRX10_UP)}
  1908. json := TJSONObject.ParseJSONValue(aJson,True) as TJSONObject;
  1909. {$ELSE}
  1910. json := TJsonObject.ParseJSONValue(TEncoding.UTF8.GetBytes(aJson),0,True) as TJSONObject;
  1911. {$ENDIF}
  1912. except
  1913. raise EJsonDeserializeError.Create(cNotValidJson);
  1914. end;
  1915. try
  1916. value := fRTTIJson.DeserializeRecord(value,nil,json);
  1917. Result := value; // value.AsType<TArray<T>>;
  1918. finally
  1919. json.Free;
  1920. end;
  1921. end;
  1922. {$ENDIF}
  1923. procedure TJsonSerializer.SetSerializeLevel(const Value: TSerializeLevel);
  1924. begin
  1925. fSerializeLevel := Value;
  1926. if Assigned(fRTTIJson) then fRTTIJson.fSerializeLevel := Value;
  1927. end;
  1928. procedure TJsonSerializer.SetUseBase64Stream(const Value: Boolean);
  1929. begin
  1930. fUseBase64Stream := Value;
  1931. if Assigned(fRTTIJson) then fRTTIJson.Options.UseBase64Stream := Value;
  1932. end;
  1933. procedure TJsonSerializer.SetUseEnumNames(const Value: Boolean);
  1934. begin
  1935. fUseEnumNames := Value;
  1936. if Assigned(fRTTIJson) then fRTTIJson.Options.UseEnumNames := Value;
  1937. end;
  1938. procedure TJsonSerializer.SetUseGUIDLowerCase(const Value: Boolean);
  1939. begin
  1940. fUseGUIDLowercase := Value;
  1941. if Assigned(fRTTIJson) then fRTTIJson.Options.UseGUIDLowerCase := Value;
  1942. end;
  1943. procedure TJsonSerializer.SetUseGUIDWithBrackets(const Value: Boolean);
  1944. begin
  1945. fUseGUIDWithBrackets := Value;
  1946. if Assigned(fRTTIJson) then fRTTIJson.Options.UseGUIDWithBrackets := Value;
  1947. end;
  1948. procedure TJsonSerializer.SetUseJsonCaseSense(const Value: Boolean);
  1949. begin
  1950. fRTTIJson.Options.UseJsonCaseSense := Value;
  1951. if Assigned(fRTTIJson) then fRTTIJson.Options.UseJsonCaseSense := Value;
  1952. end;
  1953. procedure TJsonSerializer.SetUseNullStringsAsEmpty(const Value: Boolean);
  1954. begin
  1955. fUseNullStringsAsEmpty := Value;
  1956. if Assigned(fRTTIJson) then fRTTIJson.Options.UseNullStringsAsEmpty := Value;
  1957. end;
  1958. {$IFNDEF FPC}
  1959. { TCommentProperty }
  1960. constructor TCommentProperty.Create(const aComment: string);
  1961. begin
  1962. fComment := aComment;
  1963. end;
  1964. { TCustomNameProperty }
  1965. constructor TCustomNameProperty.Create(const aName: string);
  1966. begin
  1967. fName := aName;
  1968. end;
  1969. {$ENDIF}
  1970. {$IF NOT DEFINED(DELPHIXE7_UP) AND NOT DEFINED(FPC)}
  1971. { TJSONArrayHelper }
  1972. function TJSONArrayHelper.Count: Integer;
  1973. begin
  1974. Result := Self.Size;
  1975. end;
  1976. function TJSONArrayHelper.GetItem(aValue: Integer): TJSONValue;
  1977. begin
  1978. Result := Self.Get(aValue);
  1979. end;
  1980. procedure TJSONArrayHelper.SetElements(aElements: TList<TJSONValue>);
  1981. var
  1982. jvalue : TJSONValue;
  1983. begin
  1984. for jvalue in aElements do Self.AddElement(jvalue);
  1985. aElements.Free;
  1986. end;
  1987. { TJSONValueHelper }
  1988. function TJSONValueHelper.ToJson: string;
  1989. begin
  1990. Result := Self.ToString;
  1991. end;
  1992. { TJSONObjectHelper }
  1993. function TJSONObjectHelper.Count: Integer;
  1994. begin
  1995. Result := Self.Size;
  1996. end;
  1997. function TJSONObjectHelper.GetValue(const aName: string): TJSONValue;
  1998. var
  1999. jPair : TJSONPair;
  2000. begin
  2001. Result := nil;
  2002. for jPair in Self do
  2003. begin
  2004. if jPair.JsonString.ToString = aName then Exit(jPair.JsonValue);
  2005. end;
  2006. end;
  2007. function TJSONObjectHelper.GetPair(aValue: Integer) : TJSONPair;
  2008. begin
  2009. Result := Self.Get(aValue);
  2010. end;
  2011. {$ENDIF}
  2012. end.