Quick.Json.Serializer.pas 46 KB

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