Quick.Json.Serializer.pas 64 KB

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