Quick.Json.Serializer.pas 47 KB

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