Quick.Json.Serializer.pas 67 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090
  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 : 26/01/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. 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,rType,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. {$IFDEF DELPHIRX10_UP}
  581. rMethod: TRttiMethod;
  582. {$ELSE}
  583. rfield : TRttiField;
  584. {$ENDIF}
  585. begin
  586. Result := aObject;
  587. rType := ctx.GetType(aObject.ClassInfo);
  588. rProp := rType.GetProperty('List');
  589. if (rProp = nil) or (aJson = nil) or (aJson.ClassType = TJSONNull) then Exit;
  590. member := nil;
  591. //check if exists List (denotes delphi json serialized) or not (normal json serialized)
  592. if aJson.ClassType = TJSONObject then member := GetJsonPairValueByName(aJson,aName);
  593. if member = nil then
  594. begin
  595. if aJson.ClassType <> TJSONArray then raise EJsonDeserializeError.CreateFmt('Not valid value for "%s" List',[aName]);
  596. jArray := TJSONObject.ParseJSONValue(aJson.ToJSON) as TJSONArray;
  597. end
  598. else
  599. begin
  600. if member.ClassType <> TJSONArray then raise EJsonDeserializeError.CreateFmt('Not valid value for "%s" List',[aName]);
  601. jArray := TJSONObject.ParseJSONValue(member.ToJSON) as TJSONArray;
  602. end;
  603. try
  604. rvalue := DeserializeDynArray(rProp.PropertyType.Handle,Result,jArray);
  605. //i := jarray.Count;
  606. finally
  607. jArray.Free;
  608. end;
  609. if not rValue.IsEmpty then
  610. begin
  611. {$IFDEF DELPHIRX10_UP}
  612. if (aObject <> nil) and (rvalue.IsArray) then
  613. begin
  614. rMethod := ctx.GetType(aObject.ClassType).GetMethod('Clear');
  615. if rMethod = nil then
  616. raise EJsonDeserializeError.Create('Unable to find RTTI method');
  617. rMethod.Invoke(aObject, []);
  618. rMethod := ctx.GetType(aObject.ClassType).GetMethod('Add');
  619. if rMethod = nil then
  620. raise EJsonDeserializeError.Create('Unable to find RTTI method');
  621. n := rvalue.GetArrayLength - 1;
  622. for i := 0 to n do
  623. rMethod.Invoke(aObject, [rvalue.GetArrayElement(i)]);
  624. end;
  625. {$ELSE}
  626. n := 0;
  627. for rfield in rType.GetFields do
  628. begin
  629. if rfield.Name = 'FOwnsObjects' then rfield.SetValue(aObject,True);
  630. //if rfield.Name = 'FCount' then rfield.SetValue(aObject,i);
  631. if rfield.Name = 'FItems' then
  632. begin
  633. //if TList(aObject) <> nil then TList(aObject).Clear;
  634. //rfield.GetValue(aObject).AsObject.Free;// aValue.GetReferenceToRawData)
  635. rfield.SetValue(aObject,rValue);// .SetDynArrayProp(aObject,'fItems',Result);
  636. Break;
  637. end;
  638. end;
  639. rProp := rType.GetProperty('Count');
  640. rProp.SetValue(aObject,n);
  641. {$ENDIF}
  642. end;
  643. end;
  644. {$ENDIF}
  645. {$IFNDEF FPC}
  646. procedure TRTTIJson.DeserializeXArray(Instance : TObject; aRecord : TValue; aProperty : TRttiProperty; const aPropertyName : string; aJson : TJsonObject);
  647. var
  648. ctx : TRttiContext;
  649. rRec : TRttiRecordType;
  650. rfield : TRttiField;
  651. rValue : TValue;
  652. member : TJsonValue;
  653. jArray : TJSONArray;
  654. begin
  655. rRec := ctx.GetType(aRecord.TypeInfo).AsRecord;
  656. rfield := rRec.GetField('fArray');
  657. if rfield <> nil then
  658. begin
  659. rValue := nil;
  660. //member := TJSONPair(aJson.GetValue(rField.Name));
  661. member := GetJsonPairValueByName(aJson,aPropertyName);
  662. if (member <> nil) and (rField.FieldType.TypeKind = tkDynArray) then
  663. begin
  664. jArray := TJSONObject.ParseJSONValue(member.ToJSON) as TJSONArray;
  665. try
  666. rValue := DeserializeDynArray(rField.FieldType.Handle,nil,jArray);
  667. finally
  668. jArray.Free;
  669. end;
  670. end;
  671. end;
  672. if not rValue.IsEmpty then rField.SetValue(aRecord.GetReferenceToRawData,rValue);
  673. aProperty.SetValue(Instance,aRecord);
  674. end;
  675. {$ENDIF}
  676. function StringToGUIDEx(const aGUID : string) : TGUID;
  677. begin
  678. if not aGUID.StartsWith('{') then Result := System.SysUtils.StringToGUID('{' + aGUID + '}')
  679. else Result := System.SysUtils.StringToGUID(aGUID);
  680. end;
  681. function TRTTIJson.DeserializeProperty(aObject : TObject; const aName : string; aProperty : TRttiProperty; const aJson : TJSONObject) : TObject;
  682. var
  683. rValue : TValue;
  684. {$IFNDEF FPC}
  685. member : TJsonValue;
  686. {$ELSE}
  687. member : TJsonObject;
  688. {$ENDIF}
  689. objClass: TClass;
  690. jArray : TJSONArray;
  691. json : TJSONObject;
  692. begin
  693. Result := aObject;
  694. rValue := nil;
  695. {$IFNDEF FPC}
  696. //member := TJSONPair(aJson.GetValue(aName));
  697. member := GetJsonPairValueByName(aJson,aName);
  698. {$ELSE}
  699. member := TJsonObject(aJson.Find(aName));
  700. {$ENDIF}
  701. if member <> nil then
  702. begin
  703. case aProperty.PropertyType.TypeKind of
  704. tkDynArray :
  705. begin
  706. {$IFNDEF FPC}
  707. if member is TJSONNull then Exit;
  708. jArray := TJSONObject.ParseJSONValue(member.ToJSON) as TJSONArray;
  709. {$ELSE}
  710. if member.ClassType = TJSONNull.ClassType then Exit;
  711. jArray := TJSONArray(TJSONObject.ParseJSONValue(member.ToJSON));
  712. {$ENDIF}
  713. try
  714. {$IFNDEF FPC}
  715. aProperty.SetValue(aObject,DeserializeDynArray(aProperty.PropertyType.Handle,Result,jArray));
  716. {$ELSE}
  717. DeserializeDynArray(aProperty.PropertyType.Handle,aName,Result,jArray);
  718. {$ENDIF}
  719. Exit;
  720. finally
  721. jArray.Free;
  722. end;
  723. end;
  724. tkClass :
  725. begin
  726. //if (member.JsonValue is TJSONObject) then
  727. begin
  728. json := TJsonObject(TJSONObject.ParseJSONValue(member.ToJson));
  729. try
  730. if aProperty.GetValue(aObject).AsObject = nil then
  731. begin
  732. {$IFNDEF FPC}
  733. objClass := aProperty.PropertyType.Handle^.TypeData.ClassType;
  734. rValue := DeserializeClass(objClass,json);
  735. {$ELSE}
  736. objClass := GetObjectPropClass(aObject,aName);
  737. //objClass := GetTypeData(aProperty.PropertyType.Handle)^.ClassType;
  738. rValue := DeserializeClass(objClass,json);
  739. SetObjectProp(aObject,aName,rValue.AsObject);
  740. Exit;
  741. {$ENDIF}
  742. end
  743. else
  744. begin
  745. rValue := DeserializeObject(aProperty.GetValue(aObject).AsObject,json);
  746. Exit;
  747. end;
  748. finally
  749. json.Free;
  750. end;
  751. end
  752. end;
  753. {$IFNDEF FPC}
  754. tkRecord :
  755. begin
  756. if aProperty.GetValue(aObject).TypeInfo = System.TypeInfo(TGUID) then
  757. begin
  758. rValue:=TValue.From<TGUID>(StringToGUID(UnQuotedStr(member.ToJSON,'"')));
  759. end
  760. else
  761. begin
  762. json := TJSONObject.ParseJSONValue(member.ToJson) as TJSONObject;
  763. try
  764. rValue := DeserializeRecord(aProperty.GetValue(aObject),aObject,json);
  765. finally
  766. json.Free;
  767. end;
  768. end;
  769. end;
  770. {$ENDIF}
  771. else
  772. begin
  773. {$IFNDEF FPC}
  774. //avoid return unicode escaped chars if string
  775. if aProperty.PropertyType.TypeKind in [tkString, tkLString, tkWString, tkUString] then
  776. {$IFDEF DELPHIRX10_UP}
  777. rValue := DeserializeType(aObject,aProperty.PropertyType.TypeKind,aProperty.GetValue(aObject).TypeInfo,TJsonValue(member).value)
  778. {$ELSE}
  779. rValue := DeserializeType(aObject,aProperty.PropertyType.TypeKind,aProperty.GetValue(aObject).TypeInfo,member.Value)
  780. {$ENDIF}
  781. else rValue := DeserializeType(aObject,aProperty.PropertyType.TypeKind,aProperty.GetValue(aObject).TypeInfo,member.ToJSON);
  782. {$ELSE}
  783. rValue := DeserializeType(aObject,aProperty.PropertyType.TypeKind,aName,member.ToJSON);
  784. if not rValue.IsEmpty then SetPropertyValue(aObject,aName,rValue);
  785. {$ENDIF}
  786. end;
  787. end;
  788. {$IFNDEF FPC}
  789. if not rValue.IsEmpty then aProperty.SetValue(Result,rValue);
  790. {$ENDIF}
  791. end;
  792. end;
  793. {$IFNDEF FPC}
  794. function TRTTIJson.DeserializeType(aObject : TObject; aType : TTypeKind; aTypeInfo : PTypeInfo; const aValue: string) : TValue;
  795. var
  796. i : Integer;
  797. value : string;
  798. fsettings : TFormatSettings;
  799. begin
  800. try
  801. value := UnQuotedStr(aValue,'"');
  802. case aType of
  803. tkString, tkLString, tkWString, tkUString :
  804. begin
  805. if fUseNullStringsAsEmpty and (CompareText(value, 'null') = 0) then
  806. Result := ''
  807. else
  808. Result := value;
  809. end;
  810. tkChar, tkWChar :
  811. begin
  812. Result := value;
  813. end;
  814. tkInteger :
  815. begin
  816. if CompareText(value,'null') <> 0 then Result := StrToIntDef(value,0)
  817. else Result := 0;
  818. end;
  819. tkInt64 :
  820. begin
  821. if CompareText(value,'null') <> 0 then Result := StrToInt64Def(value,0)
  822. else Result := 0;
  823. end;
  824. tkFloat :
  825. begin
  826. if aTypeInfo = TypeInfo(TDateTime) then
  827. begin
  828. if CompareText(value,'null') <> 0 then Result := JsonDateToDateTime(value);
  829. end
  830. else if aTypeInfo = TypeInfo(TDate) then
  831. begin
  832. if CompareText(value,'null') <> 0 then Result := StrToDate(value);
  833. end
  834. else if aTypeInfo = TypeInfo(TTime) then
  835. begin
  836. Result := StrToTime(value);
  837. end
  838. else
  839. begin
  840. fsettings := TFormatSettings.Create;
  841. Result := StrToFloat(StringReplace(value,'.',fsettings.DecimalSeparator,[]));
  842. end;
  843. end;
  844. tkEnumeration :
  845. begin
  846. if aTypeInfo = System.TypeInfo(Boolean) then
  847. begin
  848. Result := StrToBool(value);
  849. end
  850. else
  851. begin
  852. //if fUseEnumNames then TValue.Make(GetEnumValue(aTypeInfo,value),aTypeInfo, Result)
  853. // else TValue.Make(StrToInt(value),aTypeInfo, Result);
  854. if not TryStrToInt(value,i) then TValue.Make(GetEnumValue(aTypeInfo,value),aTypeInfo, Result)
  855. else TValue.Make(StrToInt(value),aTypeInfo, Result);
  856. end;
  857. end;
  858. tkSet :
  859. begin
  860. i := StringToSet(aTypeInfo,value);
  861. TValue.Make(@i,aTypeInfo,Result);
  862. end;
  863. else
  864. begin
  865. //raise EclJsonSerializerError.Create('Not supported data type!');
  866. end;
  867. end;
  868. except
  869. on E : Exception do
  870. begin
  871. raise EJsonDeserializeError.CreateFmt('Deserialize error type "%s.%s" : %s',[aObject.ClassName,GetTypeName(aTypeInfo),e.Message]);
  872. end;
  873. end;
  874. end;
  875. {$ELSE}
  876. function TRTTIJson.DeserializeType(aObject : TObject; aType : TTypeKind; const aPropertyName, aValue: string) : TValue;
  877. var
  878. value : string;
  879. propinfo : PPropInfo;
  880. fsettings : TFormatSettings;
  881. begin
  882. try
  883. value := UnQuotedStr(aValue,'"');
  884. if value = '' then
  885. begin
  886. Result := nil;
  887. Exit;
  888. end;
  889. propinfo := GetPropInfo(aObject,aPropertyName);
  890. //case propinfo.PropType.Kind of
  891. case aType of
  892. tkString, tkLString, tkWString, tkUString, tkAString :
  893. begin
  894. Result := value;
  895. //SetStrProp(aObject,propinfo,value);
  896. end;
  897. tkChar, tkWChar :
  898. begin
  899. Result := value;
  900. end;
  901. tkInteger :
  902. begin
  903. if CompareText(value,'null') <> 0 then Result := StrToInt(value)
  904. else Result := 0;
  905. end;
  906. tkInt64 :
  907. begin
  908. if CompareText(value,'null') <> 0 then Result := StrToInt64(value)
  909. else Result := 0;
  910. end;
  911. tkFloat :
  912. begin
  913. if propinfo.PropType = TypeInfo(TDateTime) then
  914. begin
  915. if CompareText(value,'null') <> 0 then Result := JsonDateToDateTime(value);
  916. end
  917. else if propinfo.PropType = TypeInfo(TDate) then
  918. begin
  919. if CompareText(value,'null') <> 0 then Result := StrToDate(value);
  920. end
  921. else if propinfo.PropType = TypeInfo(TTime) then
  922. begin
  923. Result := StrToTime(value);
  924. end
  925. else
  926. begin
  927. fsettings := DefaultFormatSettings;
  928. Result := StrToFloat(StringReplace(value,'.',fsettings.DecimalSeparator,[]));
  929. end;
  930. end;
  931. tkEnumeration:
  932. begin
  933. Result := value;
  934. end;
  935. tkBool :
  936. begin
  937. Result := StrToBool(value);
  938. end;
  939. tkSet :
  940. begin
  941. Result := value;
  942. end;
  943. else
  944. begin
  945. //raise EclJsonSerializerError.Create('Not supported data type!');
  946. end;
  947. end;
  948. //if not Result.IsEmpty then SetPropertyValue(aObject,propinfo,Result);
  949. except
  950. on E : Exception do
  951. begin
  952. raise EJsonDeserializeError.CreateFmt('Deserialize error type "%s" : %s',[aObject.ClassName,e.Message]);
  953. end;
  954. end;
  955. end;
  956. {$ENDIF}
  957. function TRTTIJson.IsAllowedProperty(aObject : TObject; const aPropertyName : string) : Boolean;
  958. var
  959. propname : string;
  960. begin
  961. Result := True;
  962. propname := aPropertyName.ToLower;
  963. if IsGenericList(aObject) then
  964. begin
  965. if (propname = 'capacity') or (propname = 'count') or (propname = 'ownsobjects') then Result := False;
  966. end
  967. else if (propname = 'refcount') then Result := False;
  968. end;
  969. function TRTTIJson.IsGenericList(aObject : TObject) : Boolean;
  970. var
  971. cname : string;
  972. begin
  973. if aObject = nil then Exit(False);
  974. cname := aObject.ClassName;
  975. Result := (cname.StartsWith('TObjectList')) or (cname.StartsWith('TList'));
  976. end;
  977. function TRTTIJson.IsStream(aObject : TObject) : Boolean;
  978. begin
  979. if aObject = nil then Exit(False);
  980. Result := aObject.InheritsFrom(TStream);
  981. end;
  982. function TRTTIJson.GetGenericListType(aObject : TObject) : TGenericListType;
  983. var
  984. cname : string;
  985. begin
  986. if aObject = nil then Exit(TGenericListType.gtNone);
  987. cname := aObject.ClassName;
  988. if cname.StartsWith('TObjectList') then Result := TGenericListType.gtObjectList
  989. else if cname.StartsWith('TList') then Result := TGenericListType.gtList
  990. else Result := TGenericListType.gtNone;
  991. end;
  992. function TRTTIJson.IsGenericXArray(const aClassName : string) : Boolean;
  993. begin
  994. Result := aClassName.StartsWith('TXArray');
  995. end;
  996. function TRTTIJson.GetJsonPairValueByName(aJson: TJSONObject; const aName: string): TJsonValue;
  997. var
  998. candidate : TJSONPair;
  999. i : Integer;
  1000. begin
  1001. if fUseJsonCaseSense then
  1002. begin
  1003. Result := aJson.GetValue(aName);
  1004. Exit;
  1005. end
  1006. else
  1007. begin
  1008. for i := 0 to aJson.Count - 1 do
  1009. begin
  1010. candidate := aJson.Pairs[I];
  1011. if candidate.JsonValue = nil then continue;
  1012. if CompareText(candidate.JsonString{$IFNDEF FPC}.Value{$ENDIF},aName) = 0 then Exit(candidate.JsonValue);
  1013. end;
  1014. end;
  1015. Result := nil;
  1016. end;
  1017. function TRTTIJson.GetJsonPairByName(aJson: TJSONObject; const aName: string): TJSONPair;
  1018. var
  1019. i : Integer;
  1020. begin
  1021. if fUseJsonCaseSense then
  1022. begin
  1023. Result := TJSONPair(aJson.GetValue(aName));
  1024. Exit;
  1025. end
  1026. else
  1027. begin
  1028. if aJson <> nil then
  1029. begin
  1030. for i := 0 to aJson.Count - 1 do
  1031. begin
  1032. Result := aJson.Pairs[I];
  1033. if Result.JsonValue = nil then continue;
  1034. if CompareText(Result.JsonString{$IFNDEF FPC}.Value{$ENDIF},aName) = 0 then Exit;
  1035. end;
  1036. end;
  1037. end;
  1038. Result := nil;
  1039. end;
  1040. //function TRTTIJson.GetPropertyValue(Instance : TObject; const PropertyName : string) : TValue;
  1041. //var
  1042. // pinfo : PPropInfo;
  1043. //begin
  1044. // Result := nil;
  1045. // pinfo := GetPropInfo(Instance,PropertyName);
  1046. // if pinfo = nil then raise EJsonSerializeError.CreateFmt('Property "%s" not found!',[PropertyName]);
  1047. // case pinfo.PropType^.Kind of
  1048. // tkInteger : Result := GetOrdProp(Instance,pinfo);
  1049. // tkInt64 : Result := GetInt64Prop(Instance,PropertyName);
  1050. // tkFloat : Result := GetFloatProp(Instance,PropertyName);
  1051. // tkChar : Result := Char(GetOrdProp(Instance,PropertyName));
  1052. // {$IFDEF FPC}
  1053. // tkWString : Result := GetWideStrProp(Instance,PropertyName);
  1054. // tkSString,
  1055. // tkAString,
  1056. // {$ELSE}
  1057. // tkWString,
  1058. // {$ENDIF}
  1059. // tkLString : Result := GetStrProp(Instance,pinfo);
  1060. // {$IFDEF FPC}
  1061. // tkEnumeration :
  1062. // begin
  1063. // if fUseEnumNames then Result := GetEnumName(pinfo.PropType,GetOrdProp(Instance,PropertyName))
  1064. // else Result := GetOrdProp(Instance,PropertyName);
  1065. // end;
  1066. // {$ELSE}
  1067. // tkEnumeration :
  1068. // begin
  1069. // if fUseEnumNames then Result := GetEnumName(@pinfo.PropType,GetOrdProp(Instance,PropertyName))
  1070. // else Result := GetOrdProp(Instance,PropertyName);
  1071. // end;
  1072. // {$ENDIF}
  1073. // tkSet : Result := GetSetProp(Instance,pinfo,True);
  1074. // {$IFNDEF FPC}
  1075. // tkClass :
  1076. // {$ELSE}
  1077. // tkBool : Result := Boolean(GetOrdProp(Instance,pinfo));
  1078. // tkObject :
  1079. // {$ENDIF} Result := GetObjectProp(Instance,pinfo);
  1080. // tkDynArray : Result := GetDynArrayProp(Instance,pinfo);
  1081. // end;
  1082. //end;
  1083. function TRTTIJson.GetPropertyValueFromObject(Instance : TObject; const PropertyName : string) : TValue;
  1084. var
  1085. ctx : TRttiContext;
  1086. rprop : TRttiProperty;
  1087. begin
  1088. rprop := ctx.GetType(Instance.ClassInfo).GetProperty(PropertyName);
  1089. Result := rprop.GetValue(Instance);
  1090. end;
  1091. {$IFNDEF FPC}
  1092. function TRTTIJson.GetFieldValueFromRecord(const aValue : TValue; const FieldName : string) : TValue;
  1093. var
  1094. ctx : TRttiContext;
  1095. rec : TRttiRecordType;
  1096. rfield : TRttiField;
  1097. begin
  1098. rec := ctx.GetType(aValue.TypeInfo).AsRecord;
  1099. rfield := rec.GetField(FieldName);
  1100. if rfield <> nil then Result := rField.GetValue(aValue.GetReferenceToRawData)
  1101. else Result := nil;
  1102. end;
  1103. {$ENDIF}
  1104. {$IFDEF FPC}
  1105. procedure TRTTIJson.SetPropertyValue(Instance : TObject; const PropertyName : string; aValue : TValue);
  1106. var
  1107. pinfo : PPropInfo;
  1108. begin
  1109. pinfo := GetPropInfo(Instance,PropertyName);
  1110. SetPropertyValue(Instance,pinfo,aValue);
  1111. end;
  1112. procedure TRTTIJson.SetPropertyValue(Instance : TObject; aPropInfo : PPropInfo; aValue : TValue);
  1113. begin
  1114. case aPropInfo.PropType^.Kind of
  1115. tkInteger : SetOrdProp(Instance,aPropInfo,aValue.AsInteger);
  1116. tkInt64 : SetInt64Prop(Instance,aPropInfo,aValue.AsInt64);
  1117. tkFloat : SetFloatProp(Instance,aPropInfo,aValue.AsExtended);
  1118. tkChar : SetOrdProp(Instance,aPropInfo,aValue.AsOrdinal);
  1119. {$IFDEF FPC}
  1120. tkWString : SetWideStrProp(Instance,aPropInfo,aValue.AsString);
  1121. tkSString,
  1122. tkAString,
  1123. {$ELSE}
  1124. tkWString,
  1125. {$ENDIF}
  1126. tkLString : SetStrProp(Instance,aPropInfo,aValue.AsString);
  1127. {$IFDEF FPC}
  1128. tkBool : SetOrdProp(Instance,aPropInfo,aValue.AsOrdinal);
  1129. tkSet : LoadSetProperty(Instance,aPropInfo,aValue.AsString);
  1130. {$ENDIF}
  1131. tkEnumeration : SetEnumProp(Instance,aPropInfo,aValue.AsString);
  1132. {$IFNDEF FPC}
  1133. tkClass :
  1134. {$ELSE}
  1135. tkObject :
  1136. {$ENDIF} SetObjectProp(Instance,aPropInfo,aValue.AsObject);
  1137. end;
  1138. end;
  1139. procedure TRTTIJson.LoadSetProperty(aInstance : TObject; aPropInfo: PPropInfo; const aValue: string);
  1140. type
  1141. TCardinalSet = set of 0..SizeOf(Cardinal) * 8 - 1;
  1142. const
  1143. Delims = [' ', ',', '[', ']'];
  1144. var
  1145. TypeInfo: PTypeInfo;
  1146. W: Cardinal;
  1147. I, N: Integer;
  1148. Count: Integer;
  1149. EnumName: string;
  1150. begin
  1151. W := 0;
  1152. TypeInfo := GetTypeData(GetPropType(aPropInfo))^.CompType;
  1153. Count := WordCount(aValue, Delims);
  1154. for N := 1 to Count do
  1155. begin
  1156. EnumName := ExtractWord(N, aValue, Delims);
  1157. try
  1158. I := GetEnumValue(TypeInfo, EnumName);
  1159. if I >= 0 then Include(TCardinalSet(W),I);
  1160. except
  1161. end;
  1162. end;
  1163. SetOrdProp(aInstance,aPropInfo,W);
  1164. end;
  1165. {$ENDIF}
  1166. function TRTTIJson.SerializeObject(aObject: TObject): TJSONObject;
  1167. var
  1168. ctx: TRttiContext;
  1169. {$IFNDEF FPC}
  1170. attr : TCustomAttribute;
  1171. comment : string;
  1172. {$ENDIF}
  1173. rType: TRttiType;
  1174. rProp: TRttiProperty;
  1175. jpair : TJSONPair;
  1176. ExcludeSerialize : Boolean;
  1177. propertyname : string;
  1178. propvalue : TValue;
  1179. begin
  1180. if (aObject = nil) then
  1181. begin
  1182. Result := nil;
  1183. Exit;
  1184. end;
  1185. Result := nil;
  1186. try
  1187. //if is GenericList
  1188. if IsGenericList(aObject) then
  1189. begin
  1190. //get list array
  1191. propvalue := GetPropertyValueFromObject(aObject,'List');
  1192. {$IFDEF DELPHIRX10_UP}
  1193. Result := TJSONObject(SerializeDynArray(propvalue));
  1194. {$ELSE}
  1195. Result := TJSONObject(SerializeValue(propvalue));
  1196. {$ENDIF}
  1197. Exit;
  1198. end
  1199. {$IFNDEF FPC}
  1200. else if IsStream(aObject) then
  1201. begin
  1202. Result := TJSONObject(SerializeStream(aObject));
  1203. Exit;
  1204. end
  1205. {$ENDIF}
  1206. else Result := TJSONObject.Create;
  1207. //if is standard object
  1208. propertyname := '';
  1209. rType := ctx.GetType(aObject.ClassInfo);
  1210. for rProp in TRTTI.GetProperties(rType,roFirstBase) do
  1211. begin
  1212. ExcludeSerialize := False;
  1213. propertyname := rProp.Name;
  1214. {$IFNDEF FPC}
  1215. comment := '';
  1216. if not rProp.IsReadable then Continue;
  1217. for attr in rProp.GetAttributes do
  1218. begin
  1219. if attr is TNotSerializableProperty then ExcludeSerialize := True
  1220. else if attr is TCommentProperty then comment := TCommentProperty(attr).Comment
  1221. else if attr is TCustomNameProperty then propertyname := TCustomNameProperty(attr).Name;
  1222. end;
  1223. if ((fSerializeLevel = slPublicProperty) and (rProp.PropertyType.IsPublicType))
  1224. or ((fSerializeLevel = slPublishedProperty) and ((IsPublishedProp(aObject,rProp.Name)) or (rProp.Name = 'List'))) then
  1225. {$ENDIF}
  1226. begin
  1227. if (IsAllowedProperty(aObject,propertyname)) and (not ExcludeSerialize) then
  1228. begin
  1229. //add comment as pair
  1230. {$IFNDEF FPC}
  1231. if comment <> '' then Result.AddPair(TJSONPair.Create('#Comment#->'+propertyname,Comment));
  1232. {$ENDIF}
  1233. begin
  1234. propvalue := rProp.GetValue(aObject);
  1235. jpair := TJSONPair.Create(propertyName,nil);
  1236. // if (propvalue.IsObject) and (IsGenericList(propvalue.AsObject)) then
  1237. // begin
  1238. // jpair.JsonValue := SerializeValue(GetPropertyValueFromObject(propvalue.AsObject,'List'));
  1239. // end
  1240. if propvalue.IsObject then jpair.JsonValue := SerializeObject(propvalue.AsObject)
  1241. {$IFNDEF FPC}
  1242. else if (not propvalue.IsObject) and (IsGenericXArray(string(propvalue{$IFNDEF NEXTGEN}.TypeInfo.Name{$ELSE}.TypeInfo.NameFld.ToString{$ENDIF}))) then
  1243. begin
  1244. jpair.JsonValue := SerializeValue(GetFieldValueFromRecord(propvalue,'fArray'));
  1245. end
  1246. {$ENDIF}
  1247. else
  1248. begin
  1249. {$IFNDEF FPC}
  1250. jpair.JsonValue := SerializeValue(propvalue);
  1251. {$ELSE}
  1252. jpair.JsonValue := SerializeValue(propvalue);// SerializeObject(aObject,rProp.PropertyType.TypeKind,propertyname);
  1253. {$ENDIF}
  1254. end;
  1255. //s := jpair.JsonValue.ToString;
  1256. if jpair.JsonValue <> nil then
  1257. begin
  1258. Result.AddPair(jpair);
  1259. end
  1260. else jpair.Free;
  1261. end;
  1262. end;
  1263. end;
  1264. end;
  1265. except
  1266. on E : Exception do
  1267. begin
  1268. if Result <> nil then Result.Free;
  1269. if not propertyname.IsEmpty then raise EJsonSerializeError.CreateFmt('Serialize Error -> Object property: "%s" (%s)',[propertyname,e.Message])
  1270. else raise EJsonSerializeError.CreateFmt('Serialize Error -> Object (%s)',[e.Message]);
  1271. end;
  1272. end;
  1273. end;
  1274. function TRTTIJson.GetValue(aAddr: Pointer; aType: TRTTIType): TValue;
  1275. begin
  1276. TValue.Make(aAddr,aType.Handle,Result);
  1277. end;
  1278. {$IFDEF FPC}
  1279. function TRTTIJson.GetValue(aAddr: Pointer; aTypeInfo: PTypeInfo): TValue;
  1280. begin
  1281. TValue.Make(aAddr,aTypeInfo,Result);
  1282. end;
  1283. {$ENDIF}
  1284. function TRTTIJson.SerializeValue(const aValue : TValue) : TJSONValue;
  1285. begin
  1286. Result := nil;
  1287. case avalue.Kind of
  1288. tkDynArray :
  1289. begin
  1290. {$IFNDEF FPC}
  1291. Result := SerializeDynArray(aValue);
  1292. {$ENDIF}
  1293. end;
  1294. tkClass :
  1295. begin
  1296. Result := TJSONValue(SerializeObject(aValue.AsObject));
  1297. end;
  1298. tkInterface :
  1299. begin
  1300. {$IFDEF DELPHIRX10_UP}
  1301. // Would not work with iOS/Android native interfaces
  1302. Result := TJSONValue(SerializeObject(aValue.AsInterface as TObject));
  1303. {$ENDIF}
  1304. end;
  1305. tkString, tkLString, tkWString, tkUString :
  1306. begin
  1307. Result := TJSONString.Create(aValue.AsString);
  1308. end;
  1309. tkChar, tkWChar :
  1310. begin
  1311. Result := TJSONString.Create(aValue.AsString);
  1312. end;
  1313. tkInteger :
  1314. begin
  1315. Result := TJSONNumber.Create(aValue.AsInteger);
  1316. end;
  1317. tkInt64 :
  1318. begin
  1319. Result := TJSONNumber.Create(aValue.AsInt64);
  1320. end;
  1321. tkFloat :
  1322. begin
  1323. if aValue.TypeInfo = TypeInfo(TDateTime) then
  1324. begin
  1325. if aValue.AsExtended <> 0.0 then Result := TJSONString.Create(DateTimeToJsonDate(aValue.AsExtended));
  1326. end
  1327. else if aValue.TypeInfo = TypeInfo(TDate) then
  1328. begin
  1329. if aValue.AsExtended <> 0.0 then Result := TJSONString.Create(DateToStr(aValue.AsExtended));
  1330. end
  1331. else if aValue.TypeInfo = TypeInfo(TTime) then
  1332. begin
  1333. Result := TJSONString.Create(TimeToStr(aValue.AsExtended));
  1334. end
  1335. else
  1336. begin
  1337. Result := TJSONNumber.Create(aValue.AsExtended);
  1338. end;
  1339. end;
  1340. tkEnumeration :
  1341. begin
  1342. if (aValue.TypeInfo = System.TypeInfo(Boolean)) then
  1343. begin
  1344. {$IF Defined(DELPHIRX10_UP) OR Defined(FPC)}
  1345. Result := TJSONBool.Create(aValue.AsBoolean);
  1346. {$ELSE}
  1347. if aValue.AsBoolean then Result := TJsonTrue.Create
  1348. else Result := TJsonFalse.Create;
  1349. {$ENDIF}
  1350. end
  1351. else
  1352. begin
  1353. //Result.JsonValue := TJSONString.Create(GetEnumName(aValue.TypeInfo,aValue.AsOrdinal));
  1354. if fUseEnumNames then Result := TJSONString.Create(aValue.ToString)
  1355. else Result := TJSONNumber.Create(GetEnumValue(aValue.TypeInfo,aValue.ToString));
  1356. end;
  1357. end;
  1358. {$IFDEF FPC}
  1359. tkBool :
  1360. begin
  1361. Result := TJSONBool.Create(aValue.AsBoolean);
  1362. end;
  1363. {$ENDIF}
  1364. tkSet :
  1365. begin
  1366. Result := TJSONString.Create(aValue.ToString);
  1367. end;
  1368. tkRecord :
  1369. begin
  1370. {$IFNDEF FPC}
  1371. Result := SerializeRecord(aValue);
  1372. {$ENDIF}
  1373. end;
  1374. tkVariant :
  1375. begin
  1376. {$IFNDEF FPC}
  1377. case VarType(aValue.AsVariant) and VarTypeMask of
  1378. varInteger, varInt64 : Result := TJSONNumber.Create(aValue.AsInteger);
  1379. varString, varUString, varEmpty : Result := TJSONString.Create(aValue.AsString);
  1380. varDouble : Result := TJSONNumber.Create(aValue.AsExtended);
  1381. end;
  1382. {$ENDIF}
  1383. end;
  1384. tkMethod, tkPointer, tkClassRef, tkProcedure, tkUnknown :
  1385. begin
  1386. //skip these properties
  1387. end
  1388. else
  1389. begin
  1390. {$IFNDEF FPC}
  1391. raise EJsonSerializeError.CreateFmt(cNotSupportedDataType,[GetTypeName(aValue.TypeInfo)]);
  1392. {$ELSE}
  1393. raise EJsonSerializeError.Create('Not supported Data Type');
  1394. {$ENDIF}
  1395. end;
  1396. end;
  1397. if Result = nil then Result := TJSONNull.Create;
  1398. end;
  1399. function TRTTIJson.SerializeStream(aObject: TObject): TJSONValue;
  1400. var
  1401. stream : TStream;
  1402. begin
  1403. Result := nil;
  1404. try
  1405. stream := TStream(aObject);
  1406. if fUseBase64Stream then Result := TJSONString.Create(Base64Encode(StreamToString(stream,TEncoding.Ansi)))
  1407. else Result := TJSONString.Create(StreamToString(stream,TEncoding.Ansi));
  1408. except
  1409. on E : Exception do
  1410. begin
  1411. EJsonSerializeError.CreateFmt('Serialize Error -> Stream (%s)',[e.Message]);
  1412. end;
  1413. end;
  1414. end;
  1415. {$IFNDEF FPC}
  1416. function TRTTIJson.SerializeDynArray(const aValue: TValue; aMaxElements : Integer = -1) : TJsonArray;
  1417. var
  1418. ctx : TRttiContext;
  1419. rDynArray : TRTTIDynamicArrayType;
  1420. i : Integer;
  1421. jValue : TJSONValue;
  1422. element : Integer;
  1423. list : TList<TJSONValue>;
  1424. len : Integer;
  1425. begin
  1426. element := -1;
  1427. Result := TJSONArray.Create;
  1428. try
  1429. rDynArray := ctx.GetType(aValue.TypeInfo) as TRTTIDynamicArrayType;
  1430. //if aValue.IsObjectInstance then TList<TObject>(aValue.AsObject).TrimExcess;
  1431. list := TList<TJSONValue>.Create;
  1432. if aMaxElements = -1 then len := aValue.GetArrayLength
  1433. else len := aMaxElements;
  1434. list.Capacity := len;
  1435. for i := 0 to len - 1 do
  1436. begin
  1437. if not GetValue(PPByte(aValue.GetReferenceToRawData)^ + rDynArray.ElementType.TypeSize * i, rDynArray.ElementType).IsEmpty then
  1438. begin
  1439. element := i;
  1440. jValue := SerializeValue(GetValue(PPByte(aValue.GetReferenceToRawData)^ + rDynArray.ElementType.TypeSize * i, rDynArray.ElementType));
  1441. if jValue = nil then jValue := TJSONNull.Create;
  1442. list.Add(jValue);
  1443. end;
  1444. end;
  1445. Result.SetElements(list);
  1446. except
  1447. on E : Exception do
  1448. begin
  1449. if element > -1 then raise EJsonSerializeError.CreateFmt('Serialize Error -> Array[%d] (%s)',[element,e.Message])
  1450. else raise EJsonSerializeError.CreateFmt('Serialize Error -> Array (%s)',[e.Message]);
  1451. end;
  1452. end;
  1453. end;
  1454. function TRTTIJson.SerializeRecord(const aValue : TValue) : TJSONValue;
  1455. var
  1456. ctx : TRttiContext;
  1457. json : TJSONObject;
  1458. rRec : TRttiRecordType;
  1459. rField : TRttiField;
  1460. begin
  1461. rField := nil;
  1462. try
  1463. rRec := ctx.GetType(aValue.TypeInfo).AsRecord;
  1464. if aValue.TypeInfo = System.TypeInfo(TGUID) then
  1465. begin
  1466. Result := TJSONString.Create(GUIDToString(aValue.AsType<TGUID>));
  1467. end
  1468. else
  1469. begin
  1470. json := TJSONObject.Create;
  1471. for rField in rRec.GetFields do
  1472. begin
  1473. json.AddPair(rField.Name,SerializeValue(rField.GetValue(aValue.GetReferenceToRawData)));
  1474. end;
  1475. Result := json;
  1476. end;
  1477. except
  1478. on E : Exception do
  1479. begin
  1480. if rField <> nil then raise EJsonSerializeError.CreateFmt('Serialize Error -> Record property "%s" (%s)',[rField.Name,e.Message])
  1481. else raise EJsonSerializeError.CreateFmt('Serialize Error -> Record (%s)',[e.Message]);
  1482. end;
  1483. end;
  1484. end;
  1485. {$ELSE}
  1486. function TRTTIJson.GetPropType(aPropInfo: PPropInfo): PTypeInfo;
  1487. begin
  1488. Result := aPropInfo^.PropType;
  1489. end;
  1490. function TRTTIJson.FloatProperty(aObject : TObject; aPropInfo: PPropInfo): string;
  1491. const
  1492. Precisions: array[TFloatType] of Integer = (7, 15, 18, 18, 19);
  1493. var
  1494. fsettings : TFormatSettings;
  1495. begin
  1496. fsettings := FormatSettings;
  1497. Result := StringReplace(FloatToStrF(GetFloatProp(aObject, aPropInfo), ffGeneral,
  1498. Precisions[GetTypeData(GetPropType(aPropInfo))^.FloatType],0),
  1499. '.',fsettings.DecimalSeparator,[rfReplaceAll]);
  1500. end;
  1501. function TRTTIJson.SerializeObject(aObject : TObject; aType : TTypeKind; const aPropertyName : string) : TJSONPair;
  1502. var
  1503. propinfo : PPropInfo;
  1504. jArray : TJsonArray;
  1505. jPair : TJsonPair;
  1506. jValue : TJsonValue;
  1507. i : Integer;
  1508. pArr : Pointer;
  1509. rValue : TValue;
  1510. rItemValue : TValue;
  1511. len : Integer;
  1512. begin
  1513. try
  1514. Result := TJSONPair.Create(aPropertyName,nil);
  1515. propinfo := GetPropInfo(aObject,aPropertyName);
  1516. //case propinfo.PropType.Kind of
  1517. case aType of
  1518. tkDynArray :
  1519. begin
  1520. len := 0;
  1521. jArray := TJSONArray.Create;
  1522. try
  1523. pArr := GetDynArrayProp(aObject,aPropertyName);
  1524. TValue.Make(@pArr,propinfo.PropType, rValue);
  1525. if rValue.IsArray then
  1526. begin
  1527. len := rValue.GetArrayLength;
  1528. for i := 0 to len - 1 do
  1529. begin
  1530. rItemValue := rValue.GetArrayElement(i);
  1531. jValue := SerializeValue(rItemValue);
  1532. jArray.Add(jValue);
  1533. end;
  1534. end;
  1535. Result.JsonValue := jArray;
  1536. finally
  1537. //DynArrayClear(pArr,propinfo.PropType);
  1538. pArr := nil;
  1539. end;
  1540. end;
  1541. tkClass :
  1542. begin
  1543. Result.JsonValue := TJSONValue(SerializeObject(GetObjectProp(aObject,aPropertyName)));
  1544. end;
  1545. tkString, tkLString, tkWString, tkUString, tkAString :
  1546. begin
  1547. Result.JsonValue := TJSONString.Create(GetStrProp(aObject,aPropertyName));
  1548. end;
  1549. tkChar, tkWChar :
  1550. begin
  1551. Result.JsonValue := TJSONString.Create(Char(GetOrdProp(aObject,aPropertyName)));
  1552. end;
  1553. tkInteger :
  1554. begin
  1555. Result.JsonValue := TJSONNumber.Create(GetOrdProp(aObject,aPropertyName));
  1556. end;
  1557. tkInt64 :
  1558. begin
  1559. Result.JsonValue := TJSONNumber.Create(GetOrdProp(aObject,aPropertyName));
  1560. end;
  1561. tkFloat :
  1562. begin
  1563. if propinfo.PropType = TypeInfo(TDateTime) then
  1564. begin
  1565. Result.JsonValue := TJSONString.Create(DateTimeToJsonDate(GetFloatProp(aObject,aPropertyName)));
  1566. end
  1567. else if propinfo.PropType = TypeInfo(TDate) then
  1568. begin
  1569. Result.JsonValue := TJSONString.Create(DateToStr(GetFloatProp(aObject,aPropertyName)));
  1570. end
  1571. else if propinfo.PropType = TypeInfo(TTime) then
  1572. begin
  1573. Result.JsonValue := TJSONString.Create(TimeToStr(GetFloatProp(aObject,aPropertyName)));
  1574. end
  1575. else
  1576. begin
  1577. //Result.JsonValue := TJsonFloatNumber.Create(GetFloatProp(aObject,aPropertyName));
  1578. Result.JsonValue := TJsonFloatNumber.Create(StrToFloat(FloatProperty(aObject,propinfo)));
  1579. end;
  1580. end;
  1581. tkEnumeration,tkBool :
  1582. begin
  1583. if (propinfo.PropType = System.TypeInfo(Boolean)) then
  1584. begin
  1585. Result.JsonValue := TJSONBool.Create(Boolean(GetOrdProp(aObject,aPropertyName)));
  1586. end
  1587. else
  1588. begin
  1589. if fUseEnumNames then Result.JsonValue := TJSONString.Create(GetEnumName(propinfo.PropType,GetOrdProp(aObject,aPropertyName)))
  1590. else Result.JsonValue := TJSONNumber.Create(GetOrdProp(aObject,aPropertyName));
  1591. //Result.JsonValue := TJSONString.Create(aValue.ToString);
  1592. end;
  1593. end;
  1594. tkSet :
  1595. begin
  1596. Result.JsonValue := TJSONString.Create(GetSetProp(aObject,aPropertyName));
  1597. end;
  1598. {$IFNDEF FPC}
  1599. tkRecord :
  1600. begin
  1601. Result.JsonValue := SerializeRecord(aValue);
  1602. end;
  1603. {$ENDIF}
  1604. tkMethod, tkPointer, tkClassRef ,tkInterface, tkProcedure :
  1605. begin
  1606. //skip these properties
  1607. //FreeAndNil(Result);
  1608. end
  1609. else
  1610. begin
  1611. //raise EJsonDeserializeError.CreateFmt('Not supported type "%s":%d',[aName,Integer(aValue.Kind)]);
  1612. end;
  1613. end;
  1614. if Result.JsonValue = nil then Result.JsonValue := TJSONNull.Create;
  1615. except
  1616. on E : Exception do
  1617. begin
  1618. Result.Free;
  1619. {$IFNDEF FPC}
  1620. raise EJsonSerializeError.CreateFmt('Serialize error class "%s.%s" : %s',[aName,aValue.ToString,e.Message]);
  1621. {$ENDIF}
  1622. end;
  1623. end;
  1624. end;
  1625. {$ENDIF}
  1626. { TJsonSerializer}
  1627. constructor TJsonSerializer.Create(aSerializeLevel: TSerializeLevel; aUseEnumNames : Boolean = True; aUseNullStringsAsEmpty : Boolean = False);
  1628. begin
  1629. {$IFDEF FPC}
  1630. if aSerializeLevel = TSerializeLevel.slPublicProperty then raise EJsonSerializeError.Create('FreePascal RTTI only supports published properties');
  1631. {$ENDIF}
  1632. fSerializeLevel := aSerializeLevel;
  1633. fUseEnumNames := aUseEnumNames;
  1634. fUseJsonCaseSense := False;
  1635. fUseBase64Stream := True;
  1636. fUseNullStringsAsEmpty := aUseNullStringsAsEmpty;
  1637. fRTTIJson := TRTTIJson.Create(aSerializeLevel,aUseEnumNames);
  1638. fRTTIJson.UseJsonCaseSense := fUseJsonCaseSense;
  1639. fRTTIJson.UseBase64Stream := fUseBase64Stream;
  1640. fRTTIJson.UseNullStringsAsEmpty := fUseNullStringsAsEmpty;
  1641. end;
  1642. destructor TJsonSerializer.Destroy;
  1643. begin
  1644. fRTTIJson.Free;
  1645. inherited;
  1646. end;
  1647. function TJsonSerializer.JsonToObject(aType: TClass; const aJson: string): TObject;
  1648. var
  1649. jvalue : TJSONValue;
  1650. json: TJSONObject;
  1651. begin
  1652. {$IFDEF DEBUG_SERIALIZER}
  1653. TDebugger.TimeIt(Self,'JsonToObject',aType.ClassName);
  1654. {$ENDIF}
  1655. try
  1656. {$IFDEF DELPHIRX10_UP}
  1657. jvalue := TJSONObject.ParseJSONValue(aJson,True);
  1658. if jvalue.ClassType = TJSONArray then json := TJSONObject(jvalue)
  1659. else json := jvalue as TJSONObject;
  1660. {$ELSE}
  1661. {$IFDEF FPC}
  1662. json := TJSONObject(TJSONObject.ParseJSONValue(aJson,True));
  1663. {$ELSE}
  1664. json := TJsonObject.ParseJSONValue(TEncoding.UTF8.GetBytes(aJson),0,True) as TJSONObject;
  1665. {$ENDIF}
  1666. {$ENDIF}
  1667. except
  1668. raise EJsonDeserializeError.Create(cNotValidJson);
  1669. end;
  1670. try
  1671. Result := fRTTIJson.DeserializeClass(aType,json);
  1672. finally
  1673. json.Free;
  1674. end;
  1675. end;
  1676. function TJsonSerializer.JsonToObject(aObject: TObject; const aJson: string): TObject;
  1677. var
  1678. jvalue : TJSONValue;
  1679. json: TJSONObject;
  1680. begin;
  1681. if aObject = nil then raise EJsonDeserializeError.Create('Object param cannot be null!');
  1682. {$IFDEF DEBUG_SERIALIZER}
  1683. TDebugger.TimeIt(Self,'JsonToObject',aObject.ClassName);
  1684. {$ENDIF}
  1685. try
  1686. {$IFDEF DELPHIRX10_UP}
  1687. jvalue := TJSONObject.ParseJSONValue(aJson,True);
  1688. if jvalue.ClassType = TJSONArray then json := TJSONObject(jvalue)
  1689. else json := jvalue as TJSONObject;
  1690. //json := TJSONObject.ParseJSONValue(aJson,True) as TJSONObject;
  1691. {$ELSE}
  1692. {$IFDEF FPC}
  1693. json := TJSONObject(TJSONObject.ParseJSONValue(aJson,True));
  1694. {$ELSE}
  1695. json := TJsonObject.ParseJSONValue(TEncoding.UTF8.GetBytes(aJson),0,True) as TJSONObject;
  1696. {$ENDIF}
  1697. {$ENDIF}
  1698. except
  1699. raise EJsonDeserializeError.Create(cNotValidJson);
  1700. end;
  1701. try
  1702. Result := fRTTIJson.DeserializeObject(aObject,json);
  1703. finally
  1704. json.Free;
  1705. end;
  1706. end;
  1707. function TJsonSerializer.ObjectToJson(aObject : TObject; aIndent : Boolean = False): string;
  1708. var
  1709. json: TJSONObject;
  1710. begin
  1711. {$IFDEF DEBUG_SERIALIZER}
  1712. TDebugger.TimeIt(Self,'ObjectToJson',aObject.ClassName);
  1713. {$ENDIF}
  1714. json := fRTTIJson.SerializeObject(aObject);
  1715. try
  1716. if aIndent then Result := TJsonUtils.JsonFormat(json.ToJSON)
  1717. else Result := json.ToJSON;
  1718. finally
  1719. json.Free;
  1720. end;
  1721. end;
  1722. procedure TJsonSerializer.ObjectToJsonStream(aObject: TObject; aStream: TStream);
  1723. var
  1724. json : TJsonObject;
  1725. ss : TStringStream;
  1726. begin
  1727. {$IFDEF DEBUG_SERIALIZER}
  1728. TDebugger.TimeIt(Self,'ObjectToJsonStream',aObject.ClassName);
  1729. {$ENDIF}
  1730. if aStream = nil then raise EJsonSerializeError.Create('stream parameter cannot be nil!');
  1731. json := fRTTIJson.SerializeObject(aObject);
  1732. try
  1733. ss := TStringStream.Create(json.ToString,TEncoding.UTF8);
  1734. try
  1735. aStream.CopyFrom(ss,ss.Size);
  1736. finally
  1737. ss.Free;
  1738. end;
  1739. finally
  1740. json.Free;
  1741. end;
  1742. end;
  1743. function TJsonSerializer.ObjectToJsonString(aObject : TObject; aIndent : Boolean = False): string;
  1744. var
  1745. json: TJSONObject;
  1746. begin
  1747. {$IFDEF DEBUG_SERIALIZER}
  1748. TDebugger.TimeIt(Self,'ObjectToJsonString',aObject.ClassName);
  1749. {$ENDIF}
  1750. json := fRTTIJson.SerializeObject(aObject);
  1751. try
  1752. if aIndent then Result := TJsonUtils.JsonFormat(json.ToString)
  1753. else Result := json.ToString;
  1754. finally
  1755. json.Free;
  1756. end;
  1757. end;
  1758. function TJsonSerializer.ValueToJson(const aValue: TValue; aIndent: Boolean): string;
  1759. var
  1760. json: TJSONValue;
  1761. begin
  1762. {$IFDEF DEBUG_SERIALIZER}
  1763. TDebugger.TimeIt(Self,'ValueToJson',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{$IFNDEF FPC}.ToJSON{$ELSE}.AsJson{$ENDIF})
  1769. else Result := json{$IFNDEF FPC}.ToJSON{$ELSE}.AsJson{$ENDIF};
  1770. finally
  1771. json.Free;
  1772. end;
  1773. end;
  1774. function TJsonSerializer.ValueToJsonString(const aValue: TValue; aIndent: Boolean): string;
  1775. var
  1776. json: TJSONValue;
  1777. begin
  1778. {$IFDEF DEBUG_SERIALIZER}
  1779. TDebugger.TimeIt(Self,'ValueToJsonString',aValue.ToString);
  1780. {$ENDIF}
  1781. json:= fRTTIJson.SerializeValue(aValue);
  1782. if json = nil then raise EJsonSerializerError.Create('Error serializing TValue');
  1783. try
  1784. if aIndent then Result := TJsonUtils.JsonFormat(json.ToString)
  1785. else Result := json.ToString;
  1786. finally
  1787. json.Free;
  1788. end;
  1789. end;
  1790. function TJsonSerializer.ArrayToJson<T>(aArray: TArray<T>; aIndent: Boolean): string;
  1791. var
  1792. json: TJSONValue;
  1793. begin
  1794. {$IFDEF DEBUG_SERIALIZER}
  1795. TDebugger.TimeIt(Self,'ArrayToJson','');
  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{$IFNDEF FPC}.ToJSON{$ELSE}.AsJson{$ENDIF})
  1801. else Result := json{$IFNDEF FPC}.ToJSON{$ELSE}.AsJson{$ENDIF};
  1802. finally
  1803. json.Free;
  1804. end;
  1805. end;
  1806. function TJsonSerializer.ArrayToJsonString<T>(aArray: TArray<T>; aIndent: Boolean): string;
  1807. var
  1808. json: TJSONValue;
  1809. begin
  1810. {$IFDEF DEBUG_SERIALIZER}
  1811. TDebugger.TimeIt(Self,'ArrayToJsonString','');
  1812. {$ENDIF}
  1813. json:= fRTTIJson.SerializeValue(TValue.From<TArray<T>>(aArray));
  1814. if json = nil then raise EJsonSerializerError.Create('Error serializing Array');
  1815. try
  1816. if aIndent then Result := TJsonUtils.JsonFormat(json.ToString)
  1817. else Result := json.ToString;
  1818. finally
  1819. json.Free;
  1820. end;
  1821. end;
  1822. function TJsonSerializer.JsonStreamToObject(aObject: TObject; aJsonStream: TStream): TObject;
  1823. var
  1824. json : string;
  1825. begin
  1826. {$IFDEF DEBUG_SERIALIZER}
  1827. TDebugger.TimeIt(Self,'JsonStreamToObject','');
  1828. {$ENDIF}
  1829. if aJsonStream = nil then raise EJsonDeserializeError.Create('JsonStream param cannot be nil!');
  1830. json := StreamToString(aJsonStream,TEncoding.UTF8);
  1831. Result := JsonToObject(aObject,json);
  1832. end;
  1833. {$IFNDEF FPC}
  1834. function TJsonSerializer.JsonToArray<T>(const aJson: string): TArray<T>;
  1835. var
  1836. jarray: TJSONArray;
  1837. value : TValue;
  1838. begin;
  1839. {$IFDEF DEBUG_SERIALIZER}
  1840. TDebugger.TimeIt(Self,'JsonToArray','');
  1841. {$ENDIF}
  1842. try
  1843. {$If Defined(FPC) OR Defined(DELPHIRX10_UP)}
  1844. jarray := TJSONObject.ParseJSONValue(aJson,True) as TJSONArray;
  1845. {$ELSE}
  1846. jarray := TJsonObject.ParseJSONValue(TEncoding.UTF8.GetBytes(aJson),0,True) as TJSONArray;
  1847. {$ENDIF}
  1848. except
  1849. raise EJsonDeserializeError.Create(cNotValidJson);
  1850. end;
  1851. try
  1852. value := fRTTIJson.DeserializeDynArray(PTypeInfo(TypeInfo(TArray<T>)),nil,jarray);
  1853. Result := value.AsType<TArray<T>>;
  1854. finally
  1855. jarray.Free;
  1856. end;
  1857. end;
  1858. function TJsonSerializer.JsonToValue(const aJson: string): TValue;
  1859. var
  1860. json: TJSONObject;
  1861. value : TValue;
  1862. begin;
  1863. {$IFDEF DEBUG_SERIALIZER}
  1864. TDebugger.TimeIt(Self,'JsonToValue','');
  1865. {$ENDIF}
  1866. try
  1867. {$If Defined(FPC) OR Defined(DELPHIRX10_UP)}
  1868. json := TJSONObject.ParseJSONValue(aJson,True) as TJSONObject;
  1869. {$ELSE}
  1870. json := TJsonObject.ParseJSONValue(TEncoding.UTF8.GetBytes(aJson),0,True) as TJSONObject;
  1871. {$ENDIF}
  1872. except
  1873. raise EJsonDeserializeError.Create(cNotValidJson);
  1874. end;
  1875. try
  1876. value := fRTTIJson.DeserializeRecord(value,nil,json);
  1877. Result := value; // value.AsType<TArray<T>>;
  1878. finally
  1879. json.Free;
  1880. end;
  1881. end;
  1882. {$ENDIF}
  1883. procedure TJsonSerializer.SetSerializeLevel(const Value: TSerializeLevel);
  1884. begin
  1885. fSerializeLevel := Value;
  1886. if Assigned(fRTTIJson) then fRTTIJson.fSerializeLevel := Value;
  1887. end;
  1888. procedure TJsonSerializer.SetUseBase64Stream(const Value: Boolean);
  1889. begin
  1890. fUseBase64Stream := Value;
  1891. if Assigned(fRTTIJson) then fRTTIJson.UseBase64Stream := Value;
  1892. end;
  1893. procedure TJsonSerializer.SetUseEnumNames(const Value: Boolean);
  1894. begin
  1895. fUseEnumNames := Value;
  1896. if Assigned(fRTTIJson) then fRTTIJson.UseEnumNames := Value;
  1897. end;
  1898. procedure TJsonSerializer.SetUseJsonCaseSense(const Value: Boolean);
  1899. begin
  1900. fUseJsonCaseSense := Value;
  1901. if Assigned(fRTTIJson) then fRTTIJson.UseJsonCaseSense := Value;
  1902. end;
  1903. procedure TJsonSerializer.SetUseNullStringsAsEmpty(const Value: Boolean);
  1904. begin
  1905. fUseNullStringsAsEmpty := Value;
  1906. if Assigned(fRTTIJson) then fRTTIJson.fUseNullStringsAsEmpty := Value;
  1907. end;
  1908. {$IFNDEF FPC}
  1909. { TCommentProperty }
  1910. constructor TCommentProperty.Create(const aComment: string);
  1911. begin
  1912. fComment := aComment;
  1913. end;
  1914. { TCustomNameProperty }
  1915. constructor TCustomNameProperty.Create(const aName: string);
  1916. begin
  1917. fName := aName;
  1918. end;
  1919. {$ENDIF}
  1920. {$IF NOT DEFINED(DELPHIXE7_UP) AND NOT DEFINED(FPC)}
  1921. { TJSONArrayHelper }
  1922. function TJSONArrayHelper.Count: Integer;
  1923. begin
  1924. Result := Self.Size;
  1925. end;
  1926. function TJSONArrayHelper.GetItem(aValue: Integer): TJSONValue;
  1927. begin
  1928. Result := Self.Get(aValue);
  1929. end;
  1930. procedure TJSONArrayHelper.SetElements(aElements: TList<TJSONValue>);
  1931. var
  1932. jvalue : TJSONValue;
  1933. begin
  1934. for jvalue in aElements do Self.AddElement(jvalue);
  1935. aElements.Free;
  1936. end;
  1937. { TJSONValueHelper }
  1938. function TJSONValueHelper.ToJson: string;
  1939. begin
  1940. Result := Self.ToString;
  1941. end;
  1942. { TJSONObjectHelper }
  1943. function TJSONObjectHelper.Count: Integer;
  1944. begin
  1945. Result := Self.Size;
  1946. end;
  1947. function TJSONObjectHelper.GetValue(const aName: string): TJSONValue;
  1948. var
  1949. jPair : TJSONPair;
  1950. begin
  1951. Result := nil;
  1952. for jPair in Self do
  1953. begin
  1954. if jPair.JsonString.ToString = aName then Exit(jPair.JsonValue);
  1955. end;
  1956. end;
  1957. function TJSONObjectHelper.GetPair(aValue: Integer) : TJSONPair;
  1958. begin
  1959. Result := Self.Get(aValue);
  1960. end;
  1961. {$ENDIF}
  1962. end.