Quick.Json.Serializer.pas 51 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614
  1. { ***************************************************************************
  2. Copyright (c) 2015-2019 Kike Pérez
  3. Unit : Quick.JSON.Serializer
  4. Description : Json Serializer
  5. Author : Kike Pérez
  6. Version : 1.8
  7. Created : 21/05/2018
  8. Modified : 12/04/2019
  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. Classes,
  26. SysUtils,
  27. Rtti,
  28. TypInfo,
  29. {$IFDEF FPC}
  30. rttiutils,
  31. fpjson,
  32. jsonparser,
  33. strUtils,
  34. //jsonreader,
  35. //fpjsonrtti,
  36. Quick.Json.fpc.Compatibility,
  37. {$ELSE}
  38. {$IFDEF DELPHIXE7_UP}
  39. System.Json,
  40. {$ENDIF}
  41. {$IFDEF DELPHIRX103_UP}
  42. System.Generics.Collections,
  43. {$ENDIF}
  44. {$ENDIF}
  45. DateUtils,
  46. Quick.Commons,
  47. Quick.JSON.Utils;
  48. type
  49. EJsonSerializeError = class(Exception);
  50. EJsonDeserializeError = class(Exception);
  51. {$IFNDEF FPC}
  52. TNotSerializableProperty = class(TCustomAttribute);
  53. TCommentProperty = class(TCustomAttribute)
  54. private
  55. fComment : string;
  56. public
  57. constructor Create(const aComment: string);
  58. property Comment : string read fComment;
  59. end;
  60. TCustomNameProperty = class(TCustomAttribute)
  61. private
  62. fName : string;
  63. public
  64. constructor Create(const aName: string);
  65. property Name : string read fName;
  66. end;
  67. {$ENDIF}
  68. IJsonSerializer = interface
  69. ['{CA26F7AE-F1FE-41BE-9C23-723A687F60D1}']
  70. function JsonToObject(aType: TClass; const aJson: string): TObject; overload;
  71. function JsonToObject(aObject: TObject; const aJson: string): TObject; overload;
  72. function ObjectToJson(aObject : TObject; aIndent : Boolean = False): string;
  73. end;
  74. TSerializeLevel = (slPublicProperty, slPublishedProperty);
  75. TRTTIJson = class
  76. private
  77. fSerializeLevel : TSerializeLevel;
  78. fUseEnumNames : Boolean;
  79. fUseJsonCaseSense : Boolean;
  80. function GetValue(aAddr: Pointer; aType: TRTTIType): TValue; overload;
  81. function GetValue(aAddr: Pointer; aTypeInfo: PTypeInfo): TValue; overload;
  82. function IsAllowedProperty(aObject : TObject; const aPropertyName : string) : Boolean;
  83. function IsGenericList(aObject : TObject) : Boolean;
  84. function IsGenericXArray(const aClassName : string) : Boolean;
  85. function GetPropertyValue(Instance : TObject; const PropertyName : string) : TValue;
  86. function GetPropertyValueFromObject(Instance : TObject; const PropertyName : string) : TValue;
  87. {$IFNDEF FPC}
  88. function GetFieldValueFromRecord(aValue : TValue; const FieldName : string) : TValue;
  89. {$ENDIF}
  90. procedure SetPropertyValue(Instance : TObject; aPropInfo : PPropInfo; aValue : TValue); overload;
  91. procedure SetPropertyValue(Instance : TObject; const PropertyName : string; aValue : TValue); overload;
  92. {$IFDEF FPC}
  93. function FloatProperty(aObject : TObject; aPropInfo: PPropInfo): string;
  94. function GetPropType(aPropInfo: PPropInfo): PTypeInfo;
  95. procedure LoadSetProperty(aInstance : TObject; aPropInfo: PPropInfo; const aValue: string);
  96. {$ENDIF}
  97. public
  98. constructor Create(aSerializeLevel : TSerializeLevel; aUseEnumNames : Boolean = True);
  99. property UseEnumNames : Boolean read fUseEnumNames write fUseEnumNames;
  100. property UseJsonCaseSense : Boolean read fUseJsonCaseSense write fUseJsonCaseSense;
  101. {$IFNDEF FPC}
  102. function DeserializeDynArray(aTypeInfo : PTypeInfo; aObject : TObject; const aJsonArray: TJSONArray) : TValue;
  103. function DeserializeRecord(aRecord : TValue; aObject : TObject; const aJson : TJSONObject) : TValue;
  104. {$ELSE}
  105. procedure DeserializeDynArray(aTypeInfo: PTypeInfo; const aPropertyName : string; aObject: TObject; const aJsonArray: TJSONArray);
  106. {$ENDIF}
  107. function DeserializeClass(aType : TClass; const aJson : TJSONObject) : TObject;
  108. function DeserializeObject(aObject : TObject; const aJson : TJSONObject) : TObject; overload;
  109. {$IFNDEF FPC}
  110. function DeserializeList(aObject: TObject; const aName : string; const aJson: TJSONObject) : TObject;
  111. procedure DeserializeXArray(Instance : TObject; aRecord : TValue; aProperty : TRttiProperty; const aPropertyName : string; aJson : TJsonObject);
  112. {$ENDIF}
  113. function DeserializeProperty(aObject : TObject; const aName : string; aProperty : TRttiProperty; const aJson : TJSONObject) : TObject; overload;
  114. {$IFNDEF FPC}
  115. function DeserializeType(aObject : TObject; aType : TTypeKind; aTypeInfo : PTypeInfo; const aValue: string) : TValue;
  116. {$ELSE}
  117. function DeserializeType(aObject : TObject; aType : TTypeKind; const aPropertyName, aValue: string) : TValue;
  118. {$ENDIF}
  119. {$IFNDEF FPC}
  120. function Serialize(const aName : string; aValue : TValue) : TJSONPair; overload;
  121. {$ELSE}
  122. function Serialize(aObject : TObject; aType : TTypeKind; const aPropertyName : string) : TJSONPair;
  123. function Serialize(const aName : string; aValue : TValue) : TJSONPair;
  124. {$ENDIF}
  125. function Serialize(aObject : TObject) : TJSONObject; overload;
  126. function GetJsonPairByName(aJson : TJSONObject; const aName : string) : TJSONPair;
  127. end;
  128. TJsonSerializer = class(TInterfacedObject,IJsonSerializer)
  129. strict private
  130. fSerializeLevel : TSerializeLevel;
  131. fUseEnumNames : Boolean;
  132. fUseJsonCaseSense : Boolean;
  133. fRTTIJson : TRTTIJson;
  134. private
  135. procedure SetUseEnumNames(const Value: Boolean);
  136. procedure SetUseJsonCaseSense(const Value: Boolean);
  137. public
  138. constructor Create(aSerializeLevel: TSerializeLevel; aUseEnumNames : Boolean = True);
  139. destructor Destroy; override;
  140. property SerializeLevel : TSerializeLevel read fSerializeLevel;
  141. property UseEnumNames : Boolean read fUseEnumNames write SetUseEnumNames;
  142. property UseJsonCaseSense : Boolean read fUseJsonCaseSense write SetUseJsonCaseSense;
  143. function JsonToObject(aType : TClass; const aJson: string) : TObject; overload;
  144. function JsonToObject(aObject : TObject; const aJson: string) : TObject; overload;
  145. function ObjectToJson(aObject : TObject; aIndent : Boolean = False): string;
  146. function ObjectToJsonString(aObject : TObject; aIndent : Boolean = False): string;
  147. end;
  148. PPByte = ^PByte;
  149. resourcestring
  150. cNotSupportedDataType = 'Not supported "%s" data type "%s"';
  151. cNotSerializable = 'Object is not serializable';
  152. implementation
  153. { TRTTIJson }
  154. {$IFNDEF FPC}
  155. function TRTTIJson.DeserializeDynArray(aTypeInfo: PTypeInfo; aObject: TObject; const aJsonArray: TJSONArray) : TValue;
  156. var
  157. rType: PTypeInfo;
  158. len: NativeInt;
  159. pArr: Pointer;
  160. rItemValue: TValue;
  161. i: Integer;
  162. objClass: TClass;
  163. ctx : TRttiContext;
  164. json : TJSONObject;
  165. rDynArray : TRttiDynamicArrayType;
  166. propObj : TObject;
  167. begin
  168. if GetTypeData(aTypeInfo).DynArrElType = nil then Exit;
  169. if not assigned(aJsonArray) then Exit;
  170. len := aJsonArray.Count;
  171. rType := GetTypeData(aTypeInfo).DynArrElType^;
  172. pArr := nil;
  173. DynArraySetLength(pArr,aTypeInfo, 1, @len);
  174. try
  175. TValue.Make(@pArr,aTypeInfo, Result);
  176. rDynArray := ctx.GetType(Result.TypeInfo) as TRTTIDynamicArrayType;
  177. for i := 0 to aJsonArray.Count - 1 do
  178. begin
  179. rItemValue := nil;
  180. case rType.Kind of
  181. tkClass :
  182. begin
  183. if aJsonArray.Items[i] is TJSONObject then
  184. begin
  185. propObj := GetValue(PPByte(Result.GetReferenceToRawData)^ +rDynArray.ElementType.TypeSize * i, rDynArray.ElementType).AsObject;
  186. if propObj = nil then
  187. begin
  188. objClass := rType.TypeData.ClassType;
  189. rItemValue := DeserializeClass(objClass, TJSONObject(aJsonArray.Items[i]));
  190. end
  191. else
  192. begin
  193. DeserializeObject(propObj,TJSONObject(aJsonArray.Items[i]));
  194. end;
  195. end;
  196. end;
  197. tkRecord :
  198. begin
  199. json := TJSONObject(aJsonArray.Items[i]);
  200. rItemValue := DeserializeRecord(GetValue(PPByte(Result.GetReferenceToRawData)^ +rDynArray.ElementType.TypeSize * i,
  201. rDynArray.ElementType),aObject,json);
  202. end;
  203. tkMethod, tkPointer, tkClassRef ,tkInterface, tkProcedure :
  204. begin
  205. //skip these properties
  206. end
  207. else
  208. begin
  209. rItemValue := DeserializeType(aObject,rType.Kind,aTypeInfo,aJsonArray.Items[i].Value);
  210. end;
  211. end;
  212. if not rItemValue.IsEmpty then Result.SetArrayElement(i,rItemValue);
  213. end;
  214. //aProperty.SetValue(aObject,rValue);
  215. finally
  216. DynArrayClear(pArr,aTypeInfo);
  217. end;
  218. end;
  219. {$ELSE}
  220. procedure TRTTIJson.DeserializeDynArray(aTypeInfo: PTypeInfo; const aPropertyName : string; aObject: TObject; const aJsonArray: TJSONArray);
  221. var
  222. rType: PTypeInfo;
  223. len: NativeInt;
  224. pArr: Pointer;
  225. rItemValue: TValue;
  226. i: Integer;
  227. objClass: TClass;
  228. propObj : TObject;
  229. rValue : TValue;
  230. begin
  231. if GetTypeData(aTypeInfo).ElType2 = nil then Exit;
  232. len := aJsonArray.Count;
  233. rType := GetTypeData(aTypeInfo).ElType2;
  234. pArr := nil;
  235. DynArraySetLength(pArr,aTypeInfo, 1, @len);
  236. try
  237. TValue.Make(@pArr,aTypeInfo, rValue);
  238. for i := 0 to aJsonArray.Count - 1 do
  239. begin
  240. rItemValue := nil;
  241. case rType.Kind of
  242. tkClass :
  243. begin
  244. if aJsonArray.Items[i] is TJSONObject then
  245. begin
  246. propObj := GetValue(PPByte(rValue.GetReferenceToRawData)^ +GetTypeData(aTypeInfo).elSize * i, GetTypeData(aTypeInfo).ElType2).AsObject;
  247. if propObj = nil then
  248. begin
  249. objClass := GetTypeData(aTypeInfo).ClassType;
  250. rItemValue := DeserializeClass(objClass, TJSONObject(aJsonArray.Items[i]));
  251. end
  252. else
  253. begin
  254. DeserializeObject(propObj,TJSONObject(aJsonArray.Items[i]));
  255. end;
  256. end;
  257. end;
  258. tkRecord :
  259. begin
  260. {json := TJSONObject(aJsonArray.Items[i]);
  261. rItemValue := DeserializeRecord(GetValue(PPByte(Result.GetReferenceToRawData)^ +rDynArray.ElementType.TypeSize * i,
  262. rDynArray.ElementType),aObject,json); }
  263. end;
  264. tkMethod, tkPointer, tkClassRef ,tkInterface, tkProcedure :
  265. begin
  266. //skip these properties
  267. end
  268. else
  269. begin
  270. rItemValue := DeserializeType(aObject,GetTypeData(aTypeInfo).ElType2.Kind,aPropertyName,aJsonArray.Items[i].Value);
  271. end;
  272. end;
  273. if not rItemValue.IsEmpty then rValue.SetArrayElement(i,rItemValue);
  274. end;
  275. //aProperty.SetValue(aObject,rValue);
  276. SetDynArrayProp(aObject,GetPropInfo(aObject,aPropertyName),pArr);
  277. finally
  278. DynArrayClear(pArr,aTypeInfo);
  279. end;
  280. end;
  281. {$ENDIF}
  282. {$IFNDEF FPC}
  283. function TRTTIJson.DeserializeRecord(aRecord : TValue; aObject : TObject; const aJson : TJSONObject) : TValue;
  284. var
  285. ctx : TRttiContext;
  286. rRec : TRttiRecordType;
  287. rField : TRttiField;
  288. rValue : TValue;
  289. member : TJSONPair;
  290. jArray : TJSONArray;
  291. json : TJSONObject;
  292. objClass : TClass;
  293. propobj : TObject;
  294. begin
  295. rRec := ctx.GetType(aRecord.TypeInfo).AsRecord;
  296. try
  297. for rField in rRec.GetFields do
  298. begin
  299. rValue := nil;
  300. //member := TJSONPair(aJson.GetValue(rField.Name));
  301. member := GetJsonPairByName(aJson,rField.Name);
  302. if member <> nil then
  303. case rField.FieldType.TypeKind of
  304. tkDynArray :
  305. begin
  306. jArray := TJSONObject.ParseJSONValue(member.ToJSON) as TJSONArray;
  307. try
  308. rValue := DeserializeDynArray(rField.FieldType.Handle,aObject,jArray);
  309. finally
  310. jArray.Free;
  311. end;
  312. end;
  313. tkClass :
  314. begin
  315. //if (member.JsonValue is TJSONObject) then
  316. begin
  317. propobj := rField.GetValue(@aRecord).AsObject;
  318. json := TJSONObject.ParseJSONValue(member.ToJson) as TJSONObject;
  319. try
  320. if propobj = nil then
  321. begin
  322. objClass := rField.FieldType.Handle^.TypeData.ClassType;// aProperty.PropertyType.Handle^.TypeData.ClassType;
  323. rValue := DeserializeClass(objClass,json);
  324. end
  325. else
  326. begin
  327. DeserializeObject(propobj,json);
  328. end;
  329. finally
  330. json.Free;
  331. end;
  332. end
  333. end;
  334. tkRecord :
  335. begin
  336. json := TJSONObject.ParseJSONValue(member.ToJson) as TJSONObject;
  337. try
  338. rValue := DeserializeRecord(rField.GetValue(aRecord.GetReferenceToRawData),aObject,json);
  339. finally
  340. json.Free;
  341. end;
  342. end
  343. else
  344. begin
  345. //rValue := DeserializeType(aObject,rField.FieldType.TypeKind,rField.FieldType.Handle,member.ToJson);
  346. //avoid return unicode escaped chars if string
  347. if rField.FieldType.TypeKind in [tkString, tkLString, tkWString, tkUString] then
  348. {$IFDEF DELPHIRX103_UP}
  349. rValue := DeserializeType(aObject,rField.FieldType.TypeKind,rField.FieldType.Handle,TJsonValue(member).value)
  350. {$ELSE}
  351. rValue := DeserializeType(aObject,rField.FieldType.TypeKind,rField.FieldType.Handle,member.JsonString.ToString)
  352. {$ENDIF}
  353. else rValue := DeserializeType(aObject,rField.FieldType.TypeKind,rField.FieldType.Handle,member.ToJSON);
  354. end;
  355. end;
  356. if not rValue.IsEmpty then rField.SetValue(aRecord.GetReferenceToRawData,rValue);
  357. end;
  358. Result := aRecord;
  359. finally
  360. ctx.Free;
  361. end;
  362. end;
  363. {$ENDIF}
  364. constructor TRTTIJson.Create(aSerializeLevel : TSerializeLevel; aUseEnumNames : Boolean = True);
  365. begin
  366. fSerializeLevel := aSerializeLevel;
  367. fUseEnumNames := aUseEnumNames;
  368. fUseJsonCaseSense := False;
  369. end;
  370. function TRTTIJson.DeserializeClass(aType: TClass; const aJson: TJSONObject): TObject;
  371. begin
  372. Result := nil;
  373. if (aJson = nil) or ((aJson as TJSONValue) is TJSONNull) or (aJson.Count = 0) then Exit;
  374. Result := aType.Create;
  375. try
  376. Result := DeserializeObject(Result,aJson);
  377. except
  378. on E : Exception do
  379. begin
  380. Result.Free;
  381. raise EJsonDeserializeError.CreateFmt('Deserialize error class "%s" : %s',[aType.ClassName,e.Message]);
  382. end;
  383. end;
  384. end;
  385. function TRTTIJson.DeserializeObject(aObject: TObject; const aJson: TJSONObject): TObject;
  386. var
  387. ctx: TRttiContext;
  388. rType: TRttiType;
  389. rProp: TRttiProperty;
  390. {$IFNDEF FPC}
  391. attr: TCustomAttribute;
  392. {$ENDIF}
  393. propertyname : string;
  394. begin
  395. Result := aObject;
  396. if (aJson = nil) or ((aJson as TJSONValue) is TJSONNull) or (aJson.Count = 0) or (Result = nil) then Exit;
  397. try
  398. rType := ctx.GetType(aObject.ClassInfo);
  399. try
  400. for rProp in rType.GetProperties do
  401. begin
  402. {$IFNDEF FPC}
  403. if ((fSerializeLevel = slPublicProperty) and (rProp.PropertyType.IsPublicType))
  404. or ((fSerializeLevel = slPublishedProperty) and ((IsPublishedProp(aObject,rProp.Name)) or (rProp.Name = 'List'))) then
  405. {$ENDIF}
  406. begin
  407. if ((rProp.IsWritable) or (rProp.Name = 'List')) and (IsAllowedProperty(aObject,rProp.Name)) then
  408. begin
  409. propertyname := rProp.Name;
  410. {$IFNDEF FPC}
  411. for attr in rProp.GetAttributes do if attr is TCustomNameProperty then propertyname := TCustomNameProperty(attr).Name;
  412. if rProp.Name = 'List' then
  413. begin
  414. Result := DeserializeList(Result,propertyname,aJson);
  415. end
  416. else if (rProp.GetValue(aObject).IsObject) and (IsGenericList(rProp.GetValue(aObject).AsObject)) then
  417. begin
  418. DeserializeList(rProp.GetValue(aObject).AsObject,'List',TJSONObject(aJson.GetValue(propertyname)));
  419. end
  420. else if (not rProp.GetValue(aObject).IsObject) and (IsGenericXArray(rProp.GetValue(aObject){$IFNDEF NEXTGEN}.TypeInfo.Name{$ELSE}.TypeInfo.NameFld.ToString{$ENDIF})) then
  421. begin
  422. DeserializeXArray(Result,rProp.GetValue(aObject),rProp,propertyname,aJson);
  423. end
  424. else
  425. {$ENDIF}
  426. Result := DeserializeProperty(Result,propertyname,rProp,aJson);
  427. end;
  428. end;
  429. end;
  430. finally
  431. ctx.Free;
  432. end;
  433. except
  434. on E : Exception do
  435. begin
  436. Result.Free;
  437. raise EJsonDeserializeError.CreateFmt('Deserialize error for object "%s" : %s',[aObject.ClassName,e.Message]);
  438. end;
  439. end;
  440. end;
  441. {$IFNDEF FPC}
  442. function TRTTIJson.DeserializeList(aObject: TObject; const aName : string; const aJson: TJSONObject) : TObject;
  443. var
  444. ctx : TRttiContext;
  445. rType : TRttiType;
  446. jarray : TJSONArray;
  447. member : TJSONPair;
  448. rvalue : TValue;
  449. i : Integer;
  450. rProp : TRttiProperty;
  451. {$IFNDEF DELPHIRX103_UP}
  452. rfield : TRttiField;
  453. {$ENDIF}
  454. begin
  455. Result := aObject;
  456. rType := ctx.GetType(aObject.ClassInfo);
  457. try
  458. rProp := rType.GetProperty('List');
  459. if rProp = nil then Exit;
  460. finally
  461. ctx.Free;
  462. end;
  463. member := GetJsonPairByName(aJson,aName);
  464. if member = nil then jArray := TJSONObject.ParseJSONValue(aJson.ToJSON) as TJSONArray
  465. else jArray := TJSONObject.ParseJSONValue(member.ToJSON) as TJSONArray;
  466. try
  467. rvalue := DeserializeDynArray(rProp.PropertyType.Handle,Result,jArray);
  468. //i := jarray.Count;
  469. finally
  470. jArray.Free;
  471. end;
  472. if not rValue.IsEmpty then
  473. begin
  474. {$IFDEF DELPHIRX103_UP}
  475. if (TObjectList<TObject>(aObject) <> nil) and (rvalue.IsArray) then
  476. begin
  477. TObjectList<TObject>(aObject).Clear;
  478. for i := 0 to rvalue.GetArrayLength - 1 do
  479. begin
  480. TObjectList<TObject>(aObject).Add(rvalue.GetArrayElement(i).AsObject);
  481. end;
  482. end;
  483. {$ELSE}
  484. for rfield in rType.GetFields do
  485. begin
  486. if rfield.Name = 'FOwnsObjects' then rfield.SetValue(aObject,True);
  487. //if rfield.Name = 'FCount' then rfield.SetValue(aObject,i);
  488. if rfield.Name = 'FItems' then
  489. begin
  490. //if TList(aObject) <> nil then TList(aObject).Clear;
  491. //rfield.GetValue(aObject).AsObject.Free;// aValue.GetReferenceToRawData)
  492. rfield.SetValue(aObject,rValue);// .SetDynArrayProp(aObject,'fItems',Result);
  493. Break;
  494. end;
  495. end;
  496. rProp := rType.GetProperty('Count');
  497. rProp.SetValue(aObject,i);
  498. {$ENDIF}
  499. end;
  500. end;
  501. {$ENDIF}
  502. {$IFNDEF FPC}
  503. procedure TRTTIJson.DeserializeXArray(Instance : TObject; aRecord : TValue; aProperty : TRttiProperty; const aPropertyName : string; aJson : TJsonObject);
  504. var
  505. ctx : TRttiContext;
  506. rRec : TRttiRecordType;
  507. rfield : TRttiField;
  508. rValue : TValue;
  509. member : TJSONPair;
  510. jArray : TJSONArray;
  511. begin
  512. rRec := ctx.GetType(aRecord.TypeInfo).AsRecord;
  513. try
  514. rfield := rRec.GetField('fArray');
  515. if rfield <> nil then
  516. begin
  517. rValue := nil;
  518. //member := TJSONPair(aJson.GetValue(rField.Name));
  519. member := GetJsonPairByName(aJson,aPropertyName);
  520. if (member <> nil) and (rField.FieldType.TypeKind = tkDynArray) then
  521. begin
  522. jArray := TJSONObject.ParseJSONValue(member.ToJSON) as TJSONArray;
  523. try
  524. rValue := DeserializeDynArray(rField.FieldType.Handle,nil,jArray);
  525. finally
  526. jArray.Free;
  527. end;
  528. end;
  529. end;
  530. if not rValue.IsEmpty then rField.SetValue(aRecord.GetReferenceToRawData,rValue);
  531. aProperty.SetValue(Instance,aRecord);
  532. finally
  533. ctx.Free;
  534. end;
  535. end;
  536. {$ENDIF}
  537. function TRTTIJson.DeserializeProperty(aObject : TObject; const aName : string; aProperty : TRttiProperty; const aJson : TJSONObject) : TObject;
  538. var
  539. rValue : TValue;
  540. {$IFNDEF FPC}
  541. member : TJSONPair;
  542. {$ELSE}
  543. member : TJsonObject;
  544. {$ENDIF}
  545. objClass: TClass;
  546. jArray : TJSONArray;
  547. json : TJSONObject;
  548. begin
  549. Result := aObject;
  550. rValue := nil;
  551. {$IFNDEF FPC}
  552. //member := TJSONPair(aJson.GetValue(aName));
  553. member := GetJsonPairByName(aJson,aName);
  554. {$ELSE}
  555. member := TJsonObject(aJson.Find(aName));
  556. {$ENDIF}
  557. if member <> nil then
  558. begin
  559. case aProperty.PropertyType.TypeKind of
  560. tkDynArray :
  561. begin
  562. {$IFNDEF FPC}
  563. jArray := TJSONObject.ParseJSONValue(member.ToJSON) as TJSONArray;
  564. {$ELSE}
  565. jArray := TJSONArray(TJSONObject.ParseJSONValue(member.ToJSON));
  566. {$ENDIF}
  567. try
  568. {$IFNDEF FPC}
  569. aProperty.SetValue(aObject,DeserializeDynArray(aProperty.PropertyType.Handle,Result,jArray));
  570. {$ELSE}
  571. DeserializeDynArray(aProperty.PropertyType.Handle,aName,Result,jArray);
  572. {$ENDIF}
  573. Exit;
  574. finally
  575. jArray.Free;
  576. end;
  577. end;
  578. tkClass :
  579. begin
  580. //if (member.JsonValue is TJSONObject) then
  581. begin
  582. json := TJsonObject(TJSONObject.ParseJSONValue(member.ToJson));
  583. try
  584. if aProperty.GetValue(aObject).AsObject = nil then
  585. begin
  586. {$IFNDEF FPC}
  587. objClass := aProperty.PropertyType.Handle^.TypeData.ClassType;
  588. rValue := DeserializeClass(objClass,json);
  589. {$ELSE}
  590. objClass := GetObjectPropClass(aObject,aName);
  591. //objClass := GetTypeData(aProperty.PropertyType.Handle)^.ClassType;
  592. rValue := DeserializeClass(objClass,json);
  593. SetObjectProp(aObject,aName,rValue.AsObject);
  594. Exit;
  595. {$ENDIF}
  596. end
  597. else
  598. begin
  599. rValue := DeserializeObject(aProperty.GetValue(aObject).AsObject,json);
  600. Exit;
  601. end;
  602. finally
  603. json.Free;
  604. end;
  605. end
  606. end;
  607. {$IFNDEF FPC}
  608. tkRecord :
  609. begin
  610. json := TJSONObject.ParseJSONValue(member.ToJson) as TJSONObject;
  611. try
  612. rValue := DeserializeRecord(aProperty.GetValue(aObject),aObject,json);
  613. finally
  614. json.Free;
  615. end;
  616. end;
  617. {$ENDIF}
  618. else
  619. begin
  620. {$IFNDEF FPC}
  621. //avoid return unicode escaped chars if string
  622. if aProperty.PropertyType.TypeKind in [tkString, tkLString, tkWString, tkUString] then
  623. {$IFDEF DELPHIRX103_UP}
  624. rValue := DeserializeType(aObject,aProperty.PropertyType.TypeKind,aProperty.GetValue(aObject).TypeInfo,TJsonValue(member).value)
  625. {$ELSE}
  626. rValue := DeserializeType(aObject,aProperty.PropertyType.TypeKind,aProperty.GetValue(aObject).TypeInfo,member.JsonString.ToString)
  627. {$ENDIF}
  628. else rValue := DeserializeType(aObject,aProperty.PropertyType.TypeKind,aProperty.GetValue(aObject).TypeInfo,member.ToJSON);
  629. {$ELSE}
  630. rValue := DeserializeType(aObject,aProperty.PropertyType.TypeKind,aName,member.ToJSON);
  631. if not rValue.IsEmpty then SetPropertyValue(aObject,aName,rValue);
  632. {$ENDIF}
  633. end;
  634. end;
  635. {$IFNDEF FPC}
  636. if not rValue.IsEmpty then aProperty.SetValue(Result,rValue);
  637. {$ENDIF}
  638. end;
  639. end;
  640. {$IFNDEF FPC}
  641. function TRTTIJson.DeserializeType(aObject : TObject; aType : TTypeKind; aTypeInfo : PTypeInfo; const aValue: string) : TValue;
  642. var
  643. i : Integer;
  644. value : string;
  645. fsettings : TFormatSettings;
  646. begin
  647. try
  648. value := AnsiDequotedStr(aValue,'"');
  649. case aType of
  650. tkString, tkLString, tkWString, tkUString :
  651. begin
  652. Result := value;
  653. end;
  654. tkChar, tkWChar :
  655. begin
  656. Result := value;
  657. end;
  658. tkInteger :
  659. begin
  660. Result := StrToInt(value);
  661. end;
  662. tkInt64 :
  663. begin
  664. Result := StrToInt64(value);
  665. end;
  666. tkFloat :
  667. begin
  668. if aTypeInfo = TypeInfo(TDateTime) then
  669. begin
  670. Result := JsonDateToDateTime(value);
  671. end
  672. else if aTypeInfo = TypeInfo(TDate) then
  673. begin
  674. Result := StrToDate(value);
  675. end
  676. else if aTypeInfo = TypeInfo(TTime) then
  677. begin
  678. Result := StrToTime(value);
  679. end
  680. else
  681. begin
  682. fsettings := TFormatSettings.Create;
  683. Result := StrToFloat(StringReplace(value,'.',fsettings.DecimalSeparator,[]));
  684. end;
  685. end;
  686. tkEnumeration :
  687. begin
  688. if aTypeInfo = System.TypeInfo(Boolean) then
  689. begin
  690. Result := StrToBool(value);
  691. end
  692. else
  693. begin
  694. //if fUseEnumNames then TValue.Make(GetEnumValue(aTypeInfo,value),aTypeInfo, Result)
  695. // else TValue.Make(StrToInt(value),aTypeInfo, Result);
  696. if not TryStrToInt(value,i) then TValue.Make(GetEnumValue(aTypeInfo,value),aTypeInfo, Result)
  697. else TValue.Make(StrToInt(value),aTypeInfo, Result);
  698. end;
  699. end;
  700. tkSet :
  701. begin
  702. i := StringToSet(aTypeInfo,value);
  703. TValue.Make(@i,aTypeInfo,Result);
  704. end;
  705. else
  706. begin
  707. //raise EclJsonSerializerError.Create('Not supported data type!');
  708. end;
  709. end;
  710. except
  711. on E : Exception do
  712. begin
  713. raise EJsonDeserializeError.CreateFmt('Deserialize error type "%s.%s" : %s',[aObject.ClassName,GetTypeName(aTypeInfo),e.Message]);
  714. end;
  715. end;
  716. end;
  717. {$ELSE}
  718. function TRTTIJson.DeserializeType(aObject : TObject; aType : TTypeKind; const aPropertyName, aValue: string) : TValue;
  719. var
  720. value : string;
  721. propinfo : PPropInfo;
  722. fsettings : TFormatSettings;
  723. begin
  724. try
  725. value := AnsiDequotedStr(aValue,'"');
  726. if value = '' then
  727. begin
  728. Result := nil;
  729. Exit;
  730. end;
  731. propinfo := GetPropInfo(aObject,aPropertyName);
  732. //case propinfo.PropType.Kind of
  733. case aType of
  734. tkString, tkLString, tkWString, tkUString, tkAString :
  735. begin
  736. Result := value;
  737. //SetStrProp(aObject,propinfo,value);
  738. end;
  739. tkChar, tkWChar :
  740. begin
  741. Result := value;
  742. end;
  743. tkInteger :
  744. begin
  745. Result := StrToInt(value);
  746. end;
  747. tkInt64 :
  748. begin
  749. Result := StrToInt64(value);
  750. end;
  751. tkFloat :
  752. begin
  753. if propinfo.PropType = TypeInfo(TDateTime) then
  754. begin
  755. Result := JsonDateToDateTime(value);
  756. end
  757. else if propinfo.PropType = TypeInfo(TDate) then
  758. begin
  759. Result := StrToDate(value);
  760. end
  761. else if propinfo.PropType = TypeInfo(TTime) then
  762. begin
  763. Result := StrToTime(value);
  764. end
  765. else
  766. begin
  767. fsettings := DefaultFormatSettings;
  768. Result := StrToFloat(StringReplace(value,'.',fsettings.DecimalSeparator,[]));
  769. end;
  770. end;
  771. tkEnumeration:
  772. begin
  773. Result := value;
  774. end;
  775. tkBool :
  776. begin
  777. Result := StrToBool(value);
  778. end;
  779. tkSet :
  780. begin
  781. Result := value;
  782. end;
  783. else
  784. begin
  785. //raise EclJsonSerializerError.Create('Not supported data type!');
  786. end;
  787. end;
  788. //if not Result.IsEmpty then SetPropertyValue(aObject,propinfo,Result);
  789. except
  790. on E : Exception do
  791. begin
  792. raise EJsonDeserializeError.CreateFmt('Deserialize error type "%s" : %s',[aObject.ClassName,e.Message]);
  793. end;
  794. end;
  795. end;
  796. {$ENDIF}
  797. function TRTTIJson.IsAllowedProperty(aObject : TObject; const aPropertyName : string) : Boolean;
  798. var
  799. propname : string;
  800. begin
  801. Result := True;
  802. propname := aPropertyName.ToLower;
  803. if IsGenericList(aObject) then
  804. begin
  805. if (propname = 'capacity') or (propname = 'count') or (propname = 'ownsobjects') then Result := False;
  806. end
  807. else if (propname = 'refcount') then Result := False;
  808. end;
  809. function TRTTIJson.IsGenericList(aObject : TObject) : Boolean;
  810. var
  811. cname : string;
  812. begin
  813. if aObject = nil then Exit(False);
  814. cname := aObject.ClassName;
  815. Result := (cname.StartsWith('TObjectList')) or (cname.StartsWith('TList'));
  816. end;
  817. function TRTTIJson.IsGenericXArray(const aClassName : string) : Boolean;
  818. begin
  819. Result := aClassName.StartsWith('TXArray');
  820. end;
  821. function TRTTIJson.GetJsonPairByName(aJson: TJSONObject; const aName: string): TJSONPair;
  822. var
  823. candidate : TJSONPair;
  824. i : Integer;
  825. begin
  826. if fUseJsonCaseSense then
  827. begin
  828. Result := TJSONPair(aJson.GetValue(aName));
  829. Exit;
  830. end
  831. else
  832. begin
  833. for i := 0 to aJson.Count - 1 do
  834. begin
  835. candidate := aJson.Pairs[I];
  836. if candidate.JsonValue = nil then Exit(nil);
  837. if CompareText(candidate.JsonString{$IFNDEF FPC}.Value{$ENDIF},aName) = 0 then
  838. Exit(TJsonPair(candidate.JsonValue));
  839. end;
  840. end;
  841. Result := nil;
  842. end;
  843. function TRTTIJson.GetPropertyValue(Instance : TObject; const PropertyName : string) : TValue;
  844. var
  845. pinfo : PPropInfo;
  846. begin
  847. Result := nil;
  848. pinfo := GetPropInfo(Instance,PropertyName);
  849. case pinfo.PropType^.Kind of
  850. tkInteger : Result := GetOrdProp(Instance,pinfo);
  851. tkInt64 : Result := GetInt64Prop(Instance,PropertyName);
  852. tkFloat : Result := GetFloatProp(Instance,PropertyName);
  853. tkChar : Result := Char(GetOrdProp(Instance,PropertyName));
  854. {$IFDEF FPC}
  855. tkWString : Result := GetWideStrProp(Instance,PropertyName);
  856. tkSString,
  857. tkAString,
  858. {$ELSE}
  859. tkWString,
  860. {$ENDIF}
  861. tkLString : Result := GetStrProp(Instance,pinfo);
  862. {$IFDEF FPC}
  863. tkEnumeration :
  864. begin
  865. if fUseEnumNames then Result := GetEnumName(pinfo.PropType,GetOrdProp(Instance,PropertyName))
  866. else Result := GetOrdProp(Instance,PropertyName);
  867. end;
  868. {$ELSE}
  869. tkEnumeration :
  870. begin
  871. if fUseEnumNames then Result := GetEnumName(@pinfo.PropType,GetOrdProp(Instance,PropertyName))
  872. else Result := GetOrdProp(Instance,PropertyName);
  873. end;
  874. {$ENDIF}
  875. tkSet : Result := GetSetProp(Instance,pinfo,True);
  876. {$IFNDEF FPC}
  877. tkClass :
  878. {$ELSE}
  879. tkBool : Result := Boolean(GetOrdProp(Instance,pinfo));
  880. tkObject :
  881. {$ENDIF} Result := GetObjectProp(Instance,pinfo);
  882. tkDynArray : Result := GetDynArrayProp(Instance,pinfo);
  883. end;
  884. end;
  885. function TRTTIJson.GetPropertyValueFromObject(Instance : TObject; const PropertyName : string) : TValue;
  886. var
  887. ctx : TRttiContext;
  888. rprop : TRttiProperty;
  889. begin
  890. rprop := ctx.GetType(Instance.ClassInfo).GetProperty(PropertyName);
  891. Result := rprop.GetValue(Instance);
  892. end;
  893. {$IFNDEF FPC}
  894. function TRTTIJson.GetFieldValueFromRecord(aValue : TValue; const FieldName : string) : TValue;
  895. var
  896. ctx : TRttiContext;
  897. rec : TRttiRecordType;
  898. rfield : TRttiField;
  899. begin
  900. rec := ctx.GetType(aValue.TypeInfo).AsRecord;
  901. rfield := rec.GetField(FieldName);
  902. if rfield <> nil then Result := rField.GetValue(aValue.GetReferenceToRawData)
  903. else Result := nil;
  904. end;
  905. {$ENDIF}
  906. procedure TRTTIJson.SetPropertyValue(Instance : TObject; const PropertyName : string; aValue : TValue);
  907. var
  908. pinfo : PPropInfo;
  909. begin
  910. pinfo := GetPropInfo(Instance,PropertyName);
  911. SetPropertyValue(Instance,pinfo,aValue);
  912. end;
  913. procedure TRTTIJson.SetPropertyValue(Instance : TObject; aPropInfo : PPropInfo; aValue : TValue);
  914. begin
  915. case aPropInfo.PropType^.Kind of
  916. tkInteger : SetOrdProp(Instance,aPropInfo,aValue.AsInteger);
  917. tkInt64 : SetInt64Prop(Instance,aPropInfo,aValue.AsInt64);
  918. tkFloat : SetFloatProp(Instance,aPropInfo,aValue.AsExtended);
  919. tkChar : SetOrdProp(Instance,aPropInfo,aValue.AsOrdinal);
  920. {$IFDEF FPC}
  921. tkWString : SetWideStrProp(Instance,aPropInfo,aValue.AsString);
  922. tkSString,
  923. tkAString,
  924. {$ELSE}
  925. tkWString,
  926. {$ENDIF}
  927. tkLString : SetStrProp(Instance,aPropInfo,aValue.AsString);
  928. {$IFDEF FPC}
  929. tkBool : SetOrdProp(Instance,aPropInfo,aValue.AsOrdinal);
  930. tkSet : LoadSetProperty(Instance,aPropInfo,aValue.AsString);
  931. {$ENDIF}
  932. tkEnumeration : SetEnumProp(Instance,aPropInfo,aValue.AsString);
  933. {$IFNDEF FPC}
  934. tkClass :
  935. {$ELSE}
  936. tkObject :
  937. {$ENDIF} SetObjectProp(Instance,aPropInfo,aValue.AsObject);
  938. end;
  939. end;
  940. {$IFDEF FPC}
  941. procedure TRTTIJson.LoadSetProperty(aInstance : TObject; aPropInfo: PPropInfo; const aValue: string);
  942. type
  943. TCardinalSet = set of 0..SizeOf(Cardinal) * 8 - 1;
  944. const
  945. Delims = [' ', ',', '[', ']'];
  946. var
  947. TypeInfo: PTypeInfo;
  948. W: Cardinal;
  949. I, N: Integer;
  950. Count: Integer;
  951. EnumName: string;
  952. begin
  953. W := 0;
  954. TypeInfo := GetTypeData(GetPropType(aPropInfo))^.CompType;
  955. Count := WordCount(aValue, Delims);
  956. for N := 1 to Count do
  957. begin
  958. EnumName := ExtractWord(N, aValue, Delims);
  959. try
  960. I := GetEnumValue(TypeInfo, EnumName);
  961. if I >= 0 then Include(TCardinalSet(W),I);
  962. except
  963. end;
  964. end;
  965. SetOrdProp(aInstance,aPropInfo,W);
  966. end;
  967. {$ENDIF}
  968. function TRTTIJson.Serialize(aObject: TObject): TJSONObject;
  969. var
  970. ctx: TRttiContext;
  971. {$IFNDEF FPC}
  972. attr : TCustomAttribute;
  973. comment : string;
  974. {$ENDIF}
  975. rType: TRttiType;
  976. rProp: TRttiProperty;
  977. jpair : TJSONPair;
  978. ExcludeSerialize : Boolean;
  979. propertyname : string;
  980. //listtype : TRttiType;
  981. //listprop : TRttiProperty;
  982. //listvalue : TValue;
  983. begin
  984. if (aObject = nil) then
  985. begin
  986. Result := nil;
  987. Exit;
  988. end;
  989. Result := TJSONObject.Create;
  990. try
  991. rType := ctx.GetType(aObject.ClassInfo);
  992. try
  993. //s := rType.ToString;
  994. for rProp in rType.GetProperties do
  995. begin
  996. ExcludeSerialize := False;
  997. propertyname := rProp.Name;
  998. {$IFNDEF FPC}
  999. comment := '';
  1000. for attr in rProp.GetAttributes do
  1001. begin
  1002. if attr is TNotSerializableProperty then ExcludeSerialize := True
  1003. else if attr is TCommentProperty then comment := TCommentProperty(attr).Comment
  1004. else if attr is TCustomNameProperty then propertyname := TCustomNameProperty(attr).Name;
  1005. end;
  1006. if ((fSerializeLevel = slPublicProperty) and (rProp.PropertyType.IsPublicType))
  1007. or ((fSerializeLevel = slPublishedProperty) and ((IsPublishedProp(aObject,rProp.Name)) or (rProp.Name = 'List'))) then
  1008. {$ENDIF}
  1009. begin
  1010. if (IsAllowedProperty(aObject,propertyname)) and (not ExcludeSerialize) then
  1011. begin
  1012. //add comment as pair
  1013. {$IFNDEF FPC}
  1014. if comment <> '' then Result.AddPair(TJSONPair.Create('#Comment#->'+propertyname,Comment));
  1015. {$ENDIF}
  1016. begin
  1017. if (rProp.GetValue(aObject).IsObject) and (IsGenericList(rProp.GetValue(aObject).AsObject)) then
  1018. begin
  1019. jpair := Serialize(propertyname,GetPropertyValueFromObject(rProp.GetValue(aObject).AsObject,'List'));
  1020. end
  1021. {$IFNDEF FPC}
  1022. else if (not rProp.GetValue(aObject).IsObject) and (IsGenericXArray(rProp.GetValue(aObject){$IFNDEF NEXTGEN}.TypeInfo.Name{$ELSE}.TypeInfo.NameFld.ToString{$ENDIF})) then
  1023. begin
  1024. jpair := Serialize(propertyname,GetFieldValueFromRecord(rProp.GetValue(aObject),'fArray'));
  1025. end
  1026. {$ENDIF}
  1027. else
  1028. begin
  1029. {$IFNDEF FPC}
  1030. jpair := Serialize(propertyname,rProp.GetValue(aObject));
  1031. {$ELSE}
  1032. jpair := Serialize(aObject,rProp.PropertyType.TypeKind,propertyname);
  1033. {$ENDIF}
  1034. end;
  1035. //s := jpair.JsonValue.ToString;
  1036. if jpair <> nil then
  1037. begin
  1038. Result.AddPair(jpair);
  1039. end
  1040. else jpair.Free;
  1041. end;
  1042. //Result.AddPair(Serialize(rProp.Name,rProp.GetValue(aObject)));
  1043. //s := Result.ToJSON;
  1044. end;
  1045. end;
  1046. end;
  1047. finally
  1048. ctx.Free;
  1049. end;
  1050. except
  1051. on E : Exception do
  1052. begin
  1053. Result.Free;
  1054. raise EJsonSerializeError.CreateFmt('Serialize error object "%s" : %s',[aObject.ClassName,e.Message]);
  1055. end;
  1056. end;
  1057. end;
  1058. function TRTTIJson.GetValue(aAddr: Pointer; aType: TRTTIType): TValue;
  1059. begin
  1060. TValue.Make(aAddr,aType.Handle,Result);
  1061. end;
  1062. function TRTTIJson.GetValue(aAddr: Pointer; aTypeInfo: PTypeInfo): TValue;
  1063. begin
  1064. TValue.Make(aAddr,aTypeInfo,Result);
  1065. end;
  1066. {$IFNDEF FPC}
  1067. function TRTTIJson.Serialize(const aName : string; aValue : TValue) : TJSONPair;
  1068. var
  1069. ctx: TRttiContext;
  1070. rRec : TRttiRecordType;
  1071. rField : TRttiField;
  1072. rDynArray : TRTTIDynamicArrayType;
  1073. json : TJSONObject;
  1074. jArray : TJSONArray;
  1075. jPair : TJSONPair;
  1076. jValue : TJSONValue;
  1077. i : Integer;
  1078. begin
  1079. Result := TJSONPair.Create(aName,nil);
  1080. //Result.JsonString := TJSONString(aName);
  1081. try
  1082. case avalue.Kind of
  1083. tkDynArray :
  1084. begin
  1085. jArray := TJSONArray.Create;
  1086. rDynArray := ctx.GetType(aValue.TypeInfo) as TRTTIDynamicArrayType;
  1087. try
  1088. for i := 0 to aValue.GetArrayLength - 1 do
  1089. begin
  1090. if not GetValue(PPByte(aValue.GetReferenceToRawData)^ + rDynArray.ElementType.TypeSize * i, rDynArray.ElementType).IsEmpty then
  1091. begin
  1092. jValue := nil;
  1093. jPair := Serialize(aName,GetValue(PPByte(aValue.GetReferenceToRawData)^ + rDynArray.ElementType.TypeSize * i, rDynArray.ElementType));
  1094. try
  1095. //jValue := TJsonValue(jPair.JsonValue.Clone);
  1096. jValue := jPair.JsonValue;
  1097. if jValue <> nil then
  1098. begin
  1099. jArray.AddElement(jValue);
  1100. jPair.JsonValue.Owned := False;
  1101. end;
  1102. finally
  1103. jPair.Free;
  1104. if jValue <> nil then jValue.Owned := True;
  1105. end;
  1106. end;
  1107. end;
  1108. Result.JsonValue := jArray;
  1109. finally
  1110. ctx.Free;
  1111. end;
  1112. end;
  1113. tkClass :
  1114. begin
  1115. Result.JsonValue := TJSONValue(Serialize(aValue.AsObject));
  1116. end;
  1117. tkString, tkLString, tkWString, tkUString :
  1118. begin
  1119. Result.JsonValue := TJSONString.Create(aValue.AsString);
  1120. end;
  1121. tkChar, tkWChar :
  1122. begin
  1123. Result.JsonValue := TJSONString.Create(aValue.AsString);
  1124. end;
  1125. tkInteger :
  1126. begin
  1127. Result.JsonValue := TJSONNumber.Create(aValue.AsInteger);
  1128. end;
  1129. tkInt64 :
  1130. begin
  1131. Result.JsonValue := TJSONNumber.Create(aValue.AsInt64);
  1132. end;
  1133. tkFloat :
  1134. begin
  1135. if aValue.TypeInfo = TypeInfo(TDateTime) then
  1136. begin
  1137. Result.JsonValue := TJSONString.Create(DateTimeToJsonDate(aValue.AsExtended));
  1138. end
  1139. else if aValue.TypeInfo = TypeInfo(TDate) then
  1140. begin
  1141. Result.JsonValue := TJSONString.Create(DateToStr(aValue.AsExtended));
  1142. end
  1143. else if aValue.TypeInfo = TypeInfo(TTime) then
  1144. begin
  1145. Result.JsonValue := TJSONString.Create(TimeToStr(aValue.AsExtended));
  1146. end
  1147. else
  1148. begin
  1149. Result.JsonValue := TJSONNumber.Create(aValue.AsExtended);
  1150. end;
  1151. end;
  1152. tkEnumeration :
  1153. begin
  1154. if (aValue.TypeInfo = System.TypeInfo(Boolean)) then
  1155. begin
  1156. {$IFDEF DELPHIRX10_UP}
  1157. Result.JsonValue := TJSONBool.Create(aValue.AsBoolean);
  1158. {$ELSE}
  1159. if aValue.AsBoolean then Result.JsonValue := TJsonTrue.Create
  1160. else Result.JsonValue := TJsonFalse.Create;
  1161. {$ENDIF}
  1162. end
  1163. else
  1164. begin
  1165. //Result.JsonValue := TJSONString.Create(GetEnumName(aValue.TypeInfo,aValue.AsOrdinal));
  1166. if fUseEnumNames then Result.JsonValue := TJSONString.Create(aValue.ToString)
  1167. else Result.JsonValue := TJSONNumber.Create(GetEnumValue(aValue.TypeInfo,aValue.ToString));
  1168. end;
  1169. end;
  1170. tkSet :
  1171. begin
  1172. Result.JsonValue := TJSONString.Create(aValue.ToString);
  1173. end;
  1174. tkRecord :
  1175. begin
  1176. rRec := ctx.GetType(aValue.TypeInfo).AsRecord;
  1177. try
  1178. json := TJSONObject.Create;
  1179. for rField in rRec.GetFields do
  1180. begin
  1181. json.AddPair(Serialize(rField.name,rField.GetValue(aValue.GetReferenceToRawData)));
  1182. end;
  1183. Result.JsonValue := json;
  1184. finally
  1185. ctx.Free;
  1186. end;
  1187. end;
  1188. tkMethod, tkPointer, tkClassRef ,tkInterface, tkProcedure :
  1189. begin
  1190. //skip these properties
  1191. //FreeAndNil(Result);
  1192. end
  1193. else
  1194. begin
  1195. raise EJsonSerializeError.CreateFmt(cNotSupportedDataType,[aName,GetTypeName(aValue.TypeInfo)]);
  1196. end;
  1197. end;
  1198. if Result.JsonValue = nil then Result.JsonValue := TJSONNull.Create;
  1199. except
  1200. on E : Exception do
  1201. begin
  1202. Result.Free;
  1203. raise EJsonSerializeError.CreateFmt('Serialize error class "%s.%s" : %s',[aName,aValue.ToString,e.Message]);
  1204. end;
  1205. end;
  1206. end;
  1207. {$ELSE}
  1208. function TRTTIJson.GetPropType(aPropInfo: PPropInfo): PTypeInfo;
  1209. begin
  1210. Result := aPropInfo^.PropType;
  1211. end;
  1212. function TRTTIJson.FloatProperty(aObject : TObject; aPropInfo: PPropInfo): string;
  1213. const
  1214. Precisions: array[TFloatType] of Integer = (7, 15, 18, 18, 19);
  1215. var
  1216. fsettings : TFormatSettings;
  1217. begin
  1218. fsettings := FormatSettings;
  1219. Result := StringReplace(FloatToStrF(GetFloatProp(aObject, aPropInfo), ffGeneral,
  1220. Precisions[GetTypeData(GetPropType(aPropInfo))^.FloatType],0),
  1221. '.',fsettings.DecimalSeparator,[rfReplaceAll]);
  1222. end;
  1223. function TRTTIJson.Serialize(const aName : string; aValue : TValue) : TJSONPair;
  1224. begin
  1225. Result := TJSONPair.Create(aName,nil);
  1226. //Result.JsonString := TJSONString(aName);
  1227. try
  1228. case avalue.Kind of
  1229. tkClass :
  1230. begin
  1231. Result.JsonValue := TJSONValue(Serialize(aValue.AsObject));
  1232. end;
  1233. tkString, tkLString, tkWString, tkUString :
  1234. begin
  1235. Result.JsonValue := TJSONString.Create(aValue.AsString);
  1236. end;
  1237. tkChar, tkWChar :
  1238. begin
  1239. Result.JsonValue := TJSONString.Create(aValue.AsString);
  1240. end;
  1241. tkInteger :
  1242. begin
  1243. Result.JsonValue := TJSONNumber.Create(aValue.AsInteger);
  1244. end;
  1245. tkInt64 :
  1246. begin
  1247. Result.JsonValue := TJSONNumber.Create(aValue.AsInt64);
  1248. end;
  1249. tkFloat :
  1250. begin
  1251. if aValue.TypeInfo = TypeInfo(TDateTime) then
  1252. begin
  1253. Result.JsonValue := TJSONString.Create(DateTimeToJsonDate(aValue.AsExtended));
  1254. end
  1255. else if aValue.TypeInfo = TypeInfo(TDate) then
  1256. begin
  1257. Result.JsonValue := TJSONString.Create(DateToStr(aValue.AsExtended));
  1258. end
  1259. else if aValue.TypeInfo = TypeInfo(TTime) then
  1260. begin
  1261. Result.JsonValue := TJSONString.Create(TimeToStr(aValue.AsExtended));
  1262. end
  1263. else
  1264. begin
  1265. Result.JsonValue := TJSONNumber.Create(aValue.AsExtended);
  1266. end;
  1267. end;
  1268. tkEnumeration :
  1269. begin
  1270. if (aValue.TypeInfo = System.TypeInfo(Boolean)) then
  1271. begin
  1272. Result.JsonValue := TJSONBool.Create(aValue.AsBoolean);
  1273. end
  1274. else
  1275. begin
  1276. //Result.JsonValue := TJSONString.Create(GetEnumName(aValue.TypeInfo,aValue.AsOrdinal));
  1277. if fUseEnumNames then Result.JsonValue := TJSONString.Create(aValue.ToString)
  1278. else Result.JsonValue := TJSONNumber.Create(GetEnumValue(aValue.TypeInfo,aValue.ToString));
  1279. end;
  1280. end;
  1281. tkSet :
  1282. begin
  1283. Result.JsonValue := TJSONString.Create(aValue.ToString);
  1284. end;
  1285. else
  1286. begin
  1287. //raise EJsonDeserializeError.CreateFmt('Not supported type "%s":%d',[aName,Integer(aValue.Kind)]);
  1288. end;
  1289. end;
  1290. if Result.JsonValue = nil then Result.JsonValue := TJSONNull.Create;
  1291. except
  1292. Result.Free;
  1293. end;
  1294. end;
  1295. function TRTTIJson.Serialize(aObject : TObject; aType : TTypeKind; const aPropertyName : string) : TJSONPair;
  1296. var
  1297. propinfo : PPropInfo;
  1298. jArray : TJsonArray;
  1299. jPair : TJsonPair;
  1300. jValue : TJsonValue;
  1301. i : Integer;
  1302. pArr : Pointer;
  1303. rValue : TValue;
  1304. rItemValue : TValue;
  1305. len : Integer;
  1306. begin
  1307. try
  1308. Result := TJSONPair.Create(aPropertyName,nil);
  1309. propinfo := GetPropInfo(aObject,aPropertyName);
  1310. //case propinfo.PropType.Kind of
  1311. case aType of
  1312. tkDynArray :
  1313. begin
  1314. len := 0;
  1315. jArray := TJSONArray.Create;
  1316. try
  1317. pArr := GetDynArrayProp(aObject,aPropertyName);
  1318. TValue.Make(@pArr,propinfo.PropType, rValue);
  1319. if rValue.IsArray then
  1320. begin
  1321. len := rValue.GetArrayLength;
  1322. for i := 0 to len - 1 do
  1323. begin
  1324. rItemValue := rValue.GetArrayElement(i);
  1325. jPair := Serialize(aPropertyName,rItemValue);
  1326. try
  1327. //jValue := TJsonValue(jPair.JsonValue.Clone);
  1328. jValue := jPair.JsonValue;
  1329. jArray.Add(jValue);
  1330. //jPair.JsonValue.Owned := False;
  1331. finally
  1332. jPair.Free;
  1333. //jValue.Owned := True;
  1334. end;
  1335. end;
  1336. end;
  1337. Result.JsonValue := jArray;
  1338. finally
  1339. //DynArrayClear(pArr,propinfo.PropType);
  1340. pArr := nil;
  1341. end;
  1342. end;
  1343. tkClass :
  1344. begin
  1345. Result.JsonValue := TJSONValue(Serialize(GetObjectProp(aObject,aPropertyName)));
  1346. end;
  1347. tkString, tkLString, tkWString, tkUString, tkAString :
  1348. begin
  1349. Result.JsonValue := TJSONString.Create(GetStrProp(aObject,aPropertyName));
  1350. end;
  1351. tkChar, tkWChar :
  1352. begin
  1353. Result.JsonValue := TJSONString.Create(Char(GetOrdProp(aObject,aPropertyName)));
  1354. end;
  1355. tkInteger :
  1356. begin
  1357. Result.JsonValue := TJSONNumber.Create(GetOrdProp(aObject,aPropertyName));
  1358. end;
  1359. tkInt64 :
  1360. begin
  1361. Result.JsonValue := TJSONNumber.Create(GetOrdProp(aObject,aPropertyName));
  1362. end;
  1363. tkFloat :
  1364. begin
  1365. if propinfo.PropType = TypeInfo(TDateTime) then
  1366. begin
  1367. Result.JsonValue := TJSONString.Create(DateTimeToJsonDate(GetFloatProp(aObject,aPropertyName)));
  1368. end
  1369. else if propinfo.PropType = TypeInfo(TDate) then
  1370. begin
  1371. Result.JsonValue := TJSONString.Create(DateToStr(GetFloatProp(aObject,aPropertyName)));
  1372. end
  1373. else if propinfo.PropType = TypeInfo(TTime) then
  1374. begin
  1375. Result.JsonValue := TJSONString.Create(TimeToStr(GetFloatProp(aObject,aPropertyName)));
  1376. end
  1377. else
  1378. begin
  1379. //Result.JsonValue := TJsonFloatNumber.Create(GetFloatProp(aObject,aPropertyName));
  1380. Result.JsonValue := TJsonFloatNumber.Create(StrToFloat(FloatProperty(aObject,propinfo)));
  1381. end;
  1382. end;
  1383. tkEnumeration,tkBool :
  1384. begin
  1385. if (propinfo.PropType = System.TypeInfo(Boolean)) then
  1386. begin
  1387. Result.JsonValue := TJSONBool.Create(Boolean(GetOrdProp(aObject,aPropertyName)));
  1388. end
  1389. else
  1390. begin
  1391. if fUseEnumNames then Result.JsonValue := TJSONString.Create(GetEnumName(propinfo.PropType,GetOrdProp(aObject,aPropertyName)))
  1392. else Result.JsonValue := TJSONNumber.Create(GetOrdProp(aObject,aPropertyName));
  1393. //Result.JsonValue := TJSONString.Create(aValue.ToString);
  1394. end;
  1395. end;
  1396. tkSet :
  1397. begin
  1398. Result.JsonValue := TJSONString.Create(GetSetProp(aObject,aPropertyName));
  1399. end;
  1400. {$IFNDEF FPC}
  1401. tkRecord :
  1402. begin
  1403. rRec := ctx.GetType(aValue.TypeInfo).AsRecord;
  1404. try
  1405. json := TJSONObject.Create;
  1406. for rField in rRec.GetFields do
  1407. begin
  1408. json.AddPair(Serialize(rField.name,rField.GetValue(aValue.GetReferenceToRawData)));
  1409. end;
  1410. Result.JsonValue := json;
  1411. finally
  1412. ctx.Free;
  1413. end;
  1414. end;
  1415. {$ENDIF}
  1416. tkMethod, tkPointer, tkClassRef ,tkInterface, tkProcedure :
  1417. begin
  1418. //skip these properties
  1419. //FreeAndNil(Result);
  1420. end
  1421. else
  1422. begin
  1423. //raise EJsonDeserializeError.CreateFmt('Not supported type "%s":%d',[aName,Integer(aValue.Kind)]);
  1424. end;
  1425. end;
  1426. if Result.JsonValue = nil then Result.JsonValue := TJSONNull.Create;
  1427. except
  1428. on E : Exception do
  1429. begin
  1430. Result.Free;
  1431. {$IFNDEF FPC}
  1432. raise EJsonSerializeError.CreateFmt('Serialize error class "%s.%s" : %s',[aName,aValue.ToString,e.Message]);
  1433. {$ENDIF}
  1434. end;
  1435. end;
  1436. end;
  1437. {$ENDIF}
  1438. { TJsonSerializer}
  1439. constructor TJsonSerializer.Create(aSerializeLevel: TSerializeLevel; aUseEnumNames : Boolean = True);
  1440. begin
  1441. {$IFDEF FPC}
  1442. if aSerializeLevel = TSerializeLevel.slPublicProperty then raise EJsonSerializeError.Create('FreePascal RTTI only supports published properties');
  1443. {$ENDIF}
  1444. fSerializeLevel := aSerializeLevel;
  1445. fUseEnumNames := aUseEnumNames;
  1446. fUseJsonCaseSense := False;
  1447. fRTTIJson := TRTTIJson.Create(aSerializeLevel,aUseEnumNames);
  1448. fRTTIJson.UseJsonCaseSense := fUseJsonCaseSense;
  1449. end;
  1450. function TJsonSerializer.JsonToObject(aType: TClass; const aJson: string): TObject;
  1451. var
  1452. json: TJSONObject;
  1453. begin
  1454. {$If Defined(FPC) OR Defined(DELPHIRX10_UP)}
  1455. json := TJSONObject.ParseJSONValue(aJson,True) as TJSONObject;
  1456. {$ELSE}
  1457. json := TJsonObject.ParseJSONValue(TEncoding.UTF8.GetBytes(aJson),0,True) as TJSONObject;
  1458. {$ENDIF}
  1459. try
  1460. Result := fRTTIJson.DeserializeClass(aType,json);
  1461. finally
  1462. json.Free;
  1463. end;
  1464. end;
  1465. destructor TJsonSerializer.Destroy;
  1466. begin
  1467. fRTTIJson.Free;
  1468. inherited;
  1469. end;
  1470. function TJsonSerializer.JsonToObject(aObject: TObject; const aJson: string): TObject;
  1471. var
  1472. json: TJSONObject;
  1473. begin;
  1474. {$If Defined(FPC) OR Defined(DELPHIRX10_UP)}
  1475. json := TJSONObject.ParseJSONValue(aJson,True) as TJSONObject;
  1476. {$ELSE}
  1477. json := TJsonObject.ParseJSONValue(TEncoding.UTF8.GetBytes(aJson),0,True) as TJSONObject;
  1478. {$ENDIF}
  1479. try
  1480. Result := fRTTIJson.DeserializeObject(aObject,json);
  1481. finally
  1482. json.Free;
  1483. end;
  1484. end;
  1485. function TJsonSerializer.ObjectToJson(aObject : TObject; aIndent : Boolean = False): string;
  1486. var
  1487. json: TJSONObject;
  1488. begin
  1489. json := fRTTIJson.Serialize(aObject);
  1490. try
  1491. if aIndent then Result := TJsonUtils.JsonFormat(json.ToJSON)
  1492. else Result := json.ToJSON;
  1493. finally
  1494. json.Free;
  1495. end;
  1496. end;
  1497. function TJsonSerializer.ObjectToJsonString(aObject : TObject; aIndent : Boolean = False): string;
  1498. var
  1499. json: TJSONObject;
  1500. begin
  1501. json := fRTTIJson.Serialize(aObject);
  1502. try
  1503. if aIndent then Result := TJsonUtils.JsonFormat(json.ToString)
  1504. else Result := json.ToString;
  1505. finally
  1506. json.Free;
  1507. end;
  1508. end;
  1509. procedure TJsonSerializer.SetUseEnumNames(const Value: Boolean);
  1510. begin
  1511. fUseEnumNames := Value;
  1512. if Assigned(fRTTIJson) then fRTTIJson.UseEnumNames := Value;
  1513. end;
  1514. procedure TJsonSerializer.SetUseJsonCaseSense(const Value: Boolean);
  1515. begin
  1516. fUseJsonCaseSense := Value;
  1517. if Assigned(fRTTIJson) then fRTTIJson.UseJsonCaseSense := Value;
  1518. end;
  1519. {$IFNDEF FPC}
  1520. { TCommentProperty }
  1521. constructor TCommentProperty.Create(const aComment: string);
  1522. begin
  1523. fComment := aComment;
  1524. end;
  1525. { TCustomNameProperty }
  1526. constructor TCustomNameProperty.Create(const aName: string);
  1527. begin
  1528. fName := aName;
  1529. end;
  1530. {$ENDIF}
  1531. end.