├── .gitattributes ├── .gitignore ├── LICENSE ├── README.md ├── d2010 ├── json │ ├── clJsonParser.pas │ ├── clJsonSerializer.pas │ └── clJsonSerializerBase.pas └── test │ ├── Test.dpr │ ├── Test.dproj │ ├── Test.res │ └── clJsonSerializerTests.pas ├── json ├── clJsonParser.pas ├── clJsonSerializer.pas └── clJsonSerializerBase.pas └── test ├── Test.dpr ├── Test.dproj ├── Test.res └── clJsonSerializerTests.pas /.gitattributes: -------------------------------------------------------------------------------- 1 | # Set the default behavior, in case people don't have core.autocrlf set. 2 | * text=auto 3 | 4 | # Denote all files that are truly binary and should not be modified. 5 | *.dat binary 6 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Uncomment these types if you want even more clean repository. But be careful. 2 | # It can make harm to an existing project source. Read explanations below. 3 | # 4 | # Resource files are binaries containing manifest, project icon and version info. 5 | # They can not be viewed as text or compared by diff-tools. Consider replacing them with .rc files. 6 | #*.res 7 | # 8 | # Type library file (binary). In old Delphi versions it should be stored. 9 | # Since Delphi 2009 it is produced from .ridl file and can safely be ignored. 10 | #*.tlb 11 | # 12 | # Diagram Portfolio file. Used by the diagram editor up to Delphi 7. 13 | # Uncomment this if you are not using diagrams or use newer Delphi version. 14 | #*.ddp 15 | # 16 | # Visual LiveBindings file. Added in Delphi XE2. 17 | # Uncomment this if you are not using LiveBindings Designer. 18 | #*.vlb 19 | # 20 | # Deployment Manager configuration file for your project. Added in Delphi XE2. 21 | # Uncomment this if it is not mobile development and you do not use remote debug feature. 22 | #*.deployproj 23 | # 24 | # C++ object files produced when C/C++ Output file generation is configured. 25 | # Uncomment this if you are not using external objects (zlib library for example). 26 | #*.obj 27 | # 28 | 29 | # Delphi compiler-generated binaries (safe to delete) 30 | *.exe 31 | *.dll 32 | *.bpl 33 | *.bpi 34 | *.dcp 35 | *.so 36 | *.apk 37 | *.drc 38 | *.map 39 | *.dres 40 | *.rsm 41 | *.tds 42 | *.dcu 43 | *.lib 44 | *.a 45 | *.o 46 | *.ocx 47 | 48 | # Delphi autogenerated files (duplicated info) 49 | *.cfg 50 | *.hpp 51 | *Resource.rc 52 | 53 | # Delphi local files (user-specific info) 54 | *.local 55 | *.identcache 56 | *.projdata 57 | *.tvsconfig 58 | *.dsk 59 | 60 | # Delphi history and backups 61 | __history/ 62 | __recovery/ 63 | *.~* 64 | 65 | # Castalia statistics file (since XE7 Castalia is distributed with Delphi) 66 | *.stat 67 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | 9 | This version of the GNU Lesser General Public License incorporates 10 | the terms and conditions of version 3 of the GNU General Public 11 | License, supplemented by the additional permissions listed below. 12 | 13 | 0. Additional Definitions. 14 | 15 | As used herein, "this License" refers to version 3 of the GNU Lesser 16 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 17 | General Public License. 18 | 19 | "The Library" refers to a covered work governed by this License, 20 | other than an Application or a Combined Work as defined below. 21 | 22 | An "Application" is any work that makes use of an interface provided 23 | by the Library, but which is not otherwise based on the Library. 24 | Defining a subclass of a class defined by the Library is deemed a mode 25 | of using an interface provided by the Library. 26 | 27 | A "Combined Work" is a work produced by combining or linking an 28 | Application with the Library. The particular version of the Library 29 | with which the Combined Work was made is also called the "Linked 30 | Version". 31 | 32 | The "Minimal Corresponding Source" for a Combined Work means the 33 | Corresponding Source for the Combined Work, excluding any source code 34 | for portions of the Combined Work that, considered in isolation, are 35 | based on the Application, and not on the Linked Version. 36 | 37 | The "Corresponding Application Code" for a Combined Work means the 38 | object code and/or source code for the Application, including any data 39 | and utility programs needed for reproducing the Combined Work from the 40 | Application, but excluding the System Libraries of the Combined Work. 41 | 42 | 1. Exception to Section 3 of the GNU GPL. 43 | 44 | You may convey a covered work under sections 3 and 4 of this License 45 | without being bound by section 3 of the GNU GPL. 46 | 47 | 2. Conveying Modified Versions. 48 | 49 | If you modify a copy of the Library, and, in your modifications, a 50 | facility refers to a function or data to be supplied by an Application 51 | that uses the facility (other than as an argument passed when the 52 | facility is invoked), then you may convey a copy of the modified 53 | version: 54 | 55 | a) under this License, provided that you make a good faith effort to 56 | ensure that, in the event an Application does not supply the 57 | function or data, the facility still operates, and performs 58 | whatever part of its purpose remains meaningful, or 59 | 60 | b) under the GNU GPL, with none of the additional permissions of 61 | this License applicable to that copy. 62 | 63 | 3. Object Code Incorporating Material from Library Header Files. 64 | 65 | The object code form of an Application may incorporate material from 66 | a header file that is part of the Library. You may convey such object 67 | code under terms of your choice, provided that, if the incorporated 68 | material is not limited to numerical parameters, data structure 69 | layouts and accessors, or small macros, inline functions and templates 70 | (ten or fewer lines in length), you do both of the following: 71 | 72 | a) Give prominent notice with each copy of the object code that the 73 | Library is used in it and that the Library and its use are 74 | covered by this License. 75 | 76 | b) Accompany the object code with a copy of the GNU GPL and this license 77 | document. 78 | 79 | 4. Combined Works. 80 | 81 | You may convey a Combined Work under terms of your choice that, 82 | taken together, effectively do not restrict modification of the 83 | portions of the Library contained in the Combined Work and reverse 84 | engineering for debugging such modifications, if you also do each of 85 | the following: 86 | 87 | a) Give prominent notice with each copy of the Combined Work that 88 | the Library is used in it and that the Library and its use are 89 | covered by this License. 90 | 91 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 92 | document. 93 | 94 | c) For a Combined Work that displays copyright notices during 95 | execution, include the copyright notice for the Library among 96 | these notices, as well as a reference directing the user to the 97 | copies of the GNU GPL and this license document. 98 | 99 | d) Do one of the following: 100 | 101 | 0) Convey the Minimal Corresponding Source under the terms of this 102 | License, and the Corresponding Application Code in a form 103 | suitable for, and under terms that permit, the user to 104 | recombine or relink the Application with a modified version of 105 | the Linked Version to produce a modified Combined Work, in the 106 | manner specified by section 6 of the GNU GPL for conveying 107 | Corresponding Source. 108 | 109 | 1) Use a suitable shared library mechanism for linking with the 110 | Library. A suitable mechanism is one that (a) uses at run time 111 | a copy of the Library already present on the user's computer 112 | system, and (b) will operate properly with a modified version 113 | of the Library that is interface-compatible with the Linked 114 | Version. 115 | 116 | e) Provide Installation Information, but only if you would otherwise 117 | be required to provide such information under section 6 of the 118 | GNU GPL, and only to the extent that such information is 119 | necessary to install and execute a modified version of the 120 | Combined Work produced by recombining or relinking the 121 | Application with a modified version of the Linked Version. (If 122 | you use option 4d0, the Installation Information must accompany 123 | the Minimal Corresponding Source and Corresponding Application 124 | Code. If you use option 4d1, you must provide the Installation 125 | Information in the manner specified by section 6 of the GNU GPL 126 | for conveying Corresponding Source.) 127 | 128 | 5. Combined Libraries. 129 | 130 | You may place library facilities that are a work based on the 131 | Library side by side in a single library together with other library 132 | facilities that are not Applications and are not covered by this 133 | License, and convey such a combined library under terms of your 134 | choice, if you do both of the following: 135 | 136 | a) Accompany the combined library with a copy of the same work based 137 | on the Library, uncombined with any other library facilities, 138 | conveyed under the terms of this License. 139 | 140 | b) Give prominent notice with the combined library that part of it 141 | is a work based on the Library, and explaining where to find the 142 | accompanying uncombined form of the same work. 143 | 144 | 6. Revised Versions of the GNU Lesser General Public License. 145 | 146 | The Free Software Foundation may publish revised and/or new versions 147 | of the GNU Lesser General Public License from time to time. Such new 148 | versions will be similar in spirit to the present version, but may 149 | differ in detail to address new problems or concerns. 150 | 151 | Each version is given a distinguishing version number. If the 152 | Library as you received it specifies that a certain numbered version 153 | of the GNU Lesser General Public License "or any later version" 154 | applies to it, you have the option of following the terms and 155 | conditions either of that published version or of any later version 156 | published by the Free Software Foundation. If the Library as you 157 | received it does not specify a version number of the GNU Lesser 158 | General Public License, you may choose any version of the GNU Lesser 159 | General Public License ever published by the Free Software Foundation. 160 | 161 | If the Library as you received it specifies that a proxy can decide 162 | whether future versions of the GNU Lesser General Public License shall 163 | apply, that proxy's public statement of acceptance of any version is 164 | permanent authorization for you to choose that version for the 165 | Library. 166 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # JSON object serializer for Delphi 2 | 3 | 4 | 5 | TclJsonSerializer utilizes the RTTI library and custom Delphi attributes for linking user-defined Delphi objects and properties with the corresponding JSON data parts. The updated JSON serializer correctly invokes constructors of serialized objects by requesting RTTI information for object constructors and calling it with the Invoke method. 6 | 7 | You can serialize and deserialize arrays and unions of objects of different types, deserialize inherited objects, serialize empty strings and many more. The article includes both the source code of the Json Serializer classes (TclJsonSerializer) and unit-test code that demonstrates how to serialize and deserizlise differrent data types, inlcuding Delphi strings, integers, objects and arrays. 8 | 9 | [Read the article](https://www.clevercomponents.com/articles/article040/) -------------------------------------------------------------------------------- /d2010/json/clJsonParser.pas: -------------------------------------------------------------------------------- 1 | { 2 | Copyright (C) 2016 by Clever Components 3 | 4 | Author: Sergey Shirokov 5 | 6 | Website: www.CleverComponents.com 7 | 8 | This file is part of Json Serializer. 9 | 10 | Json Serializer is free software: you can redistribute it and/or modify 11 | it under the terms of the GNU Lesser General Public License version 3 12 | as published by the Free Software Foundation and appearing in the 13 | included file COPYING.LESSER. 14 | 15 | Json Serializer is distributed in the hope that it will be useful, 16 | but WITHOUT ANY WARRANTY; without even the implied warranty of 17 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18 | GNU Lesser General Public License for more details. 19 | 20 | You should have received a copy of the GNU Lesser General Public License 21 | along with Json Serializer. If not, see . 22 | } 23 | 24 | unit clJsonParser; 25 | 26 | interface 27 | 28 | uses 29 | Classes, SysUtils, Contnrs; 30 | 31 | type 32 | EclJSONError = class(Exception) 33 | private 34 | FErrorCode: Integer; 35 | public 36 | constructor Create(const AErrorMsg: string; AErrorCode: Integer; ADummy: Boolean = False); 37 | property ErrorCode: Integer read FErrorCode; 38 | end; 39 | 40 | TclJSONString = class; 41 | TclJSONPair = class; 42 | TclJSONObject = class; 43 | TclJSONArray = class; 44 | 45 | TclJSONBase = class 46 | private 47 | class function DecodeString(const ASource: string): WideString; 48 | class function EncodeString(const ASource: WideString): string; 49 | 50 | class procedure SkipWhiteSpace(var Next: PChar); 51 | class function ParseValue(var Next: PChar): TclJSONBase; 52 | class function ParseName(var Next: PChar): string; 53 | class function ParsePair(var Next: PChar): TclJSONPair; 54 | class function ParseObj(var Next: PChar): TclJSONObject; 55 | class function ParseArray(var Next: PChar): TclJSONArray; 56 | class function ParseRoot(var Next: PChar): TclJSONBase; 57 | 58 | function GetValueString: string; 59 | procedure SetValueString(const AValue: string); 60 | protected 61 | function GetValueWideString: WideString; virtual; abstract; 62 | procedure SetValueWideString(const Value: WideString); virtual; abstract; 63 | procedure BuildJSONString(ABuffer: TStringBuilder); virtual; abstract; 64 | public 65 | class function Parse(const AJSONString: string): TclJSONBase; 66 | class function ParseObject(const AJSONString: string): TclJSONObject; 67 | 68 | function GetJSONString: string; 69 | 70 | property ValueString: string read GetValueString write SetValueString; 71 | property ValueWideString: WideString read GetValueWideString write SetValueWideString; 72 | end; 73 | 74 | TclJSONPair = class(TclJSONBase) 75 | private 76 | FName: WideString; 77 | FValue: TclJSONBase; 78 | 79 | procedure SetValue(const AValue: TclJSONBase); 80 | function GetName: string; 81 | procedure SetName(const AValue: string); 82 | protected 83 | function GetValueWideString: WideString; override; 84 | procedure SetValueWideString(const AValue: WideString); override; 85 | procedure BuildJSONString(ABuffer: TStringBuilder); override; 86 | public 87 | constructor Create; 88 | destructor Destroy; override; 89 | 90 | property Name: string read GetName write SetName; 91 | property NameWideString: WideString read FName write FName; 92 | property Value: TclJSONBase read FValue write SetValue; 93 | end; 94 | 95 | TclJSONValue = class(TclJSONBase) 96 | private 97 | FValue: WideString; 98 | protected 99 | function GetValueWideString: WideString; override; 100 | procedure SetValueWideString(const AValue: WideString); override; 101 | procedure BuildJSONString(ABuffer: TStringBuilder); override; 102 | public 103 | constructor Create; overload; 104 | constructor Create(const AValue: string); overload; 105 | constructor Create(const AValue: WideString); overload; 106 | end; 107 | 108 | TclJSONString = class(TclJSONValue) 109 | protected 110 | procedure BuildJSONString(ABuffer: TStringBuilder); override; 111 | end; 112 | 113 | TclJSONBoolean = class(TclJSONValue) 114 | private 115 | function GetValue: Boolean; 116 | procedure SetValue(const Value: Boolean); 117 | protected 118 | procedure SetValueWideString(const AValue: WideString); override; 119 | public 120 | constructor Create; overload; 121 | constructor Create(AValue: Boolean); overload; 122 | 123 | property Value: Boolean read GetValue write SetValue; 124 | end; 125 | 126 | TclJSONArray = class(TclJSONBase) 127 | private 128 | FItems: TObjectList; 129 | 130 | function GetCount: Integer; 131 | function GetItem(Index: Integer): TclJSONBase; 132 | function GetObject(Index: Integer): TclJSONObject; 133 | protected 134 | function GetValueWideString: WideString; override; 135 | procedure SetValueWideString(const AValue: WideString); override; 136 | procedure BuildJSONString(ABuffer: TStringBuilder); override; 137 | public 138 | constructor Create; 139 | destructor Destroy; override; 140 | 141 | function Add(AItem: TclJSONBase): TclJSONBase; 142 | 143 | property Count: Integer read GetCount; 144 | property Items[Index: Integer]: TclJSONBase read GetItem; 145 | property Objects[Index: Integer]: TclJSONObject read GetObject; 146 | end; 147 | 148 | TclJSONObject = class(TclJSONBase) 149 | private 150 | FMembers: TObjectList; 151 | 152 | function GetCount: Integer; 153 | function GetMember(Index: Integer): TclJSONPair; 154 | protected 155 | function GetValueWideString: WideString; override; 156 | procedure SetValueWideString(const AValue: WideString); override; 157 | procedure BuildJSONString(ABuffer: TStringBuilder); override; 158 | public 159 | constructor Create; 160 | destructor Destroy; override; 161 | 162 | function MemberByName(const AName: string): TclJSONPair; overload; 163 | function MemberByName(const AName: WideString): TclJSONPair; overload; 164 | 165 | function ValueByName(const AName: string): string; overload; 166 | function ValueByName(const AName: WideString): WideString; overload; 167 | 168 | function ObjectByName(const AName: string): TclJSONObject; overload; 169 | function ObjectByName(const AName: WideString): TclJSONObject; overload; 170 | 171 | function ArrayByName(const AName: string): TclJSONArray; overload; 172 | function ArrayByName(const AName: WideString): TclJSONArray; overload; 173 | 174 | function BooleanByName(const AName: string): Boolean; overload; 175 | function BooleanByName(const AName: WideString): Boolean; overload; 176 | 177 | function AddMember(APair: TclJSONPair): TclJSONPair; overload; 178 | function AddMember(const AName: WideString; AValue: TclJSONBase): TclJSONPair; overload; 179 | function AddMember(const AName: string; AValue: TclJSONBase): TclJSONPair; overload; 180 | 181 | function AddString(const AName, AValue: string): TclJSONString; overload; 182 | function AddString(const AName, AValue: WideString): TclJSONString; overload; 183 | 184 | function AddRequiredString(const AName, AValue: string): TclJSONString; overload; 185 | function AddRequiredString(const AName, AValue: WideString): TclJSONString; overload; 186 | 187 | function AddValue(const AName, AValue: string): TclJSONValue; overload; 188 | function AddValue(const AName, AValue: WideString): TclJSONValue; overload; 189 | 190 | function AddBoolean(const AName: string; AValue: Boolean): TclJSONBoolean; overload; 191 | function AddBoolean(const AName: WideString; AValue: Boolean): TclJSONBoolean; overload; 192 | 193 | property Count: Integer read GetCount; 194 | property Members[Index: Integer]: TclJSONPair read GetMember; 195 | end; 196 | 197 | resourcestring 198 | cUnexpectedDataEnd = 'Unexpected end of JSON data'; 199 | cUnexpectedDataSymbol = 'Unexpected symbol in JSON data'; 200 | cInvalidControlSymbol = 'Invalid control symbol in JSON data'; 201 | cInvalidUnicodeEscSequence = 'Invalid unicode escape sequence in JSON data'; 202 | cUnrecognizedEscSequence = 'Unrecognized escape sequence in JSON data'; 203 | cUnexpectedDataType = 'Unexpected data type'; 204 | 205 | const 206 | cUnexpectedDataEndCode = -100; 207 | cUnexpectedDataSymbolCode = -101; 208 | cInvalidControlSymbolCode = -102; 209 | cInvalidUnicodeEscSequenceCode = -103; 210 | cUnrecognizedEscSequenceCode = -104; 211 | cUnexpectedDataTypeCode = -106; 212 | 213 | var 214 | EscapeJsonStrings: Boolean = False; 215 | 216 | implementation 217 | 218 | const 219 | JsonBoolean: array[Boolean] of string = ('false', 'true'); 220 | 221 | { TclJSONBase } 222 | 223 | procedure TclJSONBase.SetValueString(const AValue: string); 224 | begin 225 | ValueWideString := WideString(AValue); 226 | end; 227 | 228 | class procedure TclJSONBase.SkipWhiteSpace(var Next: PChar); 229 | begin 230 | while (Next^ <> #0) do 231 | begin 232 | case (Next^) of 233 | #32, #9, #13, #10: 234 | else 235 | Break; 236 | end; 237 | Inc(Next); 238 | end; 239 | end; 240 | 241 | class function TclJSONBase.ParseArray(var Next: PChar): TclJSONArray; 242 | begin 243 | Result := TclJSONArray.Create(); 244 | try 245 | while (Next^ <> #0) do 246 | begin 247 | SkipWhiteSpace(Next); 248 | if (Next^ = #0) then 249 | begin 250 | raise EclJSONError.Create(cUnexpectedDataEnd, cUnexpectedDataEndCode); 251 | end; 252 | 253 | case (Next^) of 254 | ']': 255 | begin 256 | Inc(Next); 257 | Break; 258 | end; 259 | ',': 260 | begin 261 | Inc(Next); 262 | Result.Add(ParseRoot(Next)); 263 | Continue; 264 | end 265 | else 266 | begin 267 | Result.Add(ParseRoot(Next)); 268 | Continue; 269 | end; 270 | end; 271 | 272 | Inc(Next); 273 | end; 274 | except 275 | Result.Free(); 276 | raise; 277 | end; 278 | end; 279 | 280 | class function TclJSONBase.ParseName(var Next: PChar): string; 281 | var 282 | inQuote: Boolean; 283 | lastTwo: array[0..1] of Char; 284 | begin 285 | Result := ''; 286 | inQuote := False; 287 | lastTwo[0] := #0; 288 | lastTwo[1] := #0; 289 | while (Next^ <> #0) do 290 | begin 291 | SkipWhiteSpace(Next); 292 | 293 | case (Next^) of 294 | #0: Break; 295 | '"': 296 | begin 297 | if (lastTwo[0] <> '\') and (lastTwo[1] = '\') then 298 | begin 299 | Result := Result + Next^; 300 | end else 301 | begin 302 | if inQuote then 303 | begin 304 | Inc(Next); 305 | Break; 306 | end; 307 | inQuote := not inQuote; 308 | end; 309 | end 310 | else 311 | Result := Result + Next^; 312 | end; 313 | 314 | lastTwo[0] := lastTwo[1]; 315 | lastTwo[1] := Next^; 316 | Inc(Next); 317 | end; 318 | end; 319 | 320 | class function TclJSONBase.ParseObject(const AJSONString: string): TclJSONObject; 321 | var 322 | root: TclJSONBase; 323 | begin 324 | root := TclJSONBase.Parse(AJSONString); 325 | try 326 | if (root is TclJSONObject) then 327 | begin 328 | Result := TclJSONObject(root); 329 | end else 330 | begin 331 | raise EclJSONError.Create(cUnexpectedDataType, cUnexpectedDataTypeCode); 332 | end; 333 | except 334 | root.Free(); 335 | raise; 336 | end; 337 | end; 338 | 339 | class function TclJSONBase.ParsePair(var Next: PChar): TclJSONPair; 340 | begin 341 | Result := TclJSONPair.Create(); 342 | try 343 | while (Next^ <> #0) do 344 | begin 345 | SkipWhiteSpace(Next); 346 | if (Next^ = #0) then 347 | begin 348 | raise EclJSONError.Create(cUnexpectedDataEnd, cUnexpectedDataEndCode); 349 | end; 350 | 351 | if (Next^ = ':') and (Result.NameWideString = '') then 352 | begin 353 | raise EclJSONError.Create(cUnexpectedDataSymbol, cUnexpectedDataSymbolCode); 354 | end; 355 | 356 | if (Result.NameWideString = '') then 357 | begin 358 | Result.NameWideString := DecodeString(ParseName(Next)); 359 | Continue; 360 | end else 361 | if (Next^ = ':') then 362 | begin 363 | Inc(Next); 364 | Result.Value := ParseRoot(Next); 365 | Break; 366 | end else 367 | begin 368 | raise EclJSONError.Create(cUnexpectedDataSymbol, cUnexpectedDataSymbolCode); 369 | end; 370 | 371 | Inc(Next); 372 | end; 373 | except 374 | Result.Free(); 375 | raise; 376 | end; 377 | end; 378 | 379 | class function TclJSONBase.ParseObj(var Next: PChar): TclJSONObject; 380 | begin 381 | Result := TclJSONObject.Create(); 382 | try 383 | while (Next^ <> #0) do 384 | begin 385 | SkipWhiteSpace(Next); 386 | if (Next^ = #0) then 387 | begin 388 | raise EclJSONError.Create(cUnexpectedDataEnd, cUnexpectedDataEndCode); 389 | end; 390 | 391 | case (Next^) of 392 | '}': 393 | begin 394 | Inc(Next); 395 | Break; 396 | end; 397 | ',': 398 | begin 399 | Inc(Next); 400 | Result.AddMember(ParsePair(Next)); 401 | Continue; 402 | end 403 | else 404 | begin 405 | Result.AddMember(ParsePair(Next)); 406 | Continue; 407 | end; 408 | end; 409 | 410 | Inc(Next); 411 | end; 412 | except 413 | Result.Free(); 414 | raise; 415 | end; 416 | end; 417 | 418 | class function TclJSONBase.ParseValue(var Next: PChar): TclJSONBase; 419 | var 420 | inQuote, isString: Boolean; 421 | value: string; 422 | lastTwo: array[0..1] of Char; 423 | begin 424 | value := ''; 425 | inQuote := False; 426 | isString := False; 427 | lastTwo[0] := #0; 428 | lastTwo[1] := #0; 429 | while (Next^ <> #0) do 430 | begin 431 | if (not inQuote) then 432 | begin 433 | SkipWhiteSpace(Next); 434 | end; 435 | 436 | case (Next^) of 437 | #0: Break; 438 | '}', ']', ',': 439 | begin 440 | if inQuote then 441 | begin 442 | value := value + Next^; 443 | end else 444 | begin 445 | Break; 446 | end; 447 | end; 448 | '"': 449 | begin 450 | if inQuote and (lastTwo[0] <> '\') and (lastTwo[1] = '\') then 451 | begin 452 | value := value + Next^; 453 | end else 454 | begin 455 | if inQuote then 456 | begin 457 | Inc(Next); 458 | Break; 459 | end; 460 | inQuote := not inQuote; 461 | isString := True; 462 | end; 463 | end 464 | else 465 | value := value + Next^; 466 | end; 467 | 468 | lastTwo[0] := lastTwo[1]; 469 | lastTwo[1] := Next^; 470 | Inc(Next); 471 | end; 472 | 473 | Result := nil; 474 | try 475 | if isString then 476 | begin 477 | Result := TclJSONString.Create(); 478 | Result.ValueWideString := DecodeString(value); 479 | end else 480 | begin 481 | if (JsonBoolean[True] = value) then 482 | begin 483 | Result := TclJSONBoolean.Create(True); 484 | end else 485 | if (JsonBoolean[False] = value) then 486 | begin 487 | Result := TclJSONBoolean.Create(False); 488 | end else 489 | begin 490 | Result := TclJSONValue.Create(); 491 | Result.ValueWideString := value; 492 | end; 493 | end; 494 | except 495 | Result.Free(); 496 | raise; 497 | end; 498 | end; 499 | 500 | class function TclJSONBase.ParseRoot(var Next: PChar): TclJSONBase; 501 | begin 502 | Result := nil; 503 | 504 | while (Next^ <> #0) do 505 | begin 506 | SkipWhiteSpace(Next); 507 | if (Next^ = #0) then Break; 508 | 509 | case (Next^) of 510 | '{': 511 | begin 512 | Inc(Next); 513 | Result := ParseObj(Next); 514 | Break; 515 | end; 516 | '[': 517 | begin 518 | Inc(Next); 519 | Result := ParseArray(Next); 520 | Break; 521 | end 522 | else 523 | begin 524 | Result := ParseValue(Next); 525 | Break; 526 | end; 527 | end; 528 | 529 | Inc(Next); 530 | end; 531 | end; 532 | 533 | class function TclJSONBase.EncodeString(const ASource: WideString): string; 534 | var 535 | i: Integer; 536 | begin 537 | Result := '"'; 538 | 539 | for i := 1 to Length(ASource) do 540 | begin 541 | case ASource[i] of 542 | '/', '\', '"': 543 | begin 544 | Result := Result + '\' + Char(ASource[i]); 545 | end; 546 | #8: 547 | begin 548 | Result := Result + '\b'; 549 | end; 550 | #9: 551 | begin 552 | Result := Result + '\t'; 553 | end; 554 | #10: 555 | begin 556 | Result := Result + '\n'; 557 | end; 558 | #12: 559 | begin 560 | Result := Result + '\f'; 561 | end; 562 | #13: 563 | begin 564 | Result := Result + '\r'; 565 | end 566 | else 567 | begin 568 | if (not EscapeJsonStrings) or (ASource[i] >= WideChar(' ')) and (ASource[i] <= WideChar('~')) then 569 | begin 570 | Result := Result + Char(ASource[i]); 571 | end else 572 | begin 573 | Result := Result + '\u' + IntToHex(Ord(ASource[i]), 4); 574 | end; 575 | end; 576 | end; 577 | end; 578 | 579 | Result := Result + '"'; 580 | end; 581 | 582 | class function TclJSONBase.DecodeString(const ASource: string): WideString; 583 | var 584 | i, j, k, len: Integer; 585 | code: string; 586 | begin 587 | code := '$ '; 588 | len := Length(ASource); 589 | SetLength(Result, len); 590 | i := 1; 591 | j := 0; 592 | while (i <= len) do 593 | begin 594 | if (ASource[i] < ' ') then 595 | begin 596 | raise EclJSONError.Create(cInvalidControlSymbol, cInvalidControlSymbolCode); 597 | end; 598 | 599 | if (ASource[i] = '\') then 600 | Begin 601 | Inc(i); 602 | case ASource[i] of 603 | '"', '\', '/': 604 | begin 605 | Inc(j); 606 | Result[j] := WideChar(ASource[i]); 607 | Inc(i); 608 | end; 609 | 'b': 610 | begin 611 | Inc(j); 612 | Result[j] := #8; 613 | Inc(i); 614 | end; 615 | 't': 616 | begin 617 | Inc(j); 618 | Result[j] := #9; 619 | Inc(i); 620 | end; 621 | 'n': 622 | begin 623 | Inc(j); 624 | Result[j] := #10; 625 | Inc(i); 626 | end; 627 | 'f': 628 | begin 629 | Inc(j); 630 | Result[j] := #12; 631 | Inc(i); 632 | end; 633 | 'r': 634 | begin 635 | Inc(j); 636 | Result[j] := #13; 637 | Inc(i); 638 | end; 639 | 'u': 640 | begin 641 | if (i + 4 > len) then 642 | begin 643 | raise EclJSONError.Create(cInvalidUnicodeEscSequence, cInvalidUnicodeEscSequenceCode); 644 | end; 645 | 646 | for k := 1 to 4 do 647 | begin 648 | if not CharInSet(ASource[i + k], ['0'..'9', 'a'..'f', 'A'..'F']) then 649 | begin 650 | raise EclJSONError.Create(cInvalidUnicodeEscSequence, cInvalidUnicodeEscSequenceCode); 651 | end else 652 | begin 653 | code[k + 1] := ASource[i + k]; 654 | end; 655 | end; 656 | 657 | Inc(j); 658 | Inc(i, 5); 659 | Result[j] := WideChar(StrToInt(code)); 660 | end 661 | else 662 | raise EclJSONError.Create(cUnrecognizedEscSequence, cUnrecognizedEscSequenceCode); 663 | end; 664 | end else 665 | begin 666 | Inc(j); 667 | Result[j] := WideChar(ASource[i]); 668 | Inc(i); 669 | end; 670 | end; 671 | SetLength(Result, j); 672 | end; 673 | 674 | function TclJSONBase.GetJSONString: string; 675 | var 676 | buffer: TStringBuilder; 677 | begin 678 | buffer := TStringBuilder.Create(); 679 | try 680 | BuildJSONString(buffer); 681 | Result := buffer.ToString(); 682 | finally 683 | buffer.Free(); 684 | end; 685 | end; 686 | 687 | function TclJSONBase.GetValueString: string; 688 | begin 689 | Result := string(ValueWideString); 690 | end; 691 | 692 | class function TclJSONBase.Parse(const AJSONString: string): TclJSONBase; 693 | var 694 | Next: PChar; 695 | begin 696 | Result := nil; 697 | Next := @AJSONString[1]; 698 | if (Next^ = #0) then Exit; 699 | 700 | Result := ParseRoot(Next); 701 | try 702 | SkipWhiteSpace(Next); 703 | 704 | if (Next^ <> #0) then 705 | begin 706 | raise EclJSONError.Create(cUnexpectedDataSymbol, cUnexpectedDataSymbolCode); 707 | end; 708 | except 709 | Result.Free(); 710 | raise; 711 | end; 712 | end; 713 | 714 | { TclJSONObject } 715 | 716 | function TclJSONObject.AddMember(APair: TclJSONPair): TclJSONPair; 717 | begin 718 | FMembers.Add(APair); 719 | Result := APair; 720 | end; 721 | 722 | function TclJSONObject.AddMember(const AName: WideString; AValue: TclJSONBase): TclJSONPair; 723 | begin 724 | if (AValue <> nil) then 725 | begin 726 | Result := AddMember(TclJSONPair.Create()); 727 | 728 | Result.NameWideString := AName; 729 | Result.Value := AValue; 730 | end else 731 | begin 732 | Result := nil; 733 | end; 734 | end; 735 | 736 | function TclJSONObject.AddBoolean(const AName: string; AValue: Boolean): TclJSONBoolean; 737 | begin 738 | if (AValue) then 739 | begin 740 | Result := TclJSONBoolean(AddMember(AName, TclJSONBoolean.Create(AValue))); 741 | end else 742 | begin 743 | Result := nil; 744 | end; 745 | end; 746 | 747 | function TclJSONObject.AddBoolean(const AName: WideString; AValue: Boolean): TclJSONBoolean; 748 | begin 749 | if (AValue) then 750 | begin 751 | Result := TclJSONBoolean(AddMember(AName, TclJSONBoolean.Create(AValue))); 752 | end else 753 | begin 754 | Result := nil; 755 | end; 756 | end; 757 | 758 | function TclJSONObject.AddMember(const AName: string; AValue: TclJSONBase): TclJSONPair; 759 | begin 760 | if (AValue <> nil) then 761 | begin 762 | Result := AddMember(TclJSONPair.Create()); 763 | 764 | Result.Name := AName; 765 | Result.Value := AValue; 766 | end else 767 | begin 768 | Result := nil; 769 | end; 770 | end; 771 | 772 | function TclJSONObject.AddRequiredString(const AName, AValue: string): TclJSONString; 773 | begin 774 | Result := TclJSONString(AddMember(AName, TclJSONString.Create(AValue)).Value); 775 | end; 776 | 777 | function TclJSONObject.AddRequiredString(const AName, AValue: WideString): TclJSONString; 778 | begin 779 | Result := TclJSONString(AddMember(AName, TclJSONString.Create(AValue)).Value); 780 | end; 781 | 782 | function TclJSONObject.AddString(const AName, AValue: WideString): TclJSONString; 783 | begin 784 | if (AValue <> '') then 785 | begin 786 | Result := TclJSONString(AddMember(AName, TclJSONString.Create(AValue)).Value); 787 | end else 788 | begin 789 | Result := nil; 790 | end; 791 | end; 792 | 793 | function TclJSONObject.AddValue(const AName, AValue: WideString): TclJSONValue; 794 | begin 795 | if (AValue <> '') then 796 | begin 797 | Result := TclJSONValue(AddMember(AName, TclJSONValue.Create(AValue)).Value); 798 | end else 799 | begin 800 | Result := nil; 801 | end; 802 | end; 803 | 804 | function TclJSONObject.AddString(const AName, AValue: string): TclJSONString; 805 | begin 806 | if (AValue <> '') then 807 | begin 808 | Result := TclJSONString(AddMember(AName, TclJSONString.Create(AValue)).Value); 809 | end else 810 | begin 811 | Result := nil; 812 | end; 813 | end; 814 | 815 | function TclJSONObject.AddValue(const AName, AValue: string): TclJSONValue; 816 | begin 817 | if (AValue <> '') then 818 | begin 819 | Result := TclJSONValue(AddMember(AName, TclJSONValue.Create(AValue)).Value); 820 | end else 821 | begin 822 | Result := nil; 823 | end; 824 | end; 825 | 826 | function TclJSONObject.ArrayByName(const AName: WideString): TclJSONArray; 827 | var 828 | pair: TclJSONPair; 829 | begin 830 | pair := MemberByName(AName); 831 | if (pair <> nil) then 832 | begin 833 | if not (pair.Value is TclJSONArray) then 834 | begin 835 | raise EclJSONError.Create(cUnexpectedDataType, cUnexpectedDataTypeCode); 836 | end; 837 | 838 | Result := TclJSONArray(pair.Value); 839 | end else 840 | begin 841 | Result := nil; 842 | end; 843 | end; 844 | 845 | function TclJSONObject.ArrayByName(const AName: string): TclJSONArray; 846 | begin 847 | Result := ArrayByName(WideString(AName)); 848 | end; 849 | 850 | constructor TclJSONObject.Create; 851 | begin 852 | inherited Create(); 853 | FMembers := TObjectList.Create(True); 854 | end; 855 | 856 | destructor TclJSONObject.Destroy; 857 | begin 858 | FMembers.Free(); 859 | inherited Destroy(); 860 | end; 861 | 862 | function TclJSONObject.GetCount: Integer; 863 | begin 864 | Result := FMembers.Count; 865 | end; 866 | 867 | function TclJSONObject.BooleanByName(const AName: string): Boolean; 868 | begin 869 | Result := BooleanByName(WideString(AName)); 870 | end; 871 | 872 | function TclJSONObject.BooleanByName(const AName: WideString): Boolean; 873 | var 874 | pair: TclJSONPair; 875 | begin 876 | pair := MemberByName(AName); 877 | if (pair <> nil) then 878 | begin 879 | if not (pair.Value is TclJSONValue) then 880 | begin 881 | raise EclJSONError.Create(cUnexpectedDataType, cUnexpectedDataTypeCode); 882 | end; 883 | 884 | Result := (pair.ValueString = 'true'); 885 | end else 886 | begin 887 | Result := False; 888 | end; 889 | end; 890 | 891 | procedure TclJSONObject.BuildJSONString(ABuffer: TStringBuilder); 892 | const 893 | delimiter: array[Boolean] of string = ('', ', '); 894 | var 895 | i: Integer; 896 | begin 897 | ABuffer.Append('{'); 898 | 899 | for i := 0 to Count - 1 do 900 | begin 901 | ABuffer.Append(delimiter[i > 0]); 902 | ABuffer.Append(Members[i].GetJSONString()); 903 | end; 904 | 905 | ABuffer.Append('}'); 906 | end; 907 | 908 | function TclJSONObject.GetMember(Index: Integer): TclJSONPair; 909 | begin 910 | Result := TclJSONPair(FMembers[Index]); 911 | end; 912 | 913 | function TclJSONObject.GetValueWideString: WideString; 914 | begin 915 | Result := ''; 916 | end; 917 | 918 | function TclJSONObject.MemberByName(const AName: WideString): TclJSONPair; 919 | var 920 | i: Integer; 921 | begin 922 | for i := 0 to Count - 1 do 923 | begin 924 | Result := Members[i]; 925 | if (Result.NameWideString = AName) then Exit; 926 | end; 927 | Result := nil; 928 | end; 929 | 930 | function TclJSONObject.ObjectByName(const AName: WideString): TclJSONObject; 931 | var 932 | pair: TclJSONPair; 933 | begin 934 | pair := MemberByName(AName); 935 | if (pair <> nil) then 936 | begin 937 | if not (pair.Value is TclJSONObject) then 938 | begin 939 | raise EclJSONError.Create(cUnexpectedDataType, cUnexpectedDataTypeCode); 940 | end; 941 | 942 | Result := TclJSONObject(pair.Value); 943 | end else 944 | begin 945 | Result := nil; 946 | end; 947 | end; 948 | 949 | function TclJSONObject.ObjectByName(const AName: string): TclJSONObject; 950 | begin 951 | Result := ObjectByName(WideString(AName)); 952 | end; 953 | 954 | function TclJSONObject.MemberByName(const AName: string): TclJSONPair; 955 | begin 956 | Result := MemberByName(WideString(AName)); 957 | end; 958 | 959 | procedure TclJSONObject.SetValueWideString(const AValue: WideString); 960 | begin 961 | end; 962 | 963 | function TclJSONObject.ValueByName(const AName: string): string; 964 | begin 965 | Result := string(ValueByName(WideString(AName))); 966 | end; 967 | 968 | function TclJSONObject.ValueByName(const AName: WideString): WideString; 969 | var 970 | pair: TclJSONPair; 971 | begin 972 | pair := MemberByName(AName); 973 | if (pair <> nil) then 974 | begin 975 | Result := pair.ValueWideString; 976 | end else 977 | begin 978 | Result := ''; 979 | end; 980 | end; 981 | 982 | { TclJSONPair } 983 | 984 | constructor TclJSONPair.Create; 985 | begin 986 | inherited Create(); 987 | FValue := nil; 988 | end; 989 | 990 | destructor TclJSONPair.Destroy; 991 | begin 992 | SetValue(nil); 993 | inherited Destroy(); 994 | end; 995 | 996 | procedure TclJSONPair.BuildJSONString(ABuffer: TStringBuilder); 997 | begin 998 | ABuffer.Append(EncodeString(NameWideString)); 999 | ABuffer.Append(': '); 1000 | ABuffer.Append(Value.GetJSONString()); 1001 | end; 1002 | 1003 | function TclJSONPair.GetName: string; 1004 | begin 1005 | Result := string(FName); 1006 | end; 1007 | 1008 | function TclJSONPair.GetValueWideString: WideString; 1009 | begin 1010 | if (Value <> nil) then 1011 | begin 1012 | Result := Value.ValueWideString; 1013 | end else 1014 | begin 1015 | Result := ''; 1016 | end; 1017 | end; 1018 | 1019 | procedure TclJSONPair.SetName(const AValue: string); 1020 | begin 1021 | FName := WideString(AValue); 1022 | end; 1023 | 1024 | procedure TclJSONPair.SetValue(const AValue: TclJSONBase); 1025 | begin 1026 | FValue.Free(); 1027 | FValue := AValue; 1028 | end; 1029 | 1030 | procedure TclJSONPair.SetValueWideString(const AValue: WideString); 1031 | begin 1032 | if (Value <> nil) then 1033 | begin 1034 | Value.ValueWideString := AValue; 1035 | end; 1036 | end; 1037 | 1038 | { TclJSONArray } 1039 | 1040 | function TclJSONArray.Add(AItem: TclJSONBase): TclJSONBase; 1041 | begin 1042 | if (AItem <> nil) then 1043 | begin 1044 | FItems.Add(AItem); 1045 | end; 1046 | Result := AItem; 1047 | end; 1048 | 1049 | constructor TclJSONArray.Create; 1050 | begin 1051 | inherited Create(); 1052 | FItems := TObjectList.Create(True); 1053 | end; 1054 | 1055 | destructor TclJSONArray.Destroy; 1056 | begin 1057 | FItems.Free(); 1058 | inherited Destroy(); 1059 | end; 1060 | 1061 | function TclJSONArray.GetCount: Integer; 1062 | begin 1063 | Result := FItems.Count; 1064 | end; 1065 | 1066 | function TclJSONArray.GetItem(Index: Integer): TclJSONBase; 1067 | begin 1068 | Result := TclJSONBase(FItems[Index]); 1069 | end; 1070 | 1071 | function TclJSONArray.GetObject(Index: Integer): TclJSONObject; 1072 | var 1073 | item: TclJSONBase; 1074 | begin 1075 | item := Items[Index]; 1076 | if not (item is TclJSONObject) then 1077 | begin 1078 | raise EclJSONError.Create(cUnexpectedDataType, cUnexpectedDataTypeCode); 1079 | end; 1080 | Result := TclJSONObject(item); 1081 | end; 1082 | 1083 | procedure TclJSONArray.BuildJSONString(ABuffer: TStringBuilder); 1084 | const 1085 | delimiter: array[Boolean] of string = ('', ', '); 1086 | var 1087 | i: Integer; 1088 | begin 1089 | ABuffer.Append('['); 1090 | 1091 | for i := 0 to Count - 1 do 1092 | begin 1093 | ABuffer.Append(delimiter[i > 0]); 1094 | ABuffer.Append(Items[i].GetJSONString()); 1095 | end; 1096 | 1097 | ABuffer.Append(']'); 1098 | end; 1099 | 1100 | function TclJSONArray.GetValueWideString: WideString; 1101 | begin 1102 | Result := ''; 1103 | end; 1104 | 1105 | procedure TclJSONArray.SetValueWideString(const AValue: WideString); 1106 | begin 1107 | end; 1108 | 1109 | { TclJSONValue } 1110 | 1111 | constructor TclJSONValue.Create(const AValue: string); 1112 | begin 1113 | inherited Create(); 1114 | ValueString := AValue; 1115 | end; 1116 | 1117 | constructor TclJSONValue.Create(const AValue: WideString); 1118 | begin 1119 | inherited Create(); 1120 | ValueWideString := AValue; 1121 | end; 1122 | 1123 | constructor TclJSONValue.Create; 1124 | begin 1125 | inherited Create(); 1126 | FValue := ''; 1127 | end; 1128 | 1129 | procedure TclJSONValue.BuildJSONString(ABuffer: TStringBuilder); 1130 | begin 1131 | ABuffer.Append(ValueString); 1132 | end; 1133 | 1134 | function TclJSONValue.GetValueWideString: WideString; 1135 | begin 1136 | Result := FValue; 1137 | end; 1138 | 1139 | procedure TclJSONValue.SetValueWideString(const AValue: WideString); 1140 | begin 1141 | FValue := AValue; 1142 | end; 1143 | 1144 | { TclJSONString } 1145 | procedure TclJSONString.BuildJSONString(ABuffer: TStringBuilder); 1146 | begin 1147 | ABuffer.Append(EncodeString(ValueWideString)); 1148 | end; 1149 | 1150 | { EclJSONError } 1151 | 1152 | constructor EclJSONError.Create(const AErrorMsg: string; AErrorCode: Integer; ADummy: Boolean); 1153 | begin 1154 | inherited Create(AErrorMsg); 1155 | FErrorCode := AErrorCode; 1156 | end; 1157 | 1158 | { TclJSONBoolean } 1159 | 1160 | constructor TclJSONBoolean.Create; 1161 | begin 1162 | inherited Create(); 1163 | Value := False; 1164 | end; 1165 | 1166 | constructor TclJSONBoolean.Create(AValue: Boolean); 1167 | begin 1168 | inherited Create(); 1169 | Value := AValue; 1170 | end; 1171 | 1172 | function TclJSONBoolean.GetValue: Boolean; 1173 | begin 1174 | Result := (JsonBoolean[True] = ValueWideString); 1175 | end; 1176 | 1177 | procedure TclJSONBoolean.SetValue(const Value: Boolean); 1178 | begin 1179 | ValueWideString := JsonBoolean[Value]; 1180 | end; 1181 | 1182 | procedure TclJSONBoolean.SetValueWideString(const AValue: WideString); 1183 | begin 1184 | if (JsonBoolean[True] = AValue) then 1185 | begin 1186 | inherited SetValueWideString(JsonBoolean[True]); 1187 | end else 1188 | begin 1189 | inherited SetValueWideString(JsonBoolean[False]); 1190 | end; 1191 | end; 1192 | 1193 | end. 1194 | -------------------------------------------------------------------------------- /d2010/json/clJsonSerializer.pas: -------------------------------------------------------------------------------- 1 | { 2 | Copyright (C) 2016 by Clever Components 3 | 4 | Author: Sergey Shirokov 5 | 6 | Website: www.CleverComponents.com 7 | 8 | This file is part of Json Serializer. 9 | 10 | Json Serializer is free software: you can redistribute it and/or modify 11 | it under the terms of the GNU Lesser General Public License version 3 12 | as published by the Free Software Foundation and appearing in the 13 | included file COPYING.LESSER. 14 | 15 | Json Serializer is distributed in the hope that it will be useful, 16 | but WITHOUT ANY WARRANTY; without even the implied warranty of 17 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18 | GNU Lesser General Public License for more details. 19 | 20 | You should have received a copy of the GNU Lesser General Public License 21 | along with Json Serializer. If not, see . 22 | } 23 | 24 | unit clJsonSerializer; 25 | 26 | interface 27 | 28 | uses 29 | Classes, Generics.Collections, SysUtils, Rtti, TypInfo, clJsonSerializerBase, clJsonParser; 30 | 31 | type 32 | TclJsonTypeNameMapAttributeList = TArray; 33 | 34 | TclJsonSerializer = class(TclJsonSerializerBase) 35 | strict private 36 | class function GetArrayElementType(ATypeInfo: PTypeInfo): PPTypeInfo; static; 37 | class function GetDataClass(ATypeInfo: PTypeInfo): TClass; static; 38 | 39 | procedure GetTypeAttributes(AType: TRttiType; var ATypeNameAttrs: TclJsonTypeNameMapAttributeList); 40 | procedure GetPropertyAttributes(AProp: TRttiProperty; var APropAttr: TclJsonPropertyAttribute; 41 | var ARequiredAttr: TclJsonRequiredAttribute); 42 | function GetObjectClass(ATypeNameAttrs: TclJsonTypeNameMapAttributeList; AJsonObject: TclJSONObject): TRttiType; 43 | function EnumNameToTValue(Name: string; EnumType: PTypeInfo): TValue; 44 | 45 | procedure SerializeArray(AProperty: TRttiProperty; AObject: TObject; 46 | Attribute: TclJsonPropertyAttribute; AJson: TclJsonObject); 47 | procedure DeserializeArray(AProperty: TRttiProperty; AObject: TObject; AJsonArray: TclJSONArray); 48 | 49 | function Deserialize(AType: TClass; const AJson: TclJSONObject): TObject; overload; 50 | function Deserialize(AObject: TObject; const AJson: TclJSONObject): TObject; overload; 51 | function Serialize(AObject: TObject): TclJSONObject; 52 | public 53 | function JsonToObject(AType: TClass; const AJson: string): TObject; overload; override; 54 | function JsonToObject(AObject: TObject; const AJson: string): TObject; overload; override; 55 | function ObjectToJson(AObject: TObject): string; override; 56 | end; 57 | 58 | resourcestring 59 | cUnsupportedDataType = 'Unsupported data type'; 60 | cNonSerializable = 'The object is not serializable'; 61 | 62 | implementation 63 | 64 | { TclJsonSerializer } 65 | 66 | function TclJsonSerializer.GetObjectClass(ATypeNameAttrs: TclJsonTypeNameMapAttributeList; AJsonObject: TclJSONObject): TRttiType; 67 | var 68 | ctx: TRttiContext; 69 | typeName: string; 70 | attr: TclJsonTypeNameMapAttribute; 71 | begin 72 | Result := nil; 73 | if (ATypeNameAttrs = nil) or (Length(ATypeNameAttrs) = 0) then Exit; 74 | 75 | typeName := AJsonObject.ValueByName(ATypeNameAttrs[0].PropertyName); 76 | if (typeName = '') then Exit; 77 | 78 | ctx := TRttiContext.Create(); 79 | try 80 | for attr in ATypeNameAttrs do 81 | begin 82 | if (attr.TypeName = typeName) then 83 | begin 84 | Result := ctx.FindType(attr.TypeClassName); 85 | Exit; 86 | end; 87 | end; 88 | finally 89 | ctx.Free() 90 | end; 91 | end; 92 | 93 | procedure TclJsonSerializer.DeserializeArray(AProperty: TRttiProperty; 94 | AObject: TObject; AJsonArray: TclJSONArray); 95 | var 96 | pElType: PPTypeInfo; 97 | elType: PTypeInfo; 98 | len: NativeInt; 99 | pArr: Pointer; 100 | rValue, rItemValue: TValue; 101 | i: Integer; 102 | objClass: TClass; 103 | begin 104 | len := AJsonArray.Count; 105 | if (len = 0) then Exit; 106 | 107 | pElType := GetArrayElementType(AProperty.PropertyType.Handle); 108 | if (pElType = nil) then Exit; 109 | 110 | elType := pElType^; 111 | 112 | pArr := nil; 113 | 114 | DynArraySetLength(pArr, AProperty.PropertyType.Handle, 1, @len); 115 | try 116 | TValue.Make(@pArr, AProperty.PropertyType.Handle, rValue); 117 | 118 | for i := 0 to AJsonArray.Count - 1 do 119 | begin 120 | if (elType.Kind = tkClass) 121 | and (AJsonArray.Items[i] is TclJSONObject) then 122 | begin 123 | objClass := GetDataClass(elType); 124 | rItemValue := Deserialize(objClass, TclJSONObject(AJsonArray.Items[i])); 125 | end else 126 | if (elType.Kind in [tkString, tkLString, tkWString, tkUString]) then 127 | begin 128 | rItemValue := AJsonArray.Items[i].ValueString; 129 | end else 130 | if (elType.Kind = tkInteger) then 131 | begin 132 | rItemValue := StrToInt(AJsonArray.Items[i].ValueString); 133 | end else 134 | if (elType.Kind = tkInt64) then 135 | begin 136 | rItemValue := StrToInt64(AJsonArray.Items[i].ValueString); 137 | end else 138 | if (elType.Kind = tkEnumeration) 139 | and (elType = System.TypeInfo(Boolean)) 140 | and (AJsonArray.Items[i] is TclJSONBoolean) then 141 | begin 142 | rItemValue := TclJSONBoolean(AJsonArray.Items[i]).Value; 143 | end else 144 | if (elType.Kind = tkEnumeration) 145 | and (AJsonArray.Items[i] is TclJSONValue) then 146 | begin 147 | rItemValue := EnumNameToTValue(AJsonArray.Items[i].ValueString, elType); 148 | end else 149 | begin 150 | raise EclJsonSerializerError.Create(cUnsupportedDataType); 151 | end; 152 | 153 | rValue.SetArrayElement(i, rItemValue); 154 | end; 155 | 156 | AProperty.SetValue(AObject, rValue); 157 | finally 158 | DynArrayClear(pArr, AProperty.PropertyType.Handle); 159 | end; 160 | end; 161 | 162 | function TclJsonSerializer.EnumNameToTValue(Name: string; EnumType: PTypeInfo): TValue; 163 | var 164 | V: integer; 165 | begin 166 | V:= GetEnumValue(EnumType, Name); 167 | TValue.Make(V, EnumType, Result); 168 | end; 169 | 170 | function TclJsonSerializer.JsonToObject(AObject: TObject; const AJson: string): TObject; 171 | var 172 | obj: TclJSONObject; 173 | begin 174 | obj := TclJSONBase.ParseObject(AJson); 175 | try 176 | Result := Deserialize(AObject, obj); 177 | finally 178 | obj.Free(); 179 | end; 180 | end; 181 | 182 | function TclJsonSerializer.JsonToObject(AType: TClass; const AJson: string): TObject; 183 | var 184 | obj: TclJSONObject; 185 | begin 186 | obj := TclJSONBase.ParseObject(AJson); 187 | try 188 | Result := Deserialize(AType, obj); 189 | finally 190 | obj.Free(); 191 | end; 192 | end; 193 | 194 | function TclJsonSerializer.ObjectToJson(AObject: TObject): string; 195 | var 196 | json: TclJSONObject; 197 | begin 198 | json := Serialize(AObject); 199 | try 200 | Result := json.GetJSONString(); 201 | finally 202 | json.Free(); 203 | end; 204 | end; 205 | 206 | function TclJsonSerializer.Deserialize(AType: TClass; const AJson: TclJSONObject): TObject; 207 | var 208 | ctx: TRttiContext; 209 | lType, rType: TRttiType; 210 | instType: TRttiInstanceType; 211 | rValue: TValue; 212 | typeNameAttrs: TclJsonTypeNameMapAttributeList; 213 | begin 214 | Result := nil; 215 | if (AJson.Count = 0) then Exit; 216 | 217 | ctx := TRttiContext.Create(); 218 | try 219 | rType := ctx.GetType(AType); 220 | 221 | GetTypeAttributes(rType, typeNameAttrs); 222 | lType := GetObjectClass(typeNameAttrs, AJson); 223 | if (lType = nil) then 224 | begin 225 | lType := rType; 226 | end; 227 | instType := lType.AsInstance; 228 | rValue := instType.GetMethod('Create').Invoke(instType.MetaclassType, []); 229 | 230 | Result := rValue.AsObject; 231 | try 232 | Result := Deserialize(Result, AJson); 233 | except 234 | Result.Free(); 235 | raise; 236 | end; 237 | finally 238 | ctx.Free(); 239 | end; 240 | end; 241 | 242 | class function TclJsonSerializer.GetDataClass(ATypeInfo: PTypeInfo): TClass; 243 | function GetDataType: PTypeData; 244 | var 245 | pb: PByte; 246 | begin 247 | pb := @(ATypeInfo^).Name; 248 | pb := pb + pb^ + 1; 249 | Result := PTypeData(pb); 250 | end; 251 | begin 252 | Result := GetDataType().ClassType; 253 | end; 254 | 255 | class function TclJsonSerializer.GetArrayElementType(ATypeInfo: PTypeInfo): PPTypeInfo; 256 | type 257 | PPPTypeInfo = ^PPTypeInfo; 258 | var 259 | td: PTypeData; 260 | pb: PByte; 261 | begin 262 | td := GetTypeData(ATypeInfo); 263 | pb := @td.DynUnitName; 264 | pb := pb + pb^ + 1; 265 | Result := PPPTypeInfo(pb)^; 266 | end; 267 | 268 | function TclJsonSerializer.Deserialize(AObject: TObject; const AJson: TclJSONObject): TObject; 269 | var 270 | ctx: TRttiContext; 271 | rType: TRttiType; 272 | rProp: TRttiProperty; 273 | member: TclJSONPair; 274 | rValue: TValue; 275 | objClass: TClass; 276 | nonSerializable: Boolean; 277 | requiredAttr: TclJsonRequiredAttribute; 278 | propAttr: TclJsonPropertyAttribute; 279 | begin 280 | Result := AObject; 281 | 282 | if (AJson.Count = 0) or (Result = nil) then Exit; 283 | 284 | nonSerializable := True; 285 | 286 | ctx := TRttiContext.Create(); 287 | try 288 | rType := ctx.GetType(Result.ClassInfo); 289 | 290 | for rProp in rType.GetProperties() do 291 | begin 292 | GetPropertyAttributes(rProp, propAttr, requiredAttr); 293 | 294 | if (propAttr <> nil) then 295 | begin 296 | nonSerializable := False; 297 | 298 | member := AJson.MemberByName(TclJsonPropertyAttribute(propAttr).Name); 299 | if (member = nil) then Continue; 300 | 301 | if (rProp.PropertyType.TypeKind = tkDynArray) 302 | and (member.Value is TclJSONArray) then 303 | begin 304 | DeserializeArray(rProp, Result, TclJSONArray(member.Value)); 305 | end else 306 | if (rProp.PropertyType.TypeKind = tkClass) 307 | and (member.Value is TclJSONObject) then 308 | begin 309 | objClass := GetDataClass(rProp.PropertyType.Handle); 310 | rValue := Deserialize(objClass, TclJSONObject(member.Value)); 311 | rProp.SetValue(Result, rValue); 312 | end else 313 | if (rProp.PropertyType.TypeKind in [tkString, tkLString, tkWString, tkUString]) then 314 | begin 315 | rValue := member.ValueString; 316 | rProp.SetValue(Result, rValue); 317 | end else 318 | if (rProp.PropertyType.TypeKind = tkInteger) then 319 | begin 320 | rValue := StrToInt(member.ValueString); 321 | rProp.SetValue(Result, rValue); 322 | end else 323 | if (rProp.PropertyType.TypeKind = tkInt64) then 324 | begin 325 | rValue := StrToInt64(member.ValueString); 326 | rProp.SetValue(Result, rValue); 327 | end else 328 | if (rProp.PropertyType.TypeKind = tkEnumeration) 329 | and (rProp.GetValue(Result).TypeInfo = System.TypeInfo(Boolean)) 330 | and (member.Value is TclJSONBoolean) then 331 | begin 332 | rValue := TclJSONBoolean(member.Value).Value; 333 | rProp.SetValue(Result, rValue); 334 | end else 335 | if (rProp.PropertyType.TypeKind = tkEnumeration) 336 | and (rProp.GetValue(Result).TypeInfo.Kind = tkEnumeration) 337 | and (member.Value is TclJSONValue) then 338 | begin 339 | rValue := EnumNameToTValue(member.ValueString, rProp.GetValue(Result).TypeInfo); 340 | rProp.SetValue(Result, rValue); 341 | end else 342 | begin 343 | raise EclJsonSerializerError.Create(cUnsupportedDataType); 344 | end; 345 | end; 346 | end; 347 | finally 348 | ctx.Free(); 349 | end; 350 | 351 | if (nonSerializable) then 352 | begin 353 | raise EclJsonSerializerError.Create(cNonSerializable); 354 | end; 355 | end; 356 | 357 | procedure TclJsonSerializer.GetPropertyAttributes(AProp: TRttiProperty; var APropAttr: TclJsonPropertyAttribute; 358 | var ARequiredAttr: TclJsonRequiredAttribute); 359 | var 360 | attr: TCustomAttribute; 361 | begin 362 | APropAttr := nil; 363 | ARequiredAttr := nil; 364 | 365 | for attr in AProp.GetAttributes() do 366 | begin 367 | if (attr is TclJsonPropertyAttribute) then 368 | begin 369 | APropAttr := attr as TclJsonPropertyAttribute; 370 | end else 371 | if (attr is TclJsonRequiredAttribute) then 372 | begin 373 | ARequiredAttr := attr as TclJsonRequiredAttribute; 374 | end; 375 | end; 376 | end; 377 | 378 | type 379 | TListEx = class(TList) 380 | public 381 | function ToArray: TArray; 382 | end; 383 | 384 | { TListEx } 385 | 386 | function TListEx.ToArray: TArray; 387 | var 388 | i: Integer; 389 | begin 390 | SetLength(Result, Count); 391 | for i := 0 to Count - 1 do 392 | begin 393 | Result[i] := Items[i]; 394 | end; 395 | end; 396 | 397 | procedure TclJsonSerializer.GetTypeAttributes(AType: TRttiType; var ATypeNameAttrs: TclJsonTypeNameMapAttributeList); 398 | var 399 | attr: TCustomAttribute; 400 | list: TListEx; 401 | begin 402 | list := TListEx.Create(); 403 | try 404 | for attr in AType.GetAttributes() do 405 | begin 406 | if (attr is TclJsonTypeNameMapAttribute) then 407 | begin 408 | list.Add(attr as TclJsonTypeNameMapAttribute); 409 | end; 410 | end; 411 | ATypeNameAttrs := list.ToArray(); 412 | finally 413 | list.Free(); 414 | end; 415 | end; 416 | 417 | function TclJsonSerializer.Serialize(AObject: TObject): TclJSONObject; 418 | var 419 | ctx: TRttiContext; 420 | rType: TRttiType; 421 | rProp: TRttiProperty; 422 | nonSerializable: Boolean; 423 | requiredAttr: TclJsonRequiredAttribute; 424 | propAttr: TclJsonPropertyAttribute; 425 | begin 426 | if (AObject = nil) then 427 | begin 428 | Result := nil; 429 | Exit; 430 | end; 431 | 432 | nonSerializable := True; 433 | 434 | ctx := TRttiContext.Create(); 435 | try 436 | Result := TclJSONObject.Create(); 437 | try 438 | rType := ctx.GetType(AObject.ClassInfo); 439 | for rProp in rType.GetProperties() do 440 | begin 441 | GetPropertyAttributes(rProp, propAttr, requiredAttr); 442 | 443 | if (propAttr <> nil) then 444 | begin 445 | nonSerializable := False; 446 | 447 | if (rProp.PropertyType.TypeKind = tkDynArray) then 448 | begin 449 | SerializeArray(rProp, AObject, TclJsonPropertyAttribute(propAttr), Result); 450 | end else 451 | if (rProp.PropertyType.TypeKind = tkClass) then 452 | begin 453 | Result.AddMember(TclJsonPropertyAttribute(propAttr).Name, Serialize(rProp.GetValue(AObject).AsObject())); 454 | end else 455 | if (rProp.PropertyType.TypeKind in [tkString, tkLString, tkWString, tkUString]) then 456 | begin 457 | if (propAttr is TclJsonStringAttribute) then 458 | begin 459 | if (requiredAttr <> nil) then 460 | begin 461 | Result.AddRequiredString(TclJsonPropertyAttribute(propAttr).Name, rProp.GetValue(AObject).AsString()); 462 | end else 463 | begin 464 | Result.AddString(TclJsonPropertyAttribute(propAttr).Name, rProp.GetValue(AObject).AsString()); 465 | end; 466 | end else 467 | begin 468 | Result.AddValue(TclJsonPropertyAttribute(propAttr).Name, rProp.GetValue(AObject).AsString()); 469 | end; 470 | end else 471 | if (rProp.PropertyType.TypeKind in [tkInteger, tkInt64]) then 472 | begin 473 | Result.AddValue(TclJsonPropertyAttribute(propAttr).Name, rProp.GetValue(AObject).ToString()); 474 | end else 475 | if (rProp.PropertyType.TypeKind = tkEnumeration) 476 | and (rProp.GetValue(AObject).TypeInfo = System.TypeInfo(Boolean)) then 477 | begin 478 | Result.AddBoolean(TclJsonPropertyAttribute(propAttr).Name, rProp.GetValue(AObject).AsBoolean()); 479 | end else 480 | if (rProp.PropertyType.TypeKind = tkEnumeration) then 481 | begin 482 | Result.AddValue(TclJsonPropertyAttribute(propAttr).Name, rProp.GetValue(AObject).ToString()); 483 | end else 484 | begin 485 | raise EclJsonSerializerError.Create(cUnsupportedDataType); 486 | end; 487 | end; 488 | end; 489 | 490 | if (nonSerializable) then 491 | begin 492 | raise EclJsonSerializerError.Create(cNonSerializable); 493 | end; 494 | except 495 | Result.Free(); 496 | raise; 497 | end; 498 | finally 499 | ctx.Free(); 500 | end; 501 | end; 502 | 503 | procedure TclJsonSerializer.SerializeArray(AProperty: TRttiProperty; AObject: TObject; 504 | Attribute: TclJsonPropertyAttribute; AJson: TclJsonObject); 505 | var 506 | rValue: TValue; 507 | i: Integer; 508 | arr: TclJSONArray; 509 | begin 510 | rValue := AProperty.GetValue(AObject); 511 | 512 | if (rValue.GetArrayLength() > 0) then 513 | begin 514 | arr := TclJSONArray.Create(); 515 | AJson.AddMember(Attribute.Name, arr); 516 | 517 | for i := 0 to rValue.GetArrayLength() - 1 do 518 | begin 519 | if (rValue.GetArrayElement(i).Kind = tkClass) then 520 | begin 521 | arr.Add(Serialize(rValue.GetArrayElement(i).AsObject())); 522 | end else 523 | if (rValue.GetArrayElement(i).Kind in [tkString, tkLString, tkWString, tkUString]) then 524 | begin 525 | if (Attribute is TclJsonStringAttribute) then 526 | begin 527 | arr.Add(TclJSONString.Create(rValue.GetArrayElement(i).AsString())); 528 | end else 529 | begin 530 | arr.Add(TclJSONValue.Create(rValue.GetArrayElement(i).AsString())); 531 | end; 532 | end else 533 | if (rValue.GetArrayElement(i).Kind in [tkInteger, tkInt64]) then 534 | begin 535 | arr.Add(TclJSONValue.Create(rValue.GetArrayElement(i).ToString())); 536 | end else 537 | if (rValue.GetArrayElement(i).Kind = tkEnumeration) 538 | and (rValue.GetArrayElement(i).TypeInfo = System.TypeInfo(Boolean)) then 539 | begin 540 | arr.Add(TclJSONBoolean.Create(rValue.GetArrayElement(i).AsBoolean())); 541 | end else 542 | if (rValue.GetArrayElement(i).Kind = tkEnumeration) then 543 | begin 544 | arr.Add(TclJSONValue.Create(rValue.GetArrayElement(i).ToString())); 545 | end else 546 | begin 547 | raise EclJsonSerializerError.Create(cUnsupportedDataType); 548 | end; 549 | end; 550 | end; 551 | end; 552 | 553 | end. 554 | -------------------------------------------------------------------------------- /d2010/json/clJsonSerializerBase.pas: -------------------------------------------------------------------------------- 1 | { 2 | Copyright (C) 2016 by Clever Components 3 | 4 | Author: Sergey Shirokov 5 | 6 | Website: www.CleverComponents.com 7 | 8 | This file is part of Json Serializer. 9 | 10 | Json Serializer is free software: you can redistribute it and/or modify 11 | it under the terms of the GNU Lesser General Public License version 3 12 | as published by the Free Software Foundation and appearing in the 13 | included file COPYING.LESSER. 14 | 15 | Json Serializer is distributed in the hope that it will be useful, 16 | but WITHOUT ANY WARRANTY; without even the implied warranty of 17 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18 | GNU Lesser General Public License for more details. 19 | 20 | You should have received a copy of the GNU Lesser General Public License 21 | along with Json Serializer. If not, see . 22 | } 23 | 24 | unit clJsonSerializerBase; 25 | 26 | interface 27 | 28 | uses 29 | Classes, SysUtils, Rtti, TypInfo; 30 | 31 | type 32 | EclJsonSerializerError = class(Exception) 33 | end; 34 | 35 | TclJsonPropertyAttribute = class (TCustomAttribute) 36 | strict private 37 | FName: string; 38 | public 39 | constructor Create(const AName: string); 40 | property Name: string read FName; 41 | end; 42 | 43 | TclJsonStringAttribute = class(TclJsonPropertyAttribute); 44 | 45 | TclJsonRequiredAttribute = class(TCustomAttribute); 46 | 47 | TclJsonTypeNameMapAttribute = class(TCustomAttribute) 48 | strict private 49 | FPropertyName: string; 50 | FTypeName: string; 51 | FTypeClassName: string; 52 | public 53 | constructor Create(const APropertyName, ATypeName, ATypeClassName: string); 54 | property PropertyName: string read FPropertyName; 55 | property TypeName: string read FTypeName; 56 | property TypeClassName: string read FTypeClassName; 57 | end; 58 | 59 | TclJsonSerializerBase = class abstract 60 | public 61 | function JsonToObject(AType: TClass; const AJson: string): TObject; overload; virtual; abstract; 62 | function JsonToObject(AObject: TObject; const AJson: string): TObject; overload; virtual; abstract; 63 | function ObjectToJson(AObject: TObject): string; virtual; abstract; 64 | end; 65 | 66 | implementation 67 | 68 | { TclJsonPropertyAttribute } 69 | 70 | constructor TclJsonPropertyAttribute.Create(const AName: string); 71 | begin 72 | inherited Create(); 73 | FName := AName; 74 | end; 75 | 76 | { TclJsonTypeNameMapAttribute } 77 | 78 | constructor TclJsonTypeNameMapAttribute.Create(const APropertyName, ATypeName, ATypeClassName: string); 79 | begin 80 | inherited Create(); 81 | 82 | FPropertyName := APropertyName; 83 | FTypeName := ATypeName; 84 | FTypeClassName := ATypeClassName; 85 | end; 86 | 87 | end. 88 | -------------------------------------------------------------------------------- /d2010/test/Test.dpr: -------------------------------------------------------------------------------- 1 | program Test; 2 | 3 | uses 4 | Forms, 5 | TestFrameWork, 6 | GUITestRunner, 7 | clJsonSerializerBase in '..\json\clJsonSerializerBase.pas', 8 | clJsonSerializerTests in 'clJsonSerializerTests.pas', 9 | clJsonSerializer in '..\json\clJsonSerializer.pas', 10 | clJsonParser in '..\json\clJsonParser.pas'; 11 | 12 | {$R *.res} 13 | 14 | begin 15 | Application.Initialize; 16 | GUITestRunner.RunRegisteredTests; 17 | end. 18 | -------------------------------------------------------------------------------- /d2010/test/Test.dproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | {CC2D5522-8B79-4A11-A4B0-46057374F296} 4 | Test.dpr 5 | Debug 6 | DCC32 7 | 12.0 8 | 9 | 10 | true 11 | 12 | 13 | true 14 | Base 15 | true 16 | 17 | 18 | true 19 | Base 20 | true 21 | 22 | 23 | WinTypes=Windows;WinProcs=Windows;$(DCC_UnitAlias) 24 | Test.exe 25 | 00400000 26 | x86 27 | 28 | 29 | false 30 | RELEASE;$(DCC_Define) 31 | 0 32 | false 33 | 34 | 35 | DEBUG;$(DCC_Define) 36 | 37 | 38 | 39 | MainSource 40 | 41 | 42 | 43 | 44 | 45 | 46 | Base 47 | 48 | 49 | Cfg_2 50 | Base 51 | 52 | 53 | Cfg_1 54 | Base 55 | 56 | 57 | 58 | 59 | Delphi.Personality.12 60 | VCLApplication 61 | 62 | 63 | 64 | Test.dpr 65 | 66 | 67 | False 68 | True 69 | False 70 | 71 | 72 | True 73 | False 74 | 1 75 | 0 76 | 0 77 | 0 78 | False 79 | False 80 | False 81 | False 82 | False 83 | 1049 84 | 1251 85 | 86 | 87 | 88 | 89 | 1.0.0.0 90 | 91 | 92 | 93 | 94 | 95 | 1.0.0.0 96 | 97 | 98 | 99 | 100 | 12 101 | 102 | 103 | -------------------------------------------------------------------------------- /d2010/test/Test.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CleverComponents/Json-Serializer/bedd076d54b8489c8e5134909c978605d6db8184/d2010/test/Test.res -------------------------------------------------------------------------------- /d2010/test/clJsonSerializerTests.pas: -------------------------------------------------------------------------------- 1 | { 2 | Copyright (C) 2016 by Clever Components 3 | 4 | Author: Sergey Shirokov 5 | 6 | Website: www.CleverComponents.com 7 | 8 | This file is part of Json Serializer. 9 | 10 | Json Serializer is free software: you can redistribute it and/or modify 11 | it under the terms of the GNU Lesser General Public License version 3 12 | as published by the Free Software Foundation and appearing in the 13 | included file COPYING.LESSER. 14 | 15 | Json Serializer is distributed in the hope that it will be useful, 16 | but WITHOUT ANY WARRANTY; without even the implied warranty of 17 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18 | GNU Lesser General Public License for more details. 19 | 20 | You should have received a copy of the GNU Lesser General Public License 21 | along with Json Serializer. If not, see . 22 | } 23 | 24 | unit clJsonSerializerTests; 25 | 26 | interface 27 | 28 | uses 29 | Classes, SysUtils, TestFramework, clJsonSerializerBase, clJsonSerializer; 30 | 31 | type 32 | TclNotSerializable = class 33 | strict private 34 | FName: string; 35 | public 36 | property Name: string read FName write FName; 37 | end; 38 | 39 | TclTestUnsupportedType = class 40 | strict private 41 | FFloatValue: Double; 42 | public 43 | [TclJsonProperty('floatValue')] 44 | property FloatValue: Double read FFloatValue write FFloatValue; 45 | end; 46 | 47 | TclTestUnsupportedArrayType = class 48 | strict private 49 | FFloatArray: TArray; 50 | public 51 | [TclJsonProperty('floatArray')] 52 | property FloatArray: TArray read FFloatArray write FFloatArray; 53 | end; 54 | 55 | TclTestSubObject = class 56 | strict private 57 | FName: string; 58 | FValue: string; 59 | public 60 | [TclJsonString('name')] 61 | property Name: string read FName write FName; 62 | [TclJsonString('value')] 63 | property Value: string read FValue write FValue; 64 | end; 65 | 66 | TclTestObject = class 67 | strict private 68 | FBooleanValue: Boolean; 69 | FNonSerializable: string; 70 | FStringValue: string; 71 | FValue: string; 72 | FIntegerValue: Integer; 73 | FSubObject: TclTestSubObject; 74 | FIntArray: TArray; 75 | FStrArray: TArray; 76 | FBoolArray: TArray; 77 | FObjArray: TArray; 78 | 79 | procedure SetSubObject(const Value: TclTestSubObject); 80 | procedure SetObjArray(const Value: TArray); 81 | public 82 | constructor Create; 83 | destructor Destroy; override; 84 | 85 | [TclJsonString('stringValue')] 86 | property StringValue: string read FStringValue write FStringValue; 87 | 88 | [TclJsonProperty('integerValue')] 89 | property IntegerValue: Integer read FIntegerValue write FIntegerValue; 90 | 91 | [TclJsonProperty('value')] 92 | property Value: string read FValue write FValue; 93 | 94 | [TclJsonProperty('booleanValue')] 95 | property BooleanValue: Boolean read FBooleanValue write FBooleanValue; 96 | 97 | [TclJsonProperty('subObject')] 98 | property SubObject: TclTestSubObject read FSubObject write SetSubObject; 99 | 100 | [TclJsonProperty('intArray')] 101 | property IntArray: TArray read FIntArray write FIntArray; 102 | 103 | [TclJsonString('strArray')] 104 | property StrArray: TArray read FStrArray write FStrArray; 105 | 106 | [TclJsonProperty('boolArray')] 107 | property BoolArray: TArray read FBoolArray write FBoolArray; 108 | 109 | [TclJsonProperty('objArray')] 110 | property ObjArray: TArray read FObjArray write SetObjArray; 111 | 112 | property NonSerializable: string read FNonSerializable write FNonSerializable; 113 | end; 114 | 115 | [TclJsonTypeNameMap('tag', 'inherited', 'clJsonSerializerTests.TclTestInheritedObject')] 116 | TclTestBaseObject = class 117 | strict private 118 | FTag: string; 119 | FName: string; 120 | public 121 | [TclJsonString('tag')] 122 | property Tag: string read FTag write FTag; 123 | 124 | [TclJsonString('name')] 125 | property Name: string read FName write FName; 126 | end; 127 | 128 | TclTestInheritedObject = class(TclTestBaseObject) 129 | strict private 130 | FSubName: string; 131 | public 132 | [TclJsonString('subname')] 133 | property SubName: string read FSubName write FSubName; 134 | end; 135 | 136 | TclTestMultipleTypeArray = class 137 | strict private 138 | FConstructorCalled: Boolean; 139 | FObjArray: TArray; 140 | 141 | procedure SetObjArray(const Value: TArray); 142 | public 143 | constructor Create; 144 | destructor Destroy; override; 145 | 146 | [TclJsonProperty('objArray')] 147 | property ObjArray: TArray read FObjArray write SetObjArray; 148 | 149 | property ConstructorCalled: Boolean read FConstructorCalled; 150 | end; 151 | 152 | TclTestRequiredPropertyObject = class 153 | strict private 154 | FRequiredString: string; 155 | public 156 | [TclJsonRequired] 157 | [TclJsonString('required-string')] 158 | property RequiredString: string read FRequiredString write FRequiredString; 159 | end; 160 | 161 | TclTestEnum = (teOne, teTwo, teThree); 162 | 163 | TclTestEnumPropertyObject = class 164 | strict private 165 | FEnum: TclTestEnum; 166 | FEnumArray: TArray; 167 | public 168 | constructor Create; 169 | 170 | [TclJsonProperty('enum')] 171 | property Enum: TclTestEnum read FEnum write FEnum; 172 | 173 | [TclJsonProperty('enumArray')] 174 | property EnumArray: TArray read FEnumArray write FEnumArray; 175 | end; 176 | 177 | TclJsonSerializerTests = class(TTestCase) 178 | published 179 | procedure TestDeserialize; 180 | procedure TestDeserializeCreatedInstance; 181 | procedure TestSerialize; 182 | procedure TestUnsupportedType; 183 | procedure TestNonSerializable; 184 | procedure TestRequiredProperty; 185 | procedure TestMultipleTypeArray; 186 | procedure TestInheritedTypes; 187 | procedure TestEnumProperty; 188 | end; 189 | 190 | implementation 191 | 192 | { TclJsonSerializerTests } 193 | 194 | procedure TclJsonSerializerTests.TestDeserialize; 195 | const 196 | jsonEtalon = '{"stringValue": "qwe", "integerValue": 123, "value": asd, "booleanValue": true}'; 197 | jsonEtalon2 = '{"stringValue": "qwe", "subObject": {"name": "qwerty"}, "intArray": [111, 222], "strArray": ["val 1", "val 2"], ' + 198 | '"boolArray": [true, false], "objArray": [{"name": "an1"}, {"name": "an2"}]}'; 199 | 200 | var 201 | serializer: TclJsonSerializer; 202 | obj: TclTestObject; 203 | begin 204 | serializer := nil; 205 | obj := nil; 206 | try 207 | serializer := TclJsonSerializer.Create(); 208 | 209 | obj := serializer.JsonToObject(TclTestObject, jsonEtalon) as TclTestObject; 210 | 211 | CheckEquals('qwe', obj.StringValue); 212 | CheckEquals(123, obj.IntegerValue); 213 | CheckEquals('asd', obj.Value); 214 | CheckEquals(True, obj.BooleanValue); 215 | 216 | FreeAndNil(obj); 217 | 218 | obj := serializer.JsonToObject(TclTestObject, jsonEtalon2) as TclTestObject; 219 | 220 | CheckEquals('qwe', obj.StringValue); 221 | 222 | CheckTrue(obj.SubObject <> nil); 223 | CheckEquals('qwerty', obj.SubObject.Name); 224 | 225 | CheckEquals(2, Length(obj.IntArray)); 226 | CheckEquals(111, obj.IntArray[0]); 227 | CheckEquals(222, obj.IntArray[1]); 228 | 229 | CheckEquals(2, Length(obj.StrArray)); 230 | CheckEquals('val 1', obj.StrArray[0]); 231 | CheckEquals('val 2', obj.StrArray[1]); 232 | 233 | CheckEquals(2, Length(obj.BoolArray)); 234 | CheckEquals(True, obj.BoolArray[0]); 235 | CheckEquals(False, obj.BoolArray[1]); 236 | 237 | CheckEquals(2, Length(obj.ObjArray)); 238 | 239 | CheckTrue(obj.ObjArray[0] <> nil); 240 | CheckEquals('an1', obj.ObjArray[0].Name); 241 | 242 | CheckTrue(obj.ObjArray[1] <> nil); 243 | CheckEquals('an2', obj.ObjArray[1].Name); 244 | finally 245 | obj.Free(); 246 | serializer.Free(); 247 | end; 248 | end; 249 | 250 | procedure TclJsonSerializerTests.TestDeserializeCreatedInstance; 251 | const 252 | jsonEtalon = '{"stringValue": "qwe", "integerValue": 123, "value": asd, "booleanValue": true}'; 253 | 254 | var 255 | serializer: TclJsonSerializer; 256 | obj: TclTestObject; 257 | begin 258 | serializer := nil; 259 | obj := nil; 260 | try 261 | serializer := TclJsonSerializer.Create(); 262 | 263 | obj := TclTestObject.Create(); 264 | obj := serializer.JsonToObject(obj, jsonEtalon) as TclTestObject; 265 | 266 | CheckEquals('qwe', obj.StringValue); 267 | CheckEquals(123, obj.IntegerValue); 268 | CheckEquals('asd', obj.Value); 269 | CheckEquals(True, obj.BooleanValue); 270 | finally 271 | obj.Free(); 272 | serializer.Free(); 273 | end; 274 | end; 275 | 276 | procedure TclJsonSerializerTests.TestEnumProperty; 277 | var 278 | serializer: TclJsonSerializer; 279 | obj: TclTestEnumPropertyObject; 280 | json: string; 281 | enumArr: TArray; 282 | begin 283 | serializer := nil; 284 | obj := nil; 285 | try 286 | serializer := TclJsonSerializer.Create(); 287 | 288 | obj := TclTestEnumPropertyObject.Create(); 289 | obj.Enum := teTwo; 290 | 291 | SetLength(enumArr, 2); 292 | obj.EnumArray := enumArr; 293 | enumArr[0] := teTwo; 294 | enumArr[1] := teThree; 295 | 296 | json := serializer.ObjectToJson(obj); 297 | CheckEquals('{"enum": teTwo, "enumArray": [teTwo, teThree]}', json); 298 | FreeAndNil(obj); 299 | 300 | obj := serializer.JsonToObject(TclTestEnumPropertyObject, json) as TclTestEnumPropertyObject; 301 | Assert(teTwo = obj.Enum); 302 | CheckEquals(2, Length(obj.EnumArray)); 303 | Assert(teTwo = obj.EnumArray[0]); 304 | Assert(teThree = obj.EnumArray[1]); 305 | FreeAndNil(obj); 306 | finally 307 | obj.Free(); 308 | serializer.Free(); 309 | end; 310 | end; 311 | 312 | procedure TclJsonSerializerTests.TestInheritedTypes; 313 | const 314 | jsonBase = '{"tag": "base", "name": "base class"}'; 315 | jsonInherited = '{"tag": "inherited", "name": "inherited class", "subname": "inherited subname"}'; 316 | var 317 | serializer: TclJsonSerializer; 318 | obj: TclTestBaseObject; 319 | inh: TclTestInheritedObject; 320 | begin 321 | serializer := nil; 322 | obj := nil; 323 | try 324 | serializer := TclJsonSerializer.Create(); 325 | 326 | obj := serializer.JsonToObject(TclTestBaseObject, jsonBase) as TclTestBaseObject; 327 | 328 | CheckEquals('base', obj.Tag); 329 | CheckEquals('base class', obj.Name); 330 | 331 | FreeAndNil(obj); 332 | 333 | obj := serializer.JsonToObject(TclTestBaseObject, jsonInherited) as TclTestBaseObject; 334 | 335 | inh := obj as TclTestInheritedObject; 336 | CheckEquals('inherited', inh.Tag); 337 | CheckEquals('inherited class', inh.Name); 338 | CheckEquals('inherited subname', inh.SubName); 339 | 340 | FreeAndNil(obj); 341 | 342 | obj := serializer.JsonToObject(TclTestInheritedObject, jsonInherited) as TclTestBaseObject; 343 | 344 | inh := obj as TclTestInheritedObject; 345 | CheckEquals('inherited', inh.Tag); 346 | CheckEquals('inherited class', inh.Name); 347 | CheckEquals('inherited subname', inh.SubName); 348 | 349 | FreeAndNil(obj); 350 | finally 351 | obj.Free(); 352 | serializer.Free(); 353 | end; 354 | end; 355 | 356 | procedure TclJsonSerializerTests.TestMultipleTypeArray; 357 | const 358 | jsonEtalon = '{"objArray": [{"tag": "base", "name": "base class"}, {"tag": "inherited", "name": "inherited class", "subname": "inherited subname"}]}'; 359 | jsonEtalonMalformed = '{"objArray": [{"tag-bad": "base", "name": "base class"}, {"tag-bad": "inherited", "name": "inherited class", "subname": "inherited subname"}]}'; 360 | 361 | var 362 | serializer: TclJsonSerializer; 363 | obj: TclTestMultipleTypeArray; 364 | begin 365 | serializer := nil; 366 | obj := nil; 367 | try 368 | serializer := TclJsonSerializer.Create(); 369 | 370 | obj := serializer.JsonToObject(TclTestMultipleTypeArray, jsonEtalon) as TclTestMultipleTypeArray; 371 | 372 | CheckEquals(2, Length(obj.ObjArray)); 373 | CheckEquals('base', obj.ObjArray[0].Tag); 374 | CheckEquals('base class', obj.ObjArray[0].Name); 375 | CheckEquals('TclTestBaseObject', obj.ObjArray[0].ClassName); 376 | CheckEquals('inherited', obj.ObjArray[1].Tag); 377 | CheckEquals('inherited class', obj.ObjArray[1].Name); 378 | CheckEquals('TclTestInheritedObject', obj.ObjArray[1].ClassName); 379 | CheckEquals('inherited subname', (obj.ObjArray[1] as TclTestInheritedObject).SubName); 380 | CheckEquals(True, obj.ConstructorCalled); 381 | 382 | FreeAndNil(obj); 383 | 384 | obj := serializer.JsonToObject(TclTestMultipleTypeArray, jsonEtalonMalformed) as TclTestMultipleTypeArray; 385 | 386 | CheckEquals(2, Length(obj.ObjArray)); 387 | CheckEquals('', obj.ObjArray[0].Tag); 388 | CheckEquals('base class', obj.ObjArray[0].Name); 389 | CheckEquals('TclTestBaseObject', obj.ObjArray[0].ClassName); 390 | CheckEquals('', obj.ObjArray[1].Tag); 391 | CheckEquals('inherited class', obj.ObjArray[1].Name); 392 | CheckEquals('TclTestBaseObject', obj.ObjArray[1].ClassName); 393 | 394 | FreeAndNil(obj); 395 | finally 396 | obj.Free(); 397 | serializer.Free(); 398 | end; 399 | end; 400 | 401 | procedure TclJsonSerializerTests.TestNonSerializable; 402 | var 403 | serializer: TclJsonSerializer; 404 | obj: TclNotSerializable; 405 | begin 406 | serializer := nil; 407 | obj := nil; 408 | try 409 | serializer := TclJsonSerializer.Create(); 410 | 411 | try 412 | serializer.JsonToObject(TclNotSerializable, '{"name":"test"}'); 413 | Fail('Non-serializable objects cannot be serialized'); 414 | except 415 | on EclJsonSerializerError do; 416 | end; 417 | 418 | obj := TclNotSerializable.Create(); 419 | obj.Name := 'test'; 420 | try 421 | serializer.ObjectToJson(obj); 422 | Fail('Non-serializable objects cannot be serialized'); 423 | except 424 | on EclJsonSerializerError do; 425 | end; 426 | finally 427 | obj.Free(); 428 | serializer.Free(); 429 | end; 430 | end; 431 | 432 | procedure TclJsonSerializerTests.TestRequiredProperty; 433 | var 434 | serializer: TclJsonSerializer; 435 | obj: TclTestRequiredPropertyObject; 436 | begin 437 | serializer := nil; 438 | obj := nil; 439 | try 440 | serializer := TclJsonSerializer.Create(); 441 | 442 | obj := serializer.JsonToObject(TclTestRequiredPropertyObject, '{"required-string": "qwe"}') as TclTestRequiredPropertyObject; 443 | CheckEquals('qwe', obj.RequiredString); 444 | FreeAndNil(obj); 445 | 446 | obj := serializer.JsonToObject(TclTestRequiredPropertyObject, '{"required-string": ""}') as TclTestRequiredPropertyObject; 447 | CheckEquals('', obj.RequiredString); 448 | CheckEquals('{"required-string": ""}', serializer.ObjectToJson(obj)); 449 | FreeAndNil(obj); 450 | finally 451 | obj.Free(); 452 | serializer.Free(); 453 | end; 454 | end; 455 | 456 | procedure TclJsonSerializerTests.TestSerialize; 457 | const 458 | jsonEtalon = '{"stringValue": "qwe", "integerValue": 123, "value": asd, "booleanValue": true}'; 459 | jsonEtalon2 = '{"stringValue": "qwe", "integerValue": 123, "value": asd, "booleanValue": true, ' + 460 | '"subObject": {"name": "qwerty"}, "intArray": [111, 222], "strArray": ["val 1", "val 2"], ' + 461 | '"boolArray": [true, false], "objArray": [{"name": "an1"}, {"name": "an2"}]}'; 462 | 463 | var 464 | serializer: TclJsonSerializer; 465 | obj: TclTestObject; 466 | json: string; 467 | intArr: TArray; 468 | strArr: TArray; 469 | boolArr: TArray; 470 | objArr: TArray; 471 | begin 472 | serializer := nil; 473 | obj := nil; 474 | try 475 | serializer := TclJsonSerializer.Create(); 476 | obj := TclTestObject.Create(); 477 | 478 | obj.StringValue := 'qwe'; 479 | obj.IntegerValue := 123; 480 | obj.Value := 'asd'; 481 | obj.BooleanValue := True; 482 | obj.NonSerializable := 'zxc'; 483 | 484 | json := serializer.ObjectToJson(obj); 485 | 486 | CheckEquals(jsonEtalon, json); 487 | 488 | obj.SubObject := TclTestSubObject.Create(); 489 | obj.SubObject.Name := 'qwerty'; 490 | 491 | SetLength(intArr, 2); 492 | obj.IntArray := intArr; 493 | intArr[0] := 111; 494 | intArr[1] := 222; 495 | 496 | SetLength(strArr, 2); 497 | obj.StrArray := strArr; 498 | strArr[0] := 'val 1'; 499 | strArr[1] := 'val 2'; 500 | 501 | SetLength(boolArr, 2); 502 | obj.BoolArray := boolArr; 503 | boolArr[0] := True; 504 | boolArr[1] := False; 505 | 506 | SetLength(objArr, 2); 507 | obj.ObjArray := objArr; 508 | objArr[0] := TclTestSubObject.Create(); 509 | objArr[0].Name := 'an1'; 510 | objArr[1] := TclTestSubObject.Create(); 511 | objArr[1].Name := 'an2'; 512 | 513 | json := serializer.ObjectToJson(obj); 514 | 515 | CheckEquals(jsonEtalon2, json); 516 | finally 517 | obj.Free(); 518 | serializer.Free(); 519 | end; 520 | end; 521 | 522 | procedure TclJsonSerializerTests.TestUnsupportedType; 523 | var 524 | serializer: TclJsonSerializer; 525 | obj: TclTestUnsupportedType; 526 | objArr: TclTestUnsupportedArrayType; 527 | arr: TArray; 528 | begin 529 | serializer := nil; 530 | obj := nil; 531 | objArr := nil; 532 | try 533 | serializer := TclJsonSerializer.Create(); 534 | 535 | obj := TclTestUnsupportedType.Create(); 536 | obj.FloatValue := 12.5; 537 | 538 | try 539 | serializer.ObjectToJson(obj); 540 | Fail('Data type checking does not work'); 541 | except 542 | on EclJsonSerializerError do; 543 | end; 544 | FreeAndNil(obj); 545 | 546 | try 547 | obj := serializer.JsonToObject(TclTestUnsupportedType, '{"floatValue": 12}') as TclTestUnsupportedType; 548 | Fail('Data type checking does not work'); 549 | except 550 | on EclJsonSerializerError do; 551 | end; 552 | FreeAndNil(obj); 553 | 554 | objArr := TclTestUnsupportedArrayType.Create(); 555 | SetLength(arr, 1); 556 | objArr.FloatArray := arr; 557 | objArr.FloatArray[0] := 12.5; 558 | 559 | try 560 | serializer.ObjectToJson(objArr); 561 | Fail('Data type checking does not work'); 562 | except 563 | on EclJsonSerializerError do; 564 | end; 565 | FreeAndNil(objArr); 566 | 567 | try 568 | objArr := serializer.JsonToObject(TclTestUnsupportedArrayType, '{"floatArray": [11, 22]}') as TclTestUnsupportedArrayType; 569 | Fail('Data type checking does not work'); 570 | except 571 | on EclJsonSerializerError do; 572 | end; 573 | finally 574 | objArr.Free(); 575 | obj.Free(); 576 | serializer.Free(); 577 | end; 578 | end; 579 | 580 | { TclTestObject } 581 | 582 | constructor TclTestObject.Create; 583 | begin 584 | inherited Create(); 585 | 586 | FSubObject := nil; 587 | FIntArray := nil; 588 | FStrArray := nil; 589 | FBoolArray := nil; 590 | FObjArray := nil; 591 | end; 592 | 593 | destructor TclTestObject.Destroy; 594 | begin 595 | SetObjArray(nil); 596 | 597 | FSubObject.Free(); 598 | 599 | inherited Destroy(); 600 | end; 601 | 602 | procedure TclTestObject.SetObjArray(const Value: TArray); 603 | var 604 | obj: TObject; 605 | begin 606 | if (FObjArray <> nil) then 607 | begin 608 | for obj in FObjArray do 609 | begin 610 | obj.Free(); 611 | end; 612 | end; 613 | 614 | FObjArray := Value; 615 | end; 616 | 617 | procedure TclTestObject.SetSubObject(const Value: TclTestSubObject); 618 | begin 619 | FSubObject.Free(); 620 | FSubObject := Value; 621 | end; 622 | 623 | { TclTestMultipleTypeArray } 624 | 625 | constructor TclTestMultipleTypeArray.Create; 626 | begin 627 | inherited Create(); 628 | 629 | FObjArray := nil; 630 | FConstructorCalled := True; 631 | end; 632 | 633 | destructor TclTestMultipleTypeArray.Destroy; 634 | begin 635 | SetObjArray(nil); 636 | inherited Destroy(); 637 | end; 638 | 639 | procedure TclTestMultipleTypeArray.SetObjArray(const Value: TArray); 640 | var 641 | obj: TObject; 642 | begin 643 | if (FObjArray <> nil) then 644 | begin 645 | for obj in FObjArray do 646 | begin 647 | obj.Free(); 648 | end; 649 | end; 650 | 651 | FObjArray := Value; 652 | end; 653 | 654 | { TclTestEnumPropertyObject } 655 | 656 | constructor TclTestEnumPropertyObject.Create; 657 | begin 658 | inherited Create(); 659 | FEnumArray := nil; 660 | end; 661 | 662 | initialization 663 | TestFramework.RegisterTest(TclJsonSerializerTests.Suite); 664 | 665 | end. 666 | -------------------------------------------------------------------------------- /json/clJsonParser.pas: -------------------------------------------------------------------------------- 1 | { 2 | Copyright (C) 2016 by Clever Components 3 | 4 | Author: Sergey Shirokov 5 | 6 | Website: www.CleverComponents.com 7 | 8 | This file is part of Json Serializer. 9 | 10 | Json Serializer is free software: you can redistribute it and/or modify 11 | it under the terms of the GNU Lesser General Public License version 3 12 | as published by the Free Software Foundation and appearing in the 13 | included file COPYING.LESSER. 14 | 15 | Json Serializer is distributed in the hope that it will be useful, 16 | but WITHOUT ANY WARRANTY; without even the implied warranty of 17 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18 | GNU Lesser General Public License for more details. 19 | 20 | You should have received a copy of the GNU Lesser General Public License 21 | along with Json Serializer. If not, see . 22 | } 23 | 24 | unit clJsonParser; 25 | 26 | interface 27 | 28 | uses 29 | System.Classes, System.SysUtils, System.Contnrs; 30 | 31 | type 32 | EclJSONError = class(Exception) 33 | private 34 | FErrorCode: Integer; 35 | public 36 | constructor Create(const AErrorMsg: string; AErrorCode: Integer; ADummy: Boolean = False); 37 | property ErrorCode: Integer read FErrorCode; 38 | end; 39 | 40 | TclJSONString = class; 41 | TclJSONPair = class; 42 | TclJSONObject = class; 43 | TclJSONArray = class; 44 | 45 | TclJSONBase = class 46 | private 47 | class function DecodeString(const ASource: string): WideString; 48 | class function EncodeString(const ASource: WideString): string; 49 | 50 | class procedure SkipWhiteSpace(var Next: PChar); 51 | class function ParseValue(var Next: PChar): TclJSONBase; 52 | class function ParseName(var Next: PChar): string; 53 | class function ParsePair(var Next: PChar): TclJSONPair; 54 | class function ParseObj(var Next: PChar): TclJSONObject; 55 | class function ParseArray(var Next: PChar): TclJSONArray; 56 | class function ParseRoot(var Next: PChar): TclJSONBase; 57 | 58 | function GetValueString: string; 59 | procedure SetValueString(const AValue: string); 60 | protected 61 | function GetValueWideString: WideString; virtual; abstract; 62 | procedure SetValueWideString(const Value: WideString); virtual; abstract; 63 | procedure BuildJSONString(ABuffer: TStringBuilder); virtual; abstract; 64 | public 65 | class function Parse(const AJSONString: string): TclJSONBase; 66 | class function ParseObject(const AJSONString: string): TclJSONObject; 67 | 68 | function GetJSONString: string; 69 | 70 | property ValueString: string read GetValueString write SetValueString; 71 | property ValueWideString: WideString read GetValueWideString write SetValueWideString; 72 | end; 73 | 74 | TclJSONPair = class(TclJSONBase) 75 | private 76 | FName: WideString; 77 | FValue: TclJSONBase; 78 | 79 | procedure SetValue(const AValue: TclJSONBase); 80 | function GetName: string; 81 | procedure SetName(const AValue: string); 82 | protected 83 | function GetValueWideString: WideString; override; 84 | procedure SetValueWideString(const AValue: WideString); override; 85 | procedure BuildJSONString(ABuffer: TStringBuilder); override; 86 | public 87 | constructor Create; 88 | destructor Destroy; override; 89 | 90 | property Name: string read GetName write SetName; 91 | property NameWideString: WideString read FName write FName; 92 | property Value: TclJSONBase read FValue write SetValue; 93 | end; 94 | 95 | TclJSONValue = class(TclJSONBase) 96 | private 97 | FValue: WideString; 98 | protected 99 | function GetValueWideString: WideString; override; 100 | procedure SetValueWideString(const AValue: WideString); override; 101 | procedure BuildJSONString(ABuffer: TStringBuilder); override; 102 | public 103 | constructor Create; overload; 104 | constructor Create(const AValue: string); overload; 105 | constructor Create(const AValue: WideString); overload; 106 | end; 107 | 108 | TclJSONString = class(TclJSONValue) 109 | protected 110 | procedure BuildJSONString(ABuffer: TStringBuilder); override; 111 | end; 112 | 113 | TclJSONBoolean = class(TclJSONValue) 114 | private 115 | function GetValue: Boolean; 116 | procedure SetValue(const Value: Boolean); 117 | protected 118 | procedure SetValueWideString(const AValue: WideString); override; 119 | public 120 | constructor Create; overload; 121 | constructor Create(AValue: Boolean); overload; 122 | 123 | property Value: Boolean read GetValue write SetValue; 124 | end; 125 | 126 | TclJSONArray = class(TclJSONBase) 127 | private 128 | FItems: TObjectList; 129 | 130 | function GetCount: Integer; 131 | function GetItem(Index: Integer): TclJSONBase; 132 | function GetObject(Index: Integer): TclJSONObject; 133 | protected 134 | function GetValueWideString: WideString; override; 135 | procedure SetValueWideString(const AValue: WideString); override; 136 | procedure BuildJSONString(ABuffer: TStringBuilder); override; 137 | public 138 | constructor Create; 139 | destructor Destroy; override; 140 | 141 | function Add(AItem: TclJSONBase): TclJSONBase; 142 | 143 | property Count: Integer read GetCount; 144 | property Items[Index: Integer]: TclJSONBase read GetItem; 145 | property Objects[Index: Integer]: TclJSONObject read GetObject; 146 | end; 147 | 148 | TclJSONObject = class(TclJSONBase) 149 | private 150 | FMembers: TObjectList; 151 | 152 | function GetCount: Integer; 153 | function GetMember(Index: Integer): TclJSONPair; 154 | protected 155 | function GetValueWideString: WideString; override; 156 | procedure SetValueWideString(const AValue: WideString); override; 157 | procedure BuildJSONString(ABuffer: TStringBuilder); override; 158 | public 159 | constructor Create; 160 | destructor Destroy; override; 161 | 162 | function MemberByName(const AName: string): TclJSONPair; overload; 163 | function MemberByName(const AName: WideString): TclJSONPair; overload; 164 | 165 | function ValueByName(const AName: string): string; overload; 166 | function ValueByName(const AName: WideString): WideString; overload; 167 | 168 | function ObjectByName(const AName: string): TclJSONObject; overload; 169 | function ObjectByName(const AName: WideString): TclJSONObject; overload; 170 | 171 | function ArrayByName(const AName: string): TclJSONArray; overload; 172 | function ArrayByName(const AName: WideString): TclJSONArray; overload; 173 | 174 | function BooleanByName(const AName: string): Boolean; overload; 175 | function BooleanByName(const AName: WideString): Boolean; overload; 176 | 177 | function AddMember(APair: TclJSONPair): TclJSONPair; overload; 178 | function AddMember(const AName: WideString; AValue: TclJSONBase): TclJSONPair; overload; 179 | function AddMember(const AName: string; AValue: TclJSONBase): TclJSONPair; overload; 180 | 181 | function AddString(const AName, AValue: string): TclJSONString; overload; 182 | function AddString(const AName, AValue: WideString): TclJSONString; overload; 183 | 184 | function AddRequiredString(const AName, AValue: string): TclJSONString; overload; 185 | function AddRequiredString(const AName, AValue: WideString): TclJSONString; overload; 186 | 187 | function AddValue(const AName, AValue: string): TclJSONValue; overload; 188 | function AddValue(const AName, AValue: WideString): TclJSONValue; overload; 189 | 190 | function AddBoolean(const AName: string; AValue: Boolean): TclJSONBoolean; overload; 191 | function AddBoolean(const AName: WideString; AValue: Boolean): TclJSONBoolean; overload; 192 | 193 | property Count: Integer read GetCount; 194 | property Members[Index: Integer]: TclJSONPair read GetMember; 195 | end; 196 | 197 | resourcestring 198 | cUnexpectedDataEnd = 'Unexpected end of JSON data'; 199 | cUnexpectedDataSymbol = 'Unexpected symbol in JSON data'; 200 | cInvalidControlSymbol = 'Invalid control symbol in JSON data'; 201 | cInvalidUnicodeEscSequence = 'Invalid unicode escape sequence in JSON data'; 202 | cUnrecognizedEscSequence = 'Unrecognized escape sequence in JSON data'; 203 | cUnexpectedDataType = 'Unexpected data type'; 204 | 205 | const 206 | cUnexpectedDataEndCode = -100; 207 | cUnexpectedDataSymbolCode = -101; 208 | cInvalidControlSymbolCode = -102; 209 | cInvalidUnicodeEscSequenceCode = -103; 210 | cUnrecognizedEscSequenceCode = -104; 211 | cUnexpectedDataTypeCode = -106; 212 | 213 | var 214 | EscapeJsonStrings: Boolean = False; 215 | 216 | implementation 217 | 218 | const 219 | JsonBoolean: array[Boolean] of string = ('false', 'true'); 220 | 221 | { TclJSONBase } 222 | 223 | procedure TclJSONBase.SetValueString(const AValue: string); 224 | begin 225 | ValueWideString := WideString(AValue); 226 | end; 227 | 228 | class procedure TclJSONBase.SkipWhiteSpace(var Next: PChar); 229 | begin 230 | while (Next^ <> #0) do 231 | begin 232 | case (Next^) of 233 | #32, #9, #13, #10: 234 | else 235 | Break; 236 | end; 237 | Inc(Next); 238 | end; 239 | end; 240 | 241 | class function TclJSONBase.ParseArray(var Next: PChar): TclJSONArray; 242 | begin 243 | Result := TclJSONArray.Create(); 244 | try 245 | while (Next^ <> #0) do 246 | begin 247 | SkipWhiteSpace(Next); 248 | if (Next^ = #0) then 249 | begin 250 | raise EclJSONError.Create(cUnexpectedDataEnd, cUnexpectedDataEndCode); 251 | end; 252 | 253 | case (Next^) of 254 | ']': 255 | begin 256 | Inc(Next); 257 | Break; 258 | end; 259 | ',': 260 | begin 261 | Inc(Next); 262 | Result.Add(ParseRoot(Next)); 263 | Continue; 264 | end 265 | else 266 | begin 267 | Result.Add(ParseRoot(Next)); 268 | Continue; 269 | end; 270 | end; 271 | 272 | Inc(Next); 273 | end; 274 | except 275 | Result.Free(); 276 | raise; 277 | end; 278 | end; 279 | 280 | class function TclJSONBase.ParseName(var Next: PChar): string; 281 | var 282 | inQuote: Boolean; 283 | lastTwo: array[0..1] of Char; 284 | begin 285 | Result := ''; 286 | inQuote := False; 287 | lastTwo[0] := #0; 288 | lastTwo[1] := #0; 289 | while (Next^ <> #0) do 290 | begin 291 | SkipWhiteSpace(Next); 292 | 293 | case (Next^) of 294 | #0: Break; 295 | '"': 296 | begin 297 | if (lastTwo[0] <> '\') and (lastTwo[1] = '\') then 298 | begin 299 | Result := Result + Next^; 300 | end else 301 | begin 302 | if inQuote then 303 | begin 304 | Inc(Next); 305 | Break; 306 | end; 307 | inQuote := not inQuote; 308 | end; 309 | end 310 | else 311 | Result := Result + Next^; 312 | end; 313 | 314 | lastTwo[0] := lastTwo[1]; 315 | lastTwo[1] := Next^; 316 | Inc(Next); 317 | end; 318 | end; 319 | 320 | class function TclJSONBase.ParseObject(const AJSONString: string): TclJSONObject; 321 | var 322 | root: TclJSONBase; 323 | begin 324 | root := TclJSONBase.Parse(AJSONString); 325 | try 326 | if (root is TclJSONObject) then 327 | begin 328 | Result := TclJSONObject(root); 329 | end else 330 | begin 331 | raise EclJSONError.Create(cUnexpectedDataType, cUnexpectedDataTypeCode); 332 | end; 333 | except 334 | root.Free(); 335 | raise; 336 | end; 337 | end; 338 | 339 | class function TclJSONBase.ParsePair(var Next: PChar): TclJSONPair; 340 | begin 341 | Result := TclJSONPair.Create(); 342 | try 343 | while (Next^ <> #0) do 344 | begin 345 | SkipWhiteSpace(Next); 346 | if (Next^ = #0) then 347 | begin 348 | raise EclJSONError.Create(cUnexpectedDataEnd, cUnexpectedDataEndCode); 349 | end; 350 | 351 | if (Next^ = ':') and (Result.NameWideString = '') then 352 | begin 353 | raise EclJSONError.Create(cUnexpectedDataSymbol, cUnexpectedDataSymbolCode); 354 | end; 355 | 356 | if (Result.NameWideString = '') then 357 | begin 358 | Result.NameWideString := DecodeString(ParseName(Next)); 359 | Continue; 360 | end else 361 | if (Next^ = ':') then 362 | begin 363 | Inc(Next); 364 | Result.Value := ParseRoot(Next); 365 | Break; 366 | end else 367 | begin 368 | raise EclJSONError.Create(cUnexpectedDataSymbol, cUnexpectedDataSymbolCode); 369 | end; 370 | 371 | Inc(Next); 372 | end; 373 | except 374 | Result.Free(); 375 | raise; 376 | end; 377 | end; 378 | 379 | class function TclJSONBase.ParseObj(var Next: PChar): TclJSONObject; 380 | begin 381 | Result := TclJSONObject.Create(); 382 | try 383 | while (Next^ <> #0) do 384 | begin 385 | SkipWhiteSpace(Next); 386 | if (Next^ = #0) then 387 | begin 388 | raise EclJSONError.Create(cUnexpectedDataEnd, cUnexpectedDataEndCode); 389 | end; 390 | 391 | case (Next^) of 392 | '}': 393 | begin 394 | Inc(Next); 395 | Break; 396 | end; 397 | ',': 398 | begin 399 | Inc(Next); 400 | Result.AddMember(ParsePair(Next)); 401 | Continue; 402 | end 403 | else 404 | begin 405 | Result.AddMember(ParsePair(Next)); 406 | Continue; 407 | end; 408 | end; 409 | 410 | Inc(Next); 411 | end; 412 | except 413 | Result.Free(); 414 | raise; 415 | end; 416 | end; 417 | 418 | class function TclJSONBase.ParseValue(var Next: PChar): TclJSONBase; 419 | var 420 | inQuote, isString: Boolean; 421 | value: string; 422 | lastTwo: array[0..1] of Char; 423 | begin 424 | value := ''; 425 | inQuote := False; 426 | isString := False; 427 | lastTwo[0] := #0; 428 | lastTwo[1] := #0; 429 | while (Next^ <> #0) do 430 | begin 431 | if (not inQuote) then 432 | begin 433 | SkipWhiteSpace(Next); 434 | end; 435 | 436 | case (Next^) of 437 | #0: Break; 438 | '}', ']', ',': 439 | begin 440 | if inQuote then 441 | begin 442 | value := value + Next^; 443 | end else 444 | begin 445 | Break; 446 | end; 447 | end; 448 | '"': 449 | begin 450 | if inQuote and (lastTwo[0] <> '\') and (lastTwo[1] = '\') then 451 | begin 452 | value := value + Next^; 453 | end else 454 | begin 455 | if inQuote then 456 | begin 457 | Inc(Next); 458 | Break; 459 | end; 460 | inQuote := not inQuote; 461 | isString := True; 462 | end; 463 | end 464 | else 465 | value := value + Next^; 466 | end; 467 | 468 | lastTwo[0] := lastTwo[1]; 469 | lastTwo[1] := Next^; 470 | Inc(Next); 471 | end; 472 | 473 | Result := nil; 474 | try 475 | if isString then 476 | begin 477 | Result := TclJSONString.Create(); 478 | Result.ValueWideString := DecodeString(value); 479 | end else 480 | begin 481 | if (JsonBoolean[True] = value) then 482 | begin 483 | Result := TclJSONBoolean.Create(True); 484 | end else 485 | if (JsonBoolean[False] = value) then 486 | begin 487 | Result := TclJSONBoolean.Create(False); 488 | end else 489 | begin 490 | Result := TclJSONValue.Create(); 491 | Result.ValueWideString := value; 492 | end; 493 | end; 494 | except 495 | Result.Free(); 496 | raise; 497 | end; 498 | end; 499 | 500 | class function TclJSONBase.ParseRoot(var Next: PChar): TclJSONBase; 501 | begin 502 | Result := nil; 503 | 504 | while (Next^ <> #0) do 505 | begin 506 | SkipWhiteSpace(Next); 507 | if (Next^ = #0) then Break; 508 | 509 | case (Next^) of 510 | '{': 511 | begin 512 | Inc(Next); 513 | Result := ParseObj(Next); 514 | Break; 515 | end; 516 | '[': 517 | begin 518 | Inc(Next); 519 | Result := ParseArray(Next); 520 | Break; 521 | end 522 | else 523 | begin 524 | Result := ParseValue(Next); 525 | Break; 526 | end; 527 | end; 528 | 529 | Inc(Next); 530 | end; 531 | end; 532 | 533 | class function TclJSONBase.EncodeString(const ASource: WideString): string; 534 | var 535 | i: Integer; 536 | begin 537 | Result := '"'; 538 | 539 | for i := 1 to Length(ASource) do 540 | begin 541 | case ASource[i] of 542 | '/', '\', '"': 543 | begin 544 | Result := Result + '\' + Char(ASource[i]); 545 | end; 546 | #8: 547 | begin 548 | Result := Result + '\b'; 549 | end; 550 | #9: 551 | begin 552 | Result := Result + '\t'; 553 | end; 554 | #10: 555 | begin 556 | Result := Result + '\n'; 557 | end; 558 | #12: 559 | begin 560 | Result := Result + '\f'; 561 | end; 562 | #13: 563 | begin 564 | Result := Result + '\r'; 565 | end 566 | else 567 | begin 568 | if (not EscapeJsonStrings) or (ASource[i] >= WideChar(' ')) and (ASource[i] <= WideChar('~')) then 569 | begin 570 | Result := Result + Char(ASource[i]); 571 | end else 572 | begin 573 | Result := Result + '\u' + IntToHex(Ord(ASource[i]), 4); 574 | end; 575 | end; 576 | end; 577 | end; 578 | 579 | Result := Result + '"'; 580 | end; 581 | 582 | class function TclJSONBase.DecodeString(const ASource: string): WideString; 583 | var 584 | i, j, k, len: Integer; 585 | code: string; 586 | begin 587 | code := '$ '; 588 | len := Length(ASource); 589 | SetLength(Result, len); 590 | i := 1; 591 | j := 0; 592 | while (i <= len) do 593 | begin 594 | if (ASource[i] < ' ') then 595 | begin 596 | raise EclJSONError.Create(cInvalidControlSymbol, cInvalidControlSymbolCode); 597 | end; 598 | 599 | if (ASource[i] = '\') then 600 | Begin 601 | Inc(i); 602 | case ASource[i] of 603 | '"', '\', '/': 604 | begin 605 | Inc(j); 606 | Result[j] := WideChar(ASource[i]); 607 | Inc(i); 608 | end; 609 | 'b': 610 | begin 611 | Inc(j); 612 | Result[j] := #8; 613 | Inc(i); 614 | end; 615 | 't': 616 | begin 617 | Inc(j); 618 | Result[j] := #9; 619 | Inc(i); 620 | end; 621 | 'n': 622 | begin 623 | Inc(j); 624 | Result[j] := #10; 625 | Inc(i); 626 | end; 627 | 'f': 628 | begin 629 | Inc(j); 630 | Result[j] := #12; 631 | Inc(i); 632 | end; 633 | 'r': 634 | begin 635 | Inc(j); 636 | Result[j] := #13; 637 | Inc(i); 638 | end; 639 | 'u': 640 | begin 641 | if (i + 4 > len) then 642 | begin 643 | raise EclJSONError.Create(cInvalidUnicodeEscSequence, cInvalidUnicodeEscSequenceCode); 644 | end; 645 | 646 | for k := 1 to 4 do 647 | begin 648 | if not CharInSet(ASource[i + k], ['0'..'9', 'a'..'f', 'A'..'F']) then 649 | begin 650 | raise EclJSONError.Create(cInvalidUnicodeEscSequence, cInvalidUnicodeEscSequenceCode); 651 | end else 652 | begin 653 | code[k + 1] := ASource[i + k]; 654 | end; 655 | end; 656 | 657 | Inc(j); 658 | Inc(i, 5); 659 | Result[j] := WideChar(StrToInt(code)); 660 | end 661 | else 662 | raise EclJSONError.Create(cUnrecognizedEscSequence, cUnrecognizedEscSequenceCode); 663 | end; 664 | end else 665 | begin 666 | Inc(j); 667 | Result[j] := WideChar(ASource[i]); 668 | Inc(i); 669 | end; 670 | end; 671 | SetLength(Result, j); 672 | end; 673 | 674 | function TclJSONBase.GetJSONString: string; 675 | var 676 | buffer: TStringBuilder; 677 | begin 678 | buffer := TStringBuilder.Create(); 679 | try 680 | BuildJSONString(buffer); 681 | Result := buffer.ToString(); 682 | finally 683 | buffer.Free(); 684 | end; 685 | end; 686 | 687 | function TclJSONBase.GetValueString: string; 688 | begin 689 | Result := string(ValueWideString); 690 | end; 691 | 692 | class function TclJSONBase.Parse(const AJSONString: string): TclJSONBase; 693 | var 694 | Next: PChar; 695 | begin 696 | Result := nil; 697 | Next := @AJSONString[1]; 698 | if (Next^ = #0) then Exit; 699 | 700 | Result := ParseRoot(Next); 701 | try 702 | SkipWhiteSpace(Next); 703 | 704 | if (Next^ <> #0) then 705 | begin 706 | raise EclJSONError.Create(cUnexpectedDataSymbol, cUnexpectedDataSymbolCode); 707 | end; 708 | except 709 | Result.Free(); 710 | raise; 711 | end; 712 | end; 713 | 714 | { TclJSONObject } 715 | 716 | function TclJSONObject.AddMember(APair: TclJSONPair): TclJSONPair; 717 | begin 718 | FMembers.Add(APair); 719 | Result := APair; 720 | end; 721 | 722 | function TclJSONObject.AddMember(const AName: WideString; AValue: TclJSONBase): TclJSONPair; 723 | begin 724 | if (AValue <> nil) then 725 | begin 726 | Result := AddMember(TclJSONPair.Create()); 727 | 728 | Result.NameWideString := AName; 729 | Result.Value := AValue; 730 | end else 731 | begin 732 | Result := nil; 733 | end; 734 | end; 735 | 736 | function TclJSONObject.AddBoolean(const AName: string; AValue: Boolean): TclJSONBoolean; 737 | begin 738 | if (AValue) then 739 | begin 740 | Result := TclJSONBoolean(AddMember(AName, TclJSONBoolean.Create(AValue))); 741 | end else 742 | begin 743 | Result := nil; 744 | end; 745 | end; 746 | 747 | function TclJSONObject.AddBoolean(const AName: WideString; AValue: Boolean): TclJSONBoolean; 748 | begin 749 | if (AValue) then 750 | begin 751 | Result := TclJSONBoolean(AddMember(AName, TclJSONBoolean.Create(AValue))); 752 | end else 753 | begin 754 | Result := nil; 755 | end; 756 | end; 757 | 758 | function TclJSONObject.AddMember(const AName: string; AValue: TclJSONBase): TclJSONPair; 759 | begin 760 | if (AValue <> nil) then 761 | begin 762 | Result := AddMember(TclJSONPair.Create()); 763 | 764 | Result.Name := AName; 765 | Result.Value := AValue; 766 | end else 767 | begin 768 | Result := nil; 769 | end; 770 | end; 771 | 772 | function TclJSONObject.AddRequiredString(const AName, AValue: string): TclJSONString; 773 | begin 774 | Result := TclJSONString(AddMember(AName, TclJSONString.Create(AValue)).Value); 775 | end; 776 | 777 | function TclJSONObject.AddRequiredString(const AName, AValue: WideString): TclJSONString; 778 | begin 779 | Result := TclJSONString(AddMember(AName, TclJSONString.Create(AValue)).Value); 780 | end; 781 | 782 | function TclJSONObject.AddString(const AName, AValue: WideString): TclJSONString; 783 | begin 784 | if (AValue <> '') then 785 | begin 786 | Result := TclJSONString(AddMember(AName, TclJSONString.Create(AValue)).Value); 787 | end else 788 | begin 789 | Result := nil; 790 | end; 791 | end; 792 | 793 | function TclJSONObject.AddValue(const AName, AValue: WideString): TclJSONValue; 794 | begin 795 | if (AValue <> '') then 796 | begin 797 | Result := TclJSONValue(AddMember(AName, TclJSONValue.Create(AValue)).Value); 798 | end else 799 | begin 800 | Result := nil; 801 | end; 802 | end; 803 | 804 | function TclJSONObject.AddString(const AName, AValue: string): TclJSONString; 805 | begin 806 | if (AValue <> '') then 807 | begin 808 | Result := TclJSONString(AddMember(AName, TclJSONString.Create(AValue)).Value); 809 | end else 810 | begin 811 | Result := nil; 812 | end; 813 | end; 814 | 815 | function TclJSONObject.AddValue(const AName, AValue: string): TclJSONValue; 816 | begin 817 | if (AValue <> '') then 818 | begin 819 | Result := TclJSONValue(AddMember(AName, TclJSONValue.Create(AValue)).Value); 820 | end else 821 | begin 822 | Result := nil; 823 | end; 824 | end; 825 | 826 | function TclJSONObject.ArrayByName(const AName: WideString): TclJSONArray; 827 | var 828 | pair: TclJSONPair; 829 | begin 830 | pair := MemberByName(AName); 831 | if (pair <> nil) then 832 | begin 833 | if not (pair.Value is TclJSONArray) then 834 | begin 835 | raise EclJSONError.Create(cUnexpectedDataType, cUnexpectedDataTypeCode); 836 | end; 837 | 838 | Result := TclJSONArray(pair.Value); 839 | end else 840 | begin 841 | Result := nil; 842 | end; 843 | end; 844 | 845 | function TclJSONObject.ArrayByName(const AName: string): TclJSONArray; 846 | begin 847 | Result := ArrayByName(WideString(AName)); 848 | end; 849 | 850 | constructor TclJSONObject.Create; 851 | begin 852 | inherited Create(); 853 | FMembers := TObjectList.Create(True); 854 | end; 855 | 856 | destructor TclJSONObject.Destroy; 857 | begin 858 | FMembers.Free(); 859 | inherited Destroy(); 860 | end; 861 | 862 | function TclJSONObject.GetCount: Integer; 863 | begin 864 | Result := FMembers.Count; 865 | end; 866 | 867 | function TclJSONObject.BooleanByName(const AName: string): Boolean; 868 | begin 869 | Result := BooleanByName(WideString(AName)); 870 | end; 871 | 872 | function TclJSONObject.BooleanByName(const AName: WideString): Boolean; 873 | var 874 | pair: TclJSONPair; 875 | begin 876 | pair := MemberByName(AName); 877 | if (pair <> nil) then 878 | begin 879 | if not (pair.Value is TclJSONValue) then 880 | begin 881 | raise EclJSONError.Create(cUnexpectedDataType, cUnexpectedDataTypeCode); 882 | end; 883 | 884 | Result := (pair.ValueString = 'true'); 885 | end else 886 | begin 887 | Result := False; 888 | end; 889 | end; 890 | 891 | procedure TclJSONObject.BuildJSONString(ABuffer: TStringBuilder); 892 | const 893 | delimiter: array[Boolean] of string = ('', ', '); 894 | var 895 | i: Integer; 896 | begin 897 | ABuffer.Append('{'); 898 | 899 | for i := 0 to Count - 1 do 900 | begin 901 | ABuffer.Append(delimiter[i > 0]); 902 | ABuffer.Append(Members[i].GetJSONString()); 903 | end; 904 | 905 | ABuffer.Append('}'); 906 | end; 907 | 908 | function TclJSONObject.GetMember(Index: Integer): TclJSONPair; 909 | begin 910 | Result := TclJSONPair(FMembers[Index]); 911 | end; 912 | 913 | function TclJSONObject.GetValueWideString: WideString; 914 | begin 915 | Result := ''; 916 | end; 917 | 918 | function TclJSONObject.MemberByName(const AName: WideString): TclJSONPair; 919 | var 920 | i: Integer; 921 | begin 922 | for i := 0 to Count - 1 do 923 | begin 924 | Result := Members[i]; 925 | if (Result.NameWideString = AName) then Exit; 926 | end; 927 | Result := nil; 928 | end; 929 | 930 | function TclJSONObject.ObjectByName(const AName: WideString): TclJSONObject; 931 | var 932 | pair: TclJSONPair; 933 | begin 934 | pair := MemberByName(AName); 935 | if (pair <> nil) then 936 | begin 937 | if not (pair.Value is TclJSONObject) then 938 | begin 939 | raise EclJSONError.Create(cUnexpectedDataType, cUnexpectedDataTypeCode); 940 | end; 941 | 942 | Result := TclJSONObject(pair.Value); 943 | end else 944 | begin 945 | Result := nil; 946 | end; 947 | end; 948 | 949 | function TclJSONObject.ObjectByName(const AName: string): TclJSONObject; 950 | begin 951 | Result := ObjectByName(WideString(AName)); 952 | end; 953 | 954 | function TclJSONObject.MemberByName(const AName: string): TclJSONPair; 955 | begin 956 | Result := MemberByName(WideString(AName)); 957 | end; 958 | 959 | procedure TclJSONObject.SetValueWideString(const AValue: WideString); 960 | begin 961 | end; 962 | 963 | function TclJSONObject.ValueByName(const AName: string): string; 964 | begin 965 | Result := string(ValueByName(WideString(AName))); 966 | end; 967 | 968 | function TclJSONObject.ValueByName(const AName: WideString): WideString; 969 | var 970 | pair: TclJSONPair; 971 | begin 972 | pair := MemberByName(AName); 973 | if (pair <> nil) then 974 | begin 975 | Result := pair.ValueWideString; 976 | end else 977 | begin 978 | Result := ''; 979 | end; 980 | end; 981 | 982 | { TclJSONPair } 983 | 984 | constructor TclJSONPair.Create; 985 | begin 986 | inherited Create(); 987 | FValue := nil; 988 | end; 989 | 990 | destructor TclJSONPair.Destroy; 991 | begin 992 | SetValue(nil); 993 | inherited Destroy(); 994 | end; 995 | 996 | procedure TclJSONPair.BuildJSONString(ABuffer: TStringBuilder); 997 | begin 998 | ABuffer.Append(EncodeString(NameWideString)); 999 | ABuffer.Append(': '); 1000 | ABuffer.Append(Value.GetJSONString()); 1001 | end; 1002 | 1003 | function TclJSONPair.GetName: string; 1004 | begin 1005 | Result := string(FName); 1006 | end; 1007 | 1008 | function TclJSONPair.GetValueWideString: WideString; 1009 | begin 1010 | if (Value <> nil) then 1011 | begin 1012 | Result := Value.ValueWideString; 1013 | end else 1014 | begin 1015 | Result := ''; 1016 | end; 1017 | end; 1018 | 1019 | procedure TclJSONPair.SetName(const AValue: string); 1020 | begin 1021 | FName := WideString(AValue); 1022 | end; 1023 | 1024 | procedure TclJSONPair.SetValue(const AValue: TclJSONBase); 1025 | begin 1026 | FValue.Free(); 1027 | FValue := AValue; 1028 | end; 1029 | 1030 | procedure TclJSONPair.SetValueWideString(const AValue: WideString); 1031 | begin 1032 | if (Value <> nil) then 1033 | begin 1034 | Value.ValueWideString := AValue; 1035 | end; 1036 | end; 1037 | 1038 | { TclJSONArray } 1039 | 1040 | function TclJSONArray.Add(AItem: TclJSONBase): TclJSONBase; 1041 | begin 1042 | if (AItem <> nil) then 1043 | begin 1044 | FItems.Add(AItem); 1045 | end; 1046 | Result := AItem; 1047 | end; 1048 | 1049 | constructor TclJSONArray.Create; 1050 | begin 1051 | inherited Create(); 1052 | FItems := TObjectList.Create(True); 1053 | end; 1054 | 1055 | destructor TclJSONArray.Destroy; 1056 | begin 1057 | FItems.Free(); 1058 | inherited Destroy(); 1059 | end; 1060 | 1061 | function TclJSONArray.GetCount: Integer; 1062 | begin 1063 | Result := FItems.Count; 1064 | end; 1065 | 1066 | function TclJSONArray.GetItem(Index: Integer): TclJSONBase; 1067 | begin 1068 | Result := TclJSONBase(FItems[Index]); 1069 | end; 1070 | 1071 | function TclJSONArray.GetObject(Index: Integer): TclJSONObject; 1072 | var 1073 | item: TclJSONBase; 1074 | begin 1075 | item := Items[Index]; 1076 | if not (item is TclJSONObject) then 1077 | begin 1078 | raise EclJSONError.Create(cUnexpectedDataType, cUnexpectedDataTypeCode); 1079 | end; 1080 | Result := TclJSONObject(item); 1081 | end; 1082 | 1083 | procedure TclJSONArray.BuildJSONString(ABuffer: TStringBuilder); 1084 | const 1085 | delimiter: array[Boolean] of string = ('', ', '); 1086 | var 1087 | i: Integer; 1088 | begin 1089 | ABuffer.Append('['); 1090 | 1091 | for i := 0 to Count - 1 do 1092 | begin 1093 | ABuffer.Append(delimiter[i > 0]); 1094 | ABuffer.Append(Items[i].GetJSONString()); 1095 | end; 1096 | 1097 | ABuffer.Append(']'); 1098 | end; 1099 | 1100 | function TclJSONArray.GetValueWideString: WideString; 1101 | begin 1102 | Result := ''; 1103 | end; 1104 | 1105 | procedure TclJSONArray.SetValueWideString(const AValue: WideString); 1106 | begin 1107 | end; 1108 | 1109 | { TclJSONValue } 1110 | 1111 | constructor TclJSONValue.Create(const AValue: string); 1112 | begin 1113 | inherited Create(); 1114 | ValueString := AValue; 1115 | end; 1116 | 1117 | constructor TclJSONValue.Create(const AValue: WideString); 1118 | begin 1119 | inherited Create(); 1120 | ValueWideString := AValue; 1121 | end; 1122 | 1123 | constructor TclJSONValue.Create; 1124 | begin 1125 | inherited Create(); 1126 | FValue := ''; 1127 | end; 1128 | 1129 | procedure TclJSONValue.BuildJSONString(ABuffer: TStringBuilder); 1130 | begin 1131 | ABuffer.Append(ValueString); 1132 | end; 1133 | 1134 | function TclJSONValue.GetValueWideString: WideString; 1135 | begin 1136 | Result := FValue; 1137 | end; 1138 | 1139 | procedure TclJSONValue.SetValueWideString(const AValue: WideString); 1140 | begin 1141 | FValue := AValue; 1142 | end; 1143 | 1144 | { TclJSONString } 1145 | procedure TclJSONString.BuildJSONString(ABuffer: TStringBuilder); 1146 | begin 1147 | ABuffer.Append(EncodeString(ValueWideString)); 1148 | end; 1149 | 1150 | { EclJSONError } 1151 | 1152 | constructor EclJSONError.Create(const AErrorMsg: string; AErrorCode: Integer; ADummy: Boolean); 1153 | begin 1154 | inherited Create(AErrorMsg); 1155 | FErrorCode := AErrorCode; 1156 | end; 1157 | 1158 | { TclJSONBoolean } 1159 | 1160 | constructor TclJSONBoolean.Create; 1161 | begin 1162 | inherited Create(); 1163 | Value := False; 1164 | end; 1165 | 1166 | constructor TclJSONBoolean.Create(AValue: Boolean); 1167 | begin 1168 | inherited Create(); 1169 | Value := AValue; 1170 | end; 1171 | 1172 | function TclJSONBoolean.GetValue: Boolean; 1173 | begin 1174 | Result := (JsonBoolean[True] = ValueWideString); 1175 | end; 1176 | 1177 | procedure TclJSONBoolean.SetValue(const Value: Boolean); 1178 | begin 1179 | ValueWideString := JsonBoolean[Value]; 1180 | end; 1181 | 1182 | procedure TclJSONBoolean.SetValueWideString(const AValue: WideString); 1183 | begin 1184 | if (JsonBoolean[True] = AValue) then 1185 | begin 1186 | inherited SetValueWideString(JsonBoolean[True]); 1187 | end else 1188 | begin 1189 | inherited SetValueWideString(JsonBoolean[False]); 1190 | end; 1191 | end; 1192 | 1193 | end. 1194 | -------------------------------------------------------------------------------- /json/clJsonSerializer.pas: -------------------------------------------------------------------------------- 1 | { 2 | Copyright (C) 2016 by Clever Components 3 | 4 | Author: Sergey Shirokov 5 | 6 | Website: www.CleverComponents.com 7 | 8 | This file is part of Json Serializer. 9 | 10 | Json Serializer is free software: you can redistribute it and/or modify 11 | it under the terms of the GNU Lesser General Public License version 3 12 | as published by the Free Software Foundation and appearing in the 13 | included file COPYING.LESSER. 14 | 15 | Json Serializer is distributed in the hope that it will be useful, 16 | but WITHOUT ANY WARRANTY; without even the implied warranty of 17 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18 | GNU Lesser General Public License for more details. 19 | 20 | You should have received a copy of the GNU Lesser General Public License 21 | along with Json Serializer. If not, see . 22 | } 23 | 24 | unit clJsonSerializer; 25 | 26 | interface 27 | 28 | uses 29 | System.Classes, System.SysUtils, System.Generics.Collections, System.Rtti, System.TypInfo, clJsonSerializerBase, clJsonParser; 30 | 31 | type 32 | TclJsonTypeNameMapAttributeList = TArray; 33 | 34 | TclJsonSerializer = class(TclJsonSerializerBase) 35 | strict private 36 | procedure GetTypeAttributes(AType: TRttiType; var ATypeNameAttrs: TclJsonTypeNameMapAttributeList); 37 | procedure GetPropertyAttributes(AProp: TRttiProperty; var APropAttr: TclJsonPropertyAttribute; 38 | var ARequiredAttr: TclJsonRequiredAttribute); 39 | function GetObjectClass(ATypeNameAttrs: TclJsonTypeNameMapAttributeList; AJsonObject: TclJSONObject): TRttiType; 40 | function EnumNameToTValue(const Name: string; AProperty: TRttiProperty; EnumType: PTypeInfo): TValue; 41 | function EnumTValueToName(AValue: TValue; AProperty: TRttiProperty): string; 42 | 43 | procedure SerializeArray(AProperty: TRttiProperty; AObject: TObject; 44 | Attribute: TclJsonPropertyAttribute; AJson: TclJsonObject); 45 | procedure SerializeMap(AProperty: TRttiProperty; AObject: TObject; 46 | Attribute: TclJsonPropertyAttribute; AJson: TclJsonObject); 47 | procedure SerializeList(AProperty: TRttiProperty; AObject: TObject; 48 | Attribute: TclJsonPropertyAttribute; AJson: TclJsonObject); 49 | 50 | procedure DeserializeArray(AProperty: TRttiProperty; AObject: TObject; AJsonArray: TclJSONArray); 51 | procedure DeserializeMap(AProperty: TRttiProperty; AObject: TObject; AJsonObject: TclJSONObject); 52 | procedure DeserializeList(AProperty: TRttiProperty; AObject: TObject; AJsonArray: TclJSONArray); 53 | 54 | function Deserialize(ATypeInfo: PTypeInfo; const AJson: TclJSONObject): TObject; overload; 55 | function Deserialize(AType: TClass; const AJson: TclJSONObject): TObject; overload; 56 | function Deserialize(AObject: TObject; const AJson: TclJSONObject): TObject; overload; 57 | function Serialize(AObject: TObject): TclJSONObject; 58 | strict protected 59 | procedure SortMapKeys(var AKeyArray: TValue); virtual; 60 | public 61 | function JsonToObject(AType: TClass; const AJson: string): TObject; overload; override; 62 | function JsonToObject(AObject: TObject; const AJson: string): TObject; overload; override; 63 | function JsonToObject(const AJson: string): T; overload; 64 | function ObjectToJson(AObject: TObject): string; override; 65 | end; 66 | 67 | resourcestring 68 | cUnsupportedDataType = 'Unsupported data type'; 69 | cDictionaryRequired = 'Dictionary type is required to serialize object maps'; 70 | cObjectListRequired = 'ObjectList type is required to serialize object arrays'; 71 | cNonSerializable = 'The object is not serializable'; 72 | 73 | implementation 74 | 75 | { TclJsonSerializer } 76 | 77 | function TclJsonSerializer.GetObjectClass(ATypeNameAttrs: TclJsonTypeNameMapAttributeList; AJsonObject: TclJSONObject): TRttiType; 78 | var 79 | ctx: TRttiContext; 80 | typeName: string; 81 | attr: TclJsonTypeNameMapAttribute; 82 | begin 83 | Result := nil; 84 | if (ATypeNameAttrs = nil) or (Length(ATypeNameAttrs) = 0) then Exit; 85 | 86 | typeName := AJsonObject.ValueByName(ATypeNameAttrs[0].PropertyName); 87 | if (typeName = '') then Exit; 88 | 89 | ctx := TRttiContext.Create(); 90 | try 91 | for attr in ATypeNameAttrs do 92 | begin 93 | if (attr.TypeName = typeName) then 94 | begin 95 | Result := ctx.FindType(attr.TypeClassName); 96 | Exit; 97 | end; 98 | end; 99 | finally 100 | ctx.Free() 101 | end; 102 | end; 103 | 104 | function TclJsonSerializer.Deserialize(ATypeInfo: PTypeInfo; const AJson: TclJSONObject): TObject; 105 | var 106 | ctx: TRttiContext; 107 | lType, rType: TRttiType; 108 | instType: TRttiInstanceType; 109 | rValue: TValue; 110 | typeNameAttrs: TclJsonTypeNameMapAttributeList; 111 | begin 112 | Result := nil; 113 | if (AJson.Count = 0) then Exit; 114 | 115 | ctx := TRttiContext.Create(); 116 | try 117 | rType := ctx.GetType(ATypeInfo); 118 | 119 | GetTypeAttributes(rType, typeNameAttrs); 120 | lType := GetObjectClass(typeNameAttrs, AJson); 121 | if (lType = nil) then 122 | begin 123 | lType := rType; 124 | end; 125 | instType := lType.AsInstance; 126 | rValue := instType.GetMethod('Create').Invoke(instType.MetaclassType, []); 127 | 128 | Result := rValue.AsObject(); 129 | try 130 | Result := Deserialize(Result, AJson); 131 | except 132 | Result.Free(); 133 | raise; 134 | end; 135 | finally 136 | ctx.Free(); 137 | end; 138 | end; 139 | 140 | procedure TclJsonSerializer.DeserializeArray(AProperty: TRttiProperty; 141 | AObject: TObject; AJsonArray: TclJSONArray); 142 | var 143 | elType: PTypeInfo; 144 | len: NativeInt; 145 | pArr: Pointer; 146 | rValue, rItemValue: TValue; 147 | i: Integer; 148 | objClass: TClass; 149 | begin 150 | len := AJsonArray.Count; 151 | if (len = 0) then Exit; 152 | 153 | if (GetTypeData(AProperty.PropertyType.Handle).DynArrElType = nil) then Exit; 154 | 155 | elType := GetTypeData(AProperty.PropertyType.Handle).DynArrElType^; 156 | 157 | pArr := nil; 158 | 159 | DynArraySetLength(pArr, AProperty.PropertyType.Handle, 1, @len); 160 | try 161 | TValue.Make(@pArr, AProperty.PropertyType.Handle, rValue); 162 | 163 | for i := 0 to len - 1 do 164 | begin 165 | if (elType.Kind = tkClass) 166 | and (AJsonArray.Items[i] is TclJSONObject) then 167 | begin 168 | objClass := elType.TypeData.ClassType; 169 | rItemValue := Deserialize(objClass, TclJSONObject(AJsonArray.Items[i])); 170 | end else 171 | if (elType.Kind in [tkString, tkLString, tkWString, tkUString]) then 172 | begin 173 | rItemValue := AJsonArray.Items[i].ValueString; 174 | end else 175 | if (elType.Kind = tkInteger) then 176 | begin 177 | rItemValue := StrToInt(AJsonArray.Items[i].ValueString); 178 | end else 179 | if (elType.Kind = tkInt64) then 180 | begin 181 | rItemValue := StrToInt64(AJsonArray.Items[i].ValueString); 182 | end else 183 | if (elType.Kind = tkEnumeration) 184 | and (elType = System.TypeInfo(Boolean)) 185 | and (AJsonArray.Items[i] is TclJSONBoolean) then 186 | begin 187 | rItemValue := TclJSONBoolean(AJsonArray.Items[i]).Value; 188 | end else 189 | if (elType.Kind = tkEnumeration) 190 | and (AJsonArray.Items[i] is TclJSONValue) then 191 | begin 192 | rItemValue := EnumNameToTValue(AJsonArray.Items[i].ValueString, AProperty, elType); 193 | end else 194 | begin 195 | raise EclJsonSerializerError.Create(cUnsupportedDataType); 196 | end; 197 | 198 | rValue.SetArrayElement(i, rItemValue); 199 | end; 200 | 201 | AProperty.SetValue(AObject, rValue); 202 | finally 203 | DynArrayClear(pArr, AProperty.PropertyType.Handle); 204 | end; 205 | end; 206 | 207 | procedure TclJsonSerializer.DeserializeList(AProperty: TRttiProperty; AObject: TObject; AJsonArray: TclJSONArray); 208 | var 209 | i: Integer; 210 | listType: TRttiInstanceType; 211 | objectList, itemValue: TValue; 212 | addMethod: TRttiMethod; 213 | itemType: TRttiType; 214 | itemClass: TClass; 215 | begin 216 | if (AJsonArray.Count = 0) then Exit; 217 | 218 | listType := AProperty.PropertyType.AsInstance; 219 | addMethod := listType.GetMethod('Add'); 220 | 221 | if (addMethod = nil) then 222 | begin 223 | raise EclJsonSerializerError.Create(cObjectListRequired); 224 | end; 225 | 226 | itemType := addMethod.GetParameters[0].ParamType; 227 | itemClass := itemType.Handle^.TypeData.ClassType; 228 | 229 | objectList := listType.GetMethod('Create').Invoke(listType.MetaclassType, [True]); 230 | AProperty.SetValue(AObject, objectList); 231 | 232 | for i := 0 to AJsonArray.Count - 1 do 233 | begin 234 | if not (AJsonArray.Items[i] is TclJSONObject) then 235 | begin 236 | raise EclJsonSerializerError.Create(cUnsupportedDataType); 237 | end; 238 | 239 | itemValue := Deserialize(itemClass, TclJSONObject(AJsonArray.Items[i])); 240 | 241 | addMethod.Invoke(objectList, [itemValue]); 242 | end; 243 | end; 244 | 245 | procedure TclJsonSerializer.DeserializeMap(AProperty: TRttiProperty; 246 | AObject: TObject; AJsonObject: TclJSONObject); 247 | var 248 | i: Integer; 249 | dictType: TRttiInstanceType; 250 | mapName, mapObject, 251 | dictionary, dictOwnerships: TValue; 252 | addMethod: TRttiMethod; 253 | itemType: TRttiType; 254 | itemClass: TClass; 255 | begin 256 | if (AJsonObject.Count = 0) then Exit; 257 | 258 | //TODO deserialize non-object types, including dynarrays 259 | dictOwnerships := TValue.From([doOwnsValues]); 260 | dictType := AProperty.PropertyType.AsInstance; 261 | 262 | addMethod := dictType.GetMethod('Add'); 263 | 264 | if (addMethod = nil) then 265 | begin 266 | raise EclJsonSerializerError.Create(cDictionaryRequired); 267 | end; 268 | 269 | itemType := addMethod.GetParameters[1].ParamType; 270 | //TODO deserialize non-object types, including dynarrays 271 | itemClass := itemType.Handle^.TypeData.ClassType; 272 | 273 | //TODO deserialize non-object types, including dynarrays 274 | dictionary := dictType.GetMethod('Create').Invoke(dictType.MetaclassType, [dictOwnerships, 0]); 275 | AProperty.SetValue(AObject, dictionary); 276 | 277 | for i := 0 to AJsonObject.Count - 1 do 278 | begin 279 | if not (AJsonObject.Members[i].Value is TclJSONObject) then Continue; 280 | 281 | mapName := AJsonObject.Members[i].Name; 282 | //TODO deserialize non-object types, including dynarrays 283 | mapObject := Deserialize(itemClass, TclJSONObject(AJsonObject.Members[i].Value)); 284 | 285 | addMethod.Invoke(dictionary, [mapName, mapObject]); 286 | end; 287 | end; 288 | 289 | function TclJsonSerializer.EnumNameToTValue(const Name: string; 290 | AProperty: TRttiProperty; EnumType: PTypeInfo): TValue; 291 | var 292 | attr: TCustomAttribute; 293 | names: TArray; 294 | t: TRttiType; 295 | V: integer; 296 | begin 297 | if (AProperty.PropertyType is TRttiDynamicArrayType) then 298 | begin 299 | t := TRttiDynamicArrayType(AProperty.PropertyType).ElementType; 300 | end else 301 | if (AProperty.PropertyType is TRttiArrayType) then 302 | begin 303 | t := TRttiArrayType(AProperty.PropertyType).ElementType; 304 | end else 305 | begin 306 | t := AProperty.PropertyType; 307 | end; 308 | 309 | for attr in t.GetAttributes() do 310 | begin 311 | if (attr is TclJsonEnumNamesAttribute) then 312 | begin 313 | names := TclJsonEnumNamesAttribute(attr).Names; 314 | for V := Low(names) to High(names) do 315 | begin 316 | if (Name = names[V]) then 317 | begin 318 | TValue.Make(V, EnumType, Result); 319 | Exit; 320 | end; 321 | end; 322 | end; 323 | end; 324 | 325 | V:= GetEnumValue(EnumType, Name); 326 | TValue.Make(V, EnumType, Result); 327 | end; 328 | 329 | function TclJsonSerializer.EnumTValueToName(AValue: TValue; AProperty: TRttiProperty): string; 330 | var 331 | attr: TCustomAttribute; 332 | names: TArray; 333 | t: TRttiType; 334 | begin 335 | if (AProperty.PropertyType is TRttiDynamicArrayType) then 336 | begin 337 | t := TRttiDynamicArrayType(AProperty.PropertyType).ElementType; 338 | end else 339 | if (AProperty.PropertyType is TRttiArrayType) then 340 | begin 341 | t := TRttiArrayType(AProperty.PropertyType).ElementType; 342 | end else 343 | begin 344 | t := AProperty.PropertyType; 345 | end; 346 | 347 | for attr in t.GetAttributes() do 348 | begin 349 | if (attr is TclJsonEnumNamesAttribute) then 350 | begin 351 | names := TclJsonEnumNamesAttribute(attr).Names; 352 | if Length(names) > 0 then 353 | begin 354 | Result := names[AValue.AsOrdinal()]; 355 | end; 356 | Exit; 357 | end; 358 | end; 359 | 360 | Result := AValue.ToString(); 361 | end; 362 | 363 | function TclJsonSerializer.JsonToObject(AObject: TObject; const AJson: string): TObject; 364 | var 365 | obj: TclJSONObject; 366 | begin 367 | obj := TclJSONBase.ParseObject(AJson); 368 | try 369 | Result := Deserialize(AObject, obj); 370 | finally 371 | obj.Free(); 372 | end; 373 | end; 374 | 375 | function TclJsonSerializer.JsonToObject(const AJson: string): T; 376 | var 377 | obj: TclJSONObject; 378 | begin 379 | obj := TclJSONBase.ParseObject(AJson); 380 | try 381 | Result := TValue.From(Deserialize(TypeInfo(T), obj)).AsType; 382 | finally 383 | obj.Free(); 384 | end; 385 | end; 386 | 387 | function TclJsonSerializer.JsonToObject(AType: TClass; const AJson: string): TObject; 388 | var 389 | obj: TclJSONObject; 390 | begin 391 | obj := TclJSONBase.ParseObject(AJson); 392 | try 393 | Result := Deserialize(AType, obj); 394 | finally 395 | obj.Free(); 396 | end; 397 | end; 398 | 399 | function TclJsonSerializer.ObjectToJson(AObject: TObject): string; 400 | var 401 | json: TclJSONObject; 402 | begin 403 | json := Serialize(AObject); 404 | try 405 | Result := json.GetJSONString(); 406 | finally 407 | json.Free(); 408 | end; 409 | end; 410 | 411 | function TclJsonSerializer.Deserialize(AType: TClass; const AJson: TclJSONObject): TObject; 412 | var 413 | ctx: TRttiContext; 414 | lType, rType: TRttiType; 415 | instType: TRttiInstanceType; 416 | rValue: TValue; 417 | typeNameAttrs: TclJsonTypeNameMapAttributeList; 418 | begin 419 | Result := nil; 420 | if (AJson.Count = 0) then Exit; 421 | 422 | ctx := TRttiContext.Create(); 423 | try 424 | rType := ctx.GetType(AType); 425 | 426 | GetTypeAttributes(rType, typeNameAttrs); 427 | lType := GetObjectClass(typeNameAttrs, AJson); 428 | if (lType = nil) then 429 | begin 430 | lType := rType; 431 | end; 432 | instType := lType.AsInstance; 433 | rValue := instType.GetMethod('Create').Invoke(instType.MetaclassType, []); 434 | 435 | Result := rValue.AsObject(); 436 | try 437 | Result := Deserialize(Result, AJson); 438 | except 439 | Result.Free(); 440 | raise; 441 | end; 442 | finally 443 | ctx.Free(); 444 | end; 445 | end; 446 | 447 | function TclJsonSerializer.Deserialize(AObject: TObject; const AJson: TclJSONObject): TObject; 448 | var 449 | ctx: TRttiContext; 450 | rType: TRttiType; 451 | rProp: TRttiProperty; 452 | member: TclJSONPair; 453 | rValue: TValue; 454 | objClass: TClass; 455 | nonSerializable: Boolean; 456 | requiredAttr: TclJsonRequiredAttribute; 457 | propAttr: TclJsonPropertyAttribute; 458 | begin 459 | Result := AObject; 460 | 461 | if (AJson.Count = 0) or (Result = nil) then Exit; 462 | 463 | nonSerializable := True; 464 | 465 | ctx := TRttiContext.Create(); 466 | try 467 | rType := ctx.GetType(Result.ClassInfo); 468 | 469 | for rProp in rType.GetProperties() do 470 | begin 471 | GetPropertyAttributes(rProp, propAttr, requiredAttr); 472 | 473 | if (propAttr <> nil) then 474 | begin 475 | nonSerializable := False; 476 | 477 | member := AJson.MemberByName(TclJsonPropertyAttribute(propAttr).Name); 478 | if (member = nil) then Continue; 479 | 480 | if (rProp.PropertyType.TypeKind = tkDynArray) 481 | and (member.Value is TclJSONArray) then 482 | begin 483 | DeserializeArray(rProp, Result, TclJSONArray(member.Value)); 484 | end else 485 | if (rProp.PropertyType.TypeKind = tkClass) 486 | and (propAttr is TclJsonMapAttribute) then 487 | begin 488 | DeserializeMap(rProp, Result, TclJSONObject(member.Value)); 489 | end else 490 | if (rProp.PropertyType.TypeKind = tkClass) 491 | and (propAttr is TclJsonListAttribute) then 492 | begin 493 | DeserializeList(rProp, Result, TclJSONArray(member.Value)); 494 | end else 495 | if (rProp.PropertyType.TypeKind = tkClass) 496 | and (member.Value is TclJSONObject) then 497 | begin 498 | objClass := rProp.PropertyType.Handle^.TypeData.ClassType; 499 | rValue := Deserialize(objClass, TclJSONObject(member.Value)); 500 | rProp.SetValue(Result, rValue); 501 | end else 502 | if (rProp.PropertyType.TypeKind in [tkString, tkLString, tkWString, tkUString]) then 503 | begin 504 | rValue := member.ValueString; 505 | rProp.SetValue(Result, rValue); 506 | end else 507 | if (rProp.PropertyType.TypeKind = tkInteger) then 508 | begin 509 | rValue := StrToInt(member.ValueString); 510 | rProp.SetValue(Result, rValue); 511 | end else 512 | if (rProp.PropertyType.TypeKind = tkInt64) then 513 | begin 514 | rValue := StrToInt64(member.ValueString); 515 | rProp.SetValue(Result, rValue); 516 | end else 517 | if (rProp.PropertyType.TypeKind = tkEnumeration) 518 | and (rProp.GetValue(Result).TypeInfo = System.TypeInfo(Boolean)) 519 | and (member.Value is TclJSONBoolean) then 520 | begin 521 | rValue := TclJSONBoolean(member.Value).Value; 522 | rProp.SetValue(Result, rValue); 523 | end else 524 | if (rProp.PropertyType.TypeKind = tkEnumeration) 525 | and (rProp.GetValue(Result).TypeInfo.Kind = tkEnumeration) 526 | and (member.Value is TclJSONValue) then 527 | begin 528 | rValue := EnumNameToTValue(member.ValueString, rProp, rProp.GetValue(Result).TypeInfo); 529 | rProp.SetValue(Result, rValue); 530 | end else 531 | begin 532 | raise EclJsonSerializerError.Create(cUnsupportedDataType); 533 | end; 534 | end; 535 | end; 536 | finally 537 | ctx.Free(); 538 | end; 539 | 540 | if (nonSerializable) then 541 | begin 542 | raise EclJsonSerializerError.Create(cNonSerializable); 543 | end; 544 | end; 545 | 546 | procedure TclJsonSerializer.GetPropertyAttributes(AProp: TRttiProperty; var APropAttr: TclJsonPropertyAttribute; 547 | var ARequiredAttr: TclJsonRequiredAttribute); 548 | var 549 | attr: TCustomAttribute; 550 | begin 551 | APropAttr := nil; 552 | ARequiredAttr := nil; 553 | 554 | for attr in AProp.GetAttributes() do 555 | begin 556 | if (attr is TclJsonPropertyAttribute) then 557 | begin 558 | APropAttr := attr as TclJsonPropertyAttribute; 559 | end else 560 | if (attr is TclJsonRequiredAttribute) then 561 | begin 562 | ARequiredAttr := attr as TclJsonRequiredAttribute; 563 | end; 564 | end; 565 | end; 566 | 567 | procedure TclJsonSerializer.GetTypeAttributes(AType: TRttiType; var ATypeNameAttrs: TclJsonTypeNameMapAttributeList); 568 | var 569 | attr: TCustomAttribute; 570 | list: TList; 571 | begin 572 | list := TList.Create(); 573 | try 574 | for attr in AType.GetAttributes() do 575 | begin 576 | if (attr is TclJsonTypeNameMapAttribute) then 577 | begin 578 | list.Add(attr as TclJsonTypeNameMapAttribute); 579 | end; 580 | end; 581 | ATypeNameAttrs := list.ToArray(); 582 | finally 583 | list.Free(); 584 | end; 585 | end; 586 | 587 | function TclJsonSerializer.Serialize(AObject: TObject): TclJSONObject; 588 | var 589 | ctx: TRttiContext; 590 | rType: TRttiType; 591 | rProp: TRttiProperty; 592 | nonSerializable: Boolean; 593 | requiredAttr: TclJsonRequiredAttribute; 594 | propAttr: TclJsonPropertyAttribute; 595 | begin 596 | if (AObject = nil) then 597 | begin 598 | Result := nil; 599 | Exit; 600 | end; 601 | 602 | nonSerializable := True; 603 | 604 | ctx := TRttiContext.Create(); 605 | try 606 | Result := TclJSONObject.Create(); 607 | try 608 | rType := ctx.GetType(AObject.ClassInfo); 609 | for rProp in rType.GetProperties() do 610 | begin 611 | GetPropertyAttributes(rProp, propAttr, requiredAttr); 612 | 613 | if (propAttr <> nil) then 614 | begin 615 | nonSerializable := False; 616 | 617 | if (rProp.PropertyType.TypeKind = tkDynArray) then 618 | begin 619 | SerializeArray(rProp, AObject, TclJsonPropertyAttribute(propAttr), Result); 620 | end else 621 | if (rProp.PropertyType.TypeKind = tkClass) 622 | and (propAttr is TclJsonMapAttribute) then 623 | begin 624 | SerializeMap(rProp, AObject, TclJsonPropertyAttribute(propAttr), Result); 625 | end else 626 | if (rProp.PropertyType.TypeKind = tkClass) 627 | and (propAttr is TclJsonListAttribute) then 628 | begin 629 | SerializeList(rProp, AObject, TclJsonPropertyAttribute(propAttr), Result); 630 | end else 631 | if (rProp.PropertyType.TypeKind = tkClass) then 632 | begin 633 | Result.AddMember(TclJsonPropertyAttribute(propAttr).Name, Serialize(rProp.GetValue(AObject).AsObject())); 634 | end else 635 | if (rProp.PropertyType.TypeKind in [tkString, tkLString, tkWString, tkUString]) then 636 | begin 637 | if (propAttr is TclJsonStringAttribute) then 638 | begin 639 | if (requiredAttr <> nil) then 640 | begin 641 | Result.AddRequiredString(TclJsonPropertyAttribute(propAttr).Name, rProp.GetValue(AObject).AsString()); 642 | end else 643 | begin 644 | Result.AddString(TclJsonPropertyAttribute(propAttr).Name, rProp.GetValue(AObject).AsString()); 645 | end; 646 | end else 647 | begin 648 | Result.AddValue(TclJsonPropertyAttribute(propAttr).Name, rProp.GetValue(AObject).AsString()); 649 | end; 650 | end else 651 | if (rProp.PropertyType.TypeKind in [tkInteger, tkInt64]) then 652 | begin 653 | Result.AddValue(TclJsonPropertyAttribute(propAttr).Name, rProp.GetValue(AObject).ToString()); 654 | end else 655 | if (rProp.PropertyType.TypeKind = tkEnumeration) 656 | and (rProp.GetValue(AObject).TypeInfo = System.TypeInfo(Boolean)) then 657 | begin 658 | Result.AddBoolean(TclJsonPropertyAttribute(propAttr).Name, rProp.GetValue(AObject).AsBoolean()); 659 | end else 660 | if (rProp.PropertyType.TypeKind = tkEnumeration) then 661 | begin 662 | Result.AddValue(TclJsonPropertyAttribute(propAttr).Name, 663 | EnumTValueToName(rProp.GetValue(AObject), rProp)); 664 | end else 665 | begin 666 | raise EclJsonSerializerError.Create(cUnsupportedDataType); 667 | end; 668 | end; 669 | end; 670 | 671 | if (nonSerializable) then 672 | begin 673 | raise EclJsonSerializerError.Create(cNonSerializable); 674 | end; 675 | except 676 | Result.Free(); 677 | raise; 678 | end; 679 | finally 680 | ctx.Free(); 681 | end; 682 | end; 683 | 684 | procedure TclJsonSerializer.SerializeArray(AProperty: TRttiProperty; AObject: TObject; 685 | Attribute: TclJsonPropertyAttribute; AJson: TclJsonObject); 686 | var 687 | rValue: TValue; 688 | i: Integer; 689 | arr: TclJSONArray; 690 | begin 691 | rValue := AProperty.GetValue(AObject); 692 | 693 | if (rValue.GetArrayLength() > 0) then 694 | begin 695 | arr := TclJSONArray.Create(); 696 | AJson.AddMember(Attribute.Name, arr); 697 | 698 | for i := 0 to rValue.GetArrayLength() - 1 do 699 | begin 700 | if (rValue.GetArrayElement(i).Kind = tkClass) then 701 | begin 702 | arr.Add(Serialize(rValue.GetArrayElement(i).AsObject())); 703 | end else 704 | if (rValue.GetArrayElement(i).Kind in [tkString, tkLString, tkWString, tkUString]) then 705 | begin 706 | if (Attribute is TclJsonStringAttribute) then 707 | begin 708 | arr.Add(TclJSONString.Create(rValue.GetArrayElement(i).AsString())); 709 | end else 710 | begin 711 | arr.Add(TclJSONValue.Create(rValue.GetArrayElement(i).AsString())); 712 | end; 713 | end else 714 | if (rValue.GetArrayElement(i).Kind in [tkInteger, tkInt64]) then 715 | begin 716 | arr.Add(TclJSONValue.Create(rValue.GetArrayElement(i).ToString())); 717 | end else 718 | if (rValue.GetArrayElement(i).Kind = tkEnumeration) 719 | and (rValue.GetArrayElement(i).TypeInfo = System.TypeInfo(Boolean)) then 720 | begin 721 | arr.Add(TclJSONBoolean.Create(rValue.GetArrayElement(i).AsBoolean())); 722 | end else 723 | if (rValue.GetArrayElement(i).Kind = tkEnumeration) then 724 | begin 725 | arr.Add(TclJSONValue.Create( 726 | EnumTValueToName(rValue.GetArrayElement(i), AProperty))); 727 | end else 728 | begin 729 | raise EclJsonSerializerError.Create(cUnsupportedDataType); 730 | end; 731 | end; 732 | end; 733 | end; 734 | 735 | procedure TclJsonSerializer.SerializeList(AProperty: TRttiProperty; 736 | AObject: TObject; Attribute: TclJsonPropertyAttribute; AJson: TclJsonObject); 737 | var 738 | i, count: Integer; 739 | objectList, value: TValue; 740 | listType: TRttiType; 741 | countProp: TRttiProperty; 742 | itemsProp: TRttiIndexedProperty; 743 | arr: TclJSONArray; 744 | begin 745 | objectList := AProperty.GetValue(AObject); 746 | 747 | listType := AProperty.PropertyType.AsInstance; 748 | countProp := listType.GetProperty('Count'); 749 | itemsProp := listType.GetIndexedProperty('Items'); 750 | 751 | if (countProp = nil) or (itemsProp = nil) then 752 | begin 753 | raise EclJsonSerializerError.Create(cObjectListRequired); 754 | end; 755 | 756 | count := countProp.GetValue(objectList.AsObject()).AsInteger; 757 | if (count = 0) then Exit; 758 | 759 | arr := TclJSONArray.Create(); 760 | AJson.AddMember(Attribute.Name, arr); 761 | 762 | for i := 0 to count - 1 do 763 | begin 764 | value := itemsProp.GetValue(objectList.AsObject(), [i]); 765 | if (value.Kind <> tkClass) then 766 | begin 767 | raise EclJsonSerializerError.Create(cUnsupportedDataType); 768 | end; 769 | 770 | arr.Add(Serialize(value.AsObject())); 771 | end; 772 | end; 773 | 774 | procedure TclJsonSerializer.SortMapKeys(var AKeyArray: TValue); 775 | begin 776 | TArray.Sort(AKeyArray.AsType>()); 777 | end; 778 | 779 | procedure TclJsonSerializer.SerializeMap(AProperty: TRttiProperty; 780 | AObject: TObject; Attribute: TclJsonPropertyAttribute; AJson: TclJsonObject); 781 | var 782 | dictionary, keys, keyArray, key, value: TValue; 783 | dictType, keysType: TRttiType; 784 | keysProp: TRttiProperty; 785 | itemsProp: TRttiIndexedProperty; 786 | toArrayMethod: TRttiMethod; 787 | count, i: Integer; 788 | map: TclJsonObject; 789 | begin 790 | dictionary := AProperty.GetValue(AObject); 791 | 792 | dictType := AProperty.PropertyType.AsInstance; 793 | keysProp := dictType.GetProperty('Keys'); 794 | itemsProp := dictType.GetIndexedProperty('Items'); 795 | 796 | if (keysProp = nil) or (itemsProp = nil) then 797 | begin 798 | raise EclJsonSerializerError.Create(cDictionaryRequired); 799 | end; 800 | 801 | keysType := keysProp.PropertyType.AsInstance; 802 | toArrayMethod := keysType.GetMethod('ToArray'); 803 | 804 | if (toArrayMethod = nil) then 805 | begin 806 | raise EclJsonSerializerError.Create(cDictionaryRequired); 807 | end; 808 | 809 | keys := keysProp.GetValue(dictionary.AsObject()); 810 | keyArray := toArrayMethod.Invoke(keys.AsObject(), []); 811 | 812 | count := keyArray.GetArrayLength(); 813 | if (count = 0) then Exit; 814 | 815 | SortMapKeys(keyArray); 816 | 817 | map := TclJSONObject.Create(); 818 | AJson.AddMember(Attribute.Name, map); 819 | 820 | for i := 0 to count - 1 do 821 | begin 822 | if not (keyArray.GetArrayElement(i).Kind in [tkString, tkWString, tkLString, tkUString]) then 823 | begin 824 | raise EclJsonSerializerError.Create(cUnsupportedDataType); 825 | end; 826 | 827 | key := keyArray.GetArrayElement(i); 828 | value := itemsProp.GetValue(dictionary.AsObject(), [key]); 829 | 830 | //TODO serialize non-object types, including dynarrays 831 | map.AddMember(key.ToString(), Serialize(value.AsObject())); 832 | end; 833 | end; 834 | 835 | end. 836 | -------------------------------------------------------------------------------- /json/clJsonSerializerBase.pas: -------------------------------------------------------------------------------- 1 | { 2 | Copyright (C) 2016 by Clever Components 3 | 4 | Author: Sergey Shirokov 5 | 6 | Website: www.CleverComponents.com 7 | 8 | This file is part of Json Serializer. 9 | 10 | Json Serializer is free software: you can redistribute it and/or modify 11 | it under the terms of the GNU Lesser General Public License version 3 12 | as published by the Free Software Foundation and appearing in the 13 | included file COPYING.LESSER. 14 | 15 | Json Serializer is distributed in the hope that it will be useful, 16 | but WITHOUT ANY WARRANTY; without even the implied warranty of 17 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18 | GNU Lesser General Public License for more details. 19 | 20 | You should have received a copy of the GNU Lesser General Public License 21 | along with Json Serializer. If not, see . 22 | } 23 | 24 | unit clJsonSerializerBase; 25 | 26 | interface 27 | 28 | uses 29 | System.Classes, System.SysUtils, System.Generics.Collections, System.Rtti, System.TypInfo; 30 | 31 | type 32 | EclJsonSerializerError = class(Exception) 33 | end; 34 | 35 | TclJsonPropertyAttribute = class (TCustomAttribute) 36 | strict private 37 | FName: string; 38 | public 39 | constructor Create(const AName: string); 40 | property Name: string read FName; 41 | end; 42 | 43 | TclJsonStringAttribute = class(TclJsonPropertyAttribute); 44 | 45 | TclJsonMapAttribute = class(TclJsonPropertyAttribute); 46 | 47 | TclJsonListAttribute = class(TclJsonPropertyAttribute); 48 | 49 | TclJsonRequiredAttribute = class(TCustomAttribute); 50 | 51 | TclJsonEnumNamesAttribute = class (TCustomAttribute) 52 | strict private 53 | FNames: TArray; 54 | public 55 | constructor Create(const ANames: string); 56 | property Names: TArray read FNames; 57 | end; 58 | 59 | TclJsonTypeNameMapAttribute = class(TCustomAttribute) 60 | strict private 61 | FPropertyName: string; 62 | FTypeName: string; 63 | FTypeClassName: string; 64 | public 65 | constructor Create(const APropertyName, ATypeName, ATypeClassName: string); 66 | property PropertyName: string read FPropertyName; 67 | property TypeName: string read FTypeName; 68 | property TypeClassName: string read FTypeClassName; 69 | end; 70 | 71 | TclJsonSerializerBase = class abstract 72 | public 73 | function JsonToObject(AType: TClass; const AJson: string): TObject; overload; virtual; abstract; 74 | function JsonToObject(AObject: TObject; const AJson: string): TObject; overload; virtual; abstract; 75 | function ObjectToJson(AObject: TObject): string; virtual; abstract; 76 | end; 77 | 78 | implementation 79 | 80 | { TclJsonPropertyAttribute } 81 | 82 | constructor TclJsonPropertyAttribute.Create(const AName: string); 83 | begin 84 | inherited Create(); 85 | FName := AName; 86 | end; 87 | 88 | { TclJsonTypeNameMapAttribute } 89 | 90 | constructor TclJsonTypeNameMapAttribute.Create(const APropertyName, ATypeName, ATypeClassName: string); 91 | begin 92 | inherited Create(); 93 | 94 | FPropertyName := APropertyName; 95 | FTypeName := ATypeName; 96 | FTypeClassName := ATypeClassName; 97 | end; 98 | 99 | { TclJsonEnumNamesAttribute } 100 | 101 | constructor TclJsonEnumNamesAttribute.Create(const ANames: string); 102 | begin 103 | inherited Create(); 104 | FNames := ANames.Split([',']); 105 | end; 106 | 107 | end. 108 | -------------------------------------------------------------------------------- /test/Test.dpr: -------------------------------------------------------------------------------- 1 | program Test; 2 | 3 | uses 4 | Vcl.Forms, 5 | TestFrameWork, 6 | GUITestRunner, 7 | clJsonSerializerBase in '..\json\clJsonSerializerBase.pas', 8 | clJsonSerializerTests in 'clJsonSerializerTests.pas', 9 | clJsonSerializer in '..\json\clJsonSerializer.pas', 10 | clJsonParser in '..\json\clJsonParser.pas'; 11 | 12 | {$R *.res} 13 | 14 | begin 15 | System.ReportMemoryLeaksOnShutdown := True; 16 | Application.Initialize; 17 | GUITestRunner.RunRegisteredTests; 18 | end. 19 | -------------------------------------------------------------------------------- /test/Test.dproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | {77B61FFE-DE2E-4DBE-BE40-D39F6E982870} 4 | 18.8 5 | VCL 6 | Test.dpr 7 | True 8 | Debug 9 | Win32 10 | 3 11 | Application 12 | 13 | 14 | true 15 | 16 | 17 | true 18 | Base 19 | true 20 | 21 | 22 | true 23 | Base 24 | true 25 | 26 | 27 | true 28 | Base 29 | true 30 | 31 | 32 | true 33 | Cfg_1 34 | true 35 | true 36 | 37 | 38 | true 39 | Cfg_1 40 | true 41 | true 42 | 43 | 44 | true 45 | Base 46 | true 47 | 48 | 49 | $(BDS)\bin\delphi_PROJECTICON.ico 50 | System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) 51 | .\$(Platform)\$(Config) 52 | .\$(Platform)\$(Config) 53 | false 54 | false 55 | false 56 | false 57 | false 58 | Test 59 | 60 | 61 | 1033 62 | true 63 | bindcompfmx;DBXSqliteDriver;vcldbx;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;bindcomp;inetdb;vclib;inetdbbde;DBXInterBaseDriver;DataSnapCommon;xmlrtl;svnui;ibxpress;DbxCommonDriver;vclimg;IndyProtocols;dbxcds;DBXMySQLDriver;MetropolisUILiveTile;vclactnband;bindengine;vcldb;soaprtl;bindcompdbx;vcldsnap;bindcompvcl;vclie;vcltouch;websnap;CustomIPTransport;VclSmp;dsnap;IndyIPServer;fmxase;vcl;IndyCore;clinetsuitedXE3;IndyIPCommon;CloudService;dsnapcon;inet;fmxobj;vclx;clinetsuiteSSHdXE3;inetdbxpress;webdsnap;svn;fmxdae;bdertl;dbexpress;adortl;IndyIPClient;$(DCC_UsePackage) 64 | Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) 65 | $(BDS)\bin\default_app.manifest 66 | CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) 67 | true 68 | $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png 69 | $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png 70 | 71 | 72 | Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) 73 | $(BDS)\bin\default_app.manifest 74 | true 75 | 1033 76 | CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) 77 | bindcompfmx;DBXSqliteDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;bindcomp;inetdb;DBXInterBaseDriver;DataSnapCommon;xmlrtl;DbxCommonDriver;vclimg;IndyProtocols;dbxcds;DBXMySQLDriver;vclactnband;bindengine;vcldb;soaprtl;bindcompdbx;vcldsnap;bindcompvcl;vclie;vcltouch;websnap;CustomIPTransport;VclSmp;dsnap;IndyIPServer;fmxase;vcl;IndyCore;IndyIPCommon;dsnapcon;inet;fmxobj;vclx;inetdbxpress;webdsnap;fmxdae;dbexpress;IndyIPClient;$(DCC_UsePackage) 78 | true 79 | $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png 80 | $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png 81 | 82 | 83 | DEBUG;$(DCC_Define) 84 | true 85 | false 86 | true 87 | true 88 | true 89 | 90 | 91 | false 92 | Debug 93 | 94 | 95 | Debug 96 | 97 | 98 | false 99 | RELEASE;$(DCC_Define) 100 | 0 101 | 0 102 | 103 | 104 | 105 | MainSource 106 | 107 | 108 | 109 | 110 | 111 | 112 | Cfg_2 113 | Base 114 | 115 | 116 | Base 117 | 118 | 119 | Cfg_1 120 | Base 121 | 122 | 123 | 124 | Delphi.Personality.12 125 | 126 | 127 | 128 | 129 | False 130 | False 131 | 1 132 | 0 133 | 0 134 | 0 135 | False 136 | False 137 | False 138 | False 139 | False 140 | 1049 141 | 1251 142 | 143 | 144 | 145 | 146 | 1.0.0.0 147 | 148 | 149 | 150 | 151 | 152 | 1.0.0.0 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | 162 | 163 | 164 | Test.dpr 165 | 166 | 167 | 168 | 169 | True 170 | True 171 | 172 | 173 | 12 174 | 175 | 176 | 177 | 178 | 179 | -------------------------------------------------------------------------------- /test/Test.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CleverComponents/Json-Serializer/bedd076d54b8489c8e5134909c978605d6db8184/test/Test.res -------------------------------------------------------------------------------- /test/clJsonSerializerTests.pas: -------------------------------------------------------------------------------- 1 | { 2 | Copyright (C) 2016 by Clever Components 3 | 4 | Author: Sergey Shirokov 5 | 6 | Website: www.CleverComponents.com 7 | 8 | This file is part of Json Serializer. 9 | 10 | Json Serializer is free software: you can redistribute it and/or modify 11 | it under the terms of the GNU Lesser General Public License version 3 12 | as published by the Free Software Foundation and appearing in the 13 | included file COPYING.LESSER. 14 | 15 | Json Serializer is distributed in the hope that it will be useful, 16 | but WITHOUT ANY WARRANTY; without even the implied warranty of 17 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18 | GNU Lesser General Public License for more details. 19 | 20 | You should have received a copy of the GNU Lesser General Public License 21 | along with Json Serializer. If not, see . 22 | } 23 | 24 | unit clJsonSerializerTests; 25 | 26 | interface 27 | 28 | uses 29 | System.Classes, System.Generics.Collections, System.SysUtils, TestFramework, clJsonSerializerBase, clJsonSerializer; 30 | 31 | type 32 | TclNotSerializable = class 33 | strict private 34 | FName: string; 35 | public 36 | property Name: string read FName write FName; 37 | end; 38 | 39 | TclTestUnsupportedType = class 40 | strict private 41 | FFloatValue: Double; 42 | public 43 | [TclJsonProperty('floatValue')] 44 | property FloatValue: Double read FFloatValue write FFloatValue; 45 | end; 46 | 47 | TclTestUnsupportedArrayType = class 48 | strict private 49 | FFloatArray: TArray; 50 | public 51 | [TclJsonProperty('floatArray')] 52 | property FloatArray: TArray read FFloatArray write FFloatArray; 53 | end; 54 | 55 | TclTestSubObject = class 56 | strict private 57 | FName: string; 58 | FValue: string; 59 | public 60 | [TclJsonString('name')] 61 | property Name: string read FName write FName; 62 | [TclJsonString('value')] 63 | property Value: string read FValue write FValue; 64 | end; 65 | 66 | TclTestObject = class 67 | strict private 68 | FBooleanValue: Boolean; 69 | FNonSerializable: string; 70 | FStringValue: string; 71 | FValue: string; 72 | FIntegerValue: Integer; 73 | FSubObject: TclTestSubObject; 74 | FIntArray: TArray; 75 | FStrArray: TArray; 76 | FBoolArray: TArray; 77 | FObjArray: TArray; 78 | 79 | procedure SetSubObject(const Value: TclTestSubObject); 80 | procedure SetObjArray(const Value: TArray); 81 | public 82 | constructor Create; 83 | destructor Destroy; override; 84 | 85 | [TclJsonString('stringValue')] 86 | property StringValue: string read FStringValue write FStringValue; 87 | 88 | [TclJsonProperty('integerValue')] 89 | property IntegerValue: Integer read FIntegerValue write FIntegerValue; 90 | 91 | [TclJsonProperty('value')] 92 | property Value: string read FValue write FValue; 93 | 94 | [TclJsonProperty('booleanValue')] 95 | property BooleanValue: Boolean read FBooleanValue write FBooleanValue; 96 | 97 | [TclJsonProperty('subObject')] 98 | property SubObject: TclTestSubObject read FSubObject write SetSubObject; 99 | 100 | [TclJsonProperty('intArray')] 101 | property IntArray: TArray read FIntArray write FIntArray; 102 | 103 | [TclJsonString('strArray')] 104 | property StrArray: TArray read FStrArray write FStrArray; 105 | 106 | [TclJsonProperty('boolArray')] 107 | property BoolArray: TArray read FBoolArray write FBoolArray; 108 | 109 | [TclJsonProperty('objArray')] 110 | property ObjArray: TArray read FObjArray write SetObjArray; 111 | 112 | property NonSerializable: string read FNonSerializable write FNonSerializable; 113 | end; 114 | 115 | [TclJsonTypeNameMap('tag', 'inherited', 'clJsonSerializerTests.TclTestInheritedObject')] 116 | TclTestBaseObject = class 117 | strict private 118 | FTag: string; 119 | FName: string; 120 | public 121 | [TclJsonString('tag')] 122 | property Tag: string read FTag write FTag; 123 | 124 | [TclJsonString('name')] 125 | property Name: string read FName write FName; 126 | end; 127 | 128 | TclTestInheritedObject = class(TclTestBaseObject) 129 | strict private 130 | FSubName: string; 131 | public 132 | [TclJsonString('subname')] 133 | property SubName: string read FSubName write FSubName; 134 | end; 135 | 136 | TclTestMultipleTypeArray = class 137 | strict private 138 | FConstructorCalled: Boolean; 139 | FObjArray: TArray; 140 | 141 | procedure SetObjArray(const Value: TArray); 142 | public 143 | constructor Create; 144 | destructor Destroy; override; 145 | 146 | [TclJsonProperty('objArray')] 147 | property ObjArray: TArray read FObjArray write SetObjArray; 148 | 149 | property ConstructorCalled: Boolean read FConstructorCalled; 150 | end; 151 | 152 | TclTestRequiredPropertyObject = class 153 | strict private 154 | FRequiredString: string; 155 | public 156 | [TclJsonRequired] 157 | [TclJsonString('required-string')] 158 | property RequiredString: string read FRequiredString write FRequiredString; 159 | end; 160 | 161 | TclTestEnum = (teOne, teTwo, teThree); 162 | 163 | [TclJsonEnumNames('one,two,three')] 164 | TclTestNamedEnum = (tnOne, tnTwo, tnThree); 165 | 166 | TclTestEnumPropertyObject = class 167 | strict private 168 | FEnum: TclTestEnum; 169 | FNamedEnum: TclTestNamedEnum; 170 | FEnumArray: TArray; 171 | FNamedEnumArray: TArray; 172 | public 173 | constructor Create; 174 | destructor Destroy; override; 175 | 176 | [TclJsonProperty('enum')] 177 | property Enum: TclTestEnum read FEnum write FEnum; 178 | 179 | [TclJsonProperty('enumArray')] 180 | property EnumArray: TArray read FEnumArray write FEnumArray; 181 | 182 | [TclJsonProperty('namedEnum')] 183 | property NamedEnum: TclTestNamedEnum read FNamedEnum write FNamedEnum; 184 | 185 | [TclJsonProperty('namedEnumArray')] 186 | property NamedEnumArray: TArray read FNamedEnumArray write FNamedEnumArray; 187 | end; 188 | 189 | TclMapObjectItem = class 190 | strict private 191 | FValue: Integer; 192 | public 193 | [TclJsonProperty('value')] 194 | property Value: Integer read FValue write FValue; 195 | end; 196 | 197 | TclMapObject = class 198 | private 199 | FObjects: TObjectDictionary; 200 | 201 | procedure SetObjects(const Value: TObjectDictionary); 202 | public 203 | constructor Create; 204 | destructor Destroy; override; 205 | 206 | [TclJsonMap('objects')] 207 | property Objects: TObjectDictionary read FObjects write SetObjects; 208 | end; 209 | 210 | TclMultipleTypeMapObject = class 211 | private 212 | FObjects: TObjectDictionary; 213 | 214 | procedure SetObjects(const Value: TObjectDictionary); 215 | public 216 | constructor Create; 217 | destructor Destroy; override; 218 | 219 | [TclJsonMap('objects')] 220 | property Objects: TObjectDictionary read FObjects write SetObjects; 221 | end; 222 | 223 | TclAnyTypePropertyObject = class 224 | private 225 | FAny: string; 226 | public 227 | [TclJsonProperty('any')] 228 | property Any: string read FAny write FAny; 229 | end; 230 | 231 | 232 | TclListObjectItem = class 233 | strict private 234 | FValue: Integer; 235 | public 236 | [TclJsonProperty('value')] 237 | property Value: Integer read FValue write FValue; 238 | end; 239 | 240 | TclListObject = class 241 | private 242 | FObjects: TObjectList; 243 | 244 | procedure SetObjects(const Value: TObjectList); 245 | public 246 | constructor Create; 247 | destructor Destroy; override; 248 | 249 | [TclJsonList('objects')] 250 | property Objects: TObjectList read FObjects write SetObjects; 251 | end; 252 | 253 | TclJsonSerializerTests = class(TTestCase) 254 | published 255 | procedure TestDeserialize; 256 | procedure TestDeserializeCreatedInstance; 257 | procedure TestSerialize; 258 | procedure TestUnsupportedType; 259 | procedure TestNonSerializable; 260 | procedure TestRequiredProperty; 261 | procedure TestMultipleTypeArray; 262 | procedure TestInheritedTypes; 263 | procedure TestEnumProperty; 264 | procedure TestMapProperty; 265 | procedure TestMultipleTypeMap; 266 | procedure TestNonObjectMapProperty; 267 | procedure TestArrayMapProperty; 268 | procedure TestObjectListProperty; 269 | procedure TestAnyTypeProperty; 270 | end; 271 | 272 | implementation 273 | 274 | { TclJsonSerializerTests } 275 | 276 | procedure TclJsonSerializerTests.TestArrayMapProperty; 277 | begin 278 | CheckTrue(False, 'not implemented'); 279 | end; 280 | 281 | procedure TclJsonSerializerTests.TestDeserialize; 282 | const 283 | jsonEtalon = '{"stringValue": "qwe", "integerValue": 123, "value": asd, "booleanValue": true}'; 284 | jsonEtalon2 = '{"stringValue": "qwe", "subObject": {"name": "qwerty"}, "intArray": [111, 222], "strArray": ["val 1", "val 2"], ' + 285 | '"boolArray": [true, false], "objArray": [{"name": "an1"}, {"name": "an2"}]}'; 286 | 287 | var 288 | serializer: TclJsonSerializer; 289 | obj: TclTestObject; 290 | begin 291 | serializer := nil; 292 | obj := nil; 293 | try 294 | serializer := TclJsonSerializer.Create(); 295 | 296 | obj := serializer.JsonToObject(TclTestObject, jsonEtalon) as TclTestObject; 297 | 298 | CheckEquals('qwe', obj.StringValue); 299 | CheckEquals(123, obj.IntegerValue); 300 | CheckEquals('asd', obj.Value); 301 | CheckEquals(True, obj.BooleanValue); 302 | 303 | FreeAndNil(obj); 304 | 305 | obj := serializer.JsonToObject(TclTestObject, jsonEtalon2) as TclTestObject; 306 | 307 | CheckEquals('qwe', obj.StringValue); 308 | 309 | CheckTrue(obj.SubObject <> nil); 310 | CheckEquals('qwerty', obj.SubObject.Name); 311 | 312 | CheckEquals(2, Length(obj.IntArray)); 313 | CheckEquals(111, obj.IntArray[0]); 314 | CheckEquals(222, obj.IntArray[1]); 315 | 316 | CheckEquals(2, Length(obj.StrArray)); 317 | CheckEquals('val 1', obj.StrArray[0]); 318 | CheckEquals('val 2', obj.StrArray[1]); 319 | 320 | CheckEquals(2, Length(obj.BoolArray)); 321 | CheckEquals(True, obj.BoolArray[0]); 322 | CheckEquals(False, obj.BoolArray[1]); 323 | 324 | CheckEquals(2, Length(obj.ObjArray)); 325 | 326 | CheckTrue(obj.ObjArray[0] <> nil); 327 | CheckEquals('an1', obj.ObjArray[0].Name); 328 | 329 | CheckTrue(obj.ObjArray[1] <> nil); 330 | CheckEquals('an2', obj.ObjArray[1].Name); 331 | finally 332 | obj.Free(); 333 | serializer.Free(); 334 | end; 335 | end; 336 | 337 | procedure TclJsonSerializerTests.TestAnyTypeProperty; 338 | const 339 | jsonEtalon = '{"any": {"name": "qwerty"}}'; 340 | var 341 | serializer: TclJsonSerializer; 342 | obj: TclAnyTypePropertyObject; 343 | begin 344 | serializer := nil; 345 | obj := nil; 346 | try 347 | serializer := TclJsonSerializer.Create(); 348 | 349 | obj := serializer.JsonToObject(jsonEtalon); 350 | 351 | CheckEquals('{"name": "qwerty"}', obj.Any); 352 | finally 353 | obj.Free(); 354 | serializer.Free(); 355 | end; 356 | end; 357 | 358 | procedure TclJsonSerializerTests.TestDeserializeCreatedInstance; 359 | const 360 | jsonEtalon = '{"stringValue": "qwe", "integerValue": 123, "value": asd, "booleanValue": true}'; 361 | 362 | var 363 | serializer: TclJsonSerializer; 364 | obj: TclTestObject; 365 | begin 366 | serializer := nil; 367 | obj := nil; 368 | try 369 | serializer := TclJsonSerializer.Create(); 370 | 371 | obj := TclTestObject.Create(); 372 | obj := serializer.JsonToObject(obj, jsonEtalon) as TclTestObject; 373 | 374 | CheckEquals('qwe', obj.StringValue); 375 | CheckEquals(123, obj.IntegerValue); 376 | CheckEquals('asd', obj.Value); 377 | CheckEquals(True, obj.BooleanValue); 378 | finally 379 | obj.Free(); 380 | serializer.Free(); 381 | end; 382 | end; 383 | 384 | procedure TclJsonSerializerTests.TestMapProperty; 385 | const 386 | jsonEtalon = '{"objects": {"obj1": {"value": 1}, "obj2": {"value": 2}}}'; 387 | var 388 | serializer: TclJsonSerializer; 389 | obj: TclMapObject; 390 | json: string; 391 | begin 392 | serializer := nil; 393 | obj := nil; 394 | try 395 | serializer := TclJsonSerializer.Create(); 396 | obj := serializer.JsonToObject(jsonEtalon); 397 | CheckTrue(nil <> obj.Objects); 398 | CheckEquals(2, obj.Objects.Count); 399 | CheckTrue(obj.Objects.ContainsKey('obj2')); 400 | CheckEquals(2, obj.Objects['obj2'].Value); 401 | 402 | json := serializer.ObjectToJson(obj); 403 | CheckEquals(jsonEtalon, json); 404 | finally 405 | obj.Free(); 406 | serializer.Free(); 407 | end; 408 | end; 409 | 410 | procedure TclJsonSerializerTests.TestEnumProperty; 411 | var 412 | serializer: TclJsonSerializer; 413 | obj: TclTestEnumPropertyObject; 414 | json: string; 415 | enumArr: TArray; 416 | namedEnumArr: TArray; 417 | begin 418 | serializer := nil; 419 | obj := nil; 420 | try 421 | serializer := TclJsonSerializer.Create(); 422 | 423 | obj := TclTestEnumPropertyObject.Create(); 424 | obj.Enum := teTwo; 425 | obj.NamedEnum := tnTwo; 426 | 427 | SetLength(enumArr, 2); 428 | obj.EnumArray := enumArr; 429 | enumArr[0] := teTwo; 430 | enumArr[1] := teThree; 431 | 432 | SetLength(namedEnumArr, 2); 433 | obj.NamedEnumArray := namedEnumArr; 434 | namedEnumArr[0] := tnTwo; 435 | namedEnumArr[1] := tnThree; 436 | 437 | json := serializer.ObjectToJson(obj); 438 | CheckEquals( 439 | '{"enum": teTwo, "enumArray": [teTwo, teThree], "namedEnum": two, "namedEnumArray": [two, three]}', 440 | json); 441 | FreeAndNil(obj); 442 | 443 | obj := serializer.JsonToObject(TclTestEnumPropertyObject, json) as TclTestEnumPropertyObject; 444 | CheckTrue(teTwo = obj.Enum); 445 | CheckTrue(tnTwo = obj.NamedEnum); 446 | 447 | CheckEquals(2, Length(obj.EnumArray)); 448 | CheckTrue(teTwo = obj.EnumArray[0]); 449 | CheckTrue(teThree = obj.EnumArray[1]); 450 | 451 | CheckEquals(2, Length(obj.NamedEnumArray)); 452 | CheckTrue(tnTwo = obj.NamedEnumArray[0]); 453 | CheckTrue(tnThree = obj.NamedEnumArray[1]); 454 | 455 | FreeAndNil(obj); 456 | finally 457 | obj.Free(); 458 | serializer.Free(); 459 | end; 460 | end; 461 | 462 | procedure TclJsonSerializerTests.TestInheritedTypes; 463 | const 464 | jsonBase = '{"tag": "base", "name": "base class"}'; 465 | jsonInherited = '{"tag": "inherited", "name": "inherited class", "subname": "inherited subname"}'; 466 | var 467 | serializer: TclJsonSerializer; 468 | obj: TclTestBaseObject; 469 | inh: TclTestInheritedObject; 470 | begin 471 | serializer := nil; 472 | obj := nil; 473 | try 474 | serializer := TclJsonSerializer.Create(); 475 | 476 | obj := serializer.JsonToObject(TclTestBaseObject, jsonBase) as TclTestBaseObject; 477 | 478 | CheckEquals('base', obj.Tag); 479 | CheckEquals('base class', obj.Name); 480 | 481 | FreeAndNil(obj); 482 | 483 | obj := serializer.JsonToObject(TclTestBaseObject, jsonInherited) as TclTestBaseObject; 484 | 485 | inh := obj as TclTestInheritedObject; 486 | CheckEquals('inherited', inh.Tag); 487 | CheckEquals('inherited class', inh.Name); 488 | CheckEquals('inherited subname', inh.SubName); 489 | 490 | FreeAndNil(obj); 491 | 492 | obj := serializer.JsonToObject(TclTestInheritedObject, jsonInherited) as TclTestBaseObject; 493 | 494 | inh := obj as TclTestInheritedObject; 495 | CheckEquals('inherited', inh.Tag); 496 | CheckEquals('inherited class', inh.Name); 497 | CheckEquals('inherited subname', inh.SubName); 498 | 499 | FreeAndNil(obj); 500 | finally 501 | obj.Free(); 502 | serializer.Free(); 503 | end; 504 | end; 505 | 506 | procedure TclJsonSerializerTests.TestMultipleTypeArray; 507 | const 508 | jsonEtalon = '{"objArray": [{"tag": "base", "name": "base class"}, {"tag": "inherited", "name": "inherited class", "subname": "inherited subname"}]}'; 509 | jsonEtalonMalformed = '{"objArray": [{"tag-bad": "base", "name": "base class"}, {"tag-bad": "inherited", "name": "inherited class", "subname": "inherited subname"}]}'; 510 | 511 | var 512 | serializer: TclJsonSerializer; 513 | obj: TclTestMultipleTypeArray; 514 | begin 515 | serializer := nil; 516 | obj := nil; 517 | try 518 | serializer := TclJsonSerializer.Create(); 519 | 520 | obj := serializer.JsonToObject(TclTestMultipleTypeArray, jsonEtalon) as TclTestMultipleTypeArray; 521 | 522 | CheckEquals(2, Length(obj.ObjArray)); 523 | CheckEquals('base', obj.ObjArray[0].Tag); 524 | CheckEquals('base class', obj.ObjArray[0].Name); 525 | CheckEquals('TclTestBaseObject', obj.ObjArray[0].ClassName); 526 | CheckEquals('inherited', obj.ObjArray[1].Tag); 527 | CheckEquals('inherited class', obj.ObjArray[1].Name); 528 | CheckEquals('TclTestInheritedObject', obj.ObjArray[1].ClassName); 529 | CheckEquals('inherited subname', (obj.ObjArray[1] as TclTestInheritedObject).SubName); 530 | CheckEquals(True, obj.ConstructorCalled); 531 | 532 | FreeAndNil(obj); 533 | 534 | obj := serializer.JsonToObject(TclTestMultipleTypeArray, jsonEtalonMalformed) as TclTestMultipleTypeArray; 535 | 536 | CheckEquals(2, Length(obj.ObjArray)); 537 | CheckEquals('', obj.ObjArray[0].Tag); 538 | CheckEquals('base class', obj.ObjArray[0].Name); 539 | CheckEquals('TclTestBaseObject', obj.ObjArray[0].ClassName); 540 | CheckEquals('', obj.ObjArray[1].Tag); 541 | CheckEquals('inherited class', obj.ObjArray[1].Name); 542 | CheckEquals('TclTestBaseObject', obj.ObjArray[1].ClassName); 543 | 544 | FreeAndNil(obj); 545 | finally 546 | obj.Free(); 547 | serializer.Free(); 548 | end; 549 | end; 550 | 551 | procedure TclJsonSerializerTests.TestMultipleTypeMap; 552 | const 553 | jsonEtalon = '{"objects": {"obj1": {"tag": "base", "name": "base class"}, "obj2": {"subname": "inherited subname", "tag": "inherited", "name": "inherited class"}}}'; 554 | var 555 | serializer: TclJsonSerializer; 556 | obj: TclMultipleTypeMapObject; 557 | json: string; 558 | begin 559 | serializer := nil; 560 | obj := nil; 561 | try 562 | serializer := TclJsonSerializer.Create(); 563 | obj := serializer.JsonToObject(jsonEtalon); 564 | CheckTrue(nil <> obj.Objects); 565 | CheckEquals(2, obj.Objects.Count); 566 | 567 | CheckTrue(obj.Objects.ContainsKey('obj1')); 568 | CheckEquals('base class', obj.Objects['obj1'].Name); 569 | CheckTrue(TclTestBaseObject = obj.Objects['obj1'].ClassType); 570 | 571 | CheckTrue(obj.Objects.ContainsKey('obj2')); 572 | CheckEquals('inherited class', obj.Objects['obj2'].Name); 573 | CheckTrue(TclTestInheritedObject = obj.Objects['obj2'].ClassType); 574 | CheckEquals('inherited subname', TclTestInheritedObject(obj.Objects['obj2']).SubName); 575 | 576 | json := serializer.ObjectToJson(obj); 577 | CheckEquals(jsonEtalon, json); 578 | finally 579 | obj.Free(); 580 | serializer.Free(); 581 | end; 582 | end; 583 | 584 | procedure TclJsonSerializerTests.TestNonObjectMapProperty; 585 | begin 586 | CheckTrue(False, 'not implemented'); 587 | end; 588 | 589 | procedure TclJsonSerializerTests.TestNonSerializable; 590 | var 591 | serializer: TclJsonSerializer; 592 | obj: TclNotSerializable; 593 | begin 594 | serializer := nil; 595 | obj := nil; 596 | try 597 | serializer := TclJsonSerializer.Create(); 598 | 599 | try 600 | serializer.JsonToObject(TclNotSerializable, '{"name":"test"}'); 601 | Fail('Non-serializable objects cannot be serialized'); 602 | except 603 | on EclJsonSerializerError do; 604 | end; 605 | 606 | obj := TclNotSerializable.Create(); 607 | obj.Name := 'test'; 608 | try 609 | serializer.ObjectToJson(obj); 610 | Fail('Non-serializable objects cannot be serialized'); 611 | except 612 | on EclJsonSerializerError do; 613 | end; 614 | finally 615 | obj.Free(); 616 | serializer.Free(); 617 | end; 618 | end; 619 | 620 | procedure TclJsonSerializerTests.TestObjectListProperty; 621 | const 622 | jsonEtalon = '{"objects": [{"value": 1}, {"value": 2}]}'; 623 | var 624 | serializer: TclJsonSerializer; 625 | obj: TclListObject; 626 | json: string; 627 | begin 628 | serializer := nil; 629 | obj := nil; 630 | try 631 | serializer := TclJsonSerializer.Create(); 632 | obj := serializer.JsonToObject(jsonEtalon); 633 | CheckTrue(nil <> obj.Objects); 634 | CheckEquals(2, obj.Objects.Count); 635 | CheckEquals(2, obj.Objects[1].Value); 636 | 637 | json := serializer.ObjectToJson(obj); 638 | CheckEquals(jsonEtalon, json); 639 | finally 640 | obj.Free(); 641 | serializer.Free(); 642 | end; 643 | end; 644 | 645 | procedure TclJsonSerializerTests.TestRequiredProperty; 646 | var 647 | serializer: TclJsonSerializer; 648 | obj: TclTestRequiredPropertyObject; 649 | begin 650 | serializer := nil; 651 | obj := nil; 652 | try 653 | serializer := TclJsonSerializer.Create(); 654 | 655 | obj := serializer.JsonToObject(TclTestRequiredPropertyObject, '{"required-string": "qwe"}') as TclTestRequiredPropertyObject; 656 | CheckEquals('qwe', obj.RequiredString); 657 | FreeAndNil(obj); 658 | 659 | obj := serializer.JsonToObject(TclTestRequiredPropertyObject, '{"required-string": ""}') as TclTestRequiredPropertyObject; 660 | CheckEquals('', obj.RequiredString); 661 | CheckEquals('{"required-string": ""}', serializer.ObjectToJson(obj)); 662 | FreeAndNil(obj); 663 | finally 664 | obj.Free(); 665 | serializer.Free(); 666 | end; 667 | end; 668 | 669 | procedure TclJsonSerializerTests.TestSerialize; 670 | const 671 | jsonEtalon = '{"stringValue": "qwe", "integerValue": 123, "value": asd, "booleanValue": true}'; 672 | jsonEtalon2 = '{"stringValue": "qwe", "integerValue": 123, "value": asd, "booleanValue": true, ' + 673 | '"subObject": {"name": "qwerty"}, "intArray": [111, 222], "strArray": ["val 1", "val 2"], ' + 674 | '"boolArray": [true, false], "objArray": [{"name": "an1"}, {"name": "an2"}]}'; 675 | 676 | var 677 | serializer: TclJsonSerializer; 678 | obj: TclTestObject; 679 | json: string; 680 | intArr: TArray; 681 | strArr: TArray; 682 | boolArr: TArray; 683 | objArr: TArray; 684 | begin 685 | serializer := nil; 686 | obj := nil; 687 | try 688 | serializer := TclJsonSerializer.Create(); 689 | obj := TclTestObject.Create(); 690 | 691 | obj.StringValue := 'qwe'; 692 | obj.IntegerValue := 123; 693 | obj.Value := 'asd'; 694 | obj.BooleanValue := True; 695 | obj.NonSerializable := 'zxc'; 696 | 697 | json := serializer.ObjectToJson(obj); 698 | 699 | CheckEquals(jsonEtalon, json); 700 | 701 | obj.SubObject := TclTestSubObject.Create(); 702 | obj.SubObject.Name := 'qwerty'; 703 | 704 | SetLength(intArr, 2); 705 | obj.IntArray := intArr; 706 | intArr[0] := 111; 707 | intArr[1] := 222; 708 | 709 | SetLength(strArr, 2); 710 | obj.StrArray := strArr; 711 | strArr[0] := 'val 1'; 712 | strArr[1] := 'val 2'; 713 | 714 | SetLength(boolArr, 2); 715 | obj.BoolArray := boolArr; 716 | boolArr[0] := True; 717 | boolArr[1] := False; 718 | 719 | SetLength(objArr, 2); 720 | obj.ObjArray := objArr; 721 | objArr[0] := TclTestSubObject.Create(); 722 | objArr[0].Name := 'an1'; 723 | objArr[1] := TclTestSubObject.Create(); 724 | objArr[1].Name := 'an2'; 725 | 726 | json := serializer.ObjectToJson(obj); 727 | 728 | CheckEquals(jsonEtalon2, json); 729 | finally 730 | obj.Free(); 731 | serializer.Free(); 732 | end; 733 | end; 734 | 735 | procedure TclJsonSerializerTests.TestUnsupportedType; 736 | var 737 | serializer: TclJsonSerializer; 738 | obj: TclTestUnsupportedType; 739 | objArr: TclTestUnsupportedArrayType; 740 | arr: TArray; 741 | begin 742 | serializer := nil; 743 | obj := nil; 744 | objArr := nil; 745 | try 746 | serializer := TclJsonSerializer.Create(); 747 | 748 | obj := TclTestUnsupportedType.Create(); 749 | obj.FloatValue := 12.5; 750 | 751 | try 752 | serializer.ObjectToJson(obj); 753 | Fail('Data type checking does not work'); 754 | except 755 | on EclJsonSerializerError do; 756 | end; 757 | FreeAndNil(obj); 758 | 759 | try 760 | obj := serializer.JsonToObject(TclTestUnsupportedType, '{"floatValue": 12}') as TclTestUnsupportedType; 761 | Fail('Data type checking does not work'); 762 | except 763 | on EclJsonSerializerError do; 764 | end; 765 | FreeAndNil(obj); 766 | 767 | objArr := TclTestUnsupportedArrayType.Create(); 768 | SetLength(arr, 1); 769 | objArr.FloatArray := arr; 770 | objArr.FloatArray[0] := 12.5; 771 | 772 | try 773 | serializer.ObjectToJson(objArr); 774 | Fail('Data type checking does not work'); 775 | except 776 | on EclJsonSerializerError do; 777 | end; 778 | FreeAndNil(objArr); 779 | 780 | try 781 | objArr := serializer.JsonToObject(TclTestUnsupportedArrayType, '{"floatArray": [11, 22]}') as TclTestUnsupportedArrayType; 782 | Fail('Data type checking does not work'); 783 | except 784 | on EclJsonSerializerError do; 785 | end; 786 | finally 787 | objArr.Free(); 788 | obj.Free(); 789 | serializer.Free(); 790 | end; 791 | end; 792 | 793 | { TclTestObject } 794 | 795 | constructor TclTestObject.Create; 796 | begin 797 | inherited Create(); 798 | 799 | FSubObject := nil; 800 | FIntArray := nil; 801 | FStrArray := nil; 802 | FBoolArray := nil; 803 | FObjArray := nil; 804 | end; 805 | 806 | destructor TclTestObject.Destroy; 807 | begin 808 | ObjArray := nil; 809 | BoolArray := nil; 810 | StrArray := nil; 811 | IntArray := nil; 812 | SubObject := nil; 813 | 814 | inherited Destroy(); 815 | end; 816 | 817 | procedure TclTestObject.SetObjArray(const Value: TArray); 818 | var 819 | obj: TObject; 820 | begin 821 | if (FObjArray <> nil) then 822 | begin 823 | for obj in FObjArray do 824 | begin 825 | obj.Free(); 826 | end; 827 | end; 828 | 829 | FObjArray := Value; 830 | end; 831 | 832 | procedure TclTestObject.SetSubObject(const Value: TclTestSubObject); 833 | begin 834 | FSubObject.Free(); 835 | FSubObject := Value; 836 | end; 837 | 838 | { TclTestMultipleTypeArray } 839 | 840 | constructor TclTestMultipleTypeArray.Create; 841 | begin 842 | inherited Create(); 843 | 844 | FObjArray := nil; 845 | FConstructorCalled := True; 846 | end; 847 | 848 | destructor TclTestMultipleTypeArray.Destroy; 849 | begin 850 | ObjArray := nil; 851 | inherited Destroy(); 852 | end; 853 | 854 | procedure TclTestMultipleTypeArray.SetObjArray(const Value: TArray); 855 | var 856 | obj: TObject; 857 | begin 858 | if (FObjArray <> nil) then 859 | begin 860 | for obj in FObjArray do 861 | begin 862 | obj.Free(); 863 | end; 864 | end; 865 | 866 | FObjArray := Value; 867 | end; 868 | 869 | { TclTestEnumPropertyObject } 870 | 871 | constructor TclTestEnumPropertyObject.Create; 872 | begin 873 | inherited Create(); 874 | 875 | FEnumArray := nil; 876 | FNamedEnumArray := nil; 877 | end; 878 | 879 | destructor TclTestEnumPropertyObject.Destroy; 880 | begin 881 | NamedEnumArray := nil; 882 | EnumArray := nil; 883 | 884 | inherited Destroy(); 885 | end; 886 | 887 | { TclMapObject } 888 | 889 | constructor TclMapObject.Create; 890 | begin 891 | inherited Create(); 892 | FObjects := nil; 893 | end; 894 | 895 | destructor TclMapObject.Destroy; 896 | begin 897 | Objects := nil; 898 | inherited Destroy(); 899 | end; 900 | 901 | procedure TclMapObject.SetObjects(const Value: TObjectDictionary); 902 | begin 903 | FObjects.Free(); 904 | FObjects := Value; 905 | end; 906 | 907 | { TclMultipleTypeMapObject } 908 | 909 | constructor TclMultipleTypeMapObject.Create; 910 | begin 911 | inherited Create(); 912 | FObjects := nil; 913 | end; 914 | 915 | destructor TclMultipleTypeMapObject.Destroy; 916 | begin 917 | Objects := nil; 918 | inherited Destroy(); 919 | end; 920 | 921 | procedure TclMultipleTypeMapObject.SetObjects(const Value: TObjectDictionary); 922 | begin 923 | FObjects.Free(); 924 | FObjects := Value; 925 | end; 926 | 927 | { TclListObject } 928 | 929 | constructor TclListObject.Create; 930 | begin 931 | inherited Create(); 932 | FObjects := nil; 933 | end; 934 | 935 | destructor TclListObject.Destroy; 936 | begin 937 | Objects := nil; 938 | inherited Destroy(); 939 | end; 940 | 941 | procedure TclListObject.SetObjects(const Value: TObjectList); 942 | begin 943 | FObjects.Free(); 944 | FObjects := Value; 945 | end; 946 | 947 | initialization 948 | TestFramework.RegisterTest(TclJsonSerializerTests.Suite); 949 | 950 | end. 951 | --------------------------------------------------------------------------------