Quick.Json.Serializer.pas 24 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813
  1. { ***************************************************************************
  2. Copyright (c) 2015-2018 Kike Pérez
  3. Unit : Quick.JSON.Serializer
  4. Description : Json Serializer
  5. Author : Kike Pérez
  6. Version : 1.2
  7. Created : 21/05/2018
  8. Modified : 30/06/2018
  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. {$IFDEF FPC}
  28. Rtti,
  29. rttiutils,
  30. jsonreader,
  31. fpjsonrtti,
  32. fpjson,
  33. {$ELSE}
  34. {$IFDEF DELPHIXE7_UP}
  35. Rtti,
  36. System.Json,
  37. {$ENDIF}
  38. {$ENDIF}
  39. TypInfo,
  40. DateUtils,
  41. Quick.Commons;
  42. type
  43. EJsonSerializeError = class(Exception);
  44. EJsonDeserializeError = class(Exception);
  45. {$IFDEF FPC}
  46. TJsonPair = TJsonData;
  47. {$ELSE}
  48. TNotSerializableProperty = class(TCustomAttribute);
  49. TCommentProperty = class(TCustomAttribute)
  50. private
  51. fComment : string;
  52. public
  53. constructor Create(const aComment: string);
  54. property Comment : string read fComment;
  55. end;
  56. TCustomNameProperty = class(TCustomAttribute)
  57. private
  58. fName : string;
  59. public
  60. constructor Create(const aName: string);
  61. property Name : string read fName;
  62. end;
  63. {$ENDIF}
  64. IJsonSerializer = interface
  65. ['{CA26F7AE-F1FE-41BE-9C23-723A687F60D1}']
  66. function JsonToObject(aType: TClass; const aJson: string): TObject; overload;
  67. function JsonToObject(aObject: TObject; const aJson: string): TObject; overload;
  68. function ObjectToJson(aObject: TObject): string;
  69. end;
  70. TSerializeLevel = (slPublicProperty, slPublishedProperty);
  71. TJsonSerializer = class(TInterfacedObject,IJsonSerializer)
  72. strict private
  73. fSerializeLevel : TSerializeLevel;
  74. function GetValue(aAddr: Pointer; aType: TRTTIType): TValue;
  75. function IsAllowedProperty(aObject : TObject; const aPropertyName : string) : Boolean;
  76. function IsGenericList(aObject : TObject) : Boolean;
  77. {$IFNDEF FPC}
  78. function DeserializeDynArray(aTypeInfo : PTypeInfo; aObject : TObject; const aJsonArray: TJSONArray) : TValue;
  79. function DeserializeRecord(aRecord : TValue; aObject : TObject; const aJson : TJSONObject) : TValue;
  80. {$ENDIF}
  81. function DeserializeClass(aType : TClass; const aJson : TJSONObject) : TObject;
  82. function DeserializeObject(aObject : TObject; const aJson : TJSONObject) : TObject; overload;
  83. function DeserializeList(aObject: TObject; const aName : string; const aJson: TJSONObject) : TObject;
  84. function DeserializeProperty(aObject : TObject; const aName : string; aProperty : TRttiProperty; const aJson : TJSONObject) : TObject; overload;
  85. function DeserializeType(aObject : TObject; aType : TTypeKind; aTypeInfo : PTypeInfo; const aValue: string) : TValue;
  86. function Serialize(const aName : string; aValue : TValue) : TJSONPair; overload;
  87. function Serialize(aObject : TObject) : TJSONObject; overload;
  88. public
  89. constructor Create(aSerializeLevel : TSerializeLevel);
  90. property SerializeLevel : TSerializeLevel read fSerializeLevel;
  91. function JsonToObject(aType : TClass; const aJson: string) : TObject; overload;
  92. function JsonToObject(aObject : TObject; const aJson: string) : TObject; overload;
  93. function ObjectToJson(aObject : TObject): string;
  94. end;
  95. PPByte = ^PByte;
  96. resourcestring
  97. cNotSupportedDataType = 'Not supported "%s" data type "%s"';
  98. cNotSerializable = 'Object is not serializable';
  99. implementation
  100. { TqlJsonSerializer }
  101. {$IFNDEF FPC}
  102. function TJsonSerializer.DeserializeDynArray(aTypeInfo: PTypeInfo; aObject: TObject; const aJsonArray: TJSONArray) : TValue;
  103. var
  104. rType: PTypeInfo;
  105. len: NativeInt;
  106. pArr: Pointer;
  107. rItemValue: TValue;
  108. i: Integer;
  109. objClass: TClass;
  110. ctx : TRttiContext;
  111. json : TJSONObject;
  112. rDynArray : TRttiDynamicArrayType;
  113. propObj : TObject;
  114. begin
  115. if GetTypeData(aTypeInfo).DynArrElType = nil then Exit;
  116. len := aJsonArray.Count;
  117. rType := GetTypeData(aTypeInfo).DynArrElType^;
  118. pArr := nil;
  119. DynArraySetLength(pArr,aTypeInfo, 1, @len);
  120. try
  121. TValue.Make(@pArr,aTypeInfo, Result);
  122. rDynArray := ctx.GetType(Result.TypeInfo) as TRTTIDynamicArrayType;
  123. for i := 0 to aJsonArray.Count - 1 do
  124. begin
  125. rItemValue := nil;
  126. case rType.Kind of
  127. tkClass :
  128. begin
  129. if aJsonArray.Items[i] is TJSONObject then
  130. begin
  131. propObj := GetValue(PPByte(Result.GetReferenceToRawData)^ +rDynArray.ElementType.TypeSize * i, rDynArray.ElementType).AsObject;
  132. if propObj = nil then
  133. begin
  134. objClass := rType.TypeData.ClassType;
  135. rItemValue := DeserializeClass(objClass, TJSONObject(aJsonArray.Items[i]));
  136. end
  137. else
  138. begin
  139. DeserializeObject(propObj,TJSONObject(aJsonArray.Items[i]));
  140. end;
  141. end;
  142. end;
  143. tkRecord :
  144. begin
  145. json := TJSONObject(aJsonArray.Items[i]);
  146. rItemValue := DeserializeRecord(GetValue(PPByte(Result.GetReferenceToRawData)^ +rDynArray.ElementType.TypeSize * i,
  147. rDynArray.ElementType),aObject,json);
  148. end;
  149. tkMethod, tkPointer, tkClassRef ,tkInterface, tkProcedure :
  150. begin
  151. //skip these properties
  152. end
  153. else
  154. begin
  155. rItemValue := DeserializeType(aObject,rType.Kind,aTypeInfo,aJsonArray.Items[i].Value);
  156. end;
  157. end;
  158. if not rItemValue.IsEmpty then Result.SetArrayElement(i,rItemValue);
  159. end;
  160. //aProperty.SetValue(aObject,rValue);
  161. finally
  162. DynArrayClear(pArr,aTypeInfo);
  163. end;
  164. end;
  165. {$ENDIF}
  166. {$IFNDEF FPC}
  167. function TJsonSerializer.DeserializeRecord(aRecord : TValue; aObject : TObject; const aJson : TJSONObject) : TValue;
  168. var
  169. ctx : TRttiContext;
  170. rRec : TRttiRecordType;
  171. rField : TRttiField;
  172. rValue : TValue;
  173. member : TJSONPair;
  174. jArray : TJSONArray;
  175. json : TJSONObject;
  176. objClass : TClass;
  177. propobj : TObject;
  178. begin
  179. rRec := ctx.GetType(aRecord.TypeInfo).AsRecord;
  180. try
  181. for rField in rRec.GetFields do
  182. begin
  183. rValue := nil;
  184. member := TJSONPair(aJson.GetValue(rField.Name));
  185. if member <> nil then
  186. case rField.FieldType.TypeKind of
  187. tkDynArray :
  188. begin
  189. jArray := TJSONObject.ParseJSONValue(member.ToJSON) as TJSONArray;
  190. try
  191. rValue := DeserializeDynArray(rField.FieldType.Handle,aObject,jArray);
  192. finally
  193. jArray.Free;
  194. end;
  195. end;
  196. tkClass :
  197. begin
  198. //if (member.JsonValue is TJSONObject) then
  199. begin
  200. propobj := rField.GetValue(@aRecord).AsObject;
  201. json := TJSONObject.ParseJSONValue(member.ToJson) as TJSONObject;
  202. try
  203. if propobj = nil then
  204. begin
  205. objClass := rField.FieldType.Handle^.TypeData.ClassType;// aProperty.PropertyType.Handle^.TypeData.ClassType;
  206. rValue := DeserializeClass(objClass,json);
  207. end
  208. else
  209. begin
  210. DeserializeObject(propobj,json);
  211. end;
  212. finally
  213. json.Free;
  214. end;
  215. end
  216. end;
  217. else
  218. begin
  219. rValue := DeserializeType(aObject,rField.FieldType.TypeKind,rField.FieldType.Handle,member.JsonString.ToString);
  220. end;
  221. end;
  222. if not rValue.IsEmpty then rField.SetValue(aRecord.GetReferenceToRawData,rValue);
  223. end;
  224. Result := aRecord;
  225. finally
  226. ctx.Free;
  227. end;
  228. end;
  229. {$ENDIF}
  230. function TJsonSerializer.JsonToObject(aObject: TObject; const aJson: string): TObject;
  231. var
  232. json: TJSONObject;
  233. begin
  234. {$IFNDEF FPC}
  235. json := TJSONObject.ParseJSONValue(aJson,True) as TJSONObject;
  236. {$ELSE}
  237. json := GetJSON(aJson) as TJsonObject;
  238. {$ENDIF}
  239. try
  240. Result := DeserializeObject(aObject,json);
  241. finally
  242. json.Free;
  243. end;
  244. end;
  245. function TJsonSerializer.JsonToObject(aType: TClass; const aJson: string): TObject;
  246. var
  247. json: TJSONObject;
  248. begin
  249. {$IFNDEF FPC}
  250. json := TJSONObject.ParseJSONValue(aJson) as TJSONObject;
  251. {$ELSE}
  252. json := GetJSON(aJson) as TJsonObject;
  253. {$ENDIF}
  254. try
  255. Result := DeserializeClass(aType,json);
  256. finally
  257. json.Free;
  258. end;
  259. end;
  260. function TJsonSerializer.ObjectToJson(aObject: TObject): string;
  261. var
  262. json: TJSONObject;
  263. begin
  264. json := Serialize(aObject);
  265. try
  266. {$IFNDEF FPC}
  267. Result := json.ToJSON;
  268. {$ELSE}
  269. Result := json.AsJson;
  270. {$ENDIF}
  271. finally
  272. json.Free;
  273. end;
  274. end;
  275. constructor TJsonSerializer.Create(aSerializeLevel: TSerializeLevel);
  276. begin
  277. fSerializeLevel := aSerializeLevel;
  278. end;
  279. function TJsonSerializer.DeserializeClass(aType: TClass; const aJson: TJSONObject): TObject;
  280. begin
  281. Result := nil;
  282. if (aJson = nil) or (aJson.Count = 0) then Exit;
  283. Result := aType.Create;
  284. try
  285. Result := DeserializeObject(Result,aJson);
  286. except
  287. on E : Exception do
  288. begin
  289. Result.Free;
  290. raise EJsonDeserializeError.CreateFmt('Deserialize error class "%s" : %s',[aType.ClassName,e.Message]);
  291. end;
  292. end;
  293. end;
  294. function TJsonSerializer.DeserializeObject(aObject: TObject; const aJson: TJSONObject): TObject;
  295. var
  296. ctx: TRttiContext;
  297. rType: TRttiType;
  298. rProp: TRttiProperty;
  299. attr: TCustomAttribute;
  300. propertyname : string;
  301. begin
  302. Result := aObject;
  303. if (aJson = nil) or (aJson.Count = 0) or (Result = nil) then Exit;
  304. //if IsGenericList(aObject) then
  305. //begin
  306. // Result := DeserializeList(Result,aObject.ClassName,aJson);
  307. // Exit;
  308. //end;
  309. try
  310. rType := ctx.GetType(aObject.ClassInfo);
  311. try
  312. for rProp in rType.GetProperties do
  313. begin
  314. if ((fSerializeLevel = slPublicProperty) and (rProp.PropertyType.IsPublicType))
  315. or ((fSerializeLevel = slPublishedProperty) and (IsPublishedProp(aObject,rProp.Name))) then
  316. begin
  317. if ((rProp.IsWritable) or (rProp.Name = 'List')) and (IsAllowedProperty(aObject,rProp.Name)) then
  318. begin
  319. propertyname := rProp.Name;
  320. for attr in rProp.GetAttributes do if attr is TCustomNameProperty then propertyname := TCustomNameProperty(attr).Name;
  321. if rProp.Name = 'List' then
  322. begin
  323. Result := DeserializeList(Result,propertyname,aJson);
  324. end
  325. else
  326. Result := DeserializeProperty(Result,propertyname,rProp,aJson);
  327. end;
  328. end;
  329. end;
  330. finally
  331. ctx.Free;
  332. end;
  333. except
  334. on E : Exception do
  335. begin
  336. Result.Free;
  337. raise EJsonDeserializeError.CreateFmt('Deserialize error for object "%s" : %s',[aObject.ClassName,e.Message]);
  338. end;
  339. end;
  340. end;
  341. function TJsonSerializer.DeserializeList(aObject: TObject; const aName : string; const aJson: TJSONObject) : TObject;
  342. var
  343. ctx : TRttiContext;
  344. rType : TRttiType;
  345. rfield : TRttiField;
  346. jarray : TJSONArray;
  347. member : TJSONPair;
  348. rvalue : TValue;
  349. i : Integer;
  350. rProp : TRttiProperty;
  351. begin
  352. Result := aObject;
  353. member := TJSONPair(aJson.GetValue(aName));
  354. rType := ctx.GetType(aObject.ClassInfo);
  355. try
  356. rProp := rType.GetProperty('List');
  357. if rProp = nil then Exit;
  358. finally
  359. ctx.Free;
  360. end;
  361. jArray := TJSONObject.ParseJSONValue(member.ToJSON) as TJSONArray;
  362. try
  363. rvalue := DeserializeDynArray(rProp.PropertyType.Handle,Result,jArray);
  364. i := jarray.Count;
  365. rProp := rType.GetProperty('Count');
  366. rProp.SetValue(aObject,i);
  367. finally
  368. jArray.Free;
  369. end;
  370. if not rValue.IsEmpty then
  371. begin
  372. for rfield in rType.GetFields do
  373. begin
  374. if rfield.Name = 'FOwnsObjects' then rfield.SetValue(aObject,True);
  375. //if rfield.Name = 'FCount' then rfield.SetValue(aObject,i);
  376. if rfield.Name = 'FItems' then
  377. begin
  378. //if TList(aObject) <> nil then TList(aObject).Clear;
  379. //rfield.GetValue(aObject).AsObject.Free;// aValue.GetReferenceToRawData)
  380. rfield.SetValue(aObject,rValue);// .SetDynArrayProp(aObject,'fItems',Result);
  381. Break;
  382. end;
  383. end;
  384. end;
  385. end;
  386. function TJsonSerializer.DeserializeProperty(aObject : TObject; const aName : string; aProperty : TRttiProperty; const aJson : TJSONObject) : TObject;
  387. var
  388. rValue : TValue;
  389. member : TJSONPair;
  390. objClass: TClass;
  391. jArray : TJSONArray;
  392. json : TJSONObject;
  393. propinfo : PPropInfo;
  394. begin
  395. Result := aObject;
  396. member := TJSONPair(aJson.GetValue(aName));
  397. if member <> nil then
  398. begin
  399. case aProperty.PropertyType.TypeKind of
  400. tkDynArray :
  401. begin
  402. jArray := TJSONObject.ParseJSONValue(member.ToJSON) as TJSONArray;
  403. try
  404. aProperty.SetValue(aObject,DeserializeDynArray(aProperty.PropertyType.Handle,Result,jArray));
  405. finally
  406. jArray.Free;
  407. end;
  408. end;
  409. tkClass :
  410. begin
  411. //if (member.JsonValue is TJSONObject) then
  412. begin
  413. json := TJSONObject.ParseJSONValue(member.ToJson) as TJSONObject;
  414. try
  415. if aProperty.GetValue(aObject).AsObject = nil then
  416. begin
  417. objClass := aProperty.PropertyType.Handle^.TypeData.ClassType;
  418. rValue := DeserializeClass(objClass,json)
  419. end
  420. else
  421. begin
  422. rValue := DeserializeObject(aProperty.GetValue(aObject).AsObject,json);
  423. Exit;
  424. end;
  425. finally
  426. json.Free;
  427. end;
  428. end
  429. end;
  430. tkRecord :
  431. begin
  432. json := TJSONObject.ParseJSONValue(member.ToJson) as TJSONObject;
  433. try
  434. rValue := DeserializeRecord(aProperty.GetValue(aObject),aObject,json);
  435. finally
  436. json.Free;
  437. end;
  438. end;
  439. else
  440. begin
  441. rValue := DeserializeType(Result,aProperty.PropertyType.TypeKind,aProperty.GetValue(Result).TypeInfo,member.ToJSON);
  442. end;
  443. end;
  444. if not rValue.IsEmpty then aProperty.SetValue(Result,rValue);
  445. end;
  446. end;
  447. function TJsonSerializer.DeserializeType(aObject : TObject; aType : TTypeKind; aTypeInfo : PTypeInfo; const aValue: string) : TValue;
  448. var
  449. i : Integer;
  450. value : string;
  451. begin
  452. try
  453. value := AnsiDequotedStr(aValue,'"');
  454. case aType of
  455. tkString, tkLString, tkWString, tkUString :
  456. begin
  457. Result := value;
  458. end;
  459. tkChar, tkWChar :
  460. begin
  461. Result := value;
  462. end;
  463. tkInteger :
  464. begin
  465. Result := StrToInt(value);
  466. end;
  467. tkInt64 :
  468. begin
  469. Result := StrToInt64(value);
  470. end;
  471. tkFloat :
  472. begin
  473. if aTypeInfo = TypeInfo(TDateTime) then
  474. begin
  475. Result := JsonDateToDateTime(value);
  476. end
  477. else if aTypeInfo = TypeInfo(TDate) then
  478. begin
  479. Result := StrToDate(value);
  480. end
  481. else if aTypeInfo = TypeInfo(TTime) then
  482. begin
  483. Result := StrToTime(value);
  484. end
  485. else
  486. begin
  487. Result := StrToFloat(value);
  488. end;
  489. end;
  490. tkEnumeration :
  491. begin
  492. if aTypeInfo = System.TypeInfo(Boolean) then
  493. begin
  494. Result := StrToBool(value);
  495. end
  496. else
  497. begin
  498. TValue.Make(GetEnumValue(aTypeInfo,value),aTypeInfo, Result);
  499. end;
  500. end;
  501. tkSet :
  502. begin
  503. i := StringToSet(aTypeInfo,value);
  504. TValue.Make(@i,aTypeInfo,Result);
  505. end;
  506. else
  507. begin
  508. //raise EclJsonSerializerError.Create('Not supported data type!');
  509. end;
  510. end;
  511. except
  512. on E : Exception do
  513. begin
  514. raise EJsonDeserializeError.CreateFmt('Deserialize error type "%s.%s" : %s',[aObject.ClassName,GetTypeName(aTypeInfo),e.Message]);
  515. end;
  516. end;
  517. end;
  518. function TJsonSerializer.IsAllowedProperty(aObject : TObject; const aPropertyName : string) : Boolean;
  519. var
  520. propname : string;
  521. begin
  522. Result := True;
  523. propname := aPropertyName.ToLower;
  524. if (aObject.ClassName.StartsWith('TObjectList')) or (aObject.ClassName.StartsWith('TList')) then
  525. begin
  526. if (propname = 'capacity') or (propname = 'count') or (propname = 'ownsobjects') then Result := False;
  527. end
  528. else if (propname = 'refcount') then Result := False;
  529. end;
  530. function TJsonSerializer.IsGenericList(aObject : TObject) : Boolean;
  531. begin
  532. Result := (aObject.ClassName.StartsWith('TObjectList')) or (aObject.ClassName.StartsWith('TList'));
  533. end;
  534. function TJsonSerializer.Serialize(aObject: TObject): TJSONObject;
  535. var
  536. ctx: TRttiContext;
  537. attr : TCustomAttribute;
  538. rType: TRttiType;
  539. rProp: TRttiProperty;
  540. jpair : TJSONPair;
  541. ExcludeSerialize : Boolean;
  542. comment : string;
  543. propertyname : string;
  544. listtype : TRttiType;
  545. listprop : TRttiProperty;
  546. listvalue : TValue;
  547. begin
  548. if (aObject = nil) then
  549. begin
  550. Result := nil;
  551. Exit;
  552. end;
  553. Result := TJSONObject.Create;
  554. try
  555. rType := ctx.GetType(aObject.ClassInfo);
  556. try
  557. //s := rType.ToString;
  558. for rProp in rType.GetProperties do
  559. begin
  560. ExcludeSerialize := False;
  561. comment := '';
  562. propertyname := rProp.Name;
  563. for attr in rProp.GetAttributes do
  564. begin
  565. if attr is TNotSerializableProperty then ExcludeSerialize := True
  566. else if attr is TCommentProperty then comment := TCommentProperty(attr).Comment
  567. else if attr is TCustomNameProperty then propertyname := TCustomNameProperty(attr).Name;
  568. end;
  569. if ((fSerializeLevel = slPublicProperty) and (rProp.PropertyType.IsPublicType))
  570. or ((fSerializeLevel = slPublishedProperty) and (IsPublishedProp(aObject,rProp.Name))) then
  571. begin
  572. if (IsAllowedProperty(aObject,propertyname)) and (not ExcludeSerialize) then
  573. begin
  574. //add comment as pair
  575. if comment <> '' then Result.AddPair(TJSONPair.Create('#Comment#->'+propertyname,Comment));
  576. //s := rProp.Name;
  577. //listtype := ctx.GetType(rProp.GetValue(aObject).TypeInfo);
  578. //if (listtype.ClassParent.ClassName.StartsWith('TObjectList')) then
  579. //begin
  580. // jpair := Serialize(propertyname,rProp.GetValue(aObject));
  581. // Result.AddPair(propertyname,(jpair.JsonValue as TJSONObject).GetValue('List').Clone as TJsonValue);
  582. // jpair.Free;
  583. //listtype := ctx.GetType(rProp.GetValue(aObject).AsObject.ClassInfo);
  584. //listprop := listtype.GetProperty('List');
  585. //listvalue := listprop.GetValue(aObject);
  586. //jpair := Serialize('Groups',listvalue);
  587. //if jpair <> nil then Result.AddPair(jpair)
  588. // else jpair.Free;
  589. //Exit;
  590. //end
  591. //else
  592. begin
  593. jpair := Serialize(propertyname,rProp.GetValue(aObject));
  594. //s := jpair.JsonValue.ToString;
  595. if jpair <> nil then Result.AddPair(jpair)
  596. else jpair.Free;
  597. end;
  598. //Result.AddPair(Serialize(rProp.Name,rProp.GetValue(aObject)));
  599. //s := Result.ToJSON;
  600. end;
  601. end;
  602. end;
  603. finally
  604. ctx.Free;
  605. end;
  606. except
  607. on E : Exception do
  608. begin
  609. Result.Free;
  610. raise EJsonSerializeError.CreateFmt('Serialize error object "%s" : %s',[aObject.ClassName,e.Message]);
  611. end;
  612. end;
  613. end;
  614. function TJsonSerializer.GetValue(aAddr: Pointer; aType: TRTTIType): TValue;
  615. begin
  616. TValue.Make(aAddr,aType.Handle,Result);
  617. end;
  618. function TJsonSerializer.Serialize(const aName : string; aValue : TValue): TJSONPair;
  619. var
  620. ctx: TRttiContext;
  621. rRec : TRttiRecordType;
  622. rField : TRttiField;
  623. rDynArray : TRTTIDynamicArrayType;
  624. json : TJSONObject;
  625. jArray : TJSONArray;
  626. jPair : TJSONPair;
  627. jValue : TJSONValue;
  628. i : Integer;
  629. begin
  630. Result := TJSONPair.Create(aName,nil);
  631. //Result.JsonString := TJSONString(aName);
  632. try
  633. case aValue.Kind of
  634. tkDynArray :
  635. begin
  636. jArray := TJSONArray.Create;
  637. rDynArray := ctx.GetType(aValue.TypeInfo) as TRTTIDynamicArrayType;
  638. try
  639. for i := 0 to aValue.GetArrayLength - 1 do
  640. begin
  641. jPair := Serialize(aName,GetValue(PPByte(aValue.GetReferenceToRawData)^ + rDynArray.ElementType.TypeSize * i, rDynArray.ElementType));
  642. try
  643. //jValue := TJsonValue(jPair.JsonValue.Clone);
  644. jValue := jPair.JsonValue;
  645. jArray.AddElement(jValue);
  646. jPair.JsonValue.Owned := False;
  647. finally
  648. jPair.Free;
  649. jValue.Owned := True;
  650. end;
  651. end;
  652. Result.JsonValue := jArray;
  653. finally
  654. ctx.Free;
  655. end;
  656. end;
  657. tkClass :
  658. begin
  659. Result.JsonValue := TJSONValue(Serialize(aValue.AsObject));
  660. end;
  661. tkString, tkLString, tkWString, tkUString :
  662. begin
  663. Result.JsonValue := TJSONString.Create(aValue.AsString);
  664. end;
  665. tkChar, tkWChar :
  666. begin
  667. Result.JsonValue := TJSONString.Create(aValue.AsString);
  668. end;
  669. tkInteger :
  670. begin
  671. Result.JsonValue := TJSONNumber.Create(aValue.AsInteger);
  672. end;
  673. tkInt64 :
  674. begin
  675. Result.JsonValue := TJSONNumber.Create(aValue.AsInt64);
  676. end;
  677. tkFloat :
  678. begin
  679. if aValue.TypeInfo = TypeInfo(TDateTime) then
  680. begin
  681. Result.JsonValue := TJSONString.Create(DateTimeToJsonDate(aValue.AsExtended));
  682. end
  683. else if aValue.TypeInfo = TypeInfo(TDate) then
  684. begin
  685. Result.JsonValue := TJSONString.Create(DateToStr(aValue.AsExtended));
  686. end
  687. else if aValue.TypeInfo = TypeInfo(TTime) then
  688. begin
  689. Result.JsonValue := TJSONString.Create(TimeToStr(aValue.AsExtended));
  690. end
  691. else Result.JsonValue := TJSONNumber.Create(aValue.AsExtended);
  692. end;
  693. tkEnumeration :
  694. begin
  695. if (aValue.TypeInfo = System.TypeInfo(Boolean)) then
  696. begin
  697. Result.JsonValue := TJSONBool.Create(aValue.AsBoolean);
  698. end
  699. else
  700. begin
  701. Result.JsonValue := TJSONString.Create(GetEnumName(aValue.TypeInfo,aValue.AsOrdinal));
  702. //Result.JsonValue := TJSONString.Create(aValue.ToString);
  703. end;
  704. end;
  705. tkSet :
  706. begin
  707. Result.JsonValue := TJSONString.Create(aValue.ToString);
  708. end;
  709. tkRecord :
  710. begin
  711. rRec := ctx.GetType(aValue.TypeInfo).AsRecord;
  712. try
  713. json := TJSONObject.Create;
  714. for rField in rRec.GetFields do
  715. begin
  716. json.AddPair(Serialize(rField.name,rField.GetValue(aValue.GetReferenceToRawData)));
  717. end;
  718. Result.JsonValue := json;
  719. finally
  720. ctx.Free;
  721. end;
  722. end;
  723. tkMethod, tkPointer, tkClassRef ,tkInterface, tkProcedure :
  724. begin
  725. //skip these properties
  726. FreeAndNil(Result);
  727. end
  728. else
  729. begin
  730. raise EJsonSerializeError.Create(Format(cNotSupportedDataType,[aName,GetTypeName(aValue.TypeInfo)]));
  731. end;
  732. end;
  733. except
  734. on E : Exception do
  735. begin
  736. Result.Free;
  737. raise EJsonSerializeError.CreateFmt('Serialize error class "%s.%s" : %s',[aName,aValue.ToString,e.Message]);
  738. end;
  739. end;
  740. end;
  741. { TCommentProperty }
  742. constructor TCommentProperty.Create(const aComment: string);
  743. begin
  744. fComment := aComment;
  745. end;
  746. { TCustomNameProperty }
  747. constructor TCustomNameProperty.Create(const aName: string);
  748. begin
  749. fName := aName;
  750. end;
  751. end.