Quick.Json.Serializer.pas 67 KB

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