├── .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 |
--------------------------------------------------------------------------------