Quick.Json.Serializer.pas 67 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076
  1. { ***************************************************************************
  2. Copyright (c) 2015-2022 Kike Pérez
  3. Unit : Quick.JSON.Serializer
  4. Description : Json Serializer
  5. Author : Kike Pérez
  6. Version : 1.12
  7. Created : 21/05/2018
  8. Modified : 26/01/2022
  9. This file is part of QuickLib: https://github.com/exilon/QuickLib
  10. ***************************************************************************
  11. Licensed under the Apache License, Version 2.0 (the "License");
  12. you may not use this file except in compliance with the License.
  13. You may obtain a copy of the License at
  14. http://www.apache.org/licenses/LICENSE-2.0
  15. Unless required by applicable law or agreed to in writing, software
  16. distributed under the License is distributed on an "AS IS" BASIS,
  17. WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  18. See the License for the specific language governing permissions and
  19. limitations under the License.
  20. *************************************************************************** }
  21. unit Quick.Json.Serializer;
  22. {$i QuickLib.inc}
  23. interface
  24. uses
  25. {$IFDEF DEBUG_SERIALIZER}
  26. Quick.Debug.Utils,
  27. {$ENDIF}
  28. Classes,
  29. SysUtils,
  30. Rtti,
  31. TypInfo,
  32. Quick.Serializer.Intf,
  33. Quick.Base64,
  34. {$IFDEF FPC}
  35. rttiutils,
  36. fpjson,
  37. jsonparser,
  38. strUtils,
  39. //jsonreader,
  40. //fpjsonrtti,
  41. Quick.Json.fpc.Compatibility,
  42. {$ELSE}
  43. {$IFDEF DELPHIXE7_UP}
  44. System.Json,
  45. {$ELSE}
  46. Data.DBXJSON,
  47. {$ENDIF}
  48. {$IFDEF DELPHIRX10_UP}
  49. {$ENDIF}
  50. Variants,
  51. {$ENDIF}
  52. Generics.Collections,
  53. Quick.RTTI.Utils,
  54. DateUtils,
  55. Quick.Commons,
  56. Quick.JSON.Utils;
  57. type
  58. IJsonSerializer = ISerializer;
  59. EJsonSerializeError = class(Exception);
  60. EJsonDeserializeError = class(Exception);
  61. {$IFNDEF FPC}
  62. TNotSerializableProperty = class(TCustomAttribute);
  63. TCommentProperty = class(TCustomAttribute)
  64. private
  65. fComment : string;
  66. public
  67. constructor Create(const aComment: string);
  68. property Comment : string read fComment;
  69. end;
  70. TCustomNameProperty = class(TCustomAttribute)
  71. private
  72. fName : string;
  73. public
  74. constructor Create(const aName: string);
  75. property Name : string read fName;
  76. end;
  77. {$IFNDEF DELPHIXE7_UP}
  78. TJSONArrayHelper = class helper for Data.DBXJson.TJSONArray
  79. private
  80. function GetItem(aValue : Integer) : TJSONValue;
  81. public
  82. function Count : Integer;
  83. property Items[index : Integer] : TJSONValue read GetItem;
  84. procedure SetElements(aElements : TList<TJSONValue>);
  85. end;
  86. TJSONValueHelper = class helper for Data.DBXJson.TJSONValue
  87. public
  88. function ToJson : string;
  89. end;
  90. TJSONObjectHelper = class helper for Data.DBXJson.TJSONObject
  91. private
  92. function GetPair(aValue : Integer) : TJSONPair;
  93. public
  94. function Count : Integer;
  95. function GetValue(const aName : string) : TJSONValue;
  96. property Pairs[index : Integer] : TJSONPair read GetPair;
  97. end;
  98. {$ENDIF}
  99. {$ENDIF}
  100. TSerializeLevel = (slPublicProperty, slPublishedProperty);
  101. TRTTIJson = class
  102. type
  103. TGenericListType = (gtNone, gtList, gtObjectList);
  104. private
  105. fSerializeLevel : TSerializeLevel;
  106. fUseEnumNames : Boolean;
  107. fUseJsonCaseSense : Boolean;
  108. fUseBase64Stream : Boolean;
  109. fUseNullStringsAsEmpty : Boolean;
  110. function GetValue(aAddr: Pointer; aType: TRTTIType): TValue; overload;
  111. {$IFDEF FPC}
  112. function GetValue(aAddr: Pointer; aTypeInfo: PTypeInfo): TValue; overload;
  113. {$ENDIF}
  114. function IsAllowedProperty(aObject : TObject; const aPropertyName : string) : Boolean;
  115. //function GetPropertyValue(Instance : TObject; const PropertyName : string) : TValue;
  116. function GetPropertyValueFromObject(Instance : TObject; const PropertyName : string) : TValue;
  117. {$IFNDEF FPC}
  118. function GetFieldValueFromRecord(const aValue : TValue; const FieldName : string) : TValue;
  119. {$ENDIF}
  120. {$IFDEF FPC}
  121. procedure SetPropertyValue(Instance : TObject; aPropInfo : PPropInfo; aValue : TValue); overload;
  122. procedure SetPropertyValue(Instance : TObject; const PropertyName : string; aValue : TValue); overload;
  123. function FloatProperty(aObject : TObject; aPropInfo: PPropInfo): string;
  124. function GetPropType(aPropInfo: PPropInfo): PTypeInfo;
  125. procedure LoadSetProperty(aInstance : TObject; aPropInfo: PPropInfo; const aValue: string);
  126. {$ENDIF}
  127. {$IFNDEF FPC}
  128. function CreateInstance(aClass: TClass): TValue; overload;
  129. function CreateInstance(aType: TRttiType): TValue; overload;
  130. {$ENDIF}
  131. public
  132. constructor Create(aSerializeLevel : TSerializeLevel; aUseEnumNames : Boolean = True);
  133. property UseEnumNames : Boolean read fUseEnumNames write fUseEnumNames;
  134. property UseJsonCaseSense : Boolean read fUseJsonCaseSense write fUseJsonCaseSense;
  135. property UseBase64Stream : Boolean read fUseBase64Stream write fUseBase64Stream;
  136. property UseNullStringsAsEmpty : Boolean read fUseNullStringsAsEmpty write fUseNullStringsAsEmpty;
  137. function GetJsonPairValueByName(aJson : TJSONObject; const aName : string) : TJsonValue;
  138. function GetJsonPairByName(aJson : TJSONObject; const aName : string) : TJSONPair;
  139. function IsGenericList(aObject : TObject) : Boolean;
  140. function IsStream(aObject : TObject) : Boolean;
  141. function IsGenericXArray(const aClassName : string) : Boolean;
  142. function GetGenericListType(aObject : TObject) : TGenericListType;
  143. //serialize methods
  144. function SerializeValue(const aValue : TValue) : TJSONValue;
  145. function SerializeObject(aObject : TObject) : TJSONObject; overload;
  146. function SerializeStream(aObject : TObject) : TJSONValue;
  147. {$IFNDEF FPC}
  148. function SerializeDynArray(const aValue: TValue; aMaxElements : Integer = -1) : TJsonArray;
  149. function SerializeRecord(const aValue : TValue) : TJSONValue;
  150. {$ELSE}
  151. function SerializeObject(aObject : TObject; aType : TTypeKind; const aPropertyName : string) : TJSONPair;
  152. {$ENDIF}
  153. //deserialize methods
  154. function DeserializeClass(aType : TClass; const aJson : TJSONObject) : TObject;
  155. function DeserializeObject(aObject : TObject; const aJson : TJSONObject) : TObject; overload;
  156. function DeserializeProperty(aObject : TObject; const aName : string; aProperty : TRttiProperty; const aJson : TJSONObject) : TObject; overload;
  157. function DeserializeStream(aObject : TObject; const aJson : TJSONValue) : TObject;
  158. {$IFNDEF FPC}
  159. function DeserializeType(aObject : TObject; aType : TTypeKind; aTypeInfo : PTypeInfo; const aValue: string) : TValue;
  160. function DeserializeDynArray(aTypeInfo : PTypeInfo; aObject : TObject; const aJsonArray: TJSONArray) : TValue;
  161. function DeserializeRecord(const aRecord : TValue; aObject : TObject; const aJson : TJSONObject) : TValue;
  162. function DeserializeList(aObject: TObject; const aName : string; const aJson: TJSONObject) : TObject;
  163. procedure DeserializeXArray(Instance : TObject; aRecord : TValue; aProperty : TRttiProperty; const aPropertyName : string; aJson : TJsonObject);
  164. {$ELSE}
  165. function DeserializeType(aObject : TObject; aType : TTypeKind; const aPropertyName, aValue: string) : TValue;
  166. procedure DeserializeDynArray(aTypeInfo: PTypeInfo; const aPropertyName : string; aObject: TObject; const aJsonArray: TJSONArray);
  167. {$ENDIF}
  168. end;
  169. TJsonSerializer = class(TInterfacedObject,IJsonSerializer)
  170. strict private
  171. fSerializeLevel : TSerializeLevel;
  172. fUseEnumNames : Boolean;
  173. fUseJsonCaseSense : Boolean;
  174. fUseBase64Stream : Boolean;
  175. fUseNullStringsAsEmpty : Boolean;
  176. fRTTIJson : TRTTIJson;
  177. private
  178. procedure SetUseEnumNames(const Value: Boolean);
  179. procedure SetUseJsonCaseSense(const Value: Boolean);
  180. procedure SetSerializeLevel(const Value: TSerializeLevel);
  181. procedure SetUseBase64Stream(const Value: Boolean);
  182. //Only Delphi -> Workaround, use this when something passes : {Test : "Null"} but we expect : {Test : ""}
  183. procedure SetUseNullStringsAsEmpty(const Value : Boolean);
  184. public
  185. constructor Create(aSerializeLevel: TSerializeLevel; aUseEnumNames : Boolean = True; aUseNullStringsAsEmpty : Boolean = False);
  186. destructor Destroy; override;
  187. property SerializeLevel : TSerializeLevel read fSerializeLevel write SetSerializeLevel;
  188. property UseEnumNames : Boolean read fUseEnumNames write SetUseEnumNames;
  189. property UseJsonCaseSense : Boolean read fUseJsonCaseSense write SetUseJsonCaseSense;
  190. property UseBase64Stream : Boolean read fUseBase64Stream write SetUseBase64Stream;
  191. property UseNullStringsAsEmpty : Boolean read fUseNullStringsAsEmpty write SetUseNullStringsAsEmpty;
  192. function JsonToObject(aType : TClass; const aJson: string) : TObject; overload;
  193. function JsonToObject(aObject : TObject; const aJson: string) : TObject; overload;
  194. function JsonStreamToObject(aObject : TObject; aJsonStream : TStream) : TObject;
  195. function ObjectToJson(aObject : TObject; aIndent : Boolean = False): string;
  196. function ObjectToJsonString(aObject : TObject; aIndent : Boolean = False): string;
  197. procedure ObjectToJsonStream(aObject : TObject; aStream : TStream);
  198. function ValueToJson(const aValue : TValue; aIndent : Boolean = False) : string;
  199. function ValueToJsonString(const aValue : TValue; aIndent : Boolean = False) : string;
  200. function ArrayToJson<T>(aArray : TArray<T>; aIndent : Boolean = False) : string;
  201. function ArrayToJsonString<T>(aArray : TArray<T>; aIndent : Boolean = False) : string;
  202. {$IFNDEF FPC}
  203. function JsonToArray<T>(const aJson : string) : TArray<T>;
  204. function JsonToValue(const aJson: string): TValue;
  205. {$ENDIF}
  206. end;
  207. EJsonSerializerError = class(Exception);
  208. PPByte = ^PByte;
  209. resourcestring
  210. cNotSupportedDataType = 'Not supported data type "%s"';
  211. cSerializeObjectError = 'Serialize object "%s" error: %s';
  212. cSerializePropertyError = 'Property "%s" ("%s")';
  213. cNotSerializable = 'Object is not serializable';
  214. cNotValidJson = 'Not a valid Json';
  215. implementation
  216. { TRTTIJson }
  217. {$IFNDEF FPC}
  218. function TRTTIJson.DeserializeDynArray(aTypeInfo: PTypeInfo; aObject: TObject; const aJsonArray: TJSONArray) : TValue;
  219. var
  220. rType: PTypeInfo;
  221. len: NativeInt;
  222. pArr: Pointer;
  223. rItemValue: TValue;
  224. i: Integer;
  225. objClass: TClass;
  226. ctx : TRttiContext;
  227. json : TJSONObject;
  228. rDynArray : TRttiDynamicArrayType;
  229. propObj : TObject;
  230. begin
  231. if GetTypeData(aTypeInfo).DynArrElType = nil then Exit;
  232. if not assigned(aJsonArray) then Exit;
  233. len := aJsonArray.Count;
  234. rType := GetTypeData(aTypeInfo).DynArrElType^;
  235. pArr := nil;
  236. DynArraySetLength(pArr,aTypeInfo, 1, @len);
  237. try
  238. TValue.Make(@pArr,aTypeInfo, Result);
  239. rDynArray := ctx.GetType(Result.TypeInfo) as TRTTIDynamicArrayType;
  240. for i := 0 to aJsonArray.Count - 1 do
  241. begin
  242. rItemValue := nil;
  243. case rType.Kind of
  244. tkClass :
  245. begin
  246. if aJsonArray.Items[i] is TJSONObject then
  247. begin
  248. propObj := GetValue(PPByte(Result.GetReferenceToRawData)^ +rDynArray.ElementType.TypeSize * i, rDynArray.ElementType).AsObject;
  249. if propObj = nil then
  250. begin
  251. objClass := rType.TypeData.ClassType;
  252. rItemValue := DeserializeClass(objClass, TJSONObject(aJsonArray.Items[i]));
  253. end
  254. else
  255. begin
  256. DeserializeObject(propObj,TJSONObject(aJsonArray.Items[i]));
  257. end;
  258. end;
  259. end;
  260. tkRecord :
  261. begin
  262. json := TJSONObject(aJsonArray.Items[i]);
  263. rItemValue := DeserializeRecord(GetValue(PPByte(Result.GetReferenceToRawData)^ +rDynArray.ElementType.TypeSize * i,
  264. rDynArray.ElementType),aObject,json);
  265. end;
  266. tkMethod, tkPointer, tkClassRef ,tkInterface, tkProcedure :
  267. begin
  268. //skip these properties
  269. end
  270. else
  271. begin
  272. rItemValue := DeserializeType(aObject,rType.Kind,rType,aJsonArray.Items[i].Value);
  273. end;
  274. end;
  275. if not rItemValue.IsEmpty then Result.SetArrayElement(i,rItemValue);
  276. end;
  277. //aProperty.SetValue(aObject,rValue);
  278. finally
  279. DynArrayClear(pArr,aTypeInfo);
  280. end;
  281. end;
  282. {$ELSE}
  283. procedure TRTTIJson.DeserializeDynArray(aTypeInfo: PTypeInfo; const aPropertyName : string; aObject: TObject; const aJsonArray: TJSONArray);
  284. var
  285. rType: PTypeInfo;
  286. len: NativeInt;
  287. pArr: Pointer;
  288. rItemValue: TValue;
  289. i: Integer;
  290. objClass: TClass;
  291. propObj : TObject;
  292. rValue : TValue;
  293. begin
  294. if GetTypeData(aTypeInfo).ElType2 = nil then Exit;
  295. len := aJsonArray.Count;
  296. rType := GetTypeData(aTypeInfo).ElType2;
  297. pArr := nil;
  298. DynArraySetLength(pArr,aTypeInfo, 1, @len);
  299. try
  300. TValue.Make(@pArr,aTypeInfo, rValue);
  301. for i := 0 to aJsonArray.Count - 1 do
  302. begin
  303. rItemValue := nil;
  304. case rType.Kind of
  305. tkClass :
  306. begin
  307. if aJsonArray.Items[i] is TJSONObject then
  308. begin
  309. propObj := GetValue(PPByte(rValue.GetReferenceToRawData)^ +GetTypeData(aTypeInfo).elSize * i, GetTypeData(aTypeInfo).ElType2).AsObject;
  310. if propObj = nil then
  311. begin
  312. objClass := GetTypeData(aTypeInfo).ClassType;
  313. rItemValue := DeserializeClass(objClass, TJSONObject(aJsonArray.Items[i]));
  314. end
  315. else
  316. begin
  317. DeserializeObject(propObj,TJSONObject(aJsonArray.Items[i]));
  318. end;
  319. end;
  320. end;
  321. tkRecord :
  322. begin
  323. {json := TJSONObject(aJsonArray.Items[i]);
  324. rItemValue := DeserializeRecord(GetValue(PPByte(Result.GetReferenceToRawData)^ +rDynArray.ElementType.TypeSize * i,
  325. rDynArray.ElementType),aObject,json); }
  326. end;
  327. tkMethod, tkPointer, tkClassRef ,tkInterface, tkProcedure :
  328. begin
  329. //skip these properties
  330. end
  331. else
  332. begin
  333. rItemValue := DeserializeType(aObject,GetTypeData(aTypeInfo).ElType2.Kind,aPropertyName,aJsonArray.Items[i].Value);
  334. end;
  335. end;
  336. if not rItemValue.IsEmpty then rValue.SetArrayElement(i,rItemValue);
  337. end;
  338. //aProperty.SetValue(aObject,rValue);
  339. SetDynArrayProp(aObject,GetPropInfo(aObject,aPropertyName),pArr);
  340. finally
  341. DynArrayClear(pArr,aTypeInfo);
  342. end;
  343. end;
  344. {$ENDIF}
  345. {$IFNDEF FPC}
  346. function TRTTIJson.DeserializeRecord(const aRecord : TValue; aObject : TObject; const aJson : TJSONObject) : TValue;
  347. var
  348. ctx : TRttiContext;
  349. rRec : TRttiRecordType;
  350. rField : TRttiField;
  351. rValue : TValue;
  352. member : TJsonValue;
  353. jArray : TJSONArray;
  354. json : TJSONObject;
  355. objClass : TClass;
  356. propobj : TObject;
  357. begin
  358. rRec := ctx.GetType(aRecord.TypeInfo).AsRecord;
  359. for rField in rRec.GetFields do
  360. begin
  361. rValue := nil;
  362. //member := TJSONPair(aJson.GetValue(rField.Name));
  363. member := GetJsonPairValueByName(aJson,rField.Name);
  364. if member <> nil then
  365. case rField.FieldType.TypeKind of
  366. tkDynArray :
  367. begin
  368. jArray := TJSONObject.ParseJSONValue(member.ToJSON) as TJSONArray;
  369. try
  370. rValue := DeserializeDynArray(rField.FieldType.Handle,aObject,jArray);
  371. finally
  372. jArray.Free;
  373. end;
  374. end;
  375. tkClass :
  376. begin
  377. //if (member.JsonValue is TJSONObject) then
  378. begin
  379. propobj := rField.GetValue(@aRecord).AsObject;
  380. json := TJSONObject.ParseJSONValue(member.ToJson) as TJSONObject;
  381. try
  382. if propobj = nil then
  383. begin
  384. objClass := rField.FieldType.Handle^.TypeData.ClassType;// aProperty.PropertyType.Handle^.TypeData.ClassType;
  385. rValue := DeserializeClass(objClass,json);
  386. end
  387. else
  388. begin
  389. DeserializeObject(propobj,json);
  390. end;
  391. finally
  392. json.Free;
  393. end;
  394. end
  395. end;
  396. tkRecord :
  397. begin
  398. json := TJSONObject.ParseJSONValue(member.ToJson) as TJSONObject;
  399. try
  400. rValue := DeserializeRecord(rField.GetValue(aRecord.GetReferenceToRawData),aObject,json);
  401. finally
  402. json.Free;
  403. end;
  404. end
  405. else
  406. begin
  407. //rValue := DeserializeType(aObject,rField.FieldType.TypeKind,rField.FieldType.Handle,member.ToJson);
  408. //avoid return unicode escaped chars if string
  409. if rField.FieldType.TypeKind in [tkString, tkLString, tkWString, tkUString] then
  410. {$IFDEF DELPHIRX10_UP}
  411. rValue := DeserializeType(aObject,rField.FieldType.TypeKind,rField.FieldType.Handle,TJsonValue(member).value)
  412. {$ELSE}
  413. rValue := DeserializeType(aObject,rField.FieldType.TypeKind,rField.FieldType.Handle,member.Value)
  414. {$ENDIF}
  415. else rValue := DeserializeType(aObject,rField.FieldType.TypeKind,rField.FieldType.Handle,member.ToJSON);
  416. end;
  417. end;
  418. if not rValue.IsEmpty then rField.SetValue(aRecord.GetReferenceToRawData,rValue);
  419. end;
  420. Result := aRecord;
  421. end;
  422. {$ENDIF}
  423. function TRTTIJson.DeserializeStream(aObject: TObject; const aJson: TJSONValue): TObject;
  424. var
  425. stream : TStringStream;
  426. begin
  427. if fUseBase64Stream then stream := TStringStream.Create(Base64Decode(aJson.Value),TEncoding.Ansi)
  428. else stream := TStringStream.Create({$IFNDEF FPC}aJson.Value{$ELSE}string(aJson.Value){$ENDIF},TEncoding.Ansi);
  429. try
  430. TStream(aObject).CopyFrom(stream,stream.Size);
  431. finally
  432. stream.Free;
  433. end;
  434. Result := aObject;
  435. end;
  436. constructor TRTTIJson.Create(aSerializeLevel : TSerializeLevel; aUseEnumNames : Boolean = True);
  437. begin
  438. fSerializeLevel := aSerializeLevel;
  439. fUseEnumNames := aUseEnumNames;
  440. fUseJsonCaseSense := False;
  441. fUseBase64Stream := True;
  442. end;
  443. {$IFNDEF FPC}
  444. function TRTTIJson.CreateInstance(aClass: TClass): TValue;
  445. var
  446. ctx : TRttiContext;
  447. rtype : TRttiType;
  448. begin
  449. Result := nil;
  450. rtype := ctx.GetType(aClass);
  451. Result := CreateInstance(rtype);
  452. end;
  453. {$ENDIF}
  454. {$IFNDEF FPC}
  455. function TRTTIJson.CreateInstance(aType: TRttiType): TValue;
  456. var
  457. rmethod : TRttiMethod;
  458. begin
  459. Result := nil;
  460. if atype = nil then Exit;
  461. for rmethod in TRttiInstanceType(atype).GetMethods do
  462. begin
  463. if rmethod.IsConstructor then
  464. begin
  465. //create if don't have parameters
  466. if Length(rmethod.GetParameters) = 0 then
  467. begin
  468. Result := rmethod.Invoke(TRttiInstanceType(atype).MetaclassType,[]);
  469. Break;
  470. end;
  471. end;
  472. end;
  473. end;
  474. {$ENDIF}
  475. function TRTTIJson.DeserializeClass(aType: TClass; const aJson: TJSONObject): TObject;
  476. begin
  477. Result := nil;
  478. if (aJson = nil) or ((aJson as TJSONValue) is TJSONNull) or (aJson.Count = 0) then Exit;
  479. {$IFNDEF FPC}
  480. Result := CreateInstance(aType).AsObject;
  481. {$ELSE}
  482. Result := aType.Create;
  483. {$ENDIF}
  484. try
  485. Result := DeserializeObject(Result,aJson);
  486. except
  487. on E : Exception do
  488. begin
  489. Result.Free;
  490. raise EJsonDeserializeError.CreateFmt('Deserialize error class "%s" : %s',[aType.ClassName,e.Message]);
  491. end;
  492. end;
  493. end;
  494. function TRTTIJson.DeserializeObject(aObject: TObject; const aJson: TJSONObject): TObject;
  495. var
  496. ctx: TRttiContext;
  497. rType: TRttiType;
  498. rProp: TRttiProperty;
  499. {$IFNDEF FPC}
  500. attr: TCustomAttribute;
  501. propvalue : TValue;
  502. {$ENDIF}
  503. propertyname : string;
  504. begin
  505. Result := aObject;
  506. if (aJson = nil) or ((aJson as TJSONValue) is TJSONNull) or (aJson.Count = 0) or (Result = nil) then Exit;
  507. try
  508. //if generic list
  509. {$IFNDEF FPC}
  510. if IsGenericList(aObject) then
  511. begin
  512. DeserializeList(aObject,'List',aJson);
  513. Exit;
  514. end
  515. else
  516. {$ENDIF}
  517. if IsStream(aObject) then
  518. begin
  519. DeserializeStream(aObject,aJson);
  520. Exit;
  521. end;
  522. //if standard object
  523. rType := ctx.GetType(aObject.ClassInfo);
  524. for rProp in rType.GetProperties do
  525. begin
  526. {$IFNDEF FPC}
  527. if ((fSerializeLevel = slPublicProperty) and (rProp.PropertyType.IsPublicType))
  528. or ((fSerializeLevel = slPublishedProperty) and ((IsPublishedProp(aObject,rProp.Name)) or (rProp.Name = 'List'))) then
  529. {$ENDIF}
  530. begin
  531. if ((rProp.IsWritable) or (rProp.Name = 'List')) and (IsAllowedProperty(aObject,rProp.Name)) then
  532. begin
  533. propertyname := rProp.Name;
  534. {$IFNDEF FPC}
  535. for attr in rProp.GetAttributes do if attr is TCustomNameProperty then propertyname := TCustomNameProperty(attr).Name;
  536. propvalue := rProp.GetValue(aObject);
  537. if rProp.Name = 'List' then
  538. begin
  539. Result := DeserializeList(Result,propertyname,aJson);
  540. end
  541. else if propvalue.IsObject then
  542. begin
  543. if propvalue.AsObject = nil then
  544. begin
  545. propvalue := CreateInstance(rProp.PropertyType);
  546. rProp.SetValue(aObject,propvalue);
  547. end;
  548. if IsGenericList(propvalue.AsObject) then DeserializeList(propvalue.AsObject,'List',TJSONObject(aJson.GetValue(propertyname)))
  549. else Result := DeserializeProperty(Result,propertyname,rProp,aJson);
  550. end
  551. else if IsGenericXArray(string(propvalue{$IFNDEF NEXTGEN}.TypeInfo.Name{$ELSE}.TypeInfo.NameFld.ToString{$ENDIF})) then
  552. begin
  553. DeserializeXArray(Result,propvalue,rProp,propertyname,aJson);
  554. end
  555. else
  556. {$ENDIF}
  557. Result := DeserializeProperty(Result,propertyname,rProp,aJson);
  558. end;
  559. end;
  560. end;
  561. except
  562. on E : Exception do
  563. begin
  564. Result.Free;
  565. raise EJsonDeserializeError.CreateFmt('Deserialize error for object "%s" : %s',[aObject.ClassName,e.Message]);
  566. end;
  567. end;
  568. end;
  569. {$IFNDEF FPC}
  570. function TRTTIJson.DeserializeList(aObject: TObject; const aName : string; const aJson: TJSONObject) : TObject;
  571. var
  572. ctx : TRttiContext;
  573. rType : TRttiType;
  574. jarray : TJSONArray;
  575. member : TJsonValue;
  576. rvalue : TValue;
  577. i : Integer;
  578. n : Integer;
  579. rProp : TRttiProperty;
  580. {$IFNDEF DELPHIRX10_UP}
  581. rfield : TRttiField;
  582. {$ENDIF}
  583. genericType : TGenericListType;
  584. begin
  585. Result := aObject;
  586. rType := ctx.GetType(aObject.ClassInfo);
  587. rProp := rType.GetProperty('List');
  588. if (rProp = nil) or (aJson = nil) or (aJson.ClassType = TJSONNull) then Exit;
  589. member := nil;
  590. //check if exists List (denotes delphi json serialized) or not (normal json serialized)
  591. if aJson.ClassType = TJSONObject then member := GetJsonPairValueByName(aJson,aName);
  592. if member = nil then
  593. begin
  594. if aJson.ClassType <> TJSONArray then raise EJsonDeserializeError.CreateFmt('Not valid value for "%s" List',[aName]);
  595. jArray := TJSONObject.ParseJSONValue(aJson.ToJSON) as TJSONArray;
  596. end
  597. else
  598. begin
  599. if member.ClassType <> TJSONArray then raise EJsonDeserializeError.CreateFmt('Not valid value for "%s" List',[aName]);
  600. jArray := TJSONObject.ParseJSONValue(member.ToJSON) as TJSONArray;
  601. end;
  602. try
  603. rvalue := DeserializeDynArray(rProp.PropertyType.Handle,Result,jArray);
  604. //i := jarray.Count;
  605. finally
  606. jArray.Free;
  607. end;
  608. if not rValue.IsEmpty then
  609. begin
  610. {$IFDEF DELPHIRX10_UP}
  611. if (TObjectList<TObject>(aObject) <> nil) and (rvalue.IsArray) then
  612. begin
  613. genericType := GetGenericListType(aObject);
  614. if genericType = TGenericListType.gtObjectList then TObjectList<TObject>(aObject).Clear
  615. else TList<TObject>(aObject).Clear;
  616. n := rvalue.GetArrayLength - 1;
  617. for i := 0 to n do
  618. begin
  619. if genericType = TGenericListType.gtObjectList then TObjectList<TObject>(aObject).Add(rvalue.GetArrayElement(i).AsObject)
  620. else TList<TObject>(aObject).Add(rvalue.GetArrayElement(i).AsObject);
  621. end;
  622. end;
  623. {$ELSE}
  624. n := 0;
  625. for rfield in rType.GetFields do
  626. begin
  627. if rfield.Name = 'FOwnsObjects' then rfield.SetValue(aObject,True);
  628. //if rfield.Name = 'FCount' then rfield.SetValue(aObject,i);
  629. if rfield.Name = 'FItems' then
  630. begin
  631. //if TList(aObject) <> nil then TList(aObject).Clear;
  632. //rfield.GetValue(aObject).AsObject.Free;// aValue.GetReferenceToRawData)
  633. rfield.SetValue(aObject,rValue);// .SetDynArrayProp(aObject,'fItems',Result);
  634. Break;
  635. end;
  636. end;
  637. rProp := rType.GetProperty('Count');
  638. rProp.SetValue(aObject,n);
  639. {$ENDIF}
  640. end;
  641. end;
  642. {$ENDIF}
  643. {$IFNDEF FPC}
  644. procedure TRTTIJson.DeserializeXArray(Instance : TObject; aRecord : TValue; aProperty : TRttiProperty; const aPropertyName : string; aJson : TJsonObject);
  645. var
  646. ctx : TRttiContext;
  647. rRec : TRttiRecordType;
  648. rfield : TRttiField;
  649. rValue : TValue;
  650. member : TJsonValue;
  651. jArray : TJSONArray;
  652. begin
  653. rRec := ctx.GetType(aRecord.TypeInfo).AsRecord;
  654. rfield := rRec.GetField('fArray');
  655. if rfield <> nil then
  656. begin
  657. rValue := nil;
  658. //member := TJSONPair(aJson.GetValue(rField.Name));
  659. member := GetJsonPairValueByName(aJson,aPropertyName);
  660. if (member <> nil) and (rField.FieldType.TypeKind = tkDynArray) then
  661. begin
  662. jArray := TJSONObject.ParseJSONValue(member.ToJSON) as TJSONArray;
  663. try
  664. rValue := DeserializeDynArray(rField.FieldType.Handle,nil,jArray);
  665. finally
  666. jArray.Free;
  667. end;
  668. end;
  669. end;
  670. if not rValue.IsEmpty then rField.SetValue(aRecord.GetReferenceToRawData,rValue);
  671. aProperty.SetValue(Instance,aRecord);
  672. end;
  673. {$ENDIF}
  674. function StringToGUIDEx(const aGUID : string) : TGUID;
  675. begin
  676. if not aGUID.StartsWith('{') then Result := System.SysUtils.StringToGUID('{' + aGUID + '}')
  677. else Result := System.SysUtils.StringToGUID(aGUID);
  678. end;
  679. function TRTTIJson.DeserializeProperty(aObject : TObject; const aName : string; aProperty : TRttiProperty; const aJson : TJSONObject) : TObject;
  680. var
  681. rValue : TValue;
  682. {$IFNDEF FPC}
  683. member : TJsonValue;
  684. {$ELSE}
  685. member : TJsonObject;
  686. {$ENDIF}
  687. objClass: TClass;
  688. jArray : TJSONArray;
  689. json : TJSONObject;
  690. begin
  691. Result := aObject;
  692. rValue := nil;
  693. {$IFNDEF FPC}
  694. //member := TJSONPair(aJson.GetValue(aName));
  695. member := GetJsonPairValueByName(aJson,aName);
  696. {$ELSE}
  697. member := TJsonObject(aJson.Find(aName));
  698. {$ENDIF}
  699. if member <> nil then
  700. begin
  701. case aProperty.PropertyType.TypeKind of
  702. tkDynArray :
  703. begin
  704. {$IFNDEF FPC}
  705. if member is TJSONNull then Exit;
  706. jArray := TJSONObject.ParseJSONValue(member.ToJSON) as TJSONArray;
  707. {$ELSE}
  708. if member.ClassType = TJSONNull.ClassType then Exit;
  709. jArray := TJSONArray(TJSONObject.ParseJSONValue(member.ToJSON));
  710. {$ENDIF}
  711. try
  712. {$IFNDEF FPC}
  713. aProperty.SetValue(aObject,DeserializeDynArray(aProperty.PropertyType.Handle,Result,jArray));
  714. {$ELSE}
  715. DeserializeDynArray(aProperty.PropertyType.Handle,aName,Result,jArray);
  716. {$ENDIF}
  717. Exit;
  718. finally
  719. jArray.Free;
  720. end;
  721. end;
  722. tkClass :
  723. begin
  724. //if (member.JsonValue is TJSONObject) then
  725. begin
  726. json := TJsonObject(TJSONObject.ParseJSONValue(member.ToJson));
  727. try
  728. if aProperty.GetValue(aObject).AsObject = nil then
  729. begin
  730. {$IFNDEF FPC}
  731. objClass := aProperty.PropertyType.Handle^.TypeData.ClassType;
  732. rValue := DeserializeClass(objClass,json);
  733. {$ELSE}
  734. objClass := GetObjectPropClass(aObject,aName);
  735. //objClass := GetTypeData(aProperty.PropertyType.Handle)^.ClassType;
  736. rValue := DeserializeClass(objClass,json);
  737. SetObjectProp(aObject,aName,rValue.AsObject);
  738. Exit;
  739. {$ENDIF}
  740. end
  741. else
  742. begin
  743. rValue := DeserializeObject(aProperty.GetValue(aObject).AsObject,json);
  744. Exit;
  745. end;
  746. finally
  747. json.Free;
  748. end;
  749. end
  750. end;
  751. {$IFNDEF FPC}
  752. tkRecord :
  753. begin
  754. if aProperty.GetValue(aObject).TypeInfo = System.TypeInfo(TGUID) then
  755. begin
  756. rValue:=TValue.From<TGUID>(StringToGUID(UnQuotedStr(member.ToJSON,'"')));
  757. end
  758. else
  759. begin
  760. json := TJSONObject.ParseJSONValue(member.ToJson) as TJSONObject;
  761. try
  762. rValue := DeserializeRecord(aProperty.GetValue(aObject),aObject,json);
  763. finally
  764. json.Free;
  765. end;
  766. end;
  767. end;
  768. {$ENDIF}
  769. else
  770. begin
  771. {$IFNDEF FPC}
  772. //avoid return unicode escaped chars if string
  773. if aProperty.PropertyType.TypeKind in [tkString, tkLString, tkWString, tkUString] then
  774. {$IFDEF DELPHIRX10_UP}
  775. rValue := DeserializeType(aObject,aProperty.PropertyType.TypeKind,aProperty.GetValue(aObject).TypeInfo,TJsonValue(member).value)
  776. {$ELSE}
  777. rValue := DeserializeType(aObject,aProperty.PropertyType.TypeKind,aProperty.GetValue(aObject).TypeInfo,member.Value)
  778. {$ENDIF}
  779. else rValue := DeserializeType(aObject,aProperty.PropertyType.TypeKind,aProperty.GetValue(aObject).TypeInfo,member.ToJSON);
  780. {$ELSE}
  781. rValue := DeserializeType(aObject,aProperty.PropertyType.TypeKind,aName,member.ToJSON);
  782. if not rValue.IsEmpty then SetPropertyValue(aObject,aName,rValue);
  783. {$ENDIF}
  784. end;
  785. end;
  786. {$IFNDEF FPC}
  787. if not rValue.IsEmpty then aProperty.SetValue(Result,rValue);
  788. {$ENDIF}
  789. end;
  790. end;
  791. {$IFNDEF FPC}
  792. function TRTTIJson.DeserializeType(aObject : TObject; aType : TTypeKind; aTypeInfo : PTypeInfo; const aValue: string) : TValue;
  793. var
  794. i : Integer;
  795. value : string;
  796. fsettings : TFormatSettings;
  797. begin
  798. try
  799. value := UnQuotedStr(aValue,'"');
  800. case aType of
  801. tkString, tkLString, tkWString, tkUString :
  802. begin
  803. if fUseNullStringsAsEmpty and (CompareText(value, 'null') = 0) then
  804. Result := ''
  805. else
  806. Result := value;
  807. end;
  808. tkChar, tkWChar :
  809. begin
  810. Result := value;
  811. end;
  812. tkInteger :
  813. begin
  814. if CompareText(value,'null') <> 0 then Result := StrToIntDef(value,0)
  815. else Result := 0;
  816. end;
  817. tkInt64 :
  818. begin
  819. if CompareText(value,'null') <> 0 then Result := StrToInt64Def(value,0)
  820. else Result := 0;
  821. end;
  822. tkFloat :
  823. begin
  824. if aTypeInfo = TypeInfo(TDateTime) then
  825. begin
  826. if CompareText(value,'null') <> 0 then Result := JsonDateToDateTime(value);
  827. end
  828. else if aTypeInfo = TypeInfo(TDate) then
  829. begin
  830. if CompareText(value,'null') <> 0 then Result := StrToDate(value);
  831. end
  832. else if aTypeInfo = TypeInfo(TTime) then
  833. begin
  834. Result := StrToTime(value);
  835. end
  836. else
  837. begin
  838. fsettings := TFormatSettings.Create;
  839. Result := StrToFloat(StringReplace(value,'.',fsettings.DecimalSeparator,[]));
  840. end;
  841. end;
  842. tkEnumeration :
  843. begin
  844. if aTypeInfo = System.TypeInfo(Boolean) then
  845. begin
  846. Result := StrToBool(value);
  847. end
  848. else
  849. begin
  850. //if fUseEnumNames then TValue.Make(GetEnumValue(aTypeInfo,value),aTypeInfo, Result)
  851. // else TValue.Make(StrToInt(value),aTypeInfo, Result);
  852. if not TryStrToInt(value,i) then TValue.Make(GetEnumValue(aTypeInfo,value),aTypeInfo, Result)
  853. else TValue.Make(StrToInt(value),aTypeInfo, Result);
  854. end;
  855. end;
  856. tkSet :
  857. begin
  858. i := StringToSet(aTypeInfo,value);
  859. TValue.Make(@i,aTypeInfo,Result);
  860. end;
  861. else
  862. begin
  863. //raise EclJsonSerializerError.Create('Not supported data type!');
  864. end;
  865. end;
  866. except
  867. on E : Exception do
  868. begin
  869. raise EJsonDeserializeError.CreateFmt('Deserialize error type "%s.%s" : %s',[aObject.ClassName,GetTypeName(aTypeInfo),e.Message]);
  870. end;
  871. end;
  872. end;
  873. {$ELSE}
  874. function TRTTIJson.DeserializeType(aObject : TObject; aType : TTypeKind; const aPropertyName, aValue: string) : TValue;
  875. var
  876. value : string;
  877. propinfo : PPropInfo;
  878. fsettings : TFormatSettings;
  879. begin
  880. try
  881. value := UnQuotedStr(aValue,'"');
  882. if value = '' then
  883. begin
  884. Result := nil;
  885. Exit;
  886. end;
  887. propinfo := GetPropInfo(aObject,aPropertyName);
  888. //case propinfo.PropType.Kind of
  889. case aType of
  890. tkString, tkLString, tkWString, tkUString, tkAString :
  891. begin
  892. Result := value;
  893. //SetStrProp(aObject,propinfo,value);
  894. end;
  895. tkChar, tkWChar :
  896. begin
  897. Result := value;
  898. end;
  899. tkInteger :
  900. begin
  901. if CompareText(value,'null') <> 0 then Result := StrToInt(value)
  902. else Result := 0;
  903. end;
  904. tkInt64 :
  905. begin
  906. if CompareText(value,'null') <> 0 then Result := StrToInt64(value)
  907. else Result := 0;
  908. end;
  909. tkFloat :
  910. begin
  911. if propinfo.PropType = TypeInfo(TDateTime) then
  912. begin
  913. if CompareText(value,'null') <> 0 then Result := JsonDateToDateTime(value);
  914. end
  915. else if propinfo.PropType = TypeInfo(TDate) then
  916. begin
  917. if CompareText(value,'null') <> 0 then Result := StrToDate(value);
  918. end
  919. else if propinfo.PropType = TypeInfo(TTime) then
  920. begin
  921. Result := StrToTime(value);
  922. end
  923. else
  924. begin
  925. fsettings := DefaultFormatSettings;
  926. Result := StrToFloat(StringReplace(value,'.',fsettings.DecimalSeparator,[]));
  927. end;
  928. end;
  929. tkEnumeration:
  930. begin
  931. Result := value;
  932. end;
  933. tkBool :
  934. begin
  935. Result := StrToBool(value);
  936. end;
  937. tkSet :
  938. begin
  939. Result := value;
  940. end;
  941. else
  942. begin
  943. //raise EclJsonSerializerError.Create('Not supported data type!');
  944. end;
  945. end;
  946. //if not Result.IsEmpty then SetPropertyValue(aObject,propinfo,Result);
  947. except
  948. on E : Exception do
  949. begin
  950. raise EJsonDeserializeError.CreateFmt('Deserialize error type "%s" : %s',[aObject.ClassName,e.Message]);
  951. end;
  952. end;
  953. end;
  954. {$ENDIF}
  955. function TRTTIJson.IsAllowedProperty(aObject : TObject; const aPropertyName : string) : Boolean;
  956. var
  957. propname : string;
  958. begin
  959. Result := True;
  960. propname := aPropertyName.ToLower;
  961. if IsGenericList(aObject) then
  962. begin
  963. if (propname = 'capacity') or (propname = 'count') or (propname = 'ownsobjects') then Result := False;
  964. end
  965. else if (propname = 'refcount') then Result := False;
  966. end;
  967. function TRTTIJson.IsGenericList(aObject : TObject) : Boolean;
  968. var
  969. cname : string;
  970. begin
  971. if aObject = nil then Exit(False);
  972. cname := aObject.ClassName;
  973. Result := (cname.StartsWith('TObjectList')) or (cname.StartsWith('TList'));
  974. end;
  975. function TRTTIJson.IsStream(aObject : TObject) : Boolean;
  976. begin
  977. if aObject = nil then Exit(False);
  978. Result := aObject.InheritsFrom(TStream);
  979. end;
  980. function TRTTIJson.GetGenericListType(aObject : TObject) : TGenericListType;
  981. var
  982. cname : string;
  983. begin
  984. if aObject = nil then Exit(TGenericListType.gtNone);
  985. cname := aObject.ClassName;
  986. if cname.StartsWith('TObjectList') then Result := TGenericListType.gtObjectList
  987. else if cname.StartsWith('TList') then Result := TGenericListType.gtList
  988. else Result := TGenericListType.gtNone;
  989. end;
  990. function TRTTIJson.IsGenericXArray(const aClassName : string) : Boolean;
  991. begin
  992. Result := aClassName.StartsWith('TXArray');
  993. end;
  994. function TRTTIJson.GetJsonPairValueByName(aJson: TJSONObject; const aName: string): TJsonValue;
  995. var
  996. candidate : TJSONPair;
  997. i : Integer;
  998. begin
  999. if fUseJsonCaseSense then
  1000. begin
  1001. Result := aJson.GetValue(aName);
  1002. Exit;
  1003. end
  1004. else
  1005. begin
  1006. for i := 0 to aJson.Count - 1 do
  1007. begin
  1008. candidate := aJson.Pairs[I];
  1009. if candidate.JsonValue = nil then continue;
  1010. if CompareText(candidate.JsonString{$IFNDEF FPC}.Value{$ENDIF},aName) = 0 then Exit(candidate.JsonValue);
  1011. end;
  1012. end;
  1013. Result := nil;
  1014. end;
  1015. function TRTTIJson.GetJsonPairByName(aJson: TJSONObject; const aName: string): TJSONPair;
  1016. var
  1017. i : Integer;
  1018. begin
  1019. if fUseJsonCaseSense then
  1020. begin
  1021. Result := TJSONPair(aJson.GetValue(aName));
  1022. Exit;
  1023. end
  1024. else
  1025. begin
  1026. if aJson <> nil then
  1027. begin
  1028. for i := 0 to aJson.Count - 1 do
  1029. begin
  1030. Result := aJson.Pairs[I];
  1031. if Result.JsonValue = nil then continue;
  1032. if CompareText(Result.JsonString{$IFNDEF FPC}.Value{$ENDIF},aName) = 0 then Exit;
  1033. end;
  1034. end;
  1035. end;
  1036. Result := nil;
  1037. end;
  1038. //function TRTTIJson.GetPropertyValue(Instance : TObject; const PropertyName : string) : TValue;
  1039. //var
  1040. // pinfo : PPropInfo;
  1041. //begin
  1042. // Result := nil;
  1043. // pinfo := GetPropInfo(Instance,PropertyName);
  1044. // if pinfo = nil then raise EJsonSerializeError.CreateFmt('Property "%s" not found!',[PropertyName]);
  1045. // case pinfo.PropType^.Kind of
  1046. // tkInteger : Result := GetOrdProp(Instance,pinfo);
  1047. // tkInt64 : Result := GetInt64Prop(Instance,PropertyName);
  1048. // tkFloat : Result := GetFloatProp(Instance,PropertyName);
  1049. // tkChar : Result := Char(GetOrdProp(Instance,PropertyName));
  1050. // {$IFDEF FPC}
  1051. // tkWString : Result := GetWideStrProp(Instance,PropertyName);
  1052. // tkSString,
  1053. // tkAString,
  1054. // {$ELSE}
  1055. // tkWString,
  1056. // {$ENDIF}
  1057. // tkLString : Result := GetStrProp(Instance,pinfo);
  1058. // {$IFDEF FPC}
  1059. // tkEnumeration :
  1060. // begin
  1061. // if fUseEnumNames then Result := GetEnumName(pinfo.PropType,GetOrdProp(Instance,PropertyName))
  1062. // else Result := GetOrdProp(Instance,PropertyName);
  1063. // end;
  1064. // {$ELSE}
  1065. // tkEnumeration :
  1066. // begin
  1067. // if fUseEnumNames then Result := GetEnumName(@pinfo.PropType,GetOrdProp(Instance,PropertyName))
  1068. // else Result := GetOrdProp(Instance,PropertyName);
  1069. // end;
  1070. // {$ENDIF}
  1071. // tkSet : Result := GetSetProp(Instance,pinfo,True);
  1072. // {$IFNDEF FPC}
  1073. // tkClass :
  1074. // {$ELSE}
  1075. // tkBool : Result := Boolean(GetOrdProp(Instance,pinfo));
  1076. // tkObject :
  1077. // {$ENDIF} Result := GetObjectProp(Instance,pinfo);
  1078. // tkDynArray : Result := GetDynArrayProp(Instance,pinfo);
  1079. // end;
  1080. //end;
  1081. function TRTTIJson.GetPropertyValueFromObject(Instance : TObject; const PropertyName : string) : TValue;
  1082. var
  1083. ctx : TRttiContext;
  1084. rprop : TRttiProperty;
  1085. begin
  1086. rprop := ctx.GetType(Instance.ClassInfo).GetProperty(PropertyName);
  1087. Result := rprop.GetValue(Instance);
  1088. end;
  1089. {$IFNDEF FPC}
  1090. function TRTTIJson.GetFieldValueFromRecord(const aValue : TValue; const FieldName : string) : TValue;
  1091. var
  1092. ctx : TRttiContext;
  1093. rec : TRttiRecordType;
  1094. rfield : TRttiField;
  1095. begin
  1096. rec := ctx.GetType(aValue.TypeInfo).AsRecord;
  1097. rfield := rec.GetField(FieldName);
  1098. if rfield <> nil then Result := rField.GetValue(aValue.GetReferenceToRawData)
  1099. else Result := nil;
  1100. end;
  1101. {$ENDIF}
  1102. {$IFDEF FPC}
  1103. procedure TRTTIJson.SetPropertyValue(Instance : TObject; const PropertyName : string; aValue : TValue);
  1104. var
  1105. pinfo : PPropInfo;
  1106. begin
  1107. pinfo := GetPropInfo(Instance,PropertyName);
  1108. SetPropertyValue(Instance,pinfo,aValue);
  1109. end;
  1110. procedure TRTTIJson.SetPropertyValue(Instance : TObject; aPropInfo : PPropInfo; aValue : TValue);
  1111. begin
  1112. case aPropInfo.PropType^.Kind of
  1113. tkInteger : SetOrdProp(Instance,aPropInfo,aValue.AsInteger);
  1114. tkInt64 : SetInt64Prop(Instance,aPropInfo,aValue.AsInt64);
  1115. tkFloat : SetFloatProp(Instance,aPropInfo,aValue.AsExtended);
  1116. tkChar : SetOrdProp(Instance,aPropInfo,aValue.AsOrdinal);
  1117. {$IFDEF FPC}
  1118. tkWString : SetWideStrProp(Instance,aPropInfo,aValue.AsString);
  1119. tkSString,
  1120. tkAString,
  1121. {$ELSE}
  1122. tkWString,
  1123. {$ENDIF}
  1124. tkLString : SetStrProp(Instance,aPropInfo,aValue.AsString);
  1125. {$IFDEF FPC}
  1126. tkBool : SetOrdProp(Instance,aPropInfo,aValue.AsOrdinal);
  1127. tkSet : LoadSetProperty(Instance,aPropInfo,aValue.AsString);
  1128. {$ENDIF}
  1129. tkEnumeration : SetEnumProp(Instance,aPropInfo,aValue.AsString);
  1130. {$IFNDEF FPC}
  1131. tkClass :
  1132. {$ELSE}
  1133. tkObject :
  1134. {$ENDIF} SetObjectProp(Instance,aPropInfo,aValue.AsObject);
  1135. end;
  1136. end;
  1137. procedure TRTTIJson.LoadSetProperty(aInstance : TObject; aPropInfo: PPropInfo; const aValue: string);
  1138. type
  1139. TCardinalSet = set of 0..SizeOf(Cardinal) * 8 - 1;
  1140. const
  1141. Delims = [' ', ',', '[', ']'];
  1142. var
  1143. TypeInfo: PTypeInfo;
  1144. W: Cardinal;
  1145. I, N: Integer;
  1146. Count: Integer;
  1147. EnumName: string;
  1148. begin
  1149. W := 0;
  1150. TypeInfo := GetTypeData(GetPropType(aPropInfo))^.CompType;
  1151. Count := WordCount(aValue, Delims);
  1152. for N := 1 to Count do
  1153. begin
  1154. EnumName := ExtractWord(N, aValue, Delims);
  1155. try
  1156. I := GetEnumValue(TypeInfo, EnumName);
  1157. if I >= 0 then Include(TCardinalSet(W),I);
  1158. except
  1159. end;
  1160. end;
  1161. SetOrdProp(aInstance,aPropInfo,W);
  1162. end;
  1163. {$ENDIF}
  1164. function TRTTIJson.SerializeObject(aObject: TObject): TJSONObject;
  1165. var
  1166. ctx: TRttiContext;
  1167. {$IFNDEF FPC}
  1168. attr : TCustomAttribute;
  1169. comment : string;
  1170. {$ENDIF}
  1171. rType: TRttiType;
  1172. rProp: TRttiProperty;
  1173. jpair : TJSONPair;
  1174. ExcludeSerialize : Boolean;
  1175. propertyname : string;
  1176. propvalue : TValue;
  1177. begin
  1178. if (aObject = nil) then
  1179. begin
  1180. Result := nil;
  1181. Exit;
  1182. end;
  1183. Result := nil;
  1184. try
  1185. //if is GenericList
  1186. if IsGenericList(aObject) then
  1187. begin
  1188. //get list array
  1189. propvalue := GetPropertyValueFromObject(aObject,'List');
  1190. {$IFDEF DELPHIRX10_UP}
  1191. Result := TJSONObject(SerializeDynArray(propvalue,TList<TObject>(aObject).Count));
  1192. {$ELSE}
  1193. Result := TJSONObject(SerializeValue(propvalue));
  1194. {$ENDIF}
  1195. Exit;
  1196. end
  1197. {$IFNDEF FPC}
  1198. else if IsStream(aObject) then
  1199. begin
  1200. Result := TJSONObject(SerializeStream(aObject));
  1201. Exit;
  1202. end
  1203. {$ENDIF}
  1204. else Result := TJSONObject.Create;
  1205. //if is standard object
  1206. propertyname := '';
  1207. rType := ctx.GetType(aObject.ClassInfo);
  1208. for rProp in TRTTI.GetProperties(rType,roFirstBase) do
  1209. begin
  1210. ExcludeSerialize := False;
  1211. propertyname := rProp.Name;
  1212. {$IFNDEF FPC}
  1213. comment := '';
  1214. if not rProp.IsReadable then Continue;
  1215. for attr in rProp.GetAttributes do
  1216. begin
  1217. if attr is TNotSerializableProperty then ExcludeSerialize := True
  1218. else if attr is TCommentProperty then comment := TCommentProperty(attr).Comment
  1219. else if attr is TCustomNameProperty then propertyname := TCustomNameProperty(attr).Name;
  1220. end;
  1221. if ((fSerializeLevel = slPublicProperty) and (rProp.PropertyType.IsPublicType))
  1222. or ((fSerializeLevel = slPublishedProperty) and ((IsPublishedProp(aObject,rProp.Name)) or (rProp.Name = 'List'))) then
  1223. {$ENDIF}
  1224. begin
  1225. if (IsAllowedProperty(aObject,propertyname)) and (not ExcludeSerialize) then
  1226. begin
  1227. //add comment as pair
  1228. {$IFNDEF FPC}
  1229. if comment <> '' then Result.AddPair(TJSONPair.Create('#Comment#->'+propertyname,Comment));
  1230. {$ENDIF}
  1231. begin
  1232. propvalue := rProp.GetValue(aObject);
  1233. jpair := TJSONPair.Create(propertyName,nil);
  1234. // if (propvalue.IsObject) and (IsGenericList(propvalue.AsObject)) then
  1235. // begin
  1236. // jpair.JsonValue := SerializeValue(GetPropertyValueFromObject(propvalue.AsObject,'List'));
  1237. // end
  1238. if propvalue.IsObject then jpair.JsonValue := SerializeObject(propvalue.AsObject)
  1239. {$IFNDEF FPC}
  1240. else if (not propvalue.IsObject) and (IsGenericXArray(string(propvalue{$IFNDEF NEXTGEN}.TypeInfo.Name{$ELSE}.TypeInfo.NameFld.ToString{$ENDIF}))) then
  1241. begin
  1242. jpair.JsonValue := SerializeValue(GetFieldValueFromRecord(propvalue,'fArray'));
  1243. end
  1244. {$ENDIF}
  1245. else
  1246. begin
  1247. {$IFNDEF FPC}
  1248. jpair.JsonValue := SerializeValue(propvalue);
  1249. {$ELSE}
  1250. jpair.JsonValue := SerializeValue(propvalue);// SerializeObject(aObject,rProp.PropertyType.TypeKind,propertyname);
  1251. {$ENDIF}
  1252. end;
  1253. //s := jpair.JsonValue.ToString;
  1254. if jpair.JsonValue <> nil then
  1255. begin
  1256. Result.AddPair(jpair);
  1257. end
  1258. else jpair.Free;
  1259. end;
  1260. end;
  1261. end;
  1262. end;
  1263. except
  1264. on E : Exception do
  1265. begin
  1266. if Result <> nil then Result.Free;
  1267. if not propertyname.IsEmpty then raise EJsonSerializeError.CreateFmt('Serialize Error -> Object property: "%s" (%s)',[propertyname,e.Message])
  1268. else raise EJsonSerializeError.CreateFmt('Serialize Error -> Object (%s)',[e.Message]);
  1269. end;
  1270. end;
  1271. end;
  1272. function TRTTIJson.GetValue(aAddr: Pointer; aType: TRTTIType): TValue;
  1273. begin
  1274. TValue.Make(aAddr,aType.Handle,Result);
  1275. end;
  1276. {$IFDEF FPC}
  1277. function TRTTIJson.GetValue(aAddr: Pointer; aTypeInfo: PTypeInfo): TValue;
  1278. begin
  1279. TValue.Make(aAddr,aTypeInfo,Result);
  1280. end;
  1281. {$ENDIF}
  1282. function TRTTIJson.SerializeValue(const aValue : TValue) : TJSONValue;
  1283. begin
  1284. Result := nil;
  1285. case avalue.Kind of
  1286. tkDynArray :
  1287. begin
  1288. {$IFNDEF FPC}
  1289. Result := SerializeDynArray(aValue);
  1290. {$ENDIF}
  1291. end;
  1292. tkClass :
  1293. begin
  1294. Result := TJSONValue(SerializeObject(aValue.AsObject));
  1295. end;
  1296. tkString, tkLString, tkWString, tkUString :
  1297. begin
  1298. Result := TJSONString.Create(aValue.AsString);
  1299. end;
  1300. tkChar, tkWChar :
  1301. begin
  1302. Result := TJSONString.Create(aValue.AsString);
  1303. end;
  1304. tkInteger :
  1305. begin
  1306. Result := TJSONNumber.Create(aValue.AsInteger);
  1307. end;
  1308. tkInt64 :
  1309. begin
  1310. Result := TJSONNumber.Create(aValue.AsInt64);
  1311. end;
  1312. tkFloat :
  1313. begin
  1314. if aValue.TypeInfo = TypeInfo(TDateTime) then
  1315. begin
  1316. if aValue.AsExtended <> 0.0 then Result := TJSONString.Create(DateTimeToJsonDate(aValue.AsExtended));
  1317. end
  1318. else if aValue.TypeInfo = TypeInfo(TDate) then
  1319. begin
  1320. if aValue.AsExtended <> 0.0 then Result := TJSONString.Create(DateToStr(aValue.AsExtended));
  1321. end
  1322. else if aValue.TypeInfo = TypeInfo(TTime) then
  1323. begin
  1324. Result := TJSONString.Create(TimeToStr(aValue.AsExtended));
  1325. end
  1326. else
  1327. begin
  1328. Result := TJSONNumber.Create(aValue.AsExtended);
  1329. end;
  1330. end;
  1331. tkEnumeration :
  1332. begin
  1333. if (aValue.TypeInfo = System.TypeInfo(Boolean)) then
  1334. begin
  1335. {$IF Defined(DELPHIRX10_UP) OR Defined(FPC)}
  1336. Result := TJSONBool.Create(aValue.AsBoolean);
  1337. {$ELSE}
  1338. if aValue.AsBoolean then Result := TJsonTrue.Create
  1339. else Result := TJsonFalse.Create;
  1340. {$ENDIF}
  1341. end
  1342. else
  1343. begin
  1344. //Result.JsonValue := TJSONString.Create(GetEnumName(aValue.TypeInfo,aValue.AsOrdinal));
  1345. if fUseEnumNames then Result := TJSONString.Create(aValue.ToString)
  1346. else Result := TJSONNumber.Create(GetEnumValue(aValue.TypeInfo,aValue.ToString));
  1347. end;
  1348. end;
  1349. {$IFDEF FPC}
  1350. tkBool :
  1351. begin
  1352. Result := TJSONBool.Create(aValue.AsBoolean);
  1353. end;
  1354. {$ENDIF}
  1355. tkSet :
  1356. begin
  1357. Result := TJSONString.Create(aValue.ToString);
  1358. end;
  1359. tkRecord :
  1360. begin
  1361. {$IFNDEF FPC}
  1362. Result := SerializeRecord(aValue);
  1363. {$ENDIF}
  1364. end;
  1365. tkVariant :
  1366. begin
  1367. {$IFNDEF FPC}
  1368. case VarType(aValue.AsVariant) and VarTypeMask of
  1369. varInteger, varInt64 : Result := TJSONNumber.Create(aValue.AsInteger);
  1370. varString, varUString, varEmpty : Result := TJSONString.Create(aValue.AsString);
  1371. varDouble : Result := TJSONNumber.Create(aValue.AsExtended);
  1372. end;
  1373. {$ENDIF}
  1374. end;
  1375. tkMethod, tkPointer, tkClassRef ,tkInterface, tkProcedure, tkUnknown :
  1376. begin
  1377. //skip these properties
  1378. end
  1379. else
  1380. begin
  1381. {$IFNDEF FPC}
  1382. raise EJsonSerializeError.CreateFmt(cNotSupportedDataType,[GetTypeName(aValue.TypeInfo)]);
  1383. {$ELSE}
  1384. raise EJsonSerializeError.Create('Not supported Data Type');
  1385. {$ENDIF}
  1386. end;
  1387. end;
  1388. if Result = nil then Result := TJSONNull.Create;
  1389. end;
  1390. function TRTTIJson.SerializeStream(aObject: TObject): TJSONValue;
  1391. var
  1392. stream : TStream;
  1393. begin
  1394. Result := nil;
  1395. try
  1396. stream := TStream(aObject);
  1397. if fUseBase64Stream then Result := TJSONString.Create(Base64Encode(StreamToString(stream,TEncoding.Ansi)))
  1398. else Result := TJSONString.Create(StreamToString(stream,TEncoding.Ansi));
  1399. except
  1400. on E : Exception do
  1401. begin
  1402. EJsonSerializeError.CreateFmt('Serialize Error -> Stream (%s)',[e.Message]);
  1403. end;
  1404. end;
  1405. end;
  1406. {$IFNDEF FPC}
  1407. function TRTTIJson.SerializeDynArray(const aValue: TValue; aMaxElements : Integer = -1) : TJsonArray;
  1408. var
  1409. ctx : TRttiContext;
  1410. rDynArray : TRTTIDynamicArrayType;
  1411. i : Integer;
  1412. jValue : TJSONValue;
  1413. element : Integer;
  1414. list : TList<TJSONValue>;
  1415. len : Integer;
  1416. begin
  1417. element := -1;
  1418. Result := TJSONArray.Create;
  1419. try
  1420. rDynArray := ctx.GetType(aValue.TypeInfo) as TRTTIDynamicArrayType;
  1421. //if aValue.IsObjectInstance then TList<TObject>(aValue.AsObject).TrimExcess;
  1422. list := TList<TJSONValue>.Create;
  1423. if aMaxElements = -1 then len := aValue.GetArrayLength
  1424. else len := aMaxElements;
  1425. list.Capacity := len;
  1426. for i := 0 to len - 1 do
  1427. begin
  1428. if not GetValue(PPByte(aValue.GetReferenceToRawData)^ + rDynArray.ElementType.TypeSize * i, rDynArray.ElementType).IsEmpty then
  1429. begin
  1430. element := i;
  1431. jValue := SerializeValue(GetValue(PPByte(aValue.GetReferenceToRawData)^ + rDynArray.ElementType.TypeSize * i, rDynArray.ElementType));
  1432. if jValue = nil then jValue := TJSONNull.Create;
  1433. list.Add(jValue);
  1434. end;
  1435. end;
  1436. Result.SetElements(list);
  1437. except
  1438. on E : Exception do
  1439. begin
  1440. if element > -1 then raise EJsonSerializeError.CreateFmt('Serialize Error -> Array[%d] (%s)',[element,e.Message])
  1441. else raise EJsonSerializeError.CreateFmt('Serialize Error -> Array (%s)',[e.Message]);
  1442. end;
  1443. end;
  1444. end;
  1445. function TRTTIJson.SerializeRecord(const aValue : TValue) : TJSONValue;
  1446. var
  1447. ctx : TRttiContext;
  1448. json : TJSONObject;
  1449. rRec : TRttiRecordType;
  1450. rField : TRttiField;
  1451. begin
  1452. rField := nil;
  1453. try
  1454. rRec := ctx.GetType(aValue.TypeInfo).AsRecord;
  1455. if aValue.TypeInfo = System.TypeInfo(TGUID) then
  1456. begin
  1457. Result := TJSONString.Create(GUIDToString(aValue.AsType<TGUID>));
  1458. end
  1459. else
  1460. begin
  1461. json := TJSONObject.Create;
  1462. for rField in rRec.GetFields do
  1463. begin
  1464. json.AddPair(rField.Name,SerializeValue(rField.GetValue(aValue.GetReferenceToRawData)));
  1465. end;
  1466. Result := json;
  1467. end;
  1468. except
  1469. on E : Exception do
  1470. begin
  1471. if rField <> nil then raise EJsonSerializeError.CreateFmt('Serialize Error -> Record property "%s" (%s)',[rField.Name,e.Message])
  1472. else raise EJsonSerializeError.CreateFmt('Serialize Error -> Record (%s)',[e.Message]);
  1473. end;
  1474. end;
  1475. end;
  1476. {$ELSE}
  1477. function TRTTIJson.GetPropType(aPropInfo: PPropInfo): PTypeInfo;
  1478. begin
  1479. Result := aPropInfo^.PropType;
  1480. end;
  1481. function TRTTIJson.FloatProperty(aObject : TObject; aPropInfo: PPropInfo): string;
  1482. const
  1483. Precisions: array[TFloatType] of Integer = (7, 15, 18, 18, 19);
  1484. var
  1485. fsettings : TFormatSettings;
  1486. begin
  1487. fsettings := FormatSettings;
  1488. Result := StringReplace(FloatToStrF(GetFloatProp(aObject, aPropInfo), ffGeneral,
  1489. Precisions[GetTypeData(GetPropType(aPropInfo))^.FloatType],0),
  1490. '.',fsettings.DecimalSeparator,[rfReplaceAll]);
  1491. end;
  1492. function TRTTIJson.SerializeObject(aObject : TObject; aType : TTypeKind; const aPropertyName : string) : TJSONPair;
  1493. var
  1494. propinfo : PPropInfo;
  1495. jArray : TJsonArray;
  1496. jPair : TJsonPair;
  1497. jValue : TJsonValue;
  1498. i : Integer;
  1499. pArr : Pointer;
  1500. rValue : TValue;
  1501. rItemValue : TValue;
  1502. len : Integer;
  1503. begin
  1504. try
  1505. Result := TJSONPair.Create(aPropertyName,nil);
  1506. propinfo := GetPropInfo(aObject,aPropertyName);
  1507. //case propinfo.PropType.Kind of
  1508. case aType of
  1509. tkDynArray :
  1510. begin
  1511. len := 0;
  1512. jArray := TJSONArray.Create;
  1513. try
  1514. pArr := GetDynArrayProp(aObject,aPropertyName);
  1515. TValue.Make(@pArr,propinfo.PropType, rValue);
  1516. if rValue.IsArray then
  1517. begin
  1518. len := rValue.GetArrayLength;
  1519. for i := 0 to len - 1 do
  1520. begin
  1521. rItemValue := rValue.GetArrayElement(i);
  1522. jValue := SerializeValue(rItemValue);
  1523. jArray.Add(jValue);
  1524. end;
  1525. end;
  1526. Result.JsonValue := jArray;
  1527. finally
  1528. //DynArrayClear(pArr,propinfo.PropType);
  1529. pArr := nil;
  1530. end;
  1531. end;
  1532. tkClass :
  1533. begin
  1534. Result.JsonValue := TJSONValue(SerializeObject(GetObjectProp(aObject,aPropertyName)));
  1535. end;
  1536. tkString, tkLString, tkWString, tkUString, tkAString :
  1537. begin
  1538. Result.JsonValue := TJSONString.Create(GetStrProp(aObject,aPropertyName));
  1539. end;
  1540. tkChar, tkWChar :
  1541. begin
  1542. Result.JsonValue := TJSONString.Create(Char(GetOrdProp(aObject,aPropertyName)));
  1543. end;
  1544. tkInteger :
  1545. begin
  1546. Result.JsonValue := TJSONNumber.Create(GetOrdProp(aObject,aPropertyName));
  1547. end;
  1548. tkInt64 :
  1549. begin
  1550. Result.JsonValue := TJSONNumber.Create(GetOrdProp(aObject,aPropertyName));
  1551. end;
  1552. tkFloat :
  1553. begin
  1554. if propinfo.PropType = TypeInfo(TDateTime) then
  1555. begin
  1556. Result.JsonValue := TJSONString.Create(DateTimeToJsonDate(GetFloatProp(aObject,aPropertyName)));
  1557. end
  1558. else if propinfo.PropType = TypeInfo(TDate) then
  1559. begin
  1560. Result.JsonValue := TJSONString.Create(DateToStr(GetFloatProp(aObject,aPropertyName)));
  1561. end
  1562. else if propinfo.PropType = TypeInfo(TTime) then
  1563. begin
  1564. Result.JsonValue := TJSONString.Create(TimeToStr(GetFloatProp(aObject,aPropertyName)));
  1565. end
  1566. else
  1567. begin
  1568. //Result.JsonValue := TJsonFloatNumber.Create(GetFloatProp(aObject,aPropertyName));
  1569. Result.JsonValue := TJsonFloatNumber.Create(StrToFloat(FloatProperty(aObject,propinfo)));
  1570. end;
  1571. end;
  1572. tkEnumeration,tkBool :
  1573. begin
  1574. if (propinfo.PropType = System.TypeInfo(Boolean)) then
  1575. begin
  1576. Result.JsonValue := TJSONBool.Create(Boolean(GetOrdProp(aObject,aPropertyName)));
  1577. end
  1578. else
  1579. begin
  1580. if fUseEnumNames then Result.JsonValue := TJSONString.Create(GetEnumName(propinfo.PropType,GetOrdProp(aObject,aPropertyName)))
  1581. else Result.JsonValue := TJSONNumber.Create(GetOrdProp(aObject,aPropertyName));
  1582. //Result.JsonValue := TJSONString.Create(aValue.ToString);
  1583. end;
  1584. end;
  1585. tkSet :
  1586. begin
  1587. Result.JsonValue := TJSONString.Create(GetSetProp(aObject,aPropertyName));
  1588. end;
  1589. {$IFNDEF FPC}
  1590. tkRecord :
  1591. begin
  1592. Result.JsonValue := SerializeRecord(aValue);
  1593. end;
  1594. {$ENDIF}
  1595. tkMethod, tkPointer, tkClassRef ,tkInterface, tkProcedure :
  1596. begin
  1597. //skip these properties
  1598. //FreeAndNil(Result);
  1599. end
  1600. else
  1601. begin
  1602. //raise EJsonDeserializeError.CreateFmt('Not supported type "%s":%d',[aName,Integer(aValue.Kind)]);
  1603. end;
  1604. end;
  1605. if Result.JsonValue = nil then Result.JsonValue := TJSONNull.Create;
  1606. except
  1607. on E : Exception do
  1608. begin
  1609. Result.Free;
  1610. {$IFNDEF FPC}
  1611. raise EJsonSerializeError.CreateFmt('Serialize error class "%s.%s" : %s',[aName,aValue.ToString,e.Message]);
  1612. {$ENDIF}
  1613. end;
  1614. end;
  1615. end;
  1616. {$ENDIF}
  1617. { TJsonSerializer}
  1618. constructor TJsonSerializer.Create(aSerializeLevel: TSerializeLevel; aUseEnumNames : Boolean = True; aUseNullStringsAsEmpty : Boolean = False);
  1619. begin
  1620. {$IFDEF FPC}
  1621. if aSerializeLevel = TSerializeLevel.slPublicProperty then raise EJsonSerializeError.Create('FreePascal RTTI only supports published properties');
  1622. {$ENDIF}
  1623. fSerializeLevel := aSerializeLevel;
  1624. fUseEnumNames := aUseEnumNames;
  1625. fUseJsonCaseSense := False;
  1626. fUseBase64Stream := True;
  1627. fUseNullStringsAsEmpty := aUseNullStringsAsEmpty;
  1628. fRTTIJson := TRTTIJson.Create(aSerializeLevel,aUseEnumNames);
  1629. fRTTIJson.UseJsonCaseSense := fUseJsonCaseSense;
  1630. fRTTIJson.UseBase64Stream := fUseBase64Stream;
  1631. fRTTIJson.UseNullStringsAsEmpty := fUseNullStringsAsEmpty;
  1632. end;
  1633. destructor TJsonSerializer.Destroy;
  1634. begin
  1635. fRTTIJson.Free;
  1636. inherited;
  1637. end;
  1638. function TJsonSerializer.JsonToObject(aType: TClass; const aJson: string): TObject;
  1639. var
  1640. json: TJSONObject;
  1641. begin
  1642. {$IFDEF DEBUG_SERIALIZER}
  1643. TDebugger.TimeIt(Self,'JsonToObject',aType.ClassName);
  1644. {$ENDIF}
  1645. try
  1646. {$IFDEF DELPHIRX10_UP}
  1647. json := TJSONObject.ParseJSONValue(aJson,True) as TJSONObject;
  1648. {$ELSE}
  1649. {$IFDEF FPC}
  1650. json := TJSONObject(TJSONObject.ParseJSONValue(aJson,True));
  1651. {$ELSE}
  1652. json := TJsonObject.ParseJSONValue(TEncoding.UTF8.GetBytes(aJson),0,True) as TJSONObject;
  1653. {$ENDIF}
  1654. {$ENDIF}
  1655. except
  1656. raise EJsonDeserializeError.Create(cNotValidJson);
  1657. end;
  1658. try
  1659. Result := fRTTIJson.DeserializeClass(aType,json);
  1660. finally
  1661. json.Free;
  1662. end;
  1663. end;
  1664. function TJsonSerializer.JsonToObject(aObject: TObject; const aJson: string): TObject;
  1665. var
  1666. jvalue : TJSONValue;
  1667. json: TJSONObject;
  1668. begin;
  1669. if aObject = nil then raise EJsonDeserializeError.Create('Object param cannot be null!');
  1670. {$IFDEF DEBUG_SERIALIZER}
  1671. TDebugger.TimeIt(Self,'JsonToObject',aObject.ClassName);
  1672. {$ENDIF}
  1673. try
  1674. {$IFDEF DELPHIRX10_UP}
  1675. jvalue := TJSONObject.ParseJSONValue(aJson,True);
  1676. if jvalue.ClassType = TJSONArray then json := TJSONObject(jvalue)
  1677. else json := jvalue as TJSONObject;
  1678. //json := TJSONObject.ParseJSONValue(aJson,True) as TJSONObject;
  1679. {$ELSE}
  1680. {$IFDEF FPC}
  1681. json := TJSONObject(TJSONObject.ParseJSONValue(aJson,True));
  1682. {$ELSE}
  1683. json := TJsonObject.ParseJSONValue(TEncoding.UTF8.GetBytes(aJson),0,True) as TJSONObject;
  1684. {$ENDIF}
  1685. {$ENDIF}
  1686. except
  1687. raise EJsonDeserializeError.Create(cNotValidJson);
  1688. end;
  1689. try
  1690. Result := fRTTIJson.DeserializeObject(aObject,json);
  1691. finally
  1692. json.Free;
  1693. end;
  1694. end;
  1695. function TJsonSerializer.ObjectToJson(aObject : TObject; aIndent : Boolean = False): string;
  1696. var
  1697. json: TJSONObject;
  1698. begin
  1699. {$IFDEF DEBUG_SERIALIZER}
  1700. TDebugger.TimeIt(Self,'ObjectToJson',aObject.ClassName);
  1701. {$ENDIF}
  1702. json := fRTTIJson.SerializeObject(aObject);
  1703. try
  1704. if aIndent then Result := TJsonUtils.JsonFormat(json.ToJSON)
  1705. else Result := json.ToJSON;
  1706. finally
  1707. json.Free;
  1708. end;
  1709. end;
  1710. procedure TJsonSerializer.ObjectToJsonStream(aObject: TObject; aStream: TStream);
  1711. var
  1712. json : TJsonObject;
  1713. ss : TStringStream;
  1714. begin
  1715. {$IFDEF DEBUG_SERIALIZER}
  1716. TDebugger.TimeIt(Self,'ObjectToJsonStream',aObject.ClassName);
  1717. {$ENDIF}
  1718. if aStream = nil then raise EJsonSerializeError.Create('stream parameter cannot be nil!');
  1719. json := fRTTIJson.SerializeObject(aObject);
  1720. try
  1721. ss := TStringStream.Create(json.ToString,TEncoding.UTF8);
  1722. try
  1723. aStream.CopyFrom(ss,ss.Size);
  1724. finally
  1725. ss.Free;
  1726. end;
  1727. finally
  1728. json.Free;
  1729. end;
  1730. end;
  1731. function TJsonSerializer.ObjectToJsonString(aObject : TObject; aIndent : Boolean = False): string;
  1732. var
  1733. json: TJSONObject;
  1734. begin
  1735. {$IFDEF DEBUG_SERIALIZER}
  1736. TDebugger.TimeIt(Self,'ObjectToJsonString',aObject.ClassName);
  1737. {$ENDIF}
  1738. json := fRTTIJson.SerializeObject(aObject);
  1739. try
  1740. if aIndent then Result := TJsonUtils.JsonFormat(json.ToString)
  1741. else Result := json.ToString;
  1742. finally
  1743. json.Free;
  1744. end;
  1745. end;
  1746. function TJsonSerializer.ValueToJson(const aValue: TValue; aIndent: Boolean): string;
  1747. var
  1748. json: TJSONValue;
  1749. begin
  1750. {$IFDEF DEBUG_SERIALIZER}
  1751. TDebugger.TimeIt(Self,'ValueToJson',aValue.ToString);
  1752. {$ENDIF}
  1753. json:= fRTTIJson.SerializeValue(aValue);
  1754. if json = nil then raise EJsonSerializerError.Create('Error serializing TValue');
  1755. try
  1756. if aIndent then Result := TJsonUtils.JsonFormat(json{$IFNDEF FPC}.ToJSON{$ELSE}.AsJson{$ENDIF})
  1757. else Result := json{$IFNDEF FPC}.ToJSON{$ELSE}.AsJson{$ENDIF};
  1758. finally
  1759. json.Free;
  1760. end;
  1761. end;
  1762. function TJsonSerializer.ValueToJsonString(const aValue: TValue; aIndent: Boolean): string;
  1763. var
  1764. json: TJSONValue;
  1765. begin
  1766. {$IFDEF DEBUG_SERIALIZER}
  1767. TDebugger.TimeIt(Self,'ValueToJsonString',aValue.ToString);
  1768. {$ENDIF}
  1769. json:= fRTTIJson.SerializeValue(aValue);
  1770. if json = nil then raise EJsonSerializerError.Create('Error serializing TValue');
  1771. try
  1772. if aIndent then Result := TJsonUtils.JsonFormat(json.ToString)
  1773. else Result := json.ToString;
  1774. finally
  1775. json.Free;
  1776. end;
  1777. end;
  1778. function TJsonSerializer.ArrayToJson<T>(aArray: TArray<T>; aIndent: Boolean): string;
  1779. var
  1780. json: TJSONValue;
  1781. begin
  1782. {$IFDEF DEBUG_SERIALIZER}
  1783. TDebugger.TimeIt(Self,'ArrayToJson','');
  1784. {$ENDIF}
  1785. json:= fRTTIJson.SerializeValue(TValue.From<TArray<T>>(aArray));
  1786. if json = nil then raise EJsonSerializerError.Create('Error serializing Array');
  1787. try
  1788. if aIndent then Result := TJsonUtils.JsonFormat(json{$IFNDEF FPC}.ToJSON{$ELSE}.AsJson{$ENDIF})
  1789. else Result := json{$IFNDEF FPC}.ToJSON{$ELSE}.AsJson{$ENDIF};
  1790. finally
  1791. json.Free;
  1792. end;
  1793. end;
  1794. function TJsonSerializer.ArrayToJsonString<T>(aArray: TArray<T>; aIndent: Boolean): string;
  1795. var
  1796. json: TJSONValue;
  1797. begin
  1798. {$IFDEF DEBUG_SERIALIZER}
  1799. TDebugger.TimeIt(Self,'ArrayToJsonString','');
  1800. {$ENDIF}
  1801. json:= fRTTIJson.SerializeValue(TValue.From<TArray<T>>(aArray));
  1802. if json = nil then raise EJsonSerializerError.Create('Error serializing Array');
  1803. try
  1804. if aIndent then Result := TJsonUtils.JsonFormat(json.ToString)
  1805. else Result := json.ToString;
  1806. finally
  1807. json.Free;
  1808. end;
  1809. end;
  1810. function TJsonSerializer.JsonStreamToObject(aObject: TObject; aJsonStream: TStream): TObject;
  1811. var
  1812. json : string;
  1813. begin
  1814. {$IFDEF DEBUG_SERIALIZER}
  1815. TDebugger.TimeIt(Self,'JsonStreamToObject','');
  1816. {$ENDIF}
  1817. if aJsonStream = nil then raise EJsonDeserializeError.Create('JsonStream param cannot be nil!');
  1818. json := StreamToString(aJsonStream,TEncoding.UTF8);
  1819. Result := JsonToObject(aObject,json);
  1820. end;
  1821. {$IFNDEF FPC}
  1822. function TJsonSerializer.JsonToArray<T>(const aJson: string): TArray<T>;
  1823. var
  1824. jarray: TJSONArray;
  1825. value : TValue;
  1826. begin;
  1827. {$IFDEF DEBUG_SERIALIZER}
  1828. TDebugger.TimeIt(Self,'JsonToArray','');
  1829. {$ENDIF}
  1830. try
  1831. {$If Defined(FPC) OR Defined(DELPHIRX10_UP)}
  1832. jarray := TJSONObject.ParseJSONValue(aJson,True) as TJSONArray;
  1833. {$ELSE}
  1834. jarray := TJsonObject.ParseJSONValue(TEncoding.UTF8.GetBytes(aJson),0,True) as TJSONArray;
  1835. {$ENDIF}
  1836. except
  1837. raise EJsonDeserializeError.Create(cNotValidJson);
  1838. end;
  1839. try
  1840. value := fRTTIJson.DeserializeDynArray(PTypeInfo(TypeInfo(TArray<T>)),nil,jarray);
  1841. Result := value.AsType<TArray<T>>;
  1842. finally
  1843. jarray.Free;
  1844. end;
  1845. end;
  1846. function TJsonSerializer.JsonToValue(const aJson: string): TValue;
  1847. var
  1848. json: TJSONObject;
  1849. value : TValue;
  1850. begin;
  1851. {$IFDEF DEBUG_SERIALIZER}
  1852. TDebugger.TimeIt(Self,'JsonToValue','');
  1853. {$ENDIF}
  1854. try
  1855. {$If Defined(FPC) OR Defined(DELPHIRX10_UP)}
  1856. json := TJSONObject.ParseJSONValue(aJson,True) as TJSONObject;
  1857. {$ELSE}
  1858. json := TJsonObject.ParseJSONValue(TEncoding.UTF8.GetBytes(aJson),0,True) as TJSONObject;
  1859. {$ENDIF}
  1860. except
  1861. raise EJsonDeserializeError.Create(cNotValidJson);
  1862. end;
  1863. try
  1864. value := fRTTIJson.DeserializeRecord(value,nil,json);
  1865. Result := value; // value.AsType<TArray<T>>;
  1866. finally
  1867. json.Free;
  1868. end;
  1869. end;
  1870. {$ENDIF}
  1871. procedure TJsonSerializer.SetSerializeLevel(const Value: TSerializeLevel);
  1872. begin
  1873. fSerializeLevel := Value;
  1874. if Assigned(fRTTIJson) then fRTTIJson.fSerializeLevel := Value;
  1875. end;
  1876. procedure TJsonSerializer.SetUseBase64Stream(const Value: Boolean);
  1877. begin
  1878. fUseBase64Stream := Value;
  1879. if Assigned(fRTTIJson) then fRTTIJson.UseBase64Stream := Value;
  1880. end;
  1881. procedure TJsonSerializer.SetUseEnumNames(const Value: Boolean);
  1882. begin
  1883. fUseEnumNames := Value;
  1884. if Assigned(fRTTIJson) then fRTTIJson.UseEnumNames := Value;
  1885. end;
  1886. procedure TJsonSerializer.SetUseJsonCaseSense(const Value: Boolean);
  1887. begin
  1888. fUseJsonCaseSense := Value;
  1889. if Assigned(fRTTIJson) then fRTTIJson.UseJsonCaseSense := Value;
  1890. end;
  1891. procedure TJsonSerializer.SetUseNullStringsAsEmpty(const Value: Boolean);
  1892. begin
  1893. fUseNullStringsAsEmpty := Value;
  1894. if Assigned(fRTTIJson) then fRTTIJson.fUseNullStringsAsEmpty := Value;
  1895. end;
  1896. {$IFNDEF FPC}
  1897. { TCommentProperty }
  1898. constructor TCommentProperty.Create(const aComment: string);
  1899. begin
  1900. fComment := aComment;
  1901. end;
  1902. { TCustomNameProperty }
  1903. constructor TCustomNameProperty.Create(const aName: string);
  1904. begin
  1905. fName := aName;
  1906. end;
  1907. {$ENDIF}
  1908. {$IF NOT DEFINED(DELPHIXE7_UP) AND NOT DEFINED(FPC)}
  1909. { TJSONArrayHelper }
  1910. function TJSONArrayHelper.Count: Integer;
  1911. begin
  1912. Result := Self.Size;
  1913. end;
  1914. function TJSONArrayHelper.GetItem(aValue: Integer): TJSONValue;
  1915. begin
  1916. Result := Self.Get(aValue);
  1917. end;
  1918. procedure TJSONArrayHelper.SetElements(aElements: TList<TJSONValue>);
  1919. var
  1920. jvalue : TJSONValue;
  1921. begin
  1922. for jvalue in aElements do Self.AddElement(jvalue);
  1923. aElements.Free;
  1924. end;
  1925. { TJSONValueHelper }
  1926. function TJSONValueHelper.ToJson: string;
  1927. begin
  1928. Result := Self.ToString;
  1929. end;
  1930. { TJSONObjectHelper }
  1931. function TJSONObjectHelper.Count: Integer;
  1932. begin
  1933. Result := Self.Size;
  1934. end;
  1935. function TJSONObjectHelper.GetValue(const aName: string): TJSONValue;
  1936. var
  1937. jPair : TJSONPair;
  1938. begin
  1939. Result := nil;
  1940. for jPair in Self do
  1941. begin
  1942. if jPair.JsonString.ToString = aName then Exit(jPair.JsonValue);
  1943. end;
  1944. end;
  1945. function TJSONObjectHelper.GetPair(aValue: Integer) : TJSONPair;
  1946. begin
  1947. Result := Self.Get(aValue);
  1948. end;
  1949. {$ENDIF}
  1950. end.