Quick.YAML.Serializer.pas 50 KB

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