├── .gitignore ├── XSuperJSON.pas ├── XSuperObject.inc ├── XSuperObject.pas └── readme.md /.gitignore: -------------------------------------------------------------------------------- 1 | #delphi compiled modules 2 | *.exe 3 | *.dll 4 | *.bpl 5 | *.bpi 6 | *.dcp 7 | *.so 8 | *.apk 9 | *.drc 10 | *.map 11 | *.dres 12 | *.rsm 13 | *.tds 14 | *.dcu 15 | *.lib 16 | *.a 17 | *.ocx 18 | *.o 19 | *.stat 20 | *.local 21 | *.identcache 22 | *.~* 23 | __history/ 24 | __recovery/ 25 | Android/ 26 | iOSDevice32/ 27 | OSX32/ 28 | iOSSimulator/ 29 | 30 | #idea project 31 | #/.idea 32 | #/doc/.idea 33 | 34 | 35 | # Delphi autogenerated files (duplicated info) 36 | *.cfg 37 | *.hpp 38 | *Resource.rc 39 | 40 | # Delphi local files (user-specific info) 41 | *.local 42 | *.identcache 43 | *.projdata 44 | *.tvsconfig 45 | *.dsk 46 | 47 | # Castalia statistics file (since XE7 Castalia is distributed with Delphi) 48 | *.stat -------------------------------------------------------------------------------- /XSuperJSON.pas: -------------------------------------------------------------------------------- 1 | (* 2 | * XSuperObject - Simple JSON Framework 3 | * 4 | * The MIT License (MIT) 5 | * Copyright (c) 2015 Onur YILDIZ 6 | * 7 | * 8 | * Permission is hereby granted, free of charge, to any person 9 | * obtaining a copy of this software and associated documentation 10 | * files (the "Software"), to deal in the Software without restriction, 11 | * including without limitation the rights to use, copy, modify, 12 | * merge, publish, distribute, sublicense, and/or sell copies of the Software, 13 | * and to permit persons to whom the Software is furnished to do so, 14 | * subject to the following conditions: 15 | * 16 | * The above copyright notice and this permission notice shall 17 | * be included in all copies or substantial portions of the Software. 18 | * 19 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 20 | * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 21 | * OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 22 | * IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, 23 | * DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 24 | * TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH 25 | * THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 26 | * 27 | *) 28 | 29 | unit XSuperJSON; 30 | 31 | interface 32 | 33 | uses 34 | SysUtils, Classes, Generics.Collections, Generics.Defaults, Math, DateUtils, RegularExpressions, RTTI; 35 | 36 | 37 | const 38 | CNull = 'null'; 39 | MaxCHR = #127; 40 | 41 | Err_UnexpectedEndOfInput = 'Unexpected end of input'; 42 | Err_Expected = 'Expected %s'; 43 | Err_ExpectedButFound = '"%s" expected but "%s" found'; 44 | Err_UnexpectedTokenILLEGAL = 'Unexpected token ILLEGAL'; 45 | 46 | type 47 | 48 | // ## Forward Declarations 49 | // ----------------------- 50 | 51 | TJSONNull = class; 52 | TLexGenerator = class; 53 | TRoute = class; 54 | PPosition = ^TPosition; 55 | TPosition = record 56 | Col: Integer; 57 | Line: Integer; 58 | end; 59 | 60 | TDataType = (dtNil, dtNull, dtObject, dtArray, dtString, dtInteger, dtFloat, dtBoolean, dtDateTime, dtDate, dtTime); 61 | TJSONComparison = reference to function(Left, Right: T): Integer; 62 | // ## Exception 63 | 64 | TJSONSyntaxError = class(Exception) 65 | public 66 | constructor Create(const Msg: String; Pos: PPosition); 67 | constructor CreateFmt(const Msg: String; const Args: array of TVarRec; Pos: PPosition); 68 | end; 69 | 70 | // ## JSONWriter 71 | TJSONWriter = class 72 | public const 73 | IDENT_SIZE = 2; 74 | private 75 | FData: TStringBuilder; 76 | FIdent: Boolean; 77 | FIdentOffset: Integer; 78 | FUniversalTime: Boolean; 79 | public 80 | constructor Create(const useIdent, useUniversalTime: Boolean); 81 | destructor Destroy; override; 82 | procedure Inc; 83 | procedure Dec; 84 | 85 | function Append(const Value: string; const CRLF: Boolean = False): TJSONWriter; overload; 86 | function Append(const Value: int64; const CRLF: Boolean = False): TJSONWriter; overload; 87 | function AppendVal(const Value: string; const CRLF: Boolean = False): TJSONWriter; overload; 88 | function AppendVal(const Value: int64; const CRLF: Boolean = False): TJSONWriter; overload; 89 | function ToString: string; override; 90 | 91 | property Ident: Boolean read FIdent; 92 | property UniversalTime: Boolean read FUniversalTime; 93 | end; 94 | 95 | 96 | // ## JSON Symbols 97 | // --------------- 98 | 99 | IJSONAncestor = interface 100 | ['{FFB71762-50A1-4D27-9F59-56F6208421C7}'] 101 | function GetAsVariant: Variant; 102 | procedure SetAsVariant(const Value: Variant); 103 | function GetDataType: TDataType; 104 | function GetIsNull: Boolean; 105 | procedure AsJSONString(Str: TJSONWriter); 106 | property IsNull: Boolean read GetIsNull; 107 | property DataType: TDataType read GetDataType; 108 | property AsVariant: Variant read GetAsVariant write SetAsVariant; 109 | end; 110 | 111 | TJSONAncestor = class abstract(TInterfacedObject, IJSONAncestor) 112 | private 113 | function GetAsVariant: Variant; 114 | procedure SetAsVariant(const Value: Variant); 115 | protected 116 | function GetDataType: TDataType; virtual; 117 | function GetIsNull: Boolean; virtual; 118 | public 119 | procedure AsJSONString(Str: TJSONWriter); virtual; 120 | property IsNull: Boolean read GetIsNull; 121 | property DataType: TDataType read GetDataType; 122 | property AsVariant: Variant read GetAsVariant write SetAsVariant; 123 | end; 124 | 125 | IJSONValue = interface(IJSONAncestor) 126 | ['{0B1ED53C-EF62-4BFA-9E78-9DD9088D96C5}'] 127 | function GetData: T; 128 | procedure SetData(const Value: T); 129 | procedure SetNull; 130 | property Value: T read GetData write SetData; 131 | end; 132 | 133 | TJSONValue = class abstract(TJSONAncestor, IJSONValue) 134 | public 135 | FNull: Boolean; 136 | FData: T; 137 | protected 138 | function GetData: T; virtual; 139 | procedure SetData(const Value: T); virtual; 140 | function GetIsNull: Boolean; override; 141 | property Value: T read GetData write SetData; 142 | public 143 | constructor Create(const Value: T); 144 | constructor CreateNull; 145 | procedure SetNull; 146 | end; 147 | 148 | IJSONNull = interface(IJSONValue)['{C19F5715-B832-46D8-8668-1A9DC31393D7}']end; 149 | TJSONNull = class(TJSONValue, IJSONNull) 150 | public 151 | procedure AsJSONString(Str: TJSONWriter); override; 152 | protected 153 | function GetIsNull: Boolean; override; 154 | end; 155 | 156 | IJSONBoolean = interface(IJSONValue)['{CCC8D8C5-081D-4DCF-93DB-CC0696458A12}']end; 157 | TJSONBoolean = class(TJSONValue, IJSONBoolean) 158 | public 159 | procedure AsJSONString(Str: TJSONWriter); override; 160 | property Value; 161 | end; 162 | 163 | IJSONString = interface(IJSONValue)['{C507BB41-3674-4F47-8D6B-5605258F6A2F}']end; 164 | TJSONString = class(TJSONValue, IJSONString) 165 | public 166 | procedure AsJSONString(Str: TJSONWriter); override; 167 | property Value; 168 | end; 169 | 170 | IJSONRaw = interface(IJSONString)['{EF5EF422-1A81-49EA-A3E0-9E7D5B5CC1E2}']end; 171 | TJSONRaw = class(TJSONString, IJSONRaw) 172 | public 173 | procedure AsJSONString(Str: TJSONWriter); override; 174 | property Value; 175 | end; 176 | 177 | IJSONInteger = interface(IJSONValue)['{E9D84348-9634-40F5-8A1F-FF006F45FC6D}']end; 178 | TJSONInteger = class(TJSONValue, IJSONInteger) 179 | public 180 | procedure AsJSONString(Str: TJSONWriter); override; 181 | property Value; 182 | end; 183 | 184 | IJSONFloat = interface(IJSONValue)['{29D840FB-191B-4304-9518-C2937B3AE6B0}']end; 185 | TJSONFloat = class(TJSONValue, IJSONFloat) 186 | public 187 | procedure AsJSONString(Str: TJSONWriter); override; 188 | property Value; 189 | end; 190 | 191 | IJSONBaseDate = interface(IJSONValue) 192 | ['{7ACB3D47-A9A6-49C1-AFF3-F451368EAE48}'] 193 | function GetAsString: String; 194 | property AsString: String read GetAsString; 195 | end; 196 | 197 | TJSONBaseDate = class(TJSONValue, IJSONBaseDate) 198 | protected 199 | FFormat: String; 200 | public 201 | function GetAsString: String; 202 | procedure AsJSONString(Str: TJSONWriter); override; 203 | end; 204 | 205 | IJSONDateTime = interface(IJSONBaseDate)['{9441CA2E-B822-4C13-ABF0-15F8026CCE50}']end; 206 | TJSONDateTime = class(TJSONBaseDate, IJSONDateTime) 207 | public 208 | constructor Create(const Value: TDateTime; const Format: String = 'yyyy-mm-dd"T"hh":"mm":"ss.zzz'); 209 | property Value; 210 | end; 211 | 212 | IJSONDate = interface(IJSONBaseDate)['{A862D6A5-2C4A-41CD-B2C0-F7B58FA14066}']end; 213 | TJSONDate = class(TJSONBaseDate, IJSONDate) 214 | public 215 | constructor Create(const Value: TDate; const Format: String = 'yyyy-mm-dd'); 216 | property Value; 217 | end; 218 | 219 | IJSONTime = interface(IJSONBaseDate)['{EEBCD145-B837-4129-A21D-378DF7DA53B2}']end; 220 | TJSONTime = class(TJSONBaseDate, IJSONTime) 221 | public 222 | constructor Create(const Value: TTime; const Format: String = 'hh":"mm":"ss.zzz'); 223 | property Value; 224 | end; 225 | 226 | 227 | TJSONDateTimeCheckCallBack = reference to function(Str: String; var Value: TDateTime; var Typ: TDataType): Boolean; 228 | TJSONDateManager = class 229 | private 230 | class var FFormats: TList; 231 | class function GetFormats: TList; static; inline; 232 | public 233 | class constructor Create; 234 | class destructor Destroy; 235 | class function Check(const Data: String; var AValue: TDateTime; var Typ: TDataType): Boolean; 236 | class property Formats: TList read GetFormats; 237 | end; 238 | 239 | IJSONPair = interface 240 | ['{D328943F-5ED1-4B35-8332-573156565C96}'] 241 | function GetName: String; 242 | function GetValue: IJSONAncestor; 243 | procedure SetName(const Value: String); 244 | procedure SetValue(const Value: IJSONAncestor); 245 | property Name: String read GetName write SetName; 246 | property JSONValue: IJSONAncestor read GetValue write SetValue; 247 | end; 248 | 249 | TJSONPair = class(TInterfacedObject, IJSONPair) 250 | private 251 | FName: String; 252 | FValue: IJSONAncestor; 253 | function GetName: String; 254 | function GetValue: IJSONAncestor; 255 | procedure SetName(const Value: String); 256 | procedure SetValue(const Value: IJSONAncestor); 257 | public 258 | constructor Create(const aName: String; aValue: IJSONAncestor); 259 | destructor Destroy; override; 260 | property Name: String read GetName write SetName; 261 | property JSONValue: IJSONAncestor read GetValue write SetValue; 262 | end; 263 | 264 | TJSONEnumerator = record 265 | Index : Integer; 266 | List : TList; 267 | function MoveNext : Boolean; 268 | function GetCurrent : T; 269 | property Current : T read GetCurrent; 270 | end; 271 | 272 | IJSONObject = Interface(IJSONValue) 273 | ['{2A9244EC-F202-4CC1-9F89-7DA12437F7ED}'] 274 | function Count: Integer; 275 | function Get(const Name: String): IJSONPair; overload; 276 | function Get(const Index: Integer): IJSONPair; overload; 277 | procedure AddPair(P: IJSONPair); overload; 278 | procedure AddPair(Name: String; Value: IJSONAncestor); overload; 279 | procedure Remove(P: IJSONPair); overload; 280 | procedure Remove(const Name: String); overload; 281 | procedure Remove(const Index: Integer); overload; 282 | function GetEnumerator: TJSONEnumerator; 283 | procedure Sort(Comparison: TJSONComparison); 284 | end; 285 | 286 | 287 | TJSONObject = class(TJSONValue, IJSONObject) 288 | private 289 | FPairList: TList; 290 | FNull: Boolean; 291 | protected 292 | function GetIsNull: Boolean; override; 293 | public 294 | constructor Create; 295 | destructor Destroy; override; 296 | function Count: Integer; 297 | function Get(const Name: String): IJSONPair; overload; 298 | function Get(const Index: Integer): IJSONPair; overload; 299 | procedure AsJSONString(Str: TJSONWriter); override; 300 | procedure AddPair(P: IJSONPair); overload; 301 | procedure AddPair(Name: String; Value: IJSONAncestor); overload; inline; 302 | procedure Remove(P: IJSONPair); overload; inline; 303 | procedure Remove(const Name: String); overload; 304 | procedure Remove(const Index: Integer); overload; 305 | function GetEnumerator: TJSONEnumerator; 306 | procedure Sort(Comparison: TJSONComparison); 307 | class function ParseJSONValue(const Str: String; const CheckDate: Boolean): IJSONAncestor; 308 | end; 309 | 310 | IJSONArray = interface(IJSONValue) 311 | ['{C63B4323-6D7E-4151-BA1B-4C55CDE28FDB}'] 312 | procedure Add(Val: IJSONAncestor); 313 | procedure Remove(Val: IJSONAncestor); overload; 314 | procedure Remove(Index: Integer); overload; 315 | procedure Clear; 316 | function Count: Integer; 317 | function Get(const I: Integer): IJSONAncestor; 318 | procedure SetIndex(const Int: Integer; const Value: IJSONAncestor); 319 | function GetEnumerator: TJSONEnumerator; 320 | procedure Sort(Comparison: TJSONComparison); 321 | property Index[const Int: Integer]: IJSONAncestor read Get write SetIndex; default; 322 | end; 323 | 324 | TJSONArray = class(TJSONValue, IJSONArray) 325 | private 326 | FList: TList; 327 | FNull: Boolean; 328 | procedure SetIndex(const Int: Integer; const Value: IJSONAncestor); 329 | protected 330 | function GetIsNull: Boolean; override; 331 | public 332 | constructor Create; 333 | destructor Destroy; override; 334 | procedure AsJSONString(Str: TJSONWriter); override; 335 | procedure Add(Val: IJSONAncestor); 336 | procedure Remove(Val: IJSONAncestor); overload; 337 | procedure Remove(Index: Integer); overload; 338 | procedure Clear; 339 | function Count: Integer; 340 | function Get(const I: Integer): IJSONAncestor; 341 | function GetEnumerator: TJSONEnumerator; 342 | procedure Sort(Comparison: TJSONComparison); 343 | property Index[const Int: Integer]: IJSONAncestor read Get write SetIndex; default; 344 | end; 345 | 346 | 347 | TJSONBuilder = class 348 | private 349 | LGen: TLexGenerator; 350 | FCheckDates: Boolean; 351 | public 352 | constructor Create(const JSON: String; const CheckDates: Boolean); 353 | destructor Destroy; override; 354 | function ReadValue: IJSONAncestor; 355 | procedure ReadString(var Val: IJSONAncestor); 356 | procedure ReadInteger(var Val: IJSONAncestor); 357 | procedure ReadFloat(var Val: IJSONAncestor); 358 | procedure ReadObject(var Val: IJSONAncestor); 359 | procedure ReadTrue(var Val: IJSONAncestor); 360 | procedure ReadFalse(var Val: IJSONAncestor); 361 | procedure ReadNull(var Val: IJSONAncestor); 362 | procedure ReadArray(var Val: IJSONAncestor); 363 | end; 364 | 365 | TJSONInterpreter = class 366 | private 367 | LGen: TLexGenerator; 368 | FJSON: IJSONAncestor; 369 | FExceptionBlock: Boolean; 370 | function ReadName(Base: IJSONAncestor): IJSONAncestor; 371 | function ReadArrayIndex(Base: IJSONArray): IJSONAncestor; 372 | function ReadObject(Base: IJSONAncestor): IJSONObject; 373 | function ReadArray(Base: IJSONAncestor): IJSONArray; 374 | function ReadValue(Base: IJSONAncestor): IJSONAncestor; 375 | procedure CreateExcept(const S: String; Args: array of TVarRec); overload; 376 | procedure CreateExcept(const S: String); overload; inline; 377 | public 378 | constructor Create(const Expression: String; JSON: IJSONAncestor; BlockException: Boolean = False); 379 | destructor Destroy; override; 380 | function ReadExpression: IJSONAncestor; 381 | end; 382 | 383 | 384 | // ## Parse 385 | // -------- 386 | 387 | TLexemType = ( ltNil, 388 | ltSValue, ltIValue, ltDValue, ltNull, ltCLeft, ltCRight, 389 | ltBLeft, ltBRight, ltBSlash, ltColon, ltDot, ltVirgule, 390 | ltName, 391 | ltTrue, 392 | ltFalse ); 393 | 394 | TLexemTypes = set of TLexemType; 395 | 396 | TLexBuff = class 397 | public 398 | Capacity: Integer; 399 | Length : Integer; 400 | Buff: PWideChar; 401 | constructor Create; 402 | destructor Destroy; override; 403 | function AsString: String; inline; 404 | function AsInt64: Int64; 405 | function AsDouble: Double; 406 | function AsType: TLexemType; 407 | function AsHInt: Int64; 408 | procedure Add(Ch: WideChar); inline; 409 | procedure Grow; 410 | procedure Clear; inline; 411 | end; 412 | 413 | ILexeme = ^TLexeme; 414 | TLexeme = record 415 | Pos: TPosition; 416 | Int: Int64; 417 | Str: String; 418 | Dbl: Double; 419 | LType: TLexemType; 420 | end; 421 | 422 | TParseProc = (ppNil, ppInteger, ppDouble, ppString, ppName, ppEscape, ppEscapeUChar); 423 | 424 | TTriggerProcs = set of (ttBuffer, ttEnd, ttBack); 425 | 426 | TTrigger = class 427 | public 428 | TriggerProcs: TTriggerProcs; 429 | ParseProcs: TParseProc; 430 | NextRoute: TRoute; 431 | BF: Boolean; 432 | ED: Boolean; 433 | BK: Boolean; 434 | constructor Create(NextRoute: TRoute; TriggerProcs: TTriggerProcs; ParseProcs: TParseProc); 435 | end; 436 | 437 | TErrorTrigger = class(TTrigger) 438 | private 439 | FMessage: String; 440 | function GetMeessage: String; 441 | procedure SetMessage(const Value: String); 442 | public 443 | constructor Create(const Message: String); 444 | property Message: String read GetMeessage write SetMessage; 445 | end; 446 | 447 | 448 | TNoRouteTrigger = class(TTrigger) 449 | end; 450 | 451 | TUseRouteTrigger = class(TTrigger) 452 | end; 453 | 454 | TJumpTrigger = class(TTrigger) 455 | end; 456 | 457 | {$WARNINGS OFF} 458 | TRouteChars = set of Char; 459 | {$WARNINGS ON} 460 | 461 | TRoute = class 462 | private 463 | FName: String; 464 | FTriggers: array[#0..MaxCHR] of TTrigger; 465 | FTriggerList: TObjectList; 466 | function GetIndex(Ch: WideChar): TTrigger; inline; 467 | function GetName: String; 468 | public 469 | constructor Create(const Name: String); 470 | destructor Destroy; override; 471 | property Name: String read GetName; 472 | procedure Add(const Chars: TRouteChars; Trigger: TTrigger); 473 | procedure NoRoute(Trigger: TTrigger); 474 | function TryGetRoute(Ch: WideChar; var Trg: TTrigger): Boolean; inline; 475 | property Index[Ch: WideChar]: TTrigger read GetIndex; default; 476 | end; 477 | 478 | TLexGrammar = class 479 | private 480 | FRoutes: TList; 481 | protected 482 | function FirstRoute: TRoute; virtual; abstract; 483 | function CreateRoute(const Name: String): TRoute; 484 | function EscapeSupport: Boolean; virtual; 485 | function EscapeRoute: TRoute; virtual; 486 | public 487 | constructor Create; virtual; 488 | destructor Destroy; override; 489 | end; 490 | 491 | TJSONGrammar = class(TLexGrammar) 492 | private 493 | rFirst, 494 | rName, 495 | rString, 496 | rString2, 497 | rInt, 498 | rDouble, 499 | rExp, rExpE, 500 | rExpPM, 501 | 502 | rEscape, 503 | rEscapeRoute, 504 | rEscapeUChar: TRoute; 505 | 506 | protected 507 | function FirstRoute: TRoute; override; 508 | function EscapeSupport: Boolean; override; 509 | function EscapeRoute: TRoute; override; 510 | public 511 | constructor Create; override; 512 | destructor Destroy; override; 513 | end; 514 | 515 | TLexGenerator = class 516 | private 517 | FFirstRoute: TRoute; 518 | FBuffer: TLexBuff; 519 | FEscapeBuff: TLexBuff; 520 | FCurr: PWideChar; 521 | FCurrPos: PPosition; 522 | FLexem: ILexeme; 523 | FLexG: TLexGrammar; 524 | FEscapeSupport: Boolean; 525 | FEscapeRoute: TRoute; 526 | FExceptBlock: Boolean; 527 | procedure CreateLexeme; 528 | procedure NextLex; 529 | procedure KillLex; inline; 530 | public 531 | constructor Create(LexG: TLexGrammar = nil; ExceptBlock: Boolean = False); 532 | destructor Destroy; override; 533 | procedure Load(const Source: String); 534 | function Check(LTyp: TLexemType): Boolean; overload; 535 | function Check(LTyp: TLexemTypes): TLexemType; overload; 536 | function CheckName(var S: String): Boolean; 537 | function CheckKill(LTyp: TLexemType): Boolean; overload; 538 | function CheckKill(LTyp: TLexemTypes): TLexemType; overload; 539 | function Current: ILexeme; inline; 540 | property CurrPos: PPosition read FCurrPos; 541 | end; 542 | 543 | TSuperParser = class 544 | public 545 | class function ParseJSON(const S: String; const CheckDateTime: Boolean): IJSONAncestor; 546 | end; 547 | 548 | TISO8601 = record 549 | private 550 | FData: TMatch; 551 | FSuccess: Boolean; 552 | FOffset: Integer; 553 | FUseTime: Boolean; 554 | FUseDate: Boolean; 555 | FValue: TDateTime; 556 | FValueType: TDataType; 557 | function NextOffset: Integer; 558 | function GetIntData(const Index: Integer): Integer; overload; inline; 559 | function GetIntData(const Index: Integer; const P: Boolean): Integer; overload; 560 | function GetStrData(const Index: Integer): String; inline; 561 | procedure ReadStructure; 562 | procedure ReadZulu; 563 | function ReadDate: Boolean; 564 | function ReadTime: Boolean; 565 | procedure ReadMS; 566 | procedure ReadTZ(const P: Boolean); 567 | public 568 | constructor Create(const Value: String); 569 | property Value: TDateTime read FValue; 570 | property ValueType: TDataType read FValueType; 571 | property Success: Boolean read FSuccess; 572 | end; 573 | 574 | function LimitedStrToUTF16(const Str: String): String; 575 | 576 | implementation 577 | 578 | uses 579 | XSuperObject; 580 | 581 | const 582 | FloatFormat : TFormatSettings = ( DecimalSeparator : '.' ); 583 | STokenTypes : array [TLexemType] of string = ('Nil', 584 | 'String', 'Integer', 'Float', 'Null', '[', ']', 585 | '(', ')', '\', ':', '.', ',', 586 | '', 587 | 'TRUE', 588 | 'FALSE' ); 589 | 590 | 591 | optAll = [#0..#255]; 592 | optWhiteSpace = [' ', #0, #9, #10, #13]; 593 | 594 | optAlpha = ['a'..'z', 'A'..'Z', '$', '_', #127]; 595 | optSym = ['[', ']', '{', '}', ':', ',', '"', '''', '.']; 596 | optNumeric = ['0'..'9']; 597 | optEscape = ['b', 'f', 'n', 'r', 't', 'v', '''', '"', '\']; 598 | optEscapeUnicode = ['u']; 599 | optHex = ['A'..'F', 'a'..'f'] + optNumeric; 600 | optStop = optWhiteSpace + optSym; 601 | 602 | HexMap : array [0..15] of WideChar = ('0', '1', '2', '3', '4', '5', '6', 603 | '7', '8', '9', 'a', 'b', 'c', 'd', 'e', 'f'); 604 | 605 | var 606 | JSONLexGrammar: TJSONGrammar; 607 | function iff(const Bool: Boolean; _true, _false: Variant): Variant; inline; 608 | begin 609 | if Bool then 610 | Result := _true 611 | else 612 | Result := _false; 613 | end; 614 | 615 | function ChrToUTF16(const ChrCode: Integer): String; inline; 616 | begin 617 | Result := '\u' + 618 | HexMap[ChrCode shr 12] + 619 | HexMap[(ChrCode shr 8) and 15] + 620 | HexMap[(ChrCode shr 4) and 15] + 621 | HexMap[ChrCode and 15]; 622 | end; 623 | 624 | function StrToUTF16(const Str: String): String; 625 | var 626 | Tmp: PWideChar; 627 | begin 628 | if Str = #0 then Exit(ChrToUtf16(0)); 629 | Result := ''; 630 | if Str = '' then 631 | Exit 632 | else 633 | Tmp := PWideChar(Pointer(Str)); 634 | while Tmp^ <> #0 do 635 | begin 636 | case Tmp^ of 637 | #1..#31: case Tmp^ of 638 | #8 : Result := Result + '\b'; 639 | #9 : Result := Result + '\t'; 640 | #10: Result := Result + '\n'; 641 | //#11: Result := Result + '\v'; 642 | #12: Result := Result + '\f'; 643 | #13: Result := Result + '\r'; 644 | else 645 | Result := Result + ChrtoUTF16(Ord(Tmp^)) 646 | end; 647 | #34{"}: Result := Result + '\"'; 648 | #92{\}: Result := Result + '\\'; 649 | //#127..#65535: Result := Result + ChrtoUTF16(Ord(Tmp^)); 650 | else 651 | Result := Result + Tmp^; 652 | end; 653 | Inc(Tmp); 654 | end; 655 | end; 656 | 657 | function LimitedStrToUTF16(const Str: String): String; 658 | var 659 | Tmp: PWideChar; 660 | begin 661 | if Str = #0 then Exit(ChrToUtf16(0)); 662 | Result := ''; 663 | if Str = '' then 664 | Exit 665 | else 666 | Tmp := PWideChar(Pointer(Str)); 667 | while Tmp^ <> #0 do 668 | begin 669 | case Tmp^ of 670 | #1..#31: case Tmp^ of 671 | #8 : Result := Result + '\b'; 672 | #9 : Result := Result + '\t'; 673 | #10: Result := Result + '\n'; 674 | //#11: Result := Result + '\v'; 675 | #12: Result := Result + '\f'; 676 | #13: Result := Result + '\r'; 677 | else 678 | Result := Result + ChrtoUTF16(Ord(Tmp^)) 679 | end; 680 | else 681 | Result := Result + Tmp^; 682 | end; 683 | Inc(Tmp); 684 | end; 685 | end; 686 | 687 | { TJSONAncestor } 688 | 689 | procedure TJSONAncestor.AsJSONString(Str: TJSONWriter); 690 | begin 691 | Str.Append(''); 692 | end; 693 | 694 | function TJSONAncestor.GetDataType: TDataType; 695 | begin 696 | with TCast.Create(Self) do 697 | begin 698 | Result := DataType; 699 | Free; 700 | end; 701 | end; 702 | 703 | function TJSONAncestor.GetIsNull: Boolean; 704 | begin 705 | Result := Self is TJSONNull; 706 | end; 707 | 708 | function TJSONAncestor.GetAsVariant: Variant; 709 | begin 710 | with TCast.Create(Self) do 711 | begin 712 | Result := AsVariant; 713 | Free; 714 | end; 715 | end; 716 | 717 | procedure TJSONAncestor.SetAsVariant(const Value: Variant); 718 | begin 719 | with TCast.Create(Self) do 720 | begin 721 | AsVariant := Value; 722 | Free; 723 | end; 724 | end; 725 | 726 | { TLexBuff } 727 | 728 | procedure TLexBuff.Add(Ch: WideChar); 729 | begin 730 | if Capacity = 0 then Exit; 731 | if (Length >= Capacity - Length) then Grow; 732 | Buff[Length] := Ch; 733 | Inc(Length); 734 | Buff[Length] := #0; 735 | end; 736 | 737 | function TLexBuff.AsDouble: Double; 738 | var 739 | Res: Extended; 740 | begin 741 | Add(#0); 742 | {$WARNINGS OFF} 743 | if not TextToFloat(PWideChar(@Buff[0]), Res, fvExtended, FloatFormat) then 744 | {$WARNINGS ON} 745 | raise EConvertError.Create('') 746 | else 747 | Result := Res; 748 | end; 749 | 750 | function TLexBuff.AsHInt: Int64; 751 | var 752 | I, J: Integer; 753 | begin 754 | I := 0; 755 | Result := 0; 756 | while I < Length do 757 | begin 758 | J := Ord(Buff[I]); 759 | Inc(I); 760 | case J of 761 | Ord('a')..Ord('f') : 762 | J := J - (Ord('a') - 10); 763 | Ord('A')..Ord('F') : 764 | J := J - (Ord('A') - 10); 765 | Ord('0')..Ord('9') : 766 | J := J - Ord('0'); 767 | else 768 | Continue; 769 | end; 770 | Result := (Result shl 4) or J; 771 | end; 772 | end; 773 | 774 | function TLexBuff.AsInt64: Int64; 775 | begin 776 | Result := StrToInt64(AsString); 777 | end; 778 | 779 | function TLexBuff.AsString: String; 780 | begin 781 | SetString(Result, Buff, Length); 782 | end; 783 | 784 | function TLexBuff.AsType: TLexemType; 785 | begin 786 | Result := ltName; 787 | if Length = 0 then 788 | Exit; 789 | 790 | case Buff[0] of 791 | '[': Result := ltCLeft; 792 | ']': Result := ltCRight; 793 | ':': Result := ltColon; 794 | ',': Result := ltVirgule; 795 | '{': Result := ltBLeft; 796 | '}': Result := ltBRight; 797 | '.': Result := ltDot; 798 | else 799 | if CompareText(STokenTypes[ltTrue], AsString) = 0 then 800 | Result := ltTrue 801 | else 802 | if CompareText(STokenTypes[ltFalse], AsString) = 0 then 803 | Result := ltFalse 804 | else 805 | if CompareText(STokenTypes[ltNull], AsString) = 0 then 806 | Result := ltNull 807 | end; 808 | end; 809 | 810 | procedure TLexBuff.Clear; 811 | begin 812 | Length := 0; 813 | Buff[0] := #0; 814 | end; 815 | 816 | constructor TLexBuff.Create; 817 | begin 818 | inherited; 819 | Length := 0; 820 | Capacity := 32; 821 | GetMem(Buff, Capacity * SizeOf(PWideChar)); 822 | end; 823 | 824 | destructor TLexBuff.Destroy; 825 | begin 826 | if Assigned(Buff) then 827 | FreeMem(Buff); 828 | inherited; 829 | end; 830 | 831 | procedure TLexBuff.Grow; 832 | begin 833 | Capacity := Math.Max(Capacity * 2, Length + 8); 834 | ReallocMem(Buff, Capacity * SizeOf(WideChar)); 835 | end; 836 | 837 | { TSuperParser } 838 | 839 | class function TSuperParser.ParseJSON(const S: String; const CheckDateTime: Boolean): IJSONAncestor; 840 | var 841 | JSON: TJSONBuilder; 842 | begin 843 | JSON := TJSONBuilder.Create(S, CheckDateTime); 844 | try 845 | Result := JSON.ReadValue; 846 | finally 847 | if Assigned(JSON) then 848 | JSON.Free; 849 | end; 850 | end; 851 | 852 | { TTrigger } 853 | 854 | { TTrigger } 855 | 856 | constructor TTrigger.Create(NextRoute: TRoute; TriggerProcs: TTriggerProcs; 857 | ParseProcs: TParseProc); 858 | begin 859 | Self.NextRoute := NextRoute; 860 | Self.ParseProcs := ParseProcs; 861 | Self.TriggerProcs := TriggerProcs; 862 | BF := ttBuffer in TriggerProcs; 863 | ED := ttEnd in TriggerProcs; 864 | BK := ttBack in TriggerProcs; 865 | end; 866 | 867 | { TRoute } 868 | 869 | procedure TRoute.Add(const Chars: TRouteChars; Trigger: TTrigger); 870 | var 871 | Ch: WideChar; 872 | begin 873 | Ch := #0; 874 | 875 | if not FTriggerList.Contains(Trigger) then 876 | FTriggerList.Add(Trigger); 877 | 878 | while Ch <= MaxCHR do 879 | begin 880 | {$WARNINGS OFF} 881 | if Ch in Chars then {$WARNINGS ON} 882 | if not Assigned(FTriggers[Ch]) then 883 | FTriggers[Ch] := Trigger; 884 | Inc(Ch); 885 | end; 886 | end; 887 | 888 | constructor TRoute.Create(const Name: String); 889 | begin 890 | FName := Name; 891 | FTriggerList := TObjectList.Create; 892 | end; 893 | 894 | 895 | destructor TRoute.Destroy; 896 | begin 897 | FTriggerList.Free; 898 | inherited; 899 | end; 900 | 901 | function TRoute.GetIndex(Ch: WideChar): TTrigger; 902 | begin 903 | if Ch > MaxCHR then Ch := MaxCHR; 904 | Result := FTriggers[Ch]; 905 | end; 906 | 907 | function TRoute.GetName: String; 908 | begin 909 | Result := FName; 910 | end; 911 | 912 | procedure TRoute.NoRoute(Trigger: TTrigger); 913 | var 914 | Ch: WideChar; 915 | begin 916 | Ch := #0; 917 | 918 | if not FTriggerList.Contains(Trigger) then 919 | FTriggerList.Add(Trigger); 920 | 921 | while Ch <= MaxCHR do 922 | begin 923 | if not Assigned(FTriggers[Ch]) then 924 | FTriggers[Ch] := Trigger; 925 | Inc(Ch); 926 | end; 927 | end; 928 | 929 | function TRoute.TryGetRoute(Ch: WideChar; var Trg: TTrigger): Boolean; 930 | begin 931 | if Ch > MaxCHR then Ch := MaxCHR; 932 | if FTriggers[Ch] <> nil then 933 | begin 934 | Result := True; 935 | Trg := FTriggers[Ch]; 936 | end 937 | else 938 | Result := False; 939 | end; 940 | 941 | { TLexGrammar } 942 | 943 | constructor TLexGrammar.Create; 944 | begin 945 | FRoutes := TList.Create; 946 | end; 947 | 948 | destructor TLexGrammar.Destroy; 949 | begin 950 | FRoutes.Free; 951 | inherited; 952 | end; 953 | 954 | function TLexGrammar.EscapeRoute: TRoute; 955 | begin 956 | Result := Nil; 957 | end; 958 | 959 | function TLexGrammar.EscapeSupport: Boolean; 960 | begin 961 | Result := False; 962 | end; 963 | 964 | function TLexGrammar.CreateRoute(const Name: String): TRoute; 965 | begin 966 | Result := TRoute.Create(Name); 967 | FRoutes.Add(Result); 968 | end; 969 | 970 | { TJSONGrammar } 971 | 972 | constructor TJSONGrammar.Create; 973 | begin 974 | inherited; 975 | 976 | rFirst := CreateRoute('First'); 977 | rName := CreateRoute('Name'); 978 | rString := CreateRoute('String'); 979 | rString2 := CreateRoute('String2'); 980 | rInt := CreateRoute('Int'); 981 | rDouble := CreateRoute('Double'); 982 | 983 | rExp := CreateRoute('Exp'); 984 | rExpE := CreateRoute('ExpE'); 985 | rExpPM := CreateRoute('ExpPM'); 986 | 987 | rEscape := CreateRoute('Escape'); 988 | rEscapeRoute := CreateRoute('EscapeRoute'); 989 | rEscapeUChar := CreateRoute('EscapeUChar'); 990 | 991 | 992 | rEscape.Add( ['\'], TJumpTrigger.Create(rEscapeRoute, [], ppNil )); 993 | 994 | rEscapeRoute.Add(['u'], TJumpTrigger.Create(rEscapeUChar, [ttBuffer], ppNil)); 995 | rEscapeRoute.NoRoute(TUseRouteTrigger.Create(rEscape, [ttBuffer, ttEnd], ppEscape)); 996 | 997 | rEscapeUChar.Add(optHex, TUseRouteTrigger.Create(rEscapeUChar, [], ppEscapeUChar)); 998 | rEscapeUChar.NoRoute(TErrorTrigger.Create(ERR_UnexpectedTokenILLEGAL)); 999 | 1000 | rFirst.Add(optSym - ['"', ''''], TUseRouteTrigger.Create(rFirst, [ttBuffer, ttEnd], ppName)); 1001 | rFirst.Add(optAlpha, TUseRouteTrigger.Create(rName, [ttBuffer], ppNil)); 1002 | rFirst.Add(['"'], TJumpTrigger.Create(rString, [ttBuffer], ppNil)); 1003 | rFirst.Add([''''], TJumpTrigger.Create(rString2, [ttBuffer], ppNil)); 1004 | rFirst.Add(optNumeric, TUseRouteTrigger.Create(rInt, [ttBuffer], ppNil)); 1005 | rFirst.Add(optWhiteSpace - [#0], TJumpTrigger.Create(rFirst, [], ppNil)); 1006 | rFirst.Add(['-'], TUseRouteTrigger.Create(rInt, [ttBuffer], ppNil)); 1007 | rFirst.NoRoute(TErrorTrigger.Create(ERR_UnexpectedTokenILLEGAL)); 1008 | 1009 | rName.Add(optAll - optWhiteSpace - optSym, TUseRouteTrigger.Create(rName, [], ppNil)); 1010 | rName.Add(optWhiteSpace, TJumpTrigger.Create(rFirst, [ttEnd, ttBack], ppName)); 1011 | rName.NoRoute(TJumpTrigger.Create(rFirst, [ttEnd, ttBack], ppName)); 1012 | 1013 | rString.Add(optAll - ['"', #0, #10, #13], TUseRouteTrigger.Create(rString, [], ppNil)); 1014 | rString.Add(['"'], TJumpTrigger.Create(rFirst, [ttEnd], ppString)); 1015 | rString.Add([#0, #10, #13], TErrorTrigger.Create(ERR_UnexpectedTokenILLEGAL)); 1016 | 1017 | rString2.Add(optAll - ['''', #0, #10, #13], TUseRouteTrigger.Create(rString2, [], ppNil)); 1018 | rString2.Add([''''], TJumpTrigger.Create(rFirst, [ttEnd], ppString)); 1019 | rString2.Add([#0, #10, #13], TErrorTrigger.Create(ERR_UnexpectedTokenILLEGAL)); 1020 | 1021 | rInt.Add(optNumeric, TUseRouteTrigger.Create(rInt, [], ppNil)); 1022 | rInt.Add(['.'], TUseRouteTrigger.Create(rDouble, [], ppNil)); 1023 | rInt.Add(['e', 'E'], TUseRouteTrigger.Create(rExp, [], ppNil)); 1024 | rInt.Add(optStop, TJumpTrigger.Create(rFirst, [ttEnd, ttBack], ppInteger)); 1025 | rInt.NoRoute(TErrorTrigger.Create(ERR_UnexpectedTokenILLEGAL)); 1026 | 1027 | rDouble.Add(optNumeric, TUseRouteTrigger.Create(rDouble, [], ppNil)); 1028 | rDouble.Add(['e', 'E'], TUseRouteTrigger.Create(rExp, [], ppNil)); 1029 | rDouble.Add(optStop, TJumpTrigger.Create(rFirst, [ttEnd, ttBack], ppDouble)); 1030 | rDouble.NoRoute(TErrorTrigger.Create(ERR_UnexpectedTokenILLEGAL)); 1031 | 1032 | rExp.Add(['+', '-'], TUseRouteTrigger.Create(rExpPM, [], ppNil)); 1033 | rExp.Add(optNumeric, TUseRouteTrigger.Create(rExpE, [], ppNil)); 1034 | rExp.NoRoute(TErrorTrigger.Create(Err_UnexpectedTokenILLEGAL)); 1035 | 1036 | rExpPM.Add(optNumeric, TUseRouteTrigger.Create(rExpE, [], ppNil)); 1037 | rExpPM.NoRoute(TErrorTrigger.Create(Err_UnexpectedTokenILLEGAL)); 1038 | 1039 | rExpE.Add(optNumeric, TUseRouteTrigger.Create(rExpE, [], ppNil)); 1040 | rExpE.Add(optStop, TJumpTrigger.Create(rFirst, [ttEnd, ttBack], ppDouble)); 1041 | rExpE.NoRoute(TErrorTrigger.Create(Err_UnexpectedTokenILLEGAL)); 1042 | 1043 | end; 1044 | 1045 | destructor TJSONGrammar.Destroy; 1046 | begin 1047 | rFirst.Free; 1048 | rName.Free; 1049 | rString.Free; 1050 | rString2.Free; 1051 | rInt.Free; 1052 | rDouble.Free; 1053 | rExp.Free; 1054 | rExpE.Free; 1055 | rExpPM.Free; 1056 | rEscape.Free; 1057 | rEscapeRoute.Free; 1058 | rEscapeUChar.Free; 1059 | inherited; 1060 | end; 1061 | 1062 | function TJSONGrammar.EscapeRoute: TRoute; 1063 | begin 1064 | Result := rEscape; 1065 | end; 1066 | 1067 | function TJSONGrammar.EscapeSupport: Boolean; 1068 | begin 1069 | Result := True; 1070 | end; 1071 | 1072 | function TJSONGrammar.FirstRoute: TRoute; 1073 | begin 1074 | Result := rFirst; 1075 | end; 1076 | 1077 | { TErrorTrigger } 1078 | 1079 | constructor TErrorTrigger.Create(const Message: String); 1080 | begin 1081 | inherited Create(Nil, [], ppNil); 1082 | FMessage := Message; 1083 | end; 1084 | 1085 | function TErrorTrigger.GetMeessage: String; 1086 | begin 1087 | Result := FMessage; 1088 | end; 1089 | 1090 | procedure TErrorTrigger.SetMessage(const Value: String); 1091 | begin 1092 | FMessage := Value; 1093 | end; 1094 | 1095 | { TLexGenerator } 1096 | 1097 | function TLexGenerator.Check(LTyp: TLexemTypes): TLexemType; 1098 | begin 1099 | if not Assigned(FLexem) then 1100 | begin 1101 | NextLex; 1102 | if not Assigned(FLexem) then 1103 | Exit(ltNil); 1104 | end; 1105 | Result := iff(FLexem.LType in LTyp, FLexem.LType, ltNil); 1106 | end; 1107 | 1108 | function TLexGenerator.Check(LTyp: TLexemType): Boolean; 1109 | begin 1110 | if not Assigned(FLexem) then 1111 | begin 1112 | NextLex; 1113 | if not Assigned(FLexem) then 1114 | Exit(False); 1115 | end; 1116 | Result := FLexem.LType = LTyp; 1117 | end; 1118 | 1119 | function TLexGenerator.CheckKill(LTyp: TLexemType): Boolean; 1120 | begin 1121 | if not Assigned(FLexem) then 1122 | begin 1123 | NextLex; 1124 | if not Assigned(FLexem) then 1125 | Exit(False); 1126 | end; 1127 | if FLexem.LType = LTyp then 1128 | begin 1129 | KillLex; 1130 | Result := True; 1131 | end 1132 | else 1133 | Result := False; 1134 | end; 1135 | 1136 | function TLexGenerator.CheckKill(LTyp: TLexemTypes): TLexemType; 1137 | begin 1138 | if not Assigned(FLexem) then 1139 | begin 1140 | NextLex; 1141 | if not Assigned(FLexem) then 1142 | Exit(ltNil); 1143 | end; 1144 | if FLexem.LType in LTyp then 1145 | begin 1146 | Result := FLexem.LType; 1147 | KillLex; 1148 | end 1149 | else 1150 | Result := ltNil; 1151 | end; 1152 | 1153 | function TLexGenerator.CheckName(var S: String): Boolean; 1154 | var 1155 | lt: TLexemType; 1156 | begin 1157 | lt := Check([ltSValue, ltName, ltDValue, ltIValue, ltTrue, ltFalse]); 1158 | if lt in [ltSValue, ltName, ltTrue, ltFalse] then 1159 | begin 1160 | if (Pos(#$D, FLexem.Str) > 0) or (Pos(#$A, FLexem.Str)>0) then 1161 | Exit(False); 1162 | Result := True; 1163 | S := FLexem.Str; 1164 | end 1165 | else 1166 | Result := False; 1167 | end; 1168 | 1169 | constructor TLexGenerator.Create(LexG: TLexGrammar; ExceptBlock: Boolean); 1170 | begin 1171 | FExceptBlock := ExceptBlock; 1172 | if not Assigned(LexG) then 1173 | FLexG := JSONLexGrammar 1174 | else 1175 | FLexG := LexG; 1176 | FFirstRoute := LexG.FirstRoute; 1177 | FBuffer := TLexBuff.Create; 1178 | FEscapeSupport := LexG.EscapeSupport; 1179 | if FEscapeSupport then 1180 | begin 1181 | FEscapeRoute := LexG.EscapeRoute; 1182 | FEscapeBuff := TLexBuff.Create; 1183 | end; 1184 | New(FCurrPos); 1185 | FCurrPos.Line := 1; 1186 | FCurrPos.Col := 0; 1187 | end; 1188 | 1189 | procedure TLexGenerator.CreateLexeme; 1190 | begin 1191 | KillLex; 1192 | New(FLexem); 1193 | FillChar(FLexem.Pos, SizeOf(TPosition), 0); 1194 | FLexem.LType := ltNull; 1195 | end; 1196 | 1197 | function TLexGenerator.Current: ILexeme; 1198 | begin 1199 | Result := FLexem; 1200 | end; 1201 | 1202 | destructor TLexGenerator.Destroy; 1203 | begin 1204 | KillLex; 1205 | FBuffer.Free; 1206 | if FEscapeSupport then 1207 | FEscapeBuff.Free; 1208 | Dispose(FCurrPos); 1209 | inherited; 1210 | end; 1211 | 1212 | procedure TLexGenerator.KillLex; 1213 | begin 1214 | if Assigned(FLexem) then 1215 | begin 1216 | Dispose(FLexem); 1217 | FLexem := Nil; 1218 | end; 1219 | end; 1220 | 1221 | procedure TLexGenerator.Load(const Source: String); 1222 | begin 1223 | FCurr := PWideChar(Source); 1224 | end; 1225 | 1226 | {$HINTS OFF} 1227 | procedure TLexGenerator.NextLex; 1228 | var 1229 | Route: TRoute; 1230 | Trigger: TTrigger; 1231 | CTyp: TClass; 1232 | UseEscape, UseEscapeEnd: Boolean; 1233 | begin 1234 | CreateLexeme; 1235 | UseEscape := False; 1236 | UseEscapeEnd := False; 1237 | FBuffer.Clear; 1238 | if FEscapeSupport then 1239 | begin 1240 | FEscapeRoute := FLexG.EscapeRoute; 1241 | FEscapeBuff.Clear; 1242 | end; 1243 | 1244 | Route := FFirstRoute; 1245 | while Assigned(Route) do 1246 | begin 1247 | 1248 | if FEscapeSupport then 1249 | begin 1250 | Trigger := FEscapeRoute[FCurr^]; 1251 | if Trigger = Nil then 1252 | begin 1253 | Trigger := Route[FCurr^]; 1254 | UseEscape := False; 1255 | end 1256 | else 1257 | UseEscape := True; 1258 | end 1259 | else 1260 | begin 1261 | Trigger := Route[FCurr^]; 1262 | UseEscape := False; 1263 | end; 1264 | 1265 | if Trigger = Nil then Exit; 1266 | 1267 | CTyp := Trigger.ClassType; 1268 | 1269 | if CTyp = TErrorTrigger then 1270 | if FCurr^ = #0 then 1271 | Break 1272 | else 1273 | if FExceptBlock then 1274 | Abort 1275 | else 1276 | raise TJSONSyntaxError.Create( TErrorTrigger(Trigger).Message, FCurrPos); 1277 | 1278 | if CTyp = TUseRouteTrigger then 1279 | if UseEscape then 1280 | FEscapeBuff.Add(FCurr^) 1281 | else 1282 | FBuffer.Add(FCurr^); 1283 | 1284 | if Trigger.BF and (FLexem.Pos.Col = 0) then 1285 | FLexem.Pos := FCurrPos^; 1286 | 1287 | if not Trigger.BK then 1288 | begin 1289 | Inc(FCurr); 1290 | if FCurr^ = #10 then 1291 | begin 1292 | Inc(FCurrPos.Line); 1293 | FCurrPos.Col := 1; 1294 | end 1295 | else 1296 | Inc(FCurrPos.Col); 1297 | end; 1298 | 1299 | if Trigger.ParseProcs <> ppNil then 1300 | begin 1301 | case Trigger.ParseProcs of 1302 | ppInteger: begin 1303 | FLexem.Int := FBuffer.AsInt64; 1304 | FLexem.LType := ltIValue; 1305 | end; 1306 | ppDouble:begin 1307 | FLexem.Dbl := FBuffer.AsDouble; 1308 | FLexem.LType := ltDValue; 1309 | end; 1310 | ppString:begin 1311 | FLexem.LType := ltSValue; 1312 | end; 1313 | 1314 | ppName: begin 1315 | FLexem.Str := FBuffer.AsString; 1316 | FLexem.LType := FBuffer.AsType; 1317 | end; 1318 | 1319 | ppEscapeUChar: begin 1320 | if FEscapeBuff.Length = 4 then 1321 | begin 1322 | FBuffer.Add(Chr(FEscapeBuff.AsHInt)); 1323 | FEscapeBuff.Clear; 1324 | UseEscapeEnd := True; 1325 | end; 1326 | end; 1327 | 1328 | ppEscape: begin 1329 | case FEscapeBuff.Buff[0] of 1330 | 'b' : FBuffer.Add(#8); 1331 | 't' : FBuffer.Add(#9); 1332 | 'n' : FBuffer.Add(#10); 1333 | 'v' : FBuffer.Add(#11); 1334 | 'f' : FBuffer.Add(#12); 1335 | 'r' : FBuffer.Add(#13); 1336 | '\' : FBuffer.Add('\'); 1337 | '"' : FBuffer.Add('"'); 1338 | '''': FBuffer.Add(''''); 1339 | else 1340 | FBuffer.Add(FEscapeBuff.Buff[0]); 1341 | end; 1342 | FEscapeBuff.Clear; 1343 | end; 1344 | end; 1345 | end; 1346 | 1347 | if Trigger.ED or UseEscapeEnd then 1348 | begin 1349 | if not UseEscape then 1350 | begin 1351 | FFirstRoute := Trigger.NextRoute; 1352 | FLexem.Str := FBuffer.AsString; 1353 | Exit; 1354 | end; 1355 | UseEscape := False; 1356 | UseEscapeEnd := False; 1357 | FEscapeRoute := FLexG.EscapeRoute; 1358 | end 1359 | else 1360 | if UseEscape then 1361 | FEscapeRoute := Trigger.NextRoute 1362 | else 1363 | Route := Trigger.NextRoute; 1364 | end; 1365 | KillLex; 1366 | end; 1367 | {$HINTS ON} 1368 | 1369 | { TJSONBuilder } 1370 | 1371 | constructor TJSONBuilder.Create(const JSON: String; const CheckDates: Boolean); 1372 | begin 1373 | LGen := TLexGenerator.Create(JSONLexGrammar); 1374 | LGen.Load(JSON); 1375 | FCheckDates := CheckDates; 1376 | end; 1377 | 1378 | destructor TJSONBuilder.Destroy; 1379 | begin 1380 | LGen.Free; 1381 | inherited; 1382 | end; 1383 | 1384 | procedure TJSONBuilder.ReadArray(var Val: IJSONAncestor); 1385 | var 1386 | Item: IJSONAncestor; 1387 | begin 1388 | LGen.KillLex; 1389 | Val := TJSONArray.Create; 1390 | 1391 | repeat 1392 | Item := ReadValue; 1393 | if Assigned(Item) then 1394 | TJSONArray(Val).Add(Item); 1395 | until not LGen.CheckKill(ltVirgule); 1396 | 1397 | if not LGen.CheckKill(ltCRight) then 1398 | raise TJSONSyntaxError.Create(Err_UnexpectedEndOfInput, LGen.CurrPos); 1399 | end; 1400 | 1401 | procedure TJSONBuilder.ReadFalse(var Val: IJSONAncestor); 1402 | begin 1403 | Val := TJSONBoolean.Create(False); 1404 | LGen.KillLex; 1405 | end; 1406 | 1407 | procedure TJSONBuilder.ReadFloat(var Val: IJSONAncestor); 1408 | begin 1409 | Val := TJSONFloat.Create(LGen.Current.Dbl); 1410 | LGen.KillLex; 1411 | end; 1412 | 1413 | procedure TJSONBuilder.ReadInteger(var Val: IJSONAncestor); 1414 | begin 1415 | Val := TJSONInteger.Create(LGen.Current.Int); 1416 | LGen.KillLex; 1417 | end; 1418 | 1419 | procedure TJSONBuilder.ReadNull(var Val: IJSONAncestor); 1420 | begin 1421 | Val := TJSONNull.Create(True); 1422 | LGen.KillLex; 1423 | end; 1424 | 1425 | procedure TJSONBuilder.ReadObject(var Val: IJSONAncestor); 1426 | var 1427 | Name: String; 1428 | begin 1429 | LGen.KillLex; 1430 | Val := TJSONObject.Create; 1431 | repeat 1432 | if LGen.CheckName(Name) then 1433 | begin 1434 | LGen.KillLex; 1435 | if not LGen.CheckKill(ltColon) then 1436 | raise TJSONSyntaxError.CreateFmt(Err_Expected, [':'], LGen.CurrPos); 1437 | TJSONObject(Val).AddPair(TJSONPair.Create(Name, ReadValue)); 1438 | end 1439 | until not LGen.CheckKill(ltVirgule); 1440 | 1441 | if not LGen.CheckKill(ltBRight) then 1442 | raise TJSONSyntaxError.Create(Err_UnexpectedEndOfInput, LGen.CurrPos); 1443 | end; 1444 | 1445 | procedure TJSONBuilder.ReadString(var Val: IJSONAncestor); 1446 | var 1447 | dT: TDateTime; 1448 | DVal: TDataType; 1449 | label 1450 | JMP; 1451 | begin 1452 | if (not FCheckDates) or (Length(LGen.Current.Str) > 25 {2015-10-20T12:22:24+00:00}) or (Length(LGen.Current.Str) < 5 {22:22}) then 1453 | JMP:Val := TJSONString.Create( LGen.Current.Str ) 1454 | else 1455 | if TJSONDateManager.Check(LGen.Current.Str, dT, DVal ) then 1456 | case DVal of 1457 | dtDateTime: Val := TJSONDateTime.Create(dT); 1458 | dtDate : Val := TJSONDate.Create(TDate(dT)); 1459 | dtTime : Val := TJSONTime.Create(TTime(dT)); 1460 | else 1461 | goto JMP; 1462 | end 1463 | else 1464 | goto JMP; 1465 | LGen.KillLex; 1466 | end; 1467 | 1468 | procedure TJSONBuilder.ReadTrue(var Val: IJSONAncestor); 1469 | begin 1470 | Val := TJSONBoolean.Create(True); 1471 | LGen.KillLex; 1472 | end; 1473 | 1474 | function TJSONBuilder.ReadValue: IJSONAncestor; 1475 | begin 1476 | case LGen.Check([ ltSValue, ltIValue, ltDValue, ltBLeft, ltCLeft, 1477 | ltTrue, ltFalse, ltNull ]) of 1478 | ltSValue: ReadString(Result); 1479 | ltIValue: ReadInteger(Result); 1480 | ltDValue: ReadFloat(Result); 1481 | ltBLeft : ReadObject(Result); 1482 | ltTrue : ReadTrue(Result); 1483 | ltFalse : ReadFalse(Result); 1484 | ltCLeft : ReadArray(Result); 1485 | ltNull : ReadNull(Result); 1486 | else 1487 | Result := Nil; 1488 | end; 1489 | end; 1490 | 1491 | { TJSONString } 1492 | 1493 | procedure TJSONString.AsJSONString(Str: TJSONWriter); 1494 | begin 1495 | if IsNull then 1496 | Str.AppendVal( cNull ) 1497 | else 1498 | Str.AppendVal( '"' + StrToUTF16(Value) + '"' ); 1499 | end; 1500 | 1501 | { TJSONInteger } 1502 | 1503 | procedure TJSONInteger.AsJSONString(Str: TJSONWriter); 1504 | begin 1505 | if FNull then 1506 | Str.AppendVal( cNull ) 1507 | else 1508 | Str.AppendVal( Value ); 1509 | end; 1510 | 1511 | 1512 | { TJSONFloat } 1513 | 1514 | procedure TJSONFloat.AsJSONString(Str: TJSONWriter); 1515 | begin 1516 | if FNull then 1517 | Str.AppendVal( cNull ) 1518 | else 1519 | Str.AppendVal( FloatToStr(Value, FloatFormat) ); 1520 | end; 1521 | 1522 | { TJSONBoolean } 1523 | 1524 | procedure TJSONBoolean.AsJSONString(Str: TJSONWriter); 1525 | begin 1526 | Str.AppendVal( String(iff( IsNull, cNull, iff( Value, 'true', 'false') )) ); 1527 | end; 1528 | 1529 | { TJSONNull } 1530 | 1531 | procedure TJSONNull.AsJSONString(Str: TJSONWriter); 1532 | begin 1533 | Str.AppendVal( cNull ); 1534 | end; 1535 | 1536 | function TJSONNull.GetIsNull: Boolean; 1537 | begin 1538 | Result := True; 1539 | end; 1540 | 1541 | { TJSONObject } 1542 | 1543 | procedure TJSONObject.AddPair(P: IJSONPair); 1544 | var 1545 | N: IJSONPair; 1546 | begin 1547 | N := Get(P.Name); 1548 | if Assigned(N) then 1549 | begin 1550 | FPairList.Remove(N); 1551 | N := Nil; 1552 | end; 1553 | FPairList.Add(P); 1554 | end; 1555 | 1556 | procedure TJSONObject.AddPair(Name: String; Value: IJSONAncestor); 1557 | begin 1558 | AddPair( TJSONPair.Create(Name, Value) ); 1559 | end; 1560 | 1561 | procedure TJSONObject.AsJSONString(Str: TJSONWriter); 1562 | var 1563 | P: IJSONPair; 1564 | I,L: Integer; 1565 | begin 1566 | if FNull then 1567 | Str.AppendVal( cNull ) 1568 | else 1569 | begin 1570 | Str.Append('{', True); 1571 | Str.Inc; 1572 | L := Count-1; 1573 | for I := 0 to L do 1574 | begin 1575 | P := FPairList[I]; 1576 | Str.Append('"' + StrToUTF16(P.Name) + '":'); 1577 | if Str.Ident and (P.JSONValue.DataType in [dtObject, dtArray]) then 1578 | Str.Append('', True); 1579 | P.JSONValue.AsJSONString(Str); 1580 | if I < L then 1581 | Str.AppendVal(',', Str.Ident); 1582 | end; 1583 | Str.Dec; 1584 | if Str.Ident then 1585 | Str.Append(#$D#$A); 1586 | Str.Append('}'); 1587 | end; 1588 | end; 1589 | 1590 | function TJSONObject.Count: Integer; 1591 | begin 1592 | Result := FPairList.Count; 1593 | end; 1594 | 1595 | constructor TJSONObject.Create; 1596 | begin 1597 | FPairList := TList.Create; 1598 | end; 1599 | 1600 | destructor TJSONObject.Destroy; 1601 | begin 1602 | FPairList.Free; 1603 | inherited; 1604 | end; 1605 | 1606 | function TJSONObject.Get(const Name: String): IJSONPair; 1607 | var 1608 | P: IJSONPair; 1609 | begin 1610 | for P in FPairList do 1611 | if CompareText(Name, P.Name) = 0 then 1612 | Exit(P); 1613 | Result := Nil; 1614 | end; 1615 | 1616 | function TJSONObject.GetIsNull: Boolean; 1617 | begin 1618 | Result := FNull; 1619 | end; 1620 | 1621 | function TJSONObject.Get(const Index: Integer): IJSONPair; 1622 | begin 1623 | if (FPairList.Count = 0) or (FPairList.Count <= Index) then 1624 | Result := Nil 1625 | else 1626 | Result := FPairList[Index]; 1627 | end; 1628 | 1629 | function TJSONObject.GetEnumerator: TJSONEnumerator; 1630 | begin 1631 | Result.Index := -1; 1632 | Result.List := FPairList; 1633 | end; 1634 | 1635 | class function TJSONObject.ParseJSONValue(const Str: String; const CheckDate: Boolean): IJSONAncestor; 1636 | begin 1637 | Result := TSuperParser.ParseJSON(Str, CheckDate); 1638 | end; 1639 | 1640 | procedure TJSONObject.Remove(P: IJSONPair); 1641 | begin 1642 | Remove(P.Name); 1643 | end; 1644 | 1645 | procedure TJSONObject.Remove(const Index: Integer); 1646 | begin 1647 | if Count > Index then 1648 | FPairList.Delete(Index); 1649 | end; 1650 | 1651 | procedure TJSONObject.Sort(Comparison: TJSONComparison); 1652 | begin 1653 | FPairList.Sort( TComparer.Construct( 1654 | TComparison(Comparison) 1655 | )); 1656 | end; 1657 | 1658 | procedure TJSONObject.Remove(const Name: String); 1659 | var 1660 | R: IJSONPair; 1661 | begin 1662 | R := Get(Name); 1663 | if Assigned(R) then 1664 | begin 1665 | FPairList.Remove(R); 1666 | R := Nil; 1667 | end; 1668 | end; 1669 | 1670 | 1671 | { TJSONPair } 1672 | 1673 | constructor TJSONPair.Create(const aName: String; aValue: IJSONAncestor); 1674 | begin 1675 | FName := aName; 1676 | FValue := aValue; 1677 | end; 1678 | 1679 | destructor TJSONPair.Destroy; 1680 | begin 1681 | FValue := Nil; 1682 | inherited; 1683 | end; 1684 | 1685 | 1686 | function TJSONPair.GetName: String; 1687 | begin 1688 | Result := FName; 1689 | end; 1690 | 1691 | function TJSONPair.GetValue: IJSONAncestor; 1692 | begin 1693 | Result := FValue; 1694 | end; 1695 | 1696 | procedure TJSONPair.SetName(const Value: String); 1697 | begin 1698 | FName := Value; 1699 | end; 1700 | 1701 | procedure TJSONPair.SetValue(const Value: IJSONAncestor); 1702 | begin 1703 | FValue := Value; 1704 | end; 1705 | 1706 | { TJSONSyntaxError } 1707 | 1708 | constructor TJSONSyntaxError.Create(const Msg: String; Pos: PPosition); 1709 | begin 1710 | inherited CreateFmt(Msg + '. (Line: %d Col: %d)', [Pos.Line, Pos.Col]); 1711 | end; 1712 | 1713 | constructor TJSONSyntaxError.CreateFmt(const Msg: String; const Args: array of TVarRec; 1714 | Pos: PPosition); 1715 | begin 1716 | Create( Format(Msg, Args), Pos ); 1717 | end; 1718 | 1719 | 1720 | { TJSONArray } 1721 | 1722 | procedure TJSONArray.Add(Val: IJSONAncestor); 1723 | begin 1724 | FList.Add(Val); 1725 | end; 1726 | 1727 | procedure TJSONArray.AsJSONString(Str: TJSONWriter); 1728 | var 1729 | I,L: Integer; 1730 | begin 1731 | if FNull then 1732 | Str.AppendVal( cNull ) 1733 | else 1734 | begin 1735 | Str.Append('[', True); 1736 | Str.Inc; 1737 | L := Count - 1; 1738 | for I := 0 to L do 1739 | begin 1740 | if FList = Nil then Continue; 1741 | FList[I].AsJSONString(Str); 1742 | if I < L then 1743 | Str.AppendVal(',', Str.Ident); 1744 | end; 1745 | Str.Dec; 1746 | if Str.Ident then 1747 | Str.Append(#$D#$A); 1748 | Str.Append(']'); 1749 | end; 1750 | end; 1751 | 1752 | procedure TJSONArray.Clear; 1753 | begin 1754 | FList.Clear; 1755 | end; 1756 | 1757 | function TJSONArray.Count: Integer; 1758 | begin 1759 | Result := FList.Count; 1760 | end; 1761 | 1762 | constructor TJSONArray.Create; 1763 | begin 1764 | FList := TList.Create; 1765 | end; 1766 | 1767 | destructor TJSONArray.Destroy; 1768 | begin 1769 | FList.Free; 1770 | inherited; 1771 | end; 1772 | 1773 | function TJSONArray.Get(const I: Integer): IJSONAncestor; 1774 | begin 1775 | if (FList.Count = 0) or (Flist.Count <= I) then 1776 | Result := Nil 1777 | else 1778 | Result := FList.Items[I] 1779 | end; 1780 | 1781 | function TJSONArray.GetEnumerator: TJSONEnumerator; 1782 | begin 1783 | Result.Index := -1; 1784 | Result.List := FList; 1785 | end; 1786 | 1787 | function TJSONArray.GetIsNull: Boolean; 1788 | begin 1789 | Result := FNull; 1790 | end; 1791 | 1792 | procedure TJSONArray.Remove(Val: IJSONAncestor); 1793 | begin 1794 | FList.Remove(Val); 1795 | end; 1796 | 1797 | procedure TJSONArray.Remove(Index: Integer); 1798 | begin 1799 | FList.Delete(Index); 1800 | end; 1801 | 1802 | procedure TJSONArray.SetIndex(const Int: Integer; const Value: IJSONAncestor); 1803 | begin 1804 | if (FList.Count = 0) or (Flist.Count <= Int) then 1805 | Exit; 1806 | FList[Int] := Value; 1807 | end; 1808 | 1809 | procedure TJSONArray.Sort(Comparison: TJSONComparison); 1810 | begin 1811 | FList.Sort( TComparer.Construct( 1812 | TComparison(Comparison) 1813 | )); 1814 | end; 1815 | 1816 | { TJSONValue } 1817 | 1818 | constructor TJSONValue.Create(const Value: T); 1819 | begin 1820 | FData := Value; 1821 | FNull := False; 1822 | end; 1823 | 1824 | constructor TJSONValue.CreateNull; 1825 | begin 1826 | FNull := True; 1827 | end; 1828 | 1829 | function TJSONValue.GetData: T; 1830 | begin 1831 | Result := FData; 1832 | end; 1833 | 1834 | function TJSONValue.GetIsNull: Boolean; 1835 | begin 1836 | Result := FNull; 1837 | end; 1838 | 1839 | procedure TJSONValue.SetData(const Value: T); 1840 | begin 1841 | FData := Value; 1842 | end; 1843 | 1844 | procedure TJSONValue.SetNull; 1845 | begin 1846 | FNull := True; 1847 | end; 1848 | 1849 | { TJSONInterpreter } 1850 | 1851 | constructor TJSONInterpreter.Create(const Expression: String; 1852 | JSON: IJSONAncestor; BlockException: Boolean = False); 1853 | begin 1854 | LGen := TLexGenerator.Create(JSONLexGrammar, BlockException); 1855 | LGen.Load(Expression); 1856 | FJSON := JSON; 1857 | FExceptionBlock := BlockException; 1858 | end; 1859 | 1860 | procedure TJSONInterpreter.CreateExcept(const S: String; 1861 | Args: array of TVarRec); 1862 | begin 1863 | if FExceptionBlock then 1864 | Abort 1865 | else 1866 | raise TJSONSyntaxError.CreateFmt(S, Args, LGen.CurrPos); 1867 | end; 1868 | 1869 | procedure TJSONInterpreter.CreateExcept(const S: String); 1870 | begin 1871 | if FExceptionBlock then 1872 | Abort 1873 | else 1874 | raise TJSONSyntaxError.Create(S, LGen.CurrPos); 1875 | end; 1876 | 1877 | destructor TJSONInterpreter.Destroy; 1878 | begin 1879 | LGen.Free; 1880 | inherited; 1881 | end; 1882 | 1883 | function TJSONInterpreter.ReadArray(Base: IJSONAncestor): IJSONArray; 1884 | var 1885 | Item: IJSONAncestor; 1886 | begin 1887 | LGen.KillLex; 1888 | Result := TJSONArray.Create; 1889 | repeat 1890 | Item := ReadValue(Base); 1891 | if Assigned(Item) then 1892 | TJSONArray(Result).Add(Item); 1893 | until not LGen.CheckKill(ltVirgule); 1894 | 1895 | if not LGen.CheckKill(ltCRight) then 1896 | CreateExcept(Err_UnexpectedEndOfInput); 1897 | end; 1898 | 1899 | function TJSONInterpreter.ReadArrayIndex(Base: IJSONArray): IJSONAncestor; 1900 | var 1901 | RName: IJSONAncestor; 1902 | Index: Integer; 1903 | begin 1904 | Index := 0; 1905 | case LGen.Check([ltIValue, ltName]) of 1906 | ltIValue: 1907 | begin 1908 | Index := StrToInt(LGen.Current.Str); 1909 | LGen.KillLex; 1910 | end; 1911 | ltName: 1912 | begin 1913 | RName := ReadName(FJSON); 1914 | if not (RName is TJSONInteger) then 1915 | CreateExcept(Err_ExpectedButFound, [STokenTypes[ltIValue], STokenTypes[LGen.Current.LType]]) 1916 | else 1917 | Index := TJSONInteger(RName).Value; 1918 | end 1919 | else 1920 | CreateExcept(Err_ExpectedButFound, [STokenTypes[ltIValue], STokenTypes[LGen.Current.LType]]) 1921 | end; 1922 | Result := Base.Index[Index]; 1923 | if not LGen.CheckKill(ltCRight) then 1924 | CreateExcept(Err_Expected, [STokenTypes[ltCRight]]); 1925 | if LGen.CheckKill(ltDot) then 1926 | begin 1927 | RName := ReadName(Result); 1928 | if Assigned(RName) then 1929 | Result := RName; 1930 | end; 1931 | end; 1932 | 1933 | function TJSONInterpreter.ReadExpression: IJSONAncestor; 1934 | begin 1935 | try 1936 | case LGen.Check([ltBLeft, ltCLeft]) of 1937 | ltBLeft : Result := ReadObject(FJSON); 1938 | ltCLeft : Result := ReadArray(FJSON); 1939 | else 1940 | Result := ReadName(FJSON); 1941 | end; 1942 | except 1943 | on E: Exception do 1944 | begin 1945 | if FExceptionBlock then 1946 | Result := Nil 1947 | else 1948 | raise; 1949 | end; 1950 | end; 1951 | end; 1952 | 1953 | function TJSONInterpreter.ReadName(Base: IJSONAncestor): IJSONAncestor; 1954 | var 1955 | Name: String; 1956 | Pair: IJSONPair; 1957 | begin 1958 | if not LGen.CheckName(Name) then 1959 | Exit(Nil); 1960 | 1961 | if Base is TJSONArray then 1962 | begin 1963 | if LGen.Current.LType <> ltIValue then 1964 | CreateExcept(Err_ExpectedButFound, [STokenTypes[ltIValue], STokenTypes[LGen.Current.LType]]) 1965 | else 1966 | Result := TJSONArray(Base).Index[StrToInt(Name)]; 1967 | end 1968 | else 1969 | if Base is TJSONObject then 1970 | begin 1971 | Pair := TJSONObject(Base).Get(Name); 1972 | if Pair = Nil then 1973 | Exit(Nil) 1974 | else 1975 | Result := Pair.JSONValue; 1976 | LGen.KillLex; 1977 | if Assigned(Result) then 1978 | case LGen.CheckKill([ltDot, ltCLeft]) of 1979 | ltDot: 1980 | Result := ReadName(Result); 1981 | ltCLeft: 1982 | begin 1983 | if Result is TJSONArray then 1984 | Result := ReadArrayIndex(TJSONArray(Result)) 1985 | else 1986 | CreateExcept(Err_Expected, ['Array']); 1987 | end; 1988 | end; 1989 | end 1990 | else 1991 | Result := Nil; 1992 | end; 1993 | 1994 | function TJSONInterpreter.ReadObject(Base: IJSONAncestor): IJSONObject; 1995 | var 1996 | Name: String; 1997 | begin 1998 | LGen.KillLex; 1999 | Result := TJSONObject.Create; 2000 | repeat 2001 | if LGen.CheckName(Name) then 2002 | begin 2003 | LGen.KillLex; 2004 | if not LGen.CheckKill(ltColon) then 2005 | CreateExcept(Err_Expected, [':']); 2006 | TJSONObject(Result).AddPair(TJSONPair.Create(Name, ReadValue(Base))); 2007 | end 2008 | until not LGen.CheckKill(ltVirgule); 2009 | 2010 | if not LGen.CheckKill(ltBRight) then 2011 | CreateExcept(Err_UnexpectedEndOfInput); 2012 | end; 2013 | 2014 | function TJSONInterpreter.ReadValue(Base: IJSONAncestor): IJSONAncestor; 2015 | begin 2016 | case LGen.Check([ ltSValue, ltIValue, ltDValue, ltBLeft, ltCLeft, 2017 | ltTrue, ltFalse, ltName, ltNull ]) of 2018 | ltSValue: Result := TJSONString.Create(LGen.Current.Str); 2019 | ltIValue: Result := TJSONInteger.Create(LGen.Current.Int); 2020 | ltDValue: Result := TJSONFloat.Create(LGen.Current.Dbl); 2021 | ltBLeft : Result := ReadObject(Base); 2022 | ltTrue : Result := TJSONBoolean.Create(True); 2023 | ltFalse : Result := TJSONBoolean.Create(False); 2024 | ltCLeft : Result := ReadArray(Base); 2025 | ltNull : Result := TJSONNull.Create(True); 2026 | ltName : begin 2027 | Result := ReadName(Base); 2028 | Exit; 2029 | end 2030 | else 2031 | Result := Nil; 2032 | Exit; 2033 | end; 2034 | LGen.KillLex; 2035 | end; 2036 | 2037 | { TSuperEnumerator } 2038 | 2039 | function TJSONEnumerator.GetCurrent: T; 2040 | begin 2041 | Result := List[Index] 2042 | end; 2043 | 2044 | function TJSONEnumerator.MoveNext: Boolean; 2045 | begin 2046 | Result := Index < List.Count - 1; 2047 | if Result then 2048 | Inc(Index); 2049 | end; 2050 | 2051 | { TJSONWriter } 2052 | 2053 | function TJSONWriter.Append(const Value: string; const CRLF: Boolean = False): TJSONWriter; 2054 | begin 2055 | if FIdent then 2056 | begin 2057 | FData.Append(' ', FIdentOffset); 2058 | if CRLF then 2059 | FData.AppendLine(Value) 2060 | else 2061 | FData.Append(Value) 2062 | end 2063 | else 2064 | FData.Append(Value); 2065 | Result := Self; 2066 | end; 2067 | 2068 | function TJSONWriter.Append(const Value: int64; const CRLF: Boolean): TJSONWriter; 2069 | begin 2070 | Result := Append(IntToStr(Value), CRLF); 2071 | end; 2072 | 2073 | function TJSONWriter.AppendVal(const Value: string; const CRLF: Boolean): TJSONWriter; 2074 | begin 2075 | if CRLF then 2076 | FData.AppendLine(Value) 2077 | else 2078 | FData.Append(Value); 2079 | Result := Self; 2080 | end; 2081 | 2082 | function TJSONWriter.AppendVal(const Value: int64; const CRLF: Boolean): TJSONWriter; 2083 | begin 2084 | Result := Append(IntToStr(Value), CRLF); 2085 | end; 2086 | 2087 | constructor TJSONWriter.Create(const useIdent, useUniversalTime: Boolean); 2088 | begin 2089 | inherited Create; 2090 | FData := TStringBuilder.Create; 2091 | FIdent := useIdent; 2092 | FUniversalTime := useUniversalTime; 2093 | FIdentOffset := 0; 2094 | end; 2095 | 2096 | procedure TJSONWriter.Dec; 2097 | begin 2098 | System.Dec(FIdentOffset, IDENT_SIZE); 2099 | end; 2100 | 2101 | destructor TJSONWriter.Destroy; 2102 | begin 2103 | FData.Free; 2104 | inherited; 2105 | end; 2106 | 2107 | procedure TJSONWriter.Inc; 2108 | begin 2109 | System.Inc(FIdentOffset, IDENT_SIZE); 2110 | end; 2111 | 2112 | function TJSONWriter.ToString: string; 2113 | begin 2114 | Result := FData.ToString; 2115 | end; 2116 | 2117 | { TJSONDateTime } 2118 | 2119 | constructor TJSONDateTime.Create(const Value: TDateTime; const Format: String); 2120 | begin 2121 | inherited Create(Value); 2122 | FFormat := Format; 2123 | end; 2124 | 2125 | { TJSONDateManager } 2126 | 2127 | class function TJSONDateManager.Check(const Data: String; var AValue: TDateTime; 2128 | var Typ: TDataType): Boolean; 2129 | var 2130 | CallBck: TJSONDateTimeCheckCallBack; 2131 | begin 2132 | for CallBck in FFormats do 2133 | if CallBck(Data, AValue, Typ) then 2134 | Exit(True); 2135 | Result := False; 2136 | end; 2137 | 2138 | class constructor TJSONDateManager.Create; 2139 | begin 2140 | FFormats := TList.Create; 2141 | end; 2142 | 2143 | class destructor TJSONDateManager.Destroy; 2144 | {$IF CompilerVersion < 29} 2145 | var 2146 | I: Integer; 2147 | {$ENDIF} 2148 | begin 2149 | if Assigned(FFormats) then begin 2150 | {$IF CompilerVersion < 29} 2151 | for I := 0 to FFormats.Count - 1 do 2152 | FFormats.List[I]._Release; 2153 | {$ENDIF} 2154 | FFormats.Free; 2155 | end; 2156 | end; 2157 | 2158 | class function TJSONDateManager.GetFormats: TList; 2159 | begin 2160 | Result := FFormats; 2161 | end; 2162 | 2163 | { TISO8601 } 2164 | 2165 | constructor TISO8601.Create(const Value: String); 2166 | var 2167 | Matches: TMatchCollection; 2168 | begin 2169 | FillChar(Self, SizeOf(TISO8601), #0); 2170 | Matches := TRegEx.Matches(Value, '(?=\d{4})((\d{4})-(\d{2})-(\d{2}))?(T(\d{2})\:(\d{2})\:('+ 2171 | '\d{2})(Z)?(\.(\d{1,3})(Z)?)?([+-](\d{2})\:(\d{2}))?)?|(\d{2})\:('+ 2172 | '\d{2})\:(\d{2})(Z)?(\.(\d{1,3}))?([+-](\d{2})\:(\d{2}))?'); 2173 | if Matches.Count <> 1 then Exit; 2174 | FData := Matches.Item[0]; 2175 | FSuccess := Trim(FData.Value) = Trim(Value); 2176 | if not FSuccess then Exit; 2177 | ReadStructure; 2178 | end; 2179 | 2180 | function TISO8601.GetIntData(const Index: Integer): Integer; 2181 | begin 2182 | Result := StrToInt(GetStrData(Index)); 2183 | end; 2184 | 2185 | function TISO8601.GetIntData(const Index: Integer; const P: Boolean): Integer; 2186 | begin 2187 | Result := GetIntData(Index); 2188 | if not P then 2189 | Result := -1 * Result; 2190 | end; 2191 | 2192 | function TISO8601.GetStrData(const Index: Integer): String; 2193 | begin 2194 | Result := FData.Groups.Item[Index].Value; 2195 | end; 2196 | 2197 | function TISO8601.NextOffset: Integer; 2198 | begin 2199 | Inc(FOffset); 2200 | Result := FOffset; 2201 | end; 2202 | 2203 | procedure TISO8601.ReadStructure; 2204 | var 2205 | Len, VLen: Integer; 2206 | Grp: TGroup; 2207 | begin 2208 | FOffset := 1; 2209 | Len := FData.Groups.Count - 1; 2210 | while FOffset <= Len do 2211 | begin 2212 | Grp := FData.Groups.Item[FOffset]; 2213 | with Grp do 2214 | if Value > '' then begin 2215 | VLen := System.Length(Value); 2216 | if (Value[CharIndex] <> '.') and (VLen = 4) then begin 2217 | Dec(FOffset); 2218 | ReadDate 2219 | end else 2220 | case Value[CharIndex] of 2221 | '0'..'9': if VLen = 2 then begin 2222 | FUseTime := True; 2223 | Dec(FOffset); 2224 | if not ReadTime then 2225 | begin 2226 | FSuccess := False; 2227 | Exit; 2228 | end; 2229 | end; 2230 | 2231 | 'T', 't': begin 2232 | FUseTime := True; 2233 | if not ReadTime then 2234 | begin 2235 | FSuccess := False; 2236 | Exit; 2237 | end; 2238 | end; 2239 | 'Z': if FUseTime then ReadZulu; 2240 | '.': if FUseTime then ReadMS; 2241 | '+': if FUseTime then ReadTZ(True); 2242 | '-': if FUseTime then ReadTZ(False); 2243 | end; 2244 | end; 2245 | Inc(FOffset); 2246 | end; 2247 | if FUseDate and FUseTime then 2248 | FValueType := dtDateTime 2249 | else if FUseDate then 2250 | FValueType := dtDate 2251 | else if FUseTime then 2252 | FValueType := dtTime; 2253 | end; 2254 | 2255 | function TISO8601.ReadDate: Boolean; 2256 | begin 2257 | Result := True; 2258 | if not TryEncodeDate( GetIntData(NextOffset), GetIntData(NextOffset), GetIntData(NextOffset), FValue ) then 2259 | begin 2260 | FValue := 0; 2261 | Result := False; 2262 | end 2263 | else 2264 | FUseDate := True 2265 | end; 2266 | 2267 | procedure TISO8601.ReadMS; 2268 | var 2269 | Temp: TDateTime; 2270 | begin 2271 | if TryEncodeTime(0, 0, 0, GetIntData(NextOffset), Temp) then 2272 | FValue := FValue + TTime(Temp); 2273 | end; 2274 | 2275 | function TISO8601.ReadTime: Boolean; 2276 | var 2277 | Temp: TDateTime; 2278 | begin 2279 | if TryEncodeTime(GetIntData(NextOffset), GetIntData(NextOffset), GetIntData(NextOffset), 0, Temp ) then 2280 | begin 2281 | FValue := FValue + TTime(Temp); 2282 | FUseTime := True; 2283 | Result := True; 2284 | end 2285 | else 2286 | Result := False; 2287 | end; 2288 | 2289 | procedure TISO8601.ReadTZ(const P: Boolean); 2290 | begin 2291 | FValue := IncHour(FValue, -1 * GetIntData(NextOffset, P)); 2292 | FValue := IncMinute(FValue, -1 * GetIntData(NextOffset, P)); 2293 | FValue := TTimeZone.Local.ToLocalTime(FValue) 2294 | end; 2295 | 2296 | 2297 | procedure TISO8601.ReadZulu; 2298 | begin 2299 | FValue := TTimeZone.Local.ToLocalTime(FValue); 2300 | end; 2301 | 2302 | { TJSONDate } 2303 | 2304 | constructor TJSONDate.Create(const Value: TDate; const Format: String); 2305 | begin 2306 | inherited Create(Value); 2307 | FFormat := Format; 2308 | end; 2309 | 2310 | { TJSONTime } 2311 | 2312 | constructor TJSONTime.Create(const Value: TTime; const Format: String); 2313 | begin 2314 | inherited Create(Value); 2315 | FFormat := Format; 2316 | end; 2317 | 2318 | { TJSONBaseDate } 2319 | 2320 | procedure TJSONBaseDate.AsJSONString(Str: TJSONWriter); 2321 | begin 2322 | if FNull then 2323 | Str.AppendVal( cNull ) 2324 | else 2325 | begin 2326 | if Str.UniversalTime then 2327 | Str.AppendVal( '"' + FormatDateTime(FFormat, TTimeZone.Local.ToUniversalTime(PDateTime(@FData)^)) + 'Z"' ) 2328 | else 2329 | Str.AppendVal( '"' + FormatDateTime(FFormat, PDateTime(@FData)^) + '"' ); 2330 | end; 2331 | end; 2332 | 2333 | function TJSONBaseDate.GetAsString: String; 2334 | begin 2335 | Result := FormatDateTime(FFormat, PDateTime(@FData)^); 2336 | end; 2337 | 2338 | { TJSONRaw } 2339 | 2340 | procedure TJSONRaw.AsJSONString(Str: TJSONWriter); 2341 | begin 2342 | Str.AppendVal( Value ); 2343 | end; 2344 | 2345 | initialization 2346 | 2347 | JSONLexGrammar := TJSONGrammar.Create; 2348 | 2349 | TJSONDateManager.Formats.Add( (* ISO-8601 | [Date] + [ Time + [MS] + [UTC] + [Z] ] *) 2350 | function(Str: String; var AValue: TDateTime; var Typ: TDataType): Boolean 2351 | begin 2352 | with TISO8601.Create(Str) do 2353 | begin 2354 | Result := Success; 2355 | if Result then 2356 | begin 2357 | AValue := Value; 2358 | Typ := ValueType; 2359 | end; 2360 | end; 2361 | end); 2362 | 2363 | finalization 2364 | 2365 | JSONLexGrammar.Free; 2366 | 2367 | end. 2368 | -------------------------------------------------------------------------------- /XSuperObject.inc: -------------------------------------------------------------------------------- 1 | (* 2 | * XSuperObject - Simple JSON Framework 3 | * 4 | * The MIT License (MIT) 5 | * Copyright (c) 2015 Onur YILDIZ 6 | * 7 | * 8 | * Permission is hereby granted, free of charge, to any person 9 | * obtaining a copy of this software and associated documentation 10 | * files (the "Software"), to deal in the Software without restriction, 11 | * including without limitation the rights to use, copy, modify, 12 | * merge, publish, distribute, sublicense, and/or sell copies of the Software, 13 | * and to permit persons to whom the Software is furnished to do so, 14 | * subject to the following conditions: 15 | * 16 | * The above copyright notice and this permission notice shall 17 | * be included in all copies or substantial portions of the Software. 18 | * 19 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 20 | * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 21 | * OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 22 | * IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, 23 | * DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 24 | * TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH 25 | * THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 26 | * 27 | *) 28 | 29 | (* 30 | * Marshalling Options 31 | *) 32 | {$DEFINE SP_DATASET} 33 | {$DEFINE SP_STREAM} 34 | 35 | // ** Zero Based Strings Definations... 36 | {$UNDEF XE2UP} 37 | {$IFDEF DCC} 38 | {$IF CompilerVersion >= 24} 39 | {$DEFINE XE2UP} 40 | {$ENDIF} 41 | {$ENDIF} -------------------------------------------------------------------------------- /XSuperObject.pas: -------------------------------------------------------------------------------- 1 |  (* 2 | * XSuperObject - Simple JSON Framework 3 | * 4 | * The MIT License (MIT) 5 | * Copyright (c) 2015 Onur YILDIZ 6 | * 7 | * 8 | * Permission is hereby granted, free of charge, to any person 9 | * obtaining a copy of this software and associated documentation 10 | * files (the "Software"), to deal in the Software without restriction, 11 | * including without limitation the rights to use, copy, modify, 12 | * merge, publish, distribute, sublicense, and/or sell copies of the Software, 13 | * and to permit persons to whom the Software is furnished to do so, 14 | * subject to the following conditions: 15 | * 16 | * The above copyright notice and this permission notice shall 17 | * be included in all copies or substantial portions of the Software. 18 | * 19 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 20 | * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 21 | * OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 22 | * IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, 23 | * DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 24 | * TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH 25 | * THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 26 | * 27 | *) 28 | 29 | unit XSuperObject; 30 | 31 | interface 32 | 33 | {$I XSuperObject.inc} 34 | 35 | uses 36 | Classes, 37 | Variants, 38 | SysUtils, 39 | Character, 40 | XSuperJSON, 41 | RTTI, 42 | TypInfo, 43 | Generics.Collections 44 | {$IFDEF SP_DATASET} 45 | ,DB 46 | {$ENDIF} 47 | {$IFDEF SP_STREAM} 48 | ,IdGlobal 49 | ,IdCoderMIME 50 | {$ENDIF} 51 | ; 52 | 53 | {$IFDEF XE2UP} 54 | const CharIndex = Low(String); 55 | {$ELSE} 56 | const CharIndex = 1; 57 | {$ENDIF} 58 | 59 | type 60 | 61 | SOException = class(Exception) end; 62 | SOInvalidDate = class(SOException) end; 63 | ESerializeError = class(Exception) end; 64 | 65 | ISuperObject = interface; 66 | ISuperArray = interface; 67 | ICast = Interface; 68 | IMember = ICast; 69 | TSuperObject = class; 70 | TSuperArray = class; 71 | 72 | TMemberStatus = (jUnAssigned, jNull, jAssigned); 73 | TJSONType = (jtObject, jtArray); 74 | 75 | Alias = class(TCustomAttribute) 76 | private 77 | FName: String; 78 | public 79 | constructor Create(const AName: String); 80 | property Name: String read FName write FName; 81 | end; 82 | 83 | TRevalOption = (roNone, roEmptyArrayToNull); 84 | 85 | REVAL = class(TCustomAttribute) 86 | private 87 | FOption: TRevalOption; 88 | FEqual: Variant; 89 | FValue: Variant; 90 | public 91 | constructor Create(EQVal: String; NewVal: String); overload; 92 | constructor Create(EQVal: Integer; NewVal: Integer); overload; 93 | constructor Create(EQVal: Boolean; NewVal: Boolean); overload; 94 | constructor Create(EQVal: Double; NewVal: Double); overload; 95 | constructor Create(EQVal: String); overload; 96 | constructor Create(EQVal: Integer); overload; 97 | constructor Create(EQVal: Double); overload; 98 | constructor Create(EQVal: Boolean); overload; 99 | constructor Create(Option: TRevalOption); overload; 100 | function CheckEQ(Val: TValue): Boolean; 101 | property Equal: Variant read FEqual; 102 | property Value: Variant read FValue; 103 | property Option: TRevalOption read FOption; 104 | end; 105 | 106 | DISABLE = class(TCustomAttribute) 107 | end; 108 | 109 | DISABLEREAD = class(TCustomAttribute) 110 | end; 111 | 112 | DISABLEWRITE = class(TCustomAttribute) 113 | end; 114 | 115 | IBase = interface 116 | ['{872FA14E-9276-4F86-A8D8-832CF39DACE6}'] 117 | function AsObject: ISuperObject; 118 | function AsArray: ISuperArray; 119 | end; 120 | 121 | TBase = class(TInterfacedObject, IBase) 122 | function AsObject: ISuperObject; virtual; 123 | function AsArray: ISuperArray; virtual; 124 | end; 125 | 126 | IBaseJSON = interface(IBase) 127 | ['{EBD49266-BEF2-4B79-9BAF-329F725E0568}'] 128 | function GetBoolean(V: Typ): Boolean; 129 | function GetInteger(V: Typ): Int64; 130 | function GetString(V: Typ): String; 131 | procedure SetBoolean(V: Typ; const Value: Boolean); 132 | procedure SetInteger(V: Typ; const Value: Int64); 133 | procedure SetString(V: Typ; const Value: String); 134 | function GetObject(V: Typ): ISuperObject; 135 | procedure SetObject(V: Typ; const Value: ISuperObject); 136 | function GetArray(V: Typ): ISuperArray; 137 | procedure SetArray(V: Typ; const Value: ISuperArray); 138 | function GetDouble(V: Typ): Double; 139 | procedure SetDouble(V: Typ; const Value: Double); 140 | function GetVariant(V: Typ): Variant; 141 | procedure SetVariant(V: Typ; const Value: Variant); 142 | function GetDateTime(V: Typ): TDateTime; 143 | procedure SetDateTime(V: Typ; const Value: TDateTime); 144 | function GetDate(V: Typ): TDate; 145 | procedure SetDate(V: Typ; const Value: TDate); 146 | function GetTime(V: Typ): TTime; 147 | procedure SetTime(V: Typ; const Value: TTime); 148 | function GetSelf: T; 149 | function GetAncestor(V: Typ): IJSONAncestor; 150 | function GetNull(V: Typ): TMemberStatus; 151 | procedure SetNull(V: Typ; const Value: TMemberStatus); 152 | function GetDataType: TDataType; 153 | 154 | property Null[V: Typ]: TMemberStatus read GetNull write SetNull; 155 | property S[V: Typ]: String read GetString write SetString; 156 | property I[V: Typ]: Int64 read GetInteger write SetInteger; 157 | property B[V: Typ]: Boolean read GetBoolean write SetBoolean; 158 | property F[V: Typ]: Double read GetDouble write SetDouble; 159 | property O[V: Typ]: ISuperObject read GetObject write SetObject; 160 | property A[V: Typ]: ISuperArray read GetArray write SetArray; 161 | property V[V: Typ]: Variant read GetVariant write SetVariant; 162 | property D[V: Typ]: TDateTime read GetDateTime write SetDateTime; 163 | property Date[V: Typ]: TDate read GetDate write SetDate; 164 | property Time[V: Typ]: TTime read GetTime write SetTime; 165 | property Ancestor[V: Typ]: IJSONAncestor read GetAncestor; 166 | function Contains(Key: Typ): Boolean; 167 | function GetType(Key: Typ): TVarType; 168 | procedure Sort(Comparison: TJSONComparison); 169 | procedure SaveTo(Stream: TStream; const Ident: Boolean = false; const UniversalTime : Boolean = false); overload; 170 | procedure SaveTo(AFile: String; const Ident: Boolean = false; const UniversalTime : Boolean = false); overload; 171 | function AsJSON(const Ident: Boolean = False; const UniversalTime: Boolean = False): String; 172 | property Self: T read GetSelf; 173 | property DataType: TDataType read GetDataType; 174 | end; 175 | 176 | TJSONValueHelper = class helper for TJSONAncestor 177 | public 178 | function ValueEx: Variant; 179 | end; 180 | 181 | TCondCallBack = reference to function(Arg: T): Boolean; 182 | 183 | TBaseJSON = class(TBase, IBaseJSON) 184 | protected 185 | FJSONObj: T; 186 | FCasted: IJSONAncestor; 187 | FInterface: IInterface; 188 | FCheckDate: Boolean; 189 | function ContainsEx(Key: Typ; out Value: IJSONAncestor): Boolean; 190 | function DefaultValueClass(const Value): TT; 191 | procedure Member(const Name: Typ; const Value: TValue); overload; 192 | function Member(const Name: Typ): Boolean; overload; 193 | function GetValue(const Name: Typ): C; 194 | function GetSelf: T; 195 | function GetData(Key: Typ): IJSONAncestor; 196 | function GetVariant(V: Typ): Variant; 197 | procedure SetVariant(V: Typ; const Value: Variant); 198 | function GetDataType: TDataType; 199 | protected 200 | function GetObject(V: Typ): ISuperObject; virtual; 201 | function GetArray(V: Typ): ISuperArray; virtual; 202 | function GetBoolean(V: Typ): Boolean; virtual; 203 | function GetInteger(V: Typ): Int64; virtual; 204 | function GetString(V: Typ): String; virtual; 205 | function GetDouble(V: Typ): Double; virtual; 206 | function GetAncestor(V: Typ): IJSONAncestor; inline; 207 | function GetNull(V: Typ): TMemberStatus; virtual; 208 | function GetDateTime(V: Typ): TDateTime; virtual; 209 | function GetDate(V: Typ): TDate; virtual; 210 | function GetTime(V: Typ): TTime; virtual; 211 | procedure SetDate(V: Typ; const Value: TDate); virtual; 212 | procedure SetTime(V: Typ; const Value: TTime); virtual; 213 | procedure SetDateTime(V: Typ; const Value: TDateTime); virtual; 214 | procedure SetObject(V: Typ; const Value: ISuperObject); virtual; 215 | procedure SetArray(V: Typ; const Value: ISuperArray); virtual; 216 | procedure SetBoolean(V: Typ; const Value: Boolean); virtual; 217 | procedure SetInteger(V: Typ; const Value: Int64); virtual; 218 | procedure SetString(V: Typ; const Value: String); virtual; 219 | procedure SetDouble(V: Typ; const Value: Double); virtual; 220 | procedure SetNull(V: Typ; const Value: TMemberStatus); virtual; 221 | public 222 | constructor Create(JSON: String = '{}'; const CheckDate: Boolean = True); overload; 223 | constructor Create(JSON: T; const CheckDate: Boolean = True); overload; 224 | constructor CreateCasted(Value: IJSONAncestor; const CheckDate: Boolean = True); 225 | constructor CreateWithEscape(JSON: String = '{}'; const CheckDate: Boolean = True); 226 | destructor Destroy; override; 227 | property Null[V: Typ]: TMemberStatus read GetNull write SetNull; 228 | property S[V: Typ]: String read GetString write SetString; 229 | property I[V: Typ]: Int64 read GetInteger write SetInteger; 230 | property B[V: Typ]: Boolean read GetBoolean write SetBoolean; 231 | property F[V: Typ]: Double read GetDouble write SetDouble; 232 | property O[V: Typ]: ISuperObject read GetObject write SetObject; 233 | property A[V: Typ]: ISuperArray read GetArray write SetArray; 234 | property V[V: Typ]: Variant read GetVariant write SetVariant; 235 | property D[V: Typ]: TDateTime read GetDateTime write SetDateTime; 236 | property Date[V: Typ]: TDate read GetDate write SetDate; 237 | property Time[V: Typ]: TTime read GetTime write SetTime; 238 | property Ancestor[V: Typ]: IJSONAncestor read GetAncestor; 239 | function Contains(Key: Typ): Boolean; 240 | function GetType(Key: Typ): TVarType; 241 | procedure Sort(Comparison: TJSONComparison); virtual; abstract; 242 | procedure SaveTo(Stream: TStream; const Ident: Boolean = false; const UniversalTime : Boolean = false); overload; virtual; abstract; 243 | procedure SaveTo(AFile: String; const Ident: Boolean = false; const UniversalTime : Boolean = false); overload; virtual; abstract; 244 | function AsJSON(const Ident: Boolean = False; const UniversalTime: Boolean = False): String; inline; 245 | property Self: T read GetSelf; 246 | property DataType: TDataType read GetDataType; 247 | end; 248 | 249 | 250 | ICast = interface 251 | ['{0F5387AB-C1C9-4229-921D-226960332271}'] 252 | function GetArray: ISuperArray; 253 | function GetBoolean: Boolean; 254 | function GetDataType: TDataType; 255 | function GetFloat: Double; 256 | function GetInteger: Int64; 257 | function GetObject: ISuperObject; 258 | function GetString: String; 259 | function GetName: String; 260 | function GetVariant: Variant; 261 | function GetDate: TDate; 262 | function GetDateTime: TDateTime; 263 | function GetTime: TTime; 264 | procedure SetDate(const Value: TDate); 265 | procedure SetDateTime(const Value: TDateTime); 266 | procedure SetTime(const Value: TTime); 267 | procedure SetBoolean(const Value: Boolean); 268 | procedure SetFloat(const Value: Double); 269 | procedure SetInteger(const Value: Int64); 270 | procedure SetString(const Value: String); 271 | procedure SetVariant(const Value: Variant); 272 | 273 | property AsObject: ISuperObject read GetObject; 274 | property AsArray: ISuperArray read GetArray; 275 | property AsString: String read GetString write SetString; 276 | property AsInteger: Int64 read GetInteger write SetInteger; 277 | property AsFloat: Double read GetFloat write SetFloat; 278 | property AsBoolean: Boolean read GetBoolean write SetBoolean; 279 | property AsVariant: Variant read GetVariant write SetVariant; 280 | property AsDateTime: TDateTime read GetDateTime write SetDateTime; 281 | property AsDate: TDate read GetDate write SetDate; 282 | property AsTime: TTime read GetTime write SetTime; 283 | property DataType: TDataType read GetDataType; 284 | property Name: String read GetName; 285 | function ToString(const Ident: Boolean = False; const UniversalTime: Boolean = False): String; 286 | end; 287 | 288 | TCast = class(TInterfacedObject, ICast) 289 | private 290 | FJSON: IJSONAncestor; 291 | FName: String; 292 | function GetArray: ISuperArray; 293 | function GetBoolean: Boolean; 294 | function GetDataType: TDataType; 295 | function GetFloat: Double; 296 | function GetInteger: Int64; 297 | function GetObject: ISuperObject; 298 | function GetString: String; 299 | procedure SetBoolean(const Value: Boolean); 300 | procedure SetFloat(const Value: Double); 301 | procedure SetInteger(const Value: Int64); 302 | procedure SetString(const Value: String); 303 | function GetName: String; 304 | function GetVariant: Variant; 305 | procedure SetVariant(const Value: Variant); 306 | function GetDate: TDate; 307 | function GetDateTime: TDateTime; 308 | function GetTime: TTime; 309 | procedure SetDate(const Value: TDate); 310 | procedure SetDateTime(const Value: TDateTime); 311 | procedure SetTime(const Value: TTime); 312 | public 313 | constructor Create(Base: IJSONAncestor); overload; 314 | constructor Create(Base: IJSONPair); overload; 315 | class function CreateFrom(Base: T): ICast; 316 | destructor Destroy; override; 317 | property AsObject: ISuperObject read GetObject; 318 | property AsArray: ISuperArray read GetArray; 319 | property AsString: String read GetString write SetString; 320 | property AsInteger: Int64 read GetInteger write SetInteger; 321 | property AsFloat: Double read GetFloat write SetFloat; 322 | property AsBoolean: Boolean read GetBoolean write SetBoolean; 323 | property AsVariant: Variant read GetVariant write SetVariant; 324 | property AsDateTime: TDateTime read GetDateTime write SetDateTime; 325 | property AsDate: TDate read GetDate write SetDate; 326 | property AsTime: TTime read GetTime write SetTime; 327 | property DataType: TDataType read GetDataType; 328 | property Name: String read GetName; 329 | function ToString(const Ident: Boolean = False; const UniversalTime: Boolean = False): String; reintroduce; 330 | end; 331 | 332 | 333 | 334 | ISuperExpression = interface(ICast) 335 | ['{58366F15-0D83-4BC5-85D5-238E78E73247}'] 336 | end; 337 | 338 | TSuperExpression = class(TCast, ISuperExpression) 339 | private 340 | FInterpreter: TJSONInterpreter; 341 | public 342 | constructor Create(Base: IJSONAncestor; const Expr: String; const BlockException: Boolean = False); 343 | destructor Destroy; override; 344 | end; 345 | 346 | TSuperEnumerator = record 347 | Index : Integer; 348 | List : TJSONEnumerator; 349 | function MoveNext : Boolean; 350 | function GetCurrent : ICast; 351 | property Current : ICast read GetCurrent; 352 | end; 353 | 354 | ISuperObject = interface(IBaseJSON) 355 | ['{B7E271F3-205B-4172-8532-BE03F2A6EDE7}'] 356 | procedure First; 357 | procedure Next; 358 | function GetEoF: Boolean; 359 | function GetCount: Integer; 360 | function GetCurrentKey: String; 361 | function GetCurrentValue: IJSONAncestor; 362 | function GetOffset: Integer; 363 | function GetExpr(const Code: String): ISuperExpression; 364 | function GetRaw(V: String): String; 365 | procedure SetRaw(V: String; Value: String); 366 | 367 | 368 | procedure Add(const Key: String; const Data: IJSONAncestor); 369 | procedure SetData(V: String; Data: Variant); overload; 370 | procedure SetData(V: String; Data: Variant; AFormatSettings: TFormatSettings); overload; 371 | procedure Remove(Key: String); 372 | function Check(const Expr: String): Boolean; 373 | 374 | property Expression[const Code: String]: ISuperExpression read GetExpr; default; 375 | property Count: Integer read GetCount; 376 | property EoF: Boolean read GetEoF; 377 | property CurrentKey: String read GetCurrentKey; 378 | property CurrentValue: IJSONAncestor read GetCurrentValue; 379 | property Offset: Integer read GetOffset; 380 | function Clone: ISuperObject; 381 | function GetEnumerator: TSuperEnumerator; 382 | function T: TSuperObject; 383 | function Where(const Cond: TCondCallBack): ISuperObject; 384 | function Delete(const Cond: TCondCallBack): ISuperObject; 385 | function Cast: ICast; 386 | property Raw[V: String]: String read GetRaw write SetRaw; 387 | end; 388 | 389 | TSuperObject = class(TBaseJSON, ISuperObject) 390 | private 391 | FOffset: Integer; 392 | function GetEoF: Boolean; 393 | function GetCount: Integer; 394 | function GetCurrentKey: String; 395 | function GetCurrentValue: IJSONAncestor; 396 | function GetOffset: Integer; 397 | function GetExpr(const Code: String): ISuperExpression; 398 | function GetRaw(V: String): String; 399 | procedure SetRaw(V: String; Value: String); 400 | protected 401 | function GetString(V: String): String; override; 402 | procedure SetNull(V: String; const Value: TMemberStatus); override; 403 | public 404 | procedure First; 405 | procedure Next; 406 | 407 | procedure Add(const Key: String; const Data: IJSONAncestor); 408 | procedure SetData(V: String; Data: Variant); overload; inline; 409 | procedure SetData(V: String; Data: Variant; AFormatSettings: TFormatSettings); overload; 410 | 411 | class function ParseStream(Stream: TStream; CheckDate: Boolean = True): TSuperObject; 412 | class function ParseFile(FileName: String; CheckDate: Boolean = True): TSuperObject; 413 | 414 | procedure SaveTo(Stream: TStream; const Ident: Boolean = false; const UniversalTime : Boolean = false); overload; override; 415 | procedure SaveTo(AFile: String; const Ident: Boolean = false; const UniversalTime : Boolean = false); overload; override; 416 | procedure Remove(Key: String); 417 | function Check(const Expr: String): Boolean; 418 | 419 | property Expression[const Code: String]: ISuperExpression read GetExpr; default; 420 | property Count: Integer read GetCount; 421 | property Offset: Integer read GetOffset; 422 | property EoF: Boolean read GetEoF; 423 | property CurrentKey: String read GetCurrentKey; 424 | property CurrentValue: IJSONAncestor read GetCurrentValue; 425 | function GetEnumerator: TSuperEnumerator; 426 | function AsType: T; 427 | function T: TSuperObject; inline; 428 | function Clone: ISuperObject; 429 | function AsObject: ISuperObject; override; 430 | function AsArray: ISuperArray; override; 431 | procedure Sort(Comparison: TJSONComparison); override; 432 | function Where(const Cond: TCondCallBack): ISuperObject; 433 | function Delete(const Cond: TCondCallBack): ISuperObject; 434 | function Cast: ICast; 435 | end; 436 | 437 | ISuperArray = interface(IBaseJSON) 438 | ['{41A2D578-CFAB-4924-8F15-0D0227F35412}'] 439 | function GetLength: Integer; 440 | property Length: Integer read GetLength; 441 | procedure Add(Value: IJSONAncestor); overload; 442 | procedure Add(Value: ISuperArray); overload; 443 | procedure Add(Value: ISuperObject); overload; 444 | procedure Add(Value: Variant; DateFormat: TFormatSettings); overload; 445 | procedure Add(Value: Variant); overload; 446 | procedure Delete(Index: Integer); overload; 447 | procedure Clear; 448 | function Clone: ISuperArray; 449 | function GetEnumerator: TSuperEnumerator; 450 | function T: TSuperArray; 451 | function Where(const Cond: TCondCallBack): ISuperArray; 452 | function Delete(const Cond: TCondCallBack): ISuperArray; overload; 453 | end; 454 | 455 | TSuperArray = class(TBaseJSON, ISuperArray) 456 | private 457 | function GetLength: Integer; 458 | protected 459 | procedure SetNull(V: Integer; const aValue: TMemberStatus); override; 460 | public 461 | procedure Add(Value: IJSONAncestor); overload; 462 | procedure Add(Value: ISuperObject); overload; 463 | procedure Add(Value: ISuperArray); overload; 464 | procedure Add(Value: Variant; DateFormat: TFormatSettings); overload; 465 | procedure Add(Value: Variant); overload; 466 | procedure Delete(Index: Integer); overload; 467 | function Delete(const Cond: TCondCallBack): ISuperArray; overload; 468 | procedure Clear; 469 | property Length: Integer read GetLength; 470 | function GetEnumerator: TSuperEnumerator; 471 | procedure SaveTo(Stream: TStream; const Ident: Boolean = false; const UniversalTime : Boolean = false); overload; override; 472 | procedure SaveTo(AFile: String; const Ident: Boolean = false; const UniversalTime : Boolean = false); overload; override; 473 | procedure Sort(Comparison: TJSONComparison); override; 474 | function Clone: ISuperArray; 475 | function AsArray: ISuperArray; override; 476 | function AsObject: ISuperObject; override; 477 | function Where(const Cond: TCondCallBack): ISuperArray; 478 | function T: TSuperArray; inline; 479 | function AsType: T; 480 | end; 481 | 482 | TSuperProperty = class(TRttiProperty) 483 | public 484 | ArrayRawData: Pointer; 485 | end; 486 | 487 | TSuperField = class(TRttiField) 488 | public 489 | ArrayRawData: Pointer; 490 | end; 491 | 492 | TSuperDynArr = class(TRttiDynamicArrayType) 493 | public 494 | ArrayRawData: Pointer; 495 | end; 496 | 497 | TSuperArr = class(TRttiArrayType) 498 | public 499 | ArrayRawData: Pointer; 500 | end; 501 | 502 | TGenericsType = (gtNil, gtList, gtObjectList); 503 | 504 | TGenericsInfo = class 505 | private 506 | FContext: TRttiContext; 507 | FType: TRttiType; 508 | FAddMethod: TRttiMethod; 509 | FCountProperty: TRttiProperty; 510 | FGetItemMethod: TRttiIndexedProperty; 511 | public 512 | IsGeneric: Boolean; 513 | Typ: TRttiType; 514 | CreateArgs: TArray; 515 | procedure AddVal(Instance: TObject; Val: TValue); 516 | function Count(Instance: TObject): Integer; 517 | function Item(Instance: TObject; const Index: Integer): TObject; 518 | constructor Create(GenericClass: TClass; const AIsGeneric: Boolean; AType: TRttiType); 519 | destructor Destroy; override; 520 | end; 521 | 522 | TAttributeClass = class of TCustomAttribute; 523 | TPropertyGetterType = (pgtField, pgtMethod); 524 | 525 | TSerializeParse = class 526 | private 527 | class var FGenericsCache: TObjectDictionary; 528 | class function GetAttribute(AttributeType: TAttributeClass; Attributes: TArray): TCustomAttribute; 529 | class procedure GetAliasName(const Attributes: TArray; var Result: String); 530 | class function GetREVAL(const Attributues: TArray): REVAL; 531 | class function IsDisabled(const Attributes: TArray): Boolean; inline; 532 | class function IsDisabledRead(const Attributes: TArray): Boolean; inline; 533 | class function IsDisabledWrite(const Attributes: TArray): Boolean; inline; 534 | class function PropGetterType(Prop: TRttiProperty): TPropertyGetterType; 535 | public 536 | class constructor Create; 537 | class destructor Destroy; 538 | class function IsGenerics(Cls: TRttiType): Boolean; overload; 539 | class function IsGenerics(Cls: TClass): Boolean; overload; 540 | class function IsCollection(Cls: TRttiType): Boolean; overload; 541 | class function IsCollection(Cls: TClass): Boolean; overload; inline; 542 | class function GetGenericType(Cls: TClass): TGenericsType; 543 | class function GetGenericsCreateArgs(Cls: TRttiType): TArray; 544 | 545 | // ** Read 546 | {$IFDEF SP_STREAM} 547 | class procedure ReadStream(AStream: TStream; IResult: IJSONAncestor); 548 | {$ENDIF} 549 | class procedure ReadGeneric(AObject: TObject; IResult: ISuperArray); 550 | class procedure ReadCollection(ACollection: TCollection; IResult: ISuperArray); 551 | class procedure ReadObject(AObject: TObject; IResult: ISuperObject); 552 | class procedure ReadRecord(Info: PTypeInfo; ARecord: Pointer; IResult: ISuperObject); 553 | class function ReadRecordEx(Rec: T): ISuperObject; 554 | class procedure ReadMembers(Data: Pointer; aType: TRttiType; IJsonData: ISuperObject); 555 | class procedure ReadMember(Member: Typ; RType: PTypeInfo; MemberValue: TValue; IJsonData: IBaseJSON); 556 | 557 | class procedure ReadSet(Val: TValue; IJsonData: ISuperArray); 558 | class procedure ReadVariantOfArray(Val: Variant; IJsonData: ISuperArray); 559 | class procedure ReadTValueOfArray(Val: TValue; IJsonData: ISuperArray); 560 | class procedure ReadVariantOfObject(Val: Variant; const Name: String; IJsonData: ISuperObject); 561 | 562 | // ** Write 563 | {$IFDEF SP_STREAM} 564 | class procedure WriteStream(AStream: TStream; IData: IJSONAncestor); 565 | {$ENDIF} 566 | class procedure WriteGeneric(AObject: TObject; IData: ISuperArray); 567 | class procedure WriteCollection(ACollection: TCollection; IData: ISuperArray); 568 | class procedure WriteObject(AObject: TObject; IData: ISuperObject); 569 | class procedure WriteRecord(Info: PTypeInfo; ARecord: Pointer; IData: ISuperObject); 570 | class procedure WriteRecordEx(Rec: T; IData: ISuperObject); 571 | class procedure WriteMembers(Data: Pointer; aType: TRttiType; IJsonData: ISuperObject); 572 | class procedure WriteMember(Data: Pointer; Member: Typ; RType: PTypeInfo; MemberValue: TRttiObject; IJsonData: IBaseJSON); 573 | class procedure WriteSet(Data: Pointer; Member: TRttiObject; IJSONData: ISuperArray); 574 | class procedure SetValue(var Data: Pointer; Member: TRttiObject; MIdx: Typ; Val: TValue); 575 | class function GetValue(Data: Pointer; Member: TRttiObject; MIdx: Typ): TValue; 576 | class function GetMemberTypeInfo(Member: TRttiObject; const GetArray: Boolean = true): PTypeInfo; inline; 577 | class function GetMemberType(Member: TRttiObject; const GetArray: Boolean = true): TRttiType; //inline; 578 | class function GetArrayRawData(Member: TRttiObject): Pointer; 579 | class procedure SetArrayRawData(Member: TRttiObject; RawData: Pointer); 580 | class procedure ClearArrayRawData(Member: TRttiObject); 581 | 582 | class function ObjectConstructorParamCount(Instance: TClass): Integer; 583 | class function ObjectConstructor(Instance: TClass): TObject; 584 | class function CheckObject(Data: Pointer; Member: TRttiObject; MIdx: Typ; var Obj: TObject): Boolean; 585 | 586 | class property GenericsCache: TObjectDictionary read FGenericsCache; 587 | end; 588 | 589 | TMemberVisibilities = set of TMemberVisibility; 590 | TSerializeParseOptions = class 591 | private 592 | class var FVisibilities: TMemberVisibilities; 593 | public 594 | class constructor Create; 595 | class property Visibilities: TMemberVisibilities read FVisibilities write FVisibilities; 596 | end; 597 | 598 | TSuperObjectHelper = class helper for TObject 599 | public 600 | function AsJSON(const Ident: Boolean = False; const UniversalTime: Boolean = False): String; 601 | function AsJSONObject: ISuperObject; 602 | procedure AssignFromJSON(const JSON: String); overload; 603 | procedure AssignFromJSON(JSON: ISuperObject); overload; 604 | constructor FromJSON(const JSON: String); overload; 605 | constructor FromJSON(JSON: ISuperObject); overload; 606 | constructor FromJSON(const JSON: String; CreateArgs: Array of TValue; const ConstructMethod: String = 'Create'); overload; 607 | constructor FromJSON(const JSON: ISuperObject; CreateArgs: Array of TValue; const ConstructMethod: String = 'Create'); overload; 608 | end; 609 | 610 | TBaseSuperRecord = class 611 | public 612 | class function AsJSON(Rec: T): String; 613 | class function AsJSONObject(Rec: T): ISuperObject; 614 | class function FromJSON(JSON: String): T; overload; 615 | class function FromJSON(JSON: ISuperObject): T; overload; 616 | end; 617 | TSuperRecord = class(TBaseSuperRecord); 618 | 619 | TJSON = class 620 | public 621 | class function Parse(const Value: String): T; overload; 622 | class function Parse(JSON: ISuperObject): T; overload; 623 | class function Parse(JSON: ISuperArray): T; overload; 624 | class function SuperObject(Value: T): ISuperObject; overload; 625 | {$IFDEF SP_DATASET} 626 | class function SuperObject(Value: TDataSet): ISuperObject; overload; 627 | class function Stringify(Value: TDataSet): String; overload; 628 | {$ENDIF} 629 | class function SuperObject(Value: TValue): ISuperObject; overload; 630 | class function Stringify(Value: T; Indent: Boolean = False; UniversalTime: Boolean = True): String; overload; 631 | class function Stringify(Value: TValue; Indent: Boolean = False; UniversalTime: Boolean = True): String; overload; 632 | end; 633 | 634 | function SO(JSON: String = '{}'): ISuperObject; overload; 635 | function SO(const Args: array of const): ISuperObject; overload; 636 | function SA(JSON: String = '[]'): ISuperArray; overload; 637 | function SA(const Args: array of const): ISuperArray; overload; 638 | 639 | implementation 640 | 641 | var GenericsUnit : String; 642 | 643 | function SO(JSON: String): ISuperObject; 644 | begin 645 | if JSON = '' then JSON := '{}'; 646 | Result := TSuperObject.Create(JSON); 647 | end; 648 | 649 | function SO(const Args: array of const): ISuperObject; 650 | var 651 | I: Integer; 652 | Members: ISuperArray; 653 | begin 654 | Result := TSuperObject.Create; 655 | Members := SA(Args); 656 | if Odd(Members.Length) then 657 | Assert(False); 658 | for I := 0 to (Members.Length div 2) - 1 do 659 | Result.Add(Members.S[I*2], Members.Ancestor[(I*2)+1]); 660 | end; 661 | 662 | function SA(JSON: String): ISuperArray; 663 | begin 664 | Result := TSuperArray.Create(JSON); 665 | end; 666 | 667 | function SA(const Args: array of const): ISuperArray; 668 | var 669 | I: Integer; 670 | SArray: ISuperArray; 671 | SObject: ISuperObject; 672 | begin 673 | Result := TSuperArray.Create; 674 | for I := 0 to High(Args) do 675 | case PVarRec(@Args[I]).VType of 676 | vtInteger : Result.Add(TJSONInteger.Create(PVarRec(@Args[I]).VInteger)); 677 | vtInt64 : Result.Add(TJSONInteger.Create(PVarRec(@Args[I]).VInt64^)); 678 | vtBoolean : Result.Add(TJSONBoolean.Create(PVarRec(@Args[I]).VBoolean)); 679 | {$IFNDEF NEXTGEN} 680 | vtChar : Result.Add(TJSONString.Create(PVarRec(@Args[I]).VWideChar)); 681 | vtString : Result.Add(TJSONString.Create(String(PVarRec(@Args[I]).VString^))); 682 | vtPChar : Result.Add(TJSONString.Create(Char(PVarRec(@Args[I]).VPChar^))); 683 | vtAnsiString: Result.Add(TJSONString.Create(String(PVarRec(@Args[I]).VAnsiString))); 684 | {$ENDIF} 685 | vtWideChar: Result.Add(TJSONString.Create(PVarRec(@Args[I]).VWideChar)); 686 | vtExtended: Result.Add(TJSONFloat.Create(PVarRec(@Args[I]).VExtended^)); 687 | vtCurrency: Result.Add(TJSONFloat.Create(PVarRec(@Args[I]).VCurrency^)); 688 | vtWideString: Result.Add(TJSONString.Create(PWideChar(PVarRec(@Args[I]).VWideString))); 689 | vtUnicodeString: Result.Add(TJSONString.Create(String(PVarRec(@Args[I]).VUnicodeString))); 690 | vtInterface: 691 | if PVarRec(@Args[I]).VInterface = nil then 692 | Result.Add(TJSONNull.Create(False)) 693 | else if IInterface(PVarRec(@Args[I]).VInterface).QueryInterface(ISuperObject, SObject) = 0 then 694 | Result.Add(SObject) 695 | else if IInterface(PVarRec(@Args[I]).VInterface).QueryInterface(ISuperArray, SArray) = 0 then 696 | Result.Add(SArray) 697 | else 698 | Assert(False); 699 | vtPointer : 700 | if PVarRec(@Args[I]).VPointer = nil then 701 | Result.Add(TJSONNull.Create(False)) 702 | else 703 | Result.Add(TJSONInteger.Create(NativeInt(PVarRec(@Args[I]).VPointer))); 704 | vtVariant: 705 | Result.Add(PVarRec(@Args[I]).VVariant^); 706 | vtObject: 707 | if PVarRec(@Args[I]).VPointer = nil then 708 | Result.Add(TJSONNull.Create(False)) 709 | else 710 | Result.Add(TJSONInteger.Create(NativeInt(PVarRec(@Args[I]).VPointer))); 711 | vtClass: 712 | if PVarRec(@Args[I]).VPointer = nil then 713 | Result.Add(TJSONNull.Create(False)) 714 | else 715 | Result.Add(TJSONInteger.Create(NativeInt(PVarRec(@Args[I]).VPointer))); 716 | else 717 | Assert(false); 718 | end; 719 | end; 720 | 721 | { TSuperObject } 722 | 723 | 724 | 725 | constructor TBaseJSON.Create(JSON: String; const CheckDate: Boolean); 726 | type PInterface = ^IInterface; 727 | var 728 | JVal: IJSONAncestor; 729 | PIntf: PInterface; 730 | begin 731 | FCheckDate := CheckDate; 732 | if (Self.InheritsFrom(TSuperArray)) and (Trim(JSON) = '{}') then JSON := '[]'; 733 | JVal := TJSONObject.ParseJSONValue(JSON, FCheckDate); 734 | if JVal.QueryInterface(GetTypeData(TypeInfo(T)).Guid, FJSONObj) = S_OK then 735 | FInterface := TValue.From(FJSONObj).AsInterface 736 | else 737 | FCasted := JVal 738 | end; 739 | 740 | function TBaseJSON.GetValue(const Name: Typ): C; 741 | begin 742 | if Self.InheritsFrom(TSuperObject) then 743 | with TJSONObject(FInterface).Get(PString(@Name)^) do 744 | if JsonValue is TJSONNull then 745 | Result := Nil 746 | else 747 | Result := JSonValue as C 748 | else 749 | if Self.InheritsFrom(TSuperArray) then 750 | Result := TJSONArray(FInterface).Get(PInteger(@Name)^) as C 751 | else 752 | Result := Nil; 753 | end; 754 | 755 | function TBaseJSON.GetVariant(V: Typ): Variant; 756 | begin 757 | case GetType(V) of 758 | varString: Result := S[V]; 759 | varInt64: Result := I[V]; 760 | varDouble: Result := F[V]; 761 | varBoolean: Result := B[V]; 762 | varDate: Result := D[V]; 763 | else 764 | Result := Variants.Null; 765 | end; 766 | end; 767 | 768 | function TBaseJSON.Member(const Name: Typ): Boolean; 769 | begin 770 | if Self.InheritsFrom(TSuperObject) then 771 | Result := Assigned(TJSONObject(FInterface).Get(PString(@Name)^)) 772 | else 773 | Result := Assigned(TJSONArray(FInterface).Get(PInteger(@Name)^)) 774 | end; 775 | 776 | procedure TBaseJSON.Member(const Name: Typ; const Value: TValue); 777 | var 778 | Pair: IJSONPair; 779 | begin 780 | if Self.InheritsFrom(TSuperObject) then 781 | begin 782 | Pair := TJSONObject(FInterface).Get(PString(@Name)^); 783 | if not Assigned(Pair) then 784 | begin 785 | TJSONObject(FInterface).AddPair(PString(@Name)^, DefaultValueClass(Value) as TJSONAncestor ); 786 | Exit; 787 | end; 788 | if Assigned(Pair.JsonValue) then 789 | Pair.JsonValue := Nil; 790 | Pair.JsonValue := DefaultValueClass(Value) as TJSONAncestor; 791 | end 792 | else 793 | begin 794 | if TJSONArray(FInterface).Count - 1 < PInteger(@Name)^ then 795 | while TJSONArray(FInterface).Count - 1 < PInteger(@Name)^ do 796 | TJSONArray(FInterface).Add(DefaultValueClass(Value) as TJSONAncestor) 797 | else 798 | TJSONArray(FInterface).Index[PInteger(@Name)^] := DefaultValueClass(Value) as TJSONAncestor 799 | end; 800 | end; 801 | 802 | function TBaseJSON.AsJSON(const Ident, UniversalTime: Boolean): String; 803 | var 804 | SBuild: TJSONWriter; 805 | begin 806 | try 807 | SBuild := TJSONWriter.Create(Ident, UniversalTime); 808 | if Assigned(FCasted) then 809 | FCasted.AsJSONString(SBuild) 810 | else 811 | TJSONAncestor(FInterface).AsJSONString(SBuild); 812 | Result := SBuild.ToString; 813 | finally 814 | SBuild.Free; 815 | end; 816 | 817 | end; 818 | 819 | function TBaseJSON.Contains(Key: Typ): Boolean; 820 | begin 821 | Result := GetData(Key) <> Nil; 822 | end; 823 | 824 | function TBaseJSON.ContainsEx(Key: Typ; out Value: IJSONAncestor): Boolean; 825 | begin 826 | Value := GetData(Key); 827 | Result := Value <> Nil; 828 | end; 829 | 830 | constructor TBaseJSON.Create(JSON: T; const CheckDate: Boolean = True); 831 | begin 832 | FJSONObj := JSON; 833 | FCasted := nil; 834 | FCheckDate := CheckDate; 835 | FInterface := TValue.From(JSON).AsInterface; 836 | end; 837 | 838 | constructor TBaseJSON.CreateCasted(Value: IJSONAncestor; const CheckDate: Boolean); 839 | begin 840 | // FJSONObj := Nil; 841 | FInterface := Nil; 842 | FCasted := Value; 843 | FCheckDate := CheckDate; 844 | end; 845 | 846 | constructor TBaseJSON.CreateWithEscape(JSON: String; const CheckDate: Boolean); 847 | begin 848 | Create(LimitedStrToUTF16(JSON), CheckDate); 849 | end; 850 | 851 | function TBaseJSON.DefaultValueClass(const Value): TT; 852 | var 853 | r: TRttiContext; 854 | ty: TRttiType; 855 | begin 856 | if TJSONString.InheritsFrom(TT) then 857 | Result := TJSONString.Create(String(Value)) as TT 858 | else if TJSONInteger.InheritsFrom(TT) then 859 | Result := TJSONInteger.Create(Int64(Value)) as TT 860 | else if TJSONFloat.InheritsFrom(TT) then 861 | Result := TJSONFloat.Create(Double(Value)) as TT 862 | else if TJSONBoolean.InheritsFrom(TT) then 863 | Result := TJSONBoolean.Create(Boolean(Value)) as TT 864 | else if TJSONNull.InheritsFrom(TT) then 865 | Result := TJSONNull.Create(Boolean(Value)) as TT 866 | else if TJSONDateTime.InheritsFrom(TT) then 867 | Result := TJSONDateTime.Create(TDateTime(Value)) as TT 868 | else if TJSONDate.InheritsFrom(TT) then 869 | Result := TJSONDate.Create(TDate(Value)) as TT 870 | else if TJSONTime.InheritsFrom(TT) then 871 | Result := TJSONTime.Create(TTime(Value)) as TT 872 | else if TJSONRaw.InheritsFrom(TT) then 873 | Result := TJSONRaw.Create(String(Value)) as TT 874 | else if TJSONArray.InheritsFrom(TT) then 875 | begin 876 | if Pointer(Value) <> Nil then 877 | Exit(TJSONArray(ISuperArray(Value)) as TT); 878 | Result := TJSONArray.Create as TT; 879 | end 880 | else if TJSONObject.InheritsFrom(TT) then 881 | begin 882 | if Pointer(Value) <> Nil then 883 | Exit(TJSONObject(ISuperObject(Value)) as TT); 884 | Result := TJSONObject.Create as TT; 885 | end 886 | else 887 | begin 888 | r := TRttiContext.Create; 889 | ty := r.GetType(TClass(TT)); 890 | if ty = nil then 891 | exit(Nil); 892 | try 893 | Result := TT(ty.GetMethod('Create').Invoke(ty.AsInstance.MetaclassType, []).AsObject); 894 | except 895 | if Assigned(ty) then 896 | ty.Free; 897 | raise; 898 | end; 899 | r.Free; 900 | end; 901 | end; 902 | 903 | destructor TBaseJSON.Destroy; 904 | begin 905 | inherited; 906 | end; 907 | 908 | function TBaseJSON.GetBoolean(V: Typ): Boolean; 909 | begin 910 | Result := False; 911 | if Member(V) then 912 | Result := GetValue(V).ValueEx; 913 | end; 914 | 915 | function TBaseJSON.GetData(Key: Typ): IJSONAncestor; 916 | var 917 | P: IJsonPair; 918 | begin 919 | if Self.InheritsFrom(TSuperObject) then 920 | begin 921 | P := TJSONObject(FInterface).Get(PString(@Key)^); 922 | if Assigned(P) then 923 | Result := P.JsonValue 924 | else 925 | Result := Nil 926 | end 927 | else 928 | if Self.InheritsFrom(TSuperArray) then 929 | Result := TJSONArray(FInterface).Get(PInteger(@Key)^); 930 | end; 931 | 932 | function TBaseJSON.GetDataType: TDataType; 933 | var 934 | Cast: ICast; 935 | begin 936 | if TValue.From(FJSONObj).AsInterface <> nil then 937 | Cast := TCast.CreateFrom(FJSONObj) 938 | else 939 | if Assigned(FCasted) then 940 | Cast := TCast.Create(FCasted) 941 | else 942 | Exit(dtNil); 943 | Result := Cast.DataType 944 | end; 945 | 946 | function TBaseJSON.GetDate(V: Typ): TDate; 947 | begin 948 | Result := 0; 949 | if Member(V) then 950 | Result := GetValue(V).Value; 951 | end; 952 | 953 | function TBaseJSON.GetDateTime(V: Typ): TDateTime; 954 | begin 955 | Result := 0; 956 | if Member(V) then 957 | Result := GetValue(V).Value; 958 | end; 959 | 960 | function TBaseJSON.GetDouble(V: Typ): Double; 961 | begin 962 | Result := 0; 963 | if Member(V) then 964 | if GetType(V) = varInt64 then 965 | Result := GetValue(V).ValueEx 966 | else 967 | Result := GetValue(V).ValueEx; 968 | end; 969 | 970 | function TBaseJSON.GetInteger(V: Typ): Int64; 971 | begin 972 | Result := 0; 973 | if Member(V) then 974 | Result := GetValue(V).ValueEx; 975 | end; 976 | 977 | function TBaseJSON.GetNull(V: Typ): TMemberStatus; 978 | var 979 | Val: IJSONAncestor; 980 | begin 981 | if ContainsEx(V, Val) then begin 982 | if Val is TJSONNull then 983 | Result := jNull 984 | else 985 | Result := jAssigned 986 | end else 987 | Result := jUnAssigned; 988 | end; 989 | 990 | function TBaseJSON.GetArray(V: Typ): ISuperArray; 991 | var 992 | J: IJSONArray; 993 | begin 994 | Result := Nil; 995 | if not Member(V) then 996 | Member(V, nil); 997 | J := GetValue(V); 998 | Result := TSuperArray.Create(J); 999 | end; 1000 | 1001 | function TBaseJSON.GetObject(V: Typ): ISuperObject; 1002 | begin 1003 | Result := Nil; 1004 | if not Member(V) then 1005 | Member(V, Nil); 1006 | 1007 | Result := TSuperObject.Create(GetValue(V)); 1008 | end; 1009 | 1010 | function TBaseJSON.GetAncestor(V: Typ): IJSONAncestor; 1011 | begin 1012 | Result := GetData(V); 1013 | end; 1014 | 1015 | function TBaseJSON.GetString(V: Typ): String; 1016 | label 1017 | JMP; 1018 | begin 1019 | Result := ''; 1020 | if Member(V) then 1021 | if FCheckDate then 1022 | case Ancestor[V].DataType of 1023 | dtDateTime : Result := GetValue(V).GetAsString; 1024 | dtDate : Result := GetValue(V).GetAsString; 1025 | dtTime : Result := GetValue(V).GetAsString; 1026 | else 1027 | goto JMP; 1028 | end 1029 | else 1030 | JMP: Result := GetValue(V).ValueEx; 1031 | end; 1032 | 1033 | function TBaseJSON.GetTime(V: Typ): TTime; 1034 | begin 1035 | Result := 0; 1036 | if Member(V) then 1037 | Result := GetValue(V).Value; 1038 | end; 1039 | 1040 | function TBaseJSON.GetType(Key: Typ): TVarType; 1041 | var 1042 | Temp: IJSONAncestor; 1043 | begin 1044 | Temp := GetData(Key); 1045 | if Temp = Nil then 1046 | Result := varUnknown 1047 | else if Temp is TJSONString then 1048 | Result := varString 1049 | else if Temp is TJSONFloat then 1050 | Result := varDouble 1051 | else if Temp is TJSONInteger then 1052 | Result := varInt64 1053 | else if Temp is TJSONNull then 1054 | Result := varNull 1055 | else if Temp is TJSONObject then 1056 | Result := varObject 1057 | else if Temp is TJSONArray then 1058 | Result := varArray 1059 | else if Temp is TJSONBoolean then 1060 | Result := varBoolean 1061 | else if (Temp is TJSONDateTime) or (Temp is TJSONDate) or (Temp is TJSONTime) then 1062 | Result := varDate 1063 | end; 1064 | 1065 | procedure TBaseJSON.SetArray(V: Typ; const Value: ISuperArray); 1066 | begin 1067 | Member(V, Value.Self ) 1068 | end; 1069 | 1070 | procedure TBaseJSON.SetBoolean(V: Typ; const Value: Boolean); 1071 | begin 1072 | Member(V, Value) 1073 | end; 1074 | 1075 | procedure TBaseJSON.SetDate(V: Typ; const Value: TDate); 1076 | begin 1077 | Member(V, Value); 1078 | end; 1079 | 1080 | procedure TBaseJSON.SetDateTime(V: Typ; const Value: TDateTime); 1081 | begin 1082 | Member(V, Value); 1083 | end; 1084 | 1085 | procedure TBaseJSON.SetDouble(V: Typ; const Value: Double); 1086 | begin 1087 | Member(V, Value); 1088 | end; 1089 | 1090 | procedure TBaseJSON.SetInteger(V: Typ; const Value: Int64); 1091 | begin 1092 | Member(V, Value); 1093 | end; 1094 | 1095 | procedure TBaseJSON.SetNull(V: Typ; const Value: TMemberStatus); 1096 | begin 1097 | end; 1098 | 1099 | procedure TBaseJSON.SetObject(V: Typ; const Value: ISuperObject); 1100 | begin 1101 | Member(V, Value.Self ) 1102 | end; 1103 | 1104 | procedure TBaseJSON.SetString(V: Typ; const Value: String); 1105 | var 1106 | Anc: IJSONAncestor; 1107 | dT: TDateTime; 1108 | ValType: TDataType; 1109 | label 1110 | JMP, JERR; 1111 | begin 1112 | if FCheckDate then 1113 | begin 1114 | Anc := Ancestor[V]; 1115 | if Assigned(Anc) and (Anc.DataType in [dtDateTime..dtTime]) then 1116 | begin 1117 | if not TJSONDateManager.Check(Value, dT, ValType ) then 1118 | JERR: raise SOInvalidDate.Create('Invalid date format.') 1119 | else 1120 | case ValType of 1121 | dtDateTime: Member(V, dT); 1122 | dtDate: Member(V, TDate(dT)); 1123 | dtTime: Member(V, TTime(dT)); 1124 | else 1125 | goto JERR; 1126 | end; 1127 | end 1128 | else 1129 | goto JMP; 1130 | end 1131 | else 1132 | JMP: Member(V, Value); 1133 | end; 1134 | 1135 | procedure TBaseJSON.SetTime(V: Typ; const Value: TTime); 1136 | begin 1137 | Member(V, Value); 1138 | end; 1139 | 1140 | procedure TBaseJSON.SetVariant(V: Typ; const Value: Variant); 1141 | var 1142 | VTyp: TVarType; 1143 | begin 1144 | if VarIsNull(Value) then 1145 | Null[V] := jNull 1146 | else 1147 | begin 1148 | VTyp := GetType(V); 1149 | if VTyp = varUnknown then 1150 | VTyp := VarType(Value); 1151 | case VTyp of 1152 | varString, varUString: 1153 | S[V] := Value; 1154 | varInt64, varInteger, varByte: 1155 | I[V] := Value; 1156 | varDouble, varCurrency: 1157 | F[V] := Value; 1158 | varBoolean: 1159 | B[V] := Value; 1160 | varDate: 1161 | D[V] := Value; 1162 | varNull: 1163 | Null[V] := jNull; 1164 | end; 1165 | end; 1166 | end; 1167 | 1168 | function TBaseJSON.GetSelf: T; 1169 | begin 1170 | Result := FJSONObj; 1171 | end; 1172 | 1173 | 1174 | { TSuperObject } 1175 | 1176 | function TSuperObject.AsArray: ISuperArray; 1177 | begin 1178 | if not Assigned(FCasted) or not (FCasted is TJSONArray) then 1179 | Exit(Nil); 1180 | Result := TSuperArray.Create(IJSONArray(FCasted)); 1181 | end; 1182 | 1183 | function TSuperObject.AsObject: ISuperObject; 1184 | begin 1185 | Result := Self; 1186 | end; 1187 | 1188 | function TSuperObject.Check(const Expr: String): Boolean; 1189 | var 1190 | IExpr: ISuperExpression; 1191 | begin 1192 | IExpr := TSuperExpression.Create(FJSONObj, Expr, True); 1193 | Result := IExpr.DataType <> dtNil; 1194 | end; 1195 | 1196 | function TSuperObject.AsType: T; 1197 | begin 1198 | Result := TJSON.Parse(Self); 1199 | end; 1200 | 1201 | function TSuperObject.Cast: ICast; 1202 | begin 1203 | if Assigned(FCasted) then 1204 | Result := TCast.Create(FCasted) 1205 | else 1206 | Result := TCast.Create(FJSONObj); 1207 | end; 1208 | 1209 | function TSuperObject.Clone: ISuperObject; 1210 | begin 1211 | Result := SO(AsJSON); 1212 | end; 1213 | 1214 | function TSuperObject.Delete(const Cond: TCondCallBack): ISuperObject; 1215 | var 1216 | Member: IJSONPair; 1217 | begin 1218 | Result := Self; 1219 | if not Assigned(Cond) then 1220 | Exit; 1221 | for Member in FJSONObj do 1222 | if Cond(TCast.Create(Member)) then 1223 | Result.Self.Remove(Member); 1224 | end; 1225 | 1226 | procedure TSuperObject.First; 1227 | begin 1228 | FOffset := 0; 1229 | end; 1230 | 1231 | function TSuperObject.GetCount: Integer; 1232 | begin 1233 | Result := FJSONObj.Count; 1234 | end; 1235 | 1236 | function TSuperObject.GetCurrentKey: String; 1237 | begin 1238 | Result := FJSONObj.Get(FOffset).Name; 1239 | end; 1240 | 1241 | function TSuperObject.GetCurrentValue: IJSONAncestor; 1242 | begin 1243 | Result := FJSONObj.Get(FOffset).JsonValue; 1244 | end; 1245 | 1246 | function TSuperObject.GetEnumerator: TSuperEnumerator; 1247 | begin 1248 | Result.Index := -1; 1249 | Result.List := TJSONObject(FJSONObj).GetEnumerator 1250 | end; 1251 | 1252 | function TSuperObject.GetEoF: Boolean; 1253 | begin 1254 | Result := FOffset > Count - 1; 1255 | end; 1256 | 1257 | function TSuperObject.GetExpr(const Code: String): ISuperExpression; 1258 | begin 1259 | Result := TSuperExpression.Create(FJSONObj, Code); 1260 | end; 1261 | 1262 | 1263 | function TSuperObject.GetOffset: Integer; 1264 | begin 1265 | Result := FOffset; 1266 | end; 1267 | 1268 | function TSuperObject.GetRaw(V: String): String; 1269 | begin 1270 | Result := GetValue(V).ValueEx; 1271 | end; 1272 | 1273 | function TSuperObject.GetString(V: String): String; 1274 | begin 1275 | Result := inherited GetString(V); 1276 | end; 1277 | 1278 | procedure TSuperObject.Next; 1279 | begin 1280 | Inc(FOffset); 1281 | end; 1282 | 1283 | class function TSuperObject.ParseFile(FileName: String; CheckDate: Boolean = True): TSuperObject; 1284 | var 1285 | Strm: TFileStream; 1286 | begin 1287 | Strm := TFileStream.Create(FileName, fmOpenRead, fmShareDenyWrite); 1288 | try 1289 | Result := ParseStream(Strm, CheckDate); 1290 | finally 1291 | Strm.Free; 1292 | end; 1293 | end; 1294 | 1295 | class function TSuperObject.ParseStream(Stream: TStream; CheckDate: Boolean): TSuperObject; 1296 | var 1297 | Strm: TStringStream; 1298 | preamble, tmp: TBytes; 1299 | preambleLength: integer; 1300 | enc: TEncoding; 1301 | begin 1302 | Strm := TStringStream.Create; 1303 | try 1304 | Strm.LoadFromStream(Stream); 1305 | SetLength(tmp,10); 1306 | strm.read(tmp, 10); 1307 | enc := nil; 1308 | preambleLength := TEncoding.GetBufferEncoding(tmp, enc); 1309 | if preambleLength <> 0 then 1310 | Result := TSuperObject.Create(enc.GetString(strm.Bytes, preambleLength, stream.Size - preambleLength), CheckDate) 1311 | else 1312 | Result := TSuperObject.Create(Strm.Datastring, CheckDate); 1313 | finally 1314 | Strm.Free; 1315 | end; 1316 | end; 1317 | 1318 | procedure TSuperObject.Remove(Key: String); 1319 | begin 1320 | FJSONObj.Remove(Key); 1321 | end; 1322 | 1323 | procedure TSuperObject.SaveTo(Stream: TStream; const Ident, UniversalTime: Boolean); 1324 | var 1325 | S: TStringStream; 1326 | begin 1327 | S := TStringStream.Create( AsJSON(Ident, UniversalTime) ); 1328 | try 1329 | S.SaveToStream(Stream); 1330 | finally 1331 | S.Free; 1332 | end; 1333 | end; 1334 | 1335 | procedure TSuperObject.SaveTo(AFile: String; const Ident, UniversalTime: Boolean); 1336 | var 1337 | S: TStringStream; 1338 | begin 1339 | S := TStringStream.Create( AsJSON(Ident, UniversalTime) ); 1340 | try 1341 | S.SaveToFile(AFile); 1342 | finally 1343 | S.Free; 1344 | end; 1345 | end; 1346 | 1347 | procedure TSuperObject.Add(const Key: String; const Data: IJSONAncestor); 1348 | begin 1349 | FJSONObj.AddPair(Key, Data); 1350 | end; 1351 | 1352 | procedure TSuperObject.SetData(V: String; Data: Variant; AFormatSettings: TFormatSettings); 1353 | begin 1354 | case VarType(Data) of 1355 | varNull: 1356 | FJSONObj.AddPair(V, TJSONNull.Create(True)); 1357 | 1358 | varDate: 1359 | FJSONObj.AddPair(V, TJSONString.Create(DateTimeToStr(TDateTime(Data), AFormatSettings))); 1360 | 1361 | varInteger: 1362 | FJSONObj.AddPair(V, TJSONInteger.Create(Integer(Data))); 1363 | 1364 | varBoolean: 1365 | FJSONObj.AddPair(V, TJSONBoolean.Create(Data)); 1366 | 1367 | varString, varUString: 1368 | FJSONObj.AddPair(V, TJSONString.Create(String(Data))); 1369 | 1370 | varDouble: 1371 | FJSONObj.AddPair(V, TJSONFloat.Create(Double(Data))); 1372 | 1373 | vtCurrency: 1374 | FJSONObj.AddPair(V, TJSONFloat.Create(Currency(Data))); 1375 | 1376 | varInt64: FJSONObj.AddPair(V, TJSONInteger.Create(Int64(Data))); 1377 | end; 1378 | end; 1379 | 1380 | procedure TSuperObject.SetNull(V: String; const Value: TMemberStatus); 1381 | var 1382 | Val: IJSONAncestor; 1383 | begin 1384 | if Value = jAssigned then 1385 | Exit; 1386 | with TJSONObject(FJSONObj) do begin 1387 | if ContainsEx(V, Val) then 1388 | begin 1389 | case Value of 1390 | jUnAssigned: 1391 | Remove(V); 1392 | jNull: begin 1393 | Remove(V); 1394 | AddPair(V, TJSONNull.Create(True)); 1395 | end; 1396 | end; 1397 | end 1398 | else 1399 | AddPair(V, TJSONNull.Create(True)); 1400 | end; 1401 | end; 1402 | 1403 | procedure TSuperObject.SetRaw(V, Value: String); 1404 | begin 1405 | Member(V, Value); 1406 | end; 1407 | 1408 | procedure TSuperObject.Sort(Comparison: TJSONComparison); 1409 | begin 1410 | if not Assigned(Comparison) then Exit; 1411 | FJSONObj.Sort(function(Left, Right: IJSONPair): Integer 1412 | begin 1413 | Result := Comparison(TCast.Create(Left), TCast.Create(Right)); 1414 | end); 1415 | end; 1416 | 1417 | function TSuperObject.T: TSuperObject; 1418 | begin 1419 | Result := Self; 1420 | end; 1421 | 1422 | function TSuperObject.Where(const Cond: TCondCallBack): ISuperObject; 1423 | var 1424 | Member: IJSONPair; 1425 | begin 1426 | Result := TSuperObject.Create('{}', FCheckDate); 1427 | if not Assigned(Cond) then 1428 | Exit; 1429 | for Member in FJSONObj do 1430 | if Cond(TCast.Create(Member)) then 1431 | Result.Self.AddPair(Member); 1432 | end; 1433 | 1434 | procedure TSuperObject.SetData(V: String; Data: Variant); 1435 | begin 1436 | SetData(V, Data, FormatSettings); 1437 | end; 1438 | 1439 | { TSuperArray } 1440 | 1441 | procedure TSuperArray.Add(Value: Variant; DateFormat: TFormatSettings); 1442 | begin 1443 | if VarIsNull(Value) then 1444 | begin 1445 | TJSONArray(FJSONObj).Add(TJSONNull.Create(True)); 1446 | Exit; 1447 | end; 1448 | 1449 | case VarType(Value) of 1450 | varDate : 1451 | TJSONArray(FJSONObj).Add(TJSONString.Create(DateTimeToStr(TDateTime(Value), DateFormat))); 1452 | 1453 | varBoolean: 1454 | TJSONArray(FJSONObj).Add(TJSONBoolean.Create(Value)); 1455 | 1456 | else 1457 | with TValue.FromVariant(Value) do 1458 | case Kind of 1459 | tkInteger, tkInt64: 1460 | TJSONArray(FJSONObj).Add(TJSONInteger.Create(Int64(Value))); 1461 | 1462 | tkFloat: 1463 | TJSONArray(FJSONObj).Add(TJSONFloat.Create(Double(Value))); 1464 | 1465 | tkString, tkWChar, tkLString, tkWString, tkUString, tkChar: 1466 | TJSONArray(FJSONObj).Add(TJSONString.Create(Value)); 1467 | end; 1468 | end; 1469 | 1470 | end; 1471 | 1472 | procedure TSuperArray.Add(Value: Variant); 1473 | begin 1474 | Add(Value, FormatSettings); 1475 | end; 1476 | 1477 | function TSuperArray.AsArray: ISuperArray; 1478 | begin 1479 | Result := Self; 1480 | end; 1481 | 1482 | function TSuperArray.AsObject: ISuperObject; 1483 | begin 1484 | Result := TSuperObject.CreateCasted(FJSONObj); 1485 | end; 1486 | 1487 | function TSuperArray.AsType: T; 1488 | var 1489 | Ctx: TRttiContext; 1490 | Typ: TRttiType; 1491 | begin 1492 | Ctx := TRttiContext.Create; 1493 | try 1494 | Typ := Ctx.GetType(TypeInfo(T)); 1495 | if not Assigned(Typ) then 1496 | Exit; 1497 | if Typ.IsInstance then begin 1498 | if TSerializeParse.IsGenerics(Typ) then begin 1499 | Result := TValue.From(TSerializeParse.ObjectConstructor(Typ.AsInstance.MetaclassType)).AsType; 1500 | TSerializeParse.WriteGeneric(TValue.From(Result).AsObject, Self); 1501 | Exit; 1502 | end else if TSerializeParse.IsCollection(Typ) then begin 1503 | Result := TValue.From(TSerializeParse.ObjectConstructor(Typ.AsInstance.MetaclassType)).AsType; 1504 | TSerializeParse.WriteCollection(TValue.From(Result).AsObject as TCollection, Self); 1505 | Exit; 1506 | end; 1507 | end; 1508 | raise SOException.Create('Unsupported type.'); 1509 | except 1510 | Ctx.Free; 1511 | raise; 1512 | end; 1513 | end; 1514 | 1515 | procedure TSuperArray.Add(Value: IJSONAncestor); 1516 | begin 1517 | TJSONArray(FJSONObj).Add(Value); 1518 | end; 1519 | 1520 | procedure TSuperArray.Clear; 1521 | begin 1522 | FJSONObj.Clear; 1523 | end; 1524 | 1525 | function TSuperArray.Clone: ISuperArray; 1526 | begin 1527 | Result := SA(AsJSON); 1528 | end; 1529 | 1530 | function TSuperArray.Delete(const Cond: TCondCallBack): ISuperArray; 1531 | var 1532 | Member: IJSONAncestor; 1533 | begin 1534 | Result := Self; 1535 | if not Assigned(Cond) then 1536 | Exit; 1537 | for Member in FJSONObj do 1538 | if Cond(TCast.Create(Member)) then 1539 | Result.Self.Remove(Member); 1540 | end; 1541 | 1542 | procedure TSuperArray.Delete(Index: Integer); 1543 | begin 1544 | TJsonArray(FJSONObj).Remove(Index); 1545 | end; 1546 | 1547 | function TSuperArray.GetEnumerator: TSuperEnumerator; 1548 | begin 1549 | Result.Index := -1; 1550 | Result.List := TJSONArray(FJSONObj).GetEnumerator 1551 | end; 1552 | 1553 | function TSuperArray.GetLength: Integer; 1554 | begin 1555 | Result := TJSONArray(FJSONObj).Count; 1556 | end; 1557 | 1558 | procedure TSuperArray.SaveTo(Stream: TStream; const Ident, UniversalTime: Boolean); 1559 | var 1560 | S: TStringStream; 1561 | begin 1562 | S := TStringStream.Create( AsJSON(Ident, UniversalTime) ); 1563 | try 1564 | S.SaveToStream(Stream); 1565 | finally 1566 | S.Free; 1567 | end; 1568 | end; 1569 | 1570 | procedure TSuperArray.SaveTo(AFile: String; const Ident, UniversalTime: Boolean); 1571 | var 1572 | S: TStringStream; 1573 | begin 1574 | S := TStringStream.Create( AsJSON(Ident, UniversalTime) ); 1575 | try 1576 | S.SaveToFile(AFile); 1577 | finally 1578 | S.Free; 1579 | end; 1580 | end; 1581 | 1582 | procedure TSuperArray.SetNull(V: Integer; const aValue: TMemberStatus); 1583 | var 1584 | Val: IJSONAncestor; 1585 | begin 1586 | if aValue = jAssigned then 1587 | Exit; 1588 | with FJSONObj do begin 1589 | if ContainsEx(V, Val) then 1590 | begin 1591 | case aValue of 1592 | jUnAssigned: 1593 | Remove(V); 1594 | jNull: begin 1595 | Index[V] := TJSONNull.Create(True); 1596 | end; 1597 | end; 1598 | end 1599 | else 1600 | Member(V, True); 1601 | end; 1602 | end; 1603 | 1604 | procedure TSuperArray.Sort(Comparison: TJSONComparison); 1605 | begin 1606 | if not Assigned(Comparison) then Exit; 1607 | FJSONObj.Sort(function(Left, Right: IJSONAncestor): Integer 1608 | begin 1609 | Result := Comparison(TCast.Create(Left), TCast.Create(Right)); 1610 | end); 1611 | end; 1612 | 1613 | function TSuperArray.T: TSuperArray; 1614 | begin 1615 | Result := Self; 1616 | end; 1617 | 1618 | function TSuperArray.Where(const Cond: TCondCallBack): ISuperArray; 1619 | var 1620 | Member: IJSONAncestor; 1621 | begin 1622 | Result := TSuperArray.Create('[]', FCheckDate); 1623 | if not Assigned(Cond) then 1624 | Exit; 1625 | for Member in FJSONObj do 1626 | if Cond(TCast.Create(Member)) then 1627 | Result.Self.Add(Member); 1628 | end; 1629 | 1630 | procedure TSuperArray.Add(Value: ISuperObject); 1631 | begin 1632 | Add(Value.Self); 1633 | end; 1634 | 1635 | procedure TSuperArray.Add(Value: ISuperArray); 1636 | begin 1637 | Add(Value.Self); 1638 | end; 1639 | 1640 | { TSuperObjectHelper } 1641 | 1642 | function TSuperObjectHelper.AsJSON(const Ident: Boolean = False; const UniversalTime: Boolean = False): String; 1643 | begin 1644 | Result := AsJSONObject.AsJSON(Ident, UniversalTime); 1645 | end; 1646 | 1647 | constructor TSuperObjectHelper.FromJSON(const JSON: String); 1648 | begin 1649 | FromJSON(JSON, []); 1650 | end; 1651 | 1652 | function TSuperObjectHelper.AsJSONObject: ISuperObject; 1653 | var 1654 | IResult: ISuperObject; 1655 | begin 1656 | try 1657 | IResult := TSuperObject.Create; 1658 | TSerializeParse.ReadObject(Self, IResult); 1659 | finally 1660 | Result := IResult; 1661 | end; 1662 | end; 1663 | 1664 | procedure TSuperObjectHelper.AssignFromJSON(const JSON: String); 1665 | begin 1666 | TSerializeParse.WriteObject(Self, SO(JSON)); 1667 | end; 1668 | 1669 | procedure TSuperObjectHelper.AssignFromJSON(JSON: ISuperObject); 1670 | begin 1671 | TSerializeParse.WriteObject(Self, JSON); 1672 | end; 1673 | 1674 | constructor TSuperObjectHelper.FromJSON(const JSON: String; CreateArgs: array of TValue; const ConstructMethod: String); 1675 | var 1676 | IData: ISuperObject; 1677 | begin 1678 | IData := TSuperObject.Create(JSON); 1679 | FromJSON(IData, CreateArgs, ConstructMethod); 1680 | end; 1681 | 1682 | constructor TSuperObjectHelper.FromJSON(const JSON: ISuperObject; CreateArgs: array of TValue; const ConstructMethod: String); 1683 | var 1684 | Ctx: TRttiContext; 1685 | Typ: TRttiType; 1686 | Method: TRttiMethod; 1687 | begin 1688 | Ctx := TRttiContext.Create; 1689 | try 1690 | Typ := Ctx.GetType(ClassType); 1691 | if not Assigned(Typ) then Exit; 1692 | Method := Typ.GetMethod(ConstructMethod); 1693 | if (not Assigned(Method)) or not Method.IsConstructor then Exit; 1694 | Method.Invoke(Self, CreateArgs); 1695 | finally 1696 | Ctx.Free; 1697 | TSerializeParse.WriteObject(Self, JSON); 1698 | end; 1699 | end; 1700 | 1701 | constructor TSuperObjectHelper.FromJSON(JSON: ISuperObject); 1702 | begin 1703 | FromJSON(JSON, []); 1704 | end; 1705 | 1706 | { TSerializeParse } 1707 | 1708 | class procedure TSerializeParse.ReadMembers(Data: Pointer; aType: TRttiType; IJsonData: ISuperObject); 1709 | var 1710 | Prop: TRttiProperty; 1711 | Field: TRttiField; 1712 | MemberName: String; 1713 | RevalAttribute: REVAL; 1714 | Value: TValue; 1715 | Attributes: TArray; 1716 | begin 1717 | for Prop in aType.GetProperties do 1718 | begin 1719 | if (not (Prop.Visibility in TSerializeParseOptions.Visibilities)) 1720 | {$IFDEF AUTOREFCOUNT} or (Prop.Parent.AsInstance.MetaclassType = TObject){$ENDIF} 1721 | or (Prop.Parent.AsInstance.MetaclassType = TCollectionItem) then Continue; 1722 | 1723 | MemberName := Prop.Name; 1724 | Attributes := Prop.GetAttributes; 1725 | // * Read Disable 1726 | if IsDisabled(Attributes) or IsDisabledWrite(Attributes) then 1727 | Continue; 1728 | 1729 | // * Read Alias Name 1730 | GetAliasName(Attributes, MemberName); 1731 | 1732 | Value := Prop.GetValue(Data); 1733 | 1734 | // * Read Reval Attribute 1735 | RevalAttribute := GetREVAL(Attributes); 1736 | if (RevalAttribute <> Nil) and (RevalAttribute.CheckEQ(Value)) then 1737 | Value := TValue.FromVariant(RevalAttribute.Value); 1738 | 1739 | ReadMember(MemberName, Prop.PropertyType.Handle, Value, IJSonData); 1740 | end; 1741 | 1742 | for Field in aType.GetFields do 1743 | begin 1744 | if not (Field.Visibility in TSerializeParseOptions.Visibilities) then Continue; 1745 | 1746 | MemberName := Field.Name; 1747 | Attributes := Field.GetAttributes; 1748 | // * Read Disable 1749 | if IsDisabled(Attributes) or IsDisabledWrite(Attributes) then 1750 | Continue; 1751 | 1752 | // * Read Alias Name 1753 | GetAliasName(Field.GetAttributes, MemberName); 1754 | 1755 | Value := Field.GetValue(Data); 1756 | 1757 | // * Read Reval Attribute 1758 | RevalAttribute := GetREVAL(Field.GetAttributes); 1759 | if (RevalAttribute <> Nil) and (RevalAttribute.CheckEQ(Value)) then 1760 | Value := TValue.FromVariant(RevalAttribute.Value); 1761 | 1762 | ReadMember(MemberName, Field.FieldType.Handle, Value, IJSonData); 1763 | end; 1764 | end; 1765 | 1766 | class procedure TSerializeParse.ReadObject(AObject: TObject; IResult: ISuperObject); 1767 | var 1768 | Ctx: TRttiContext; 1769 | Typ: TRttiType; 1770 | begin 1771 | Ctx := TRttiContext.Create; 1772 | try 1773 | Typ := Ctx.GetType(AObject.ClassType); 1774 | if not Assigned(Typ) then Exit; 1775 | ReadMembers(AObject, Typ, IResult) ; 1776 | finally 1777 | Ctx.Free; 1778 | end; 1779 | end; 1780 | 1781 | class procedure TSerializeParse.ReadRecord(Info: PTypeInfo; ARecord: Pointer; IResult: ISuperObject); 1782 | var 1783 | Ctx: TRttiContext; 1784 | Typ: TRttiRecordType; 1785 | begin 1786 | Ctx := TRttiContext.Create; 1787 | try 1788 | Typ := Ctx.GetType(Info).AsRecord; 1789 | if not Assigned(Typ) then Exit; 1790 | ReadMembers(ARecord, Typ, IResult) ; 1791 | finally 1792 | Ctx.Free; 1793 | end; 1794 | end; 1795 | 1796 | class function TSerializeParse.ReadRecordEx(Rec: T): ISuperObject; 1797 | var 1798 | IResult: ISuperObject; 1799 | begin 1800 | try 1801 | IResult := TSuperObject.Create; 1802 | with TValue.From(Rec) do 1803 | ReadRecord(TypeInfo, GetReferenceToRawData, IResult); 1804 | finally 1805 | Result := IResult; 1806 | end; 1807 | end; 1808 | 1809 | class function TSerializeParse.CheckObject(Data: Pointer; 1810 | Member: TRttiObject; MIdx: Typ; var Obj: TObject): Boolean; 1811 | var 1812 | rtype: TRttiType; 1813 | rawData: Pointer; 1814 | Val, ArrVal: TValue; 1815 | begin 1816 | Obj := Nil; 1817 | rawData := GetArrayRawData(Member); 1818 | rtype := GetMemberType(Member); 1819 | if rawData <> nil then 1820 | begin 1821 | Obj := GetValue(rawData, Member, MIdx).AsObject; 1822 | if (Obj = Nil) and (ObjectConstructorParamCount(rtype.AsInstance.MetaclassType) = 0 ) then 1823 | begin 1824 | Obj := ObjectConstructor(rtype.AsInstance.MetaclassType); 1825 | TValue.Make(@Obj, rtype.Handle , Val); 1826 | if Member.ClassType = TRttiDynamicArrayType then begin 1827 | TValue.Make(rawData, TRttiDynamicArrayType(Member).Handle, ArrVal); 1828 | rawData := ArrVal.GetReferenceToRawArrayElement(PInteger(@MIdx)^) 1829 | 1830 | end else if Member.ClassType = TRttiArrayType then begin 1831 | TValue.Make(rawData, TRttiArrayType(Member).Handle, ArrVal); 1832 | rawData := ArrVal.GetReferenceToRawArrayElement(PInteger(@MIdx)^) 1833 | 1834 | end; 1835 | 1836 | SetValue(rawData, Member, MIdx, Val); 1837 | end; 1838 | end 1839 | else 1840 | begin 1841 | Obj := GetValue(Data, Member, '').AsObject; 1842 | if (Obj = Nil) and (ObjectConstructorParamCount(rtype.AsInstance.MetaclassType) = 0 ) then 1843 | begin 1844 | Obj := ObjectConstructor(rtype.AsInstance.MetaclassType); 1845 | TValue.Make(@Obj, rtype.Handle , Val); 1846 | SetValue(Data, Member, '', Val); 1847 | end; 1848 | end; 1849 | Result := Obj <> nil; 1850 | end; 1851 | 1852 | class procedure TSerializeParse.ClearArrayRawData(Member: TRttiObject); 1853 | begin 1854 | SetArrayRawData(Member, Nil); 1855 | end; 1856 | 1857 | class constructor TSerializeParse.Create; 1858 | begin 1859 | FGenericsCache := TObjectDictionary.Create([doOwnsValues]); 1860 | end; 1861 | 1862 | class destructor TSerializeParse.Destroy; 1863 | begin 1864 | FGenericsCache.Free; 1865 | end; 1866 | 1867 | {$WARNINGS OFF} 1868 | class function TSerializeParse.GetArrayRawData(Member: TRttiObject): Pointer; 1869 | begin 1870 | if Member is TRttiProperty then 1871 | Result := TSuperProperty(Member).ArrayRawData 1872 | 1873 | else if Member is TRttiField then 1874 | Result := TSuperField(Member).ArrayRawData 1875 | 1876 | else if Member is TRttiDynamicArrayType then 1877 | Result := TSuperDynArr(Member).ArrayRawData 1878 | 1879 | else if Member is TRttiArrayType then 1880 | Result := TSuperArr(Member).ArrayRawData; 1881 | 1882 | end; 1883 | {$WARNINGS ON} 1884 | 1885 | class function TSerializeParse.GetAttribute(AttributeType: TAttributeClass; Attributes: TArray): TCustomAttribute; 1886 | var 1887 | Attr: TCustomAttribute; 1888 | begin 1889 | for Attr in Attributes do 1890 | if Attr is AttributeType then 1891 | Exit(Attr); 1892 | Result := Nil; 1893 | end; 1894 | 1895 | class function TSerializeParse.GetGenericsCreateArgs(Cls: TRttiType): TArray; 1896 | var 1897 | Info: TGenericsInfo; 1898 | begin 1899 | SetLength(Result, 0); 1900 | if FGenericsCache.TryGetValue(Cls.AsInstance.MetaclassType, Info) then 1901 | Result := Info.CreateArgs 1902 | else 1903 | if Cls.AsInstance.MetaclassType.InheritsFrom(TStringStream) then 1904 | begin 1905 | SetLength(Result, 3); 1906 | Result[0] := TValue.From(''); 1907 | Result[1] := TValue.From(TEncoding.UTF8); 1908 | Result[2] := TValue.From(True) 1909 | end; 1910 | 1911 | end; 1912 | 1913 | class function TSerializeParse.GetGenericType(Cls: TClass): TGenericsType; 1914 | var 1915 | Temp: String; 1916 | begin 1917 | Temp := Cls.ClassName; 1918 | if Copy(Temp, 1, 6) = 'TList<' then 1919 | Result := gtList 1920 | else if Copy(Temp, 1, 12) = 'TObjectList<' then 1921 | Result := gtObjectList 1922 | else 1923 | Result := gtNil 1924 | end; 1925 | 1926 | {$WARNINGS OFF} 1927 | class function TSerializeParse.GetMemberType(Member: TRttiObject; const GetArray: Boolean): TRttiType; 1928 | begin 1929 | if Member is TRttiProperty then begin 1930 | Result := TRttiProperty(Member).PropertyType; 1931 | if GetArray and (TSuperProperty(Member).ArrayRawData <> Nil) then 1932 | if Result is TRttiArrayType then 1933 | Result := TRttiArrayType(Result).ElementType 1934 | else 1935 | Result := TRttiDynamicArrayType(Result).ElementType; 1936 | 1937 | end else if Member is TRttiField then begin 1938 | Result := TRttiField(Member).FieldType; 1939 | if GetArray and (TSuperField(Member).ArrayRawData <> Nil) then 1940 | if Result is TRttiArrayType then 1941 | Result := TRttiArrayType(Result).ElementType 1942 | else 1943 | Result := TRttiDynamicArrayType(Result).ElementType; 1944 | 1945 | end else if Member is TRttiDynamicArrayType then begin 1946 | Result := TRttiDynamicArrayType(Member).ElementType 1947 | 1948 | end else if Member is TRttiArrayType then begin 1949 | Result := TRttiArrayType(Member).ElementType 1950 | 1951 | end; 1952 | end; 1953 | {$WARNINGS ON} 1954 | 1955 | class function TSerializeParse.GetMemberTypeInfo( 1956 | Member: TRttiObject; const GetArray: Boolean): PTypeInfo; 1957 | begin 1958 | Result := GetMemberType(Member, GetArray).Handle 1959 | end; 1960 | 1961 | class function TSerializeParse.GetREVAL(const Attributues: TArray): REVAL; 1962 | begin 1963 | Result := REVAL(GetAttribute(REVAL, Attributues)); 1964 | end; 1965 | 1966 | class function TSerializeParse.PropGetterType(Prop: TRttiProperty): TPropertyGetterType; 1967 | var 1968 | Getter: Pointer; 1969 | begin 1970 | if Prop is TRttiInstanceProperty then begin 1971 | Getter := TRttiInstanceProperty(Prop).PropInfo^.GetProc; 1972 | if (IntPtr(Getter) and PROPSLOT_MASK) <> PROPSLOT_FIELD then 1973 | Exit(pgtMethod); 1974 | end; 1975 | Result := pgtField; 1976 | end; 1977 | 1978 | class function TSerializeParse.GetValue(Data: Pointer; 1979 | Member: TRttiObject; MIdx: Typ): TValue; 1980 | begin 1981 | if (TypeInfo(Typ) = TypeInfo(Integer) ) and ( GetMemberTypeInfo(Member, False).Kind in [tkDynArray, tkArray] ) then 1982 | Result := GetValue(GetArrayRawData(Member), Member, '').GetArrayElement(PInteger(@MIdx)^) 1983 | 1984 | else if Member is TRttiProperty then begin 1985 | if (TRttiProperty(Member).PropertyType.Handle.Kind = tkDynArray) and (PropGetterType(TRttiProperty(Member)) = pgtMethod) then begin 1986 | TValue.Make(Nil, TRttiProperty(Member).PropertyType.Handle, Result); 1987 | Exit; 1988 | end; 1989 | Result := TRttiProperty(Member).GetValue(Data) 1990 | 1991 | end else if Member is TRttiField then 1992 | Result := TRttiField(Member).GetValue(Data) 1993 | 1994 | else if Member is TRttiDynamicArrayType then begin 1995 | TValue.Make(GetArrayRawData(Member), TRttiDynamicArrayType(Member).Handle, Result); 1996 | Result := Result.GetArrayElement(PInteger(@MIdx)^); 1997 | end; 1998 | end; 1999 | 2000 | class function TSerializeParse.IsCollection(Cls: TRttiType): Boolean; 2001 | begin 2002 | if Cls = Nil then Exit(False); 2003 | Result := Cls.AsInstance.MetaclassType.InheritsFrom(TCollection); 2004 | end; 2005 | 2006 | class function TSerializeParse.IsCollection(Cls: TClass): Boolean; 2007 | begin 2008 | with TRttiContext.Create do 2009 | try 2010 | Result := IsCollection(GetType(Cls)); 2011 | finally 2012 | Free; 2013 | end; 2014 | end; 2015 | 2016 | class function TSerializeParse.IsDisabled(const Attributes: TArray): Boolean; 2017 | begin 2018 | Result := GetAttribute(DISABLE, Attributes) <> Nil; 2019 | end; 2020 | 2021 | class function TSerializeParse.IsDisabledRead(const Attributes: TArray): Boolean; 2022 | begin 2023 | Result := GetAttribute(DISABLEREAD, Attributes) <> Nil; 2024 | end; 2025 | 2026 | class function TSerializeParse.IsDisabledWrite(const Attributes: TArray): Boolean; 2027 | begin 2028 | Result := GetAttribute(DISABLEWRITE, Attributes) <> Nil; 2029 | end; 2030 | 2031 | class function TSerializeParse.IsGenerics(Cls: TClass): Boolean; 2032 | var 2033 | Info: TGenericsInfo; 2034 | ctx: TRttiContext; 2035 | typ: TRttiType; 2036 | begin 2037 | if FGenericsCache.TryGetValue(Cls, Info) then 2038 | Result := Info.IsGeneric 2039 | else 2040 | begin 2041 | Result := False; 2042 | ctx := TRttiContext.Create; 2043 | try 2044 | typ := ctx.GetType(Cls); 2045 | if typ <> Nil then 2046 | Result := IsGenerics(typ) 2047 | finally 2048 | ctx.Free; 2049 | end; 2050 | end; 2051 | end; 2052 | 2053 | class function TSerializeParse.IsGenerics(Cls: TRttiType): Boolean; 2054 | var 2055 | C: TClass; 2056 | Mtd: TRttiMethod; 2057 | Info: TGenericsInfo; 2058 | Gt: TGenericsType; 2059 | begin 2060 | Result := False; 2061 | C := Cls.AsInstance.MetaclassType; 2062 | if FGenericsCache.TryGetValue(C, Info) then 2063 | Exit(Info.IsGeneric); 2064 | 2065 | if C.UnitName = GenericsUnit then begin 2066 | Gt := GetGenericType(C); 2067 | if Gt in [gtList, gtObjectList] then begin 2068 | Mtd := Cls.GetMethod('First'); 2069 | if (Mtd <> Nil) and (Mtd.MethodKind = mkFunction) then begin // TList<> or TObjectList<> 2070 | Info := TGenericsInfo.Create(C, True, Mtd.ReturnType); 2071 | if Gt = gtObjectList then begin 2072 | SetLength(Info.CreateArgs, 1); 2073 | Info.CreateArgs[0] := True; 2074 | end; 2075 | FGenericsCache.Add(C, Info); 2076 | Exit(True); 2077 | end 2078 | end; 2079 | end; 2080 | end; 2081 | 2082 | class function TSerializeParse.ObjectConstructor( 2083 | Instance: TClass): TObject; 2084 | var 2085 | Ctx: TRttiContext; 2086 | Typ: TRttiType; 2087 | Mtd: TRttiMethod; 2088 | function InEncoding(List: TArray): Boolean; 2089 | var 2090 | I: Integer; 2091 | begin 2092 | if Length(List) <> 3 then Exit(False); 2093 | for I := 0 to High(List) do 2094 | if (List[I].ParamType.TypeKind = tkClass) and (List[I].ParamType.AsInstance.MetaclassType.InheritsFrom(TEncoding)) then 2095 | Exit(True); 2096 | Result := False; 2097 | end; 2098 | begin 2099 | Ctx := TRttiContext.Create; 2100 | try 2101 | Typ := Ctx.GetType(Instance); 2102 | Mtd := nil; 2103 | {$IFNDEF Android or IOS} 2104 | if Instance.InheritsFrom(TStringStream) then begin 2105 | for Mtd in Typ.GetMethods do 2106 | if (CompareText(Mtd.Name, 'Create') = 0) and InEncoding(Mtd.GetParameters) then 2107 | Break; 2108 | Assert(Assigned(Mtd)); 2109 | end 2110 | else 2111 | {$ENDIF} 2112 | Mtd := Typ.GetMethod('Create'); 2113 | 2114 | Result := Mtd.Invoke(Instance, GetGenericsCreateArgs(Typ)).AsObject; 2115 | finally 2116 | Ctx.Free; 2117 | end; 2118 | end; 2119 | 2120 | class function TSerializeParse.ObjectConstructorParamCount( 2121 | Instance: TClass): Integer; 2122 | var 2123 | Ctx: TRttiContext; 2124 | Typ: TRttiType; 2125 | Mtd: TRttiMethod; 2126 | begin 2127 | Result := -1; 2128 | Ctx := TRttiContext.Create; 2129 | try 2130 | Typ := Ctx.GetType(Instance); 2131 | if IsGenerics(Typ) then 2132 | Exit(0); 2133 | if not Assigned(Typ) then Exit; 2134 | Mtd := Typ.GetMethod('Create'); 2135 | if not Assigned(Mtd) then Exit; 2136 | Result := Length( Mtd.GetParameters ); 2137 | finally 2138 | Ctx.Free; 2139 | end; 2140 | end; 2141 | 2142 | class procedure TSerializeParse.ReadCollection(ACollection: TCollection; IResult: ISuperArray); 2143 | var 2144 | I: Integer; 2145 | Item: TCollectionItem; 2146 | begin 2147 | for I := 0 to ACollection.Count - 1 do 2148 | begin 2149 | Item := ACollection.Items[I]; 2150 | if Item <> Nil then 2151 | ReadObject(Item, IResult.O[I]) 2152 | end; 2153 | end; 2154 | 2155 | class procedure TSerializeParse.ReadGeneric(AObject: TObject; IResult: ISuperArray); 2156 | var 2157 | I, Len: Integer; 2158 | Info: TGenericsInfo; 2159 | Item: TObject; 2160 | begin 2161 | Info := FGenericsCache[AObject.ClassType]; 2162 | Len := Info.Count(AObject); 2163 | for I := 0 to Len - 1 do 2164 | begin 2165 | Item := Info.Item(AObject, I); 2166 | if Item <> Nil then 2167 | ReadObject(Item, IResult.O[I]) 2168 | end; 2169 | end; 2170 | 2171 | class procedure TSerializeParse.ReadMember(Member: Typ; RType: PTypeInfo; MemberValue: TValue; IJsonData: IBaseJSON); 2172 | var 2173 | I: Integer; 2174 | SubVal: TValue; 2175 | Obj: TObject; 2176 | begin 2177 | if MemberValue.IsEmpty and not (RType.Kind in [tkArray, tkDynArray]) then 2178 | IJSONDATA.Null[Member] := jNull 2179 | else 2180 | if RType = TypeInfo(TDateTime) then 2181 | IJSonData.D[Member] := MemberValue.AsType 2182 | else 2183 | if RType = TypeInfo(TDate) then 2184 | IJSONData.Date[Member] := MemberValue.AsType 2185 | else 2186 | if RType = TypeInfo(TTime) then 2187 | IJsonData.Time[Member] := MemberValue.AsType 2188 | else 2189 | case RType.Kind of 2190 | tkInteger: 2191 | IJSonData.I[Member] := MemberValue.AsInteger; 2192 | 2193 | tkInt64: 2194 | IJSonData.I[Member] := MemberValue.AsInt64; 2195 | 2196 | tkChar, tkString, tkWChar, tkLString, tkWString, tkUString: 2197 | IJSonData.S[Member] := MemberValue.AsString ; 2198 | 2199 | tkEnumeration: 2200 | if MemberValue.TypeInfo = TypeInfo(Boolean) then 2201 | IJsonData.B[Member] := Boolean( MemberValue.AsOrdinal ) 2202 | else 2203 | IJsonData.I[Member] := MemberValue.AsOrdinal; 2204 | 2205 | tkFloat: 2206 | IJsonData.F[Member] := MemberValue.AsExtended; 2207 | 2208 | tkSet: 2209 | ReadSet(MemberValue, IJsonData.A[Member]); 2210 | 2211 | tkClass, tkPointer: 2212 | if MemberValue.IsObject and (MemberValue.AsObject <> Nil) then 2213 | begin 2214 | Obj := MemberValue.AsObject; 2215 | if Obj is TStream then begin 2216 | IJSONData.S[Member] := ''; 2217 | {$IFDEF SP_STREAM} 2218 | ReadStream(TStream(Obj), IJSONData.Ancestor[Member]) 2219 | {$ENDIF} 2220 | end else if IsGenerics(Obj.ClassType) then 2221 | ReadGeneric(Obj, IJSonData.A[Member]) 2222 | else if IsCollection(Obj.ClassType) then 2223 | ReadCollection(Obj as TCollection, IJSONData.A[Member]) 2224 | else 2225 | ReadObject(Obj, IJSonData.O[Member]); 2226 | end; 2227 | 2228 | tkVariant: 2229 | if TypeInfo(Typ) = TypeInfo(String) then 2230 | ReadVariantOfObject(MemberValue.AsVariant, PString(@Member)^, ISuperObject(IJsonData)) 2231 | else 2232 | if TypeInfo(Typ) = TypeInfo(Integer) then 2233 | ReadVariantOfArray(MemberValue.AsVariant, ISuperArray(IJsonData) ); 2234 | 2235 | tkArray, tkDynArray: 2236 | if not MemberValue.IsArray then 2237 | IJSONDATA.Null[Member] := jNull 2238 | else begin 2239 | IJsonData.A[Member]; 2240 | with MemberValue do 2241 | for I := 0 to GetArrayLength - 1 do begin 2242 | SubVal := GetArrayElement(I); 2243 | ReadMember( I, SubVal.TypeInfo, SubVal, IJsonData.A[Member]); 2244 | end; 2245 | end; 2246 | 2247 | tkRecord: 2248 | ReadRecord(MemberValue.TypeInfo, MemberValue.GetReferenceToRawData, IJSonData.O[Member]); 2249 | 2250 | tkInterface: 2251 | if (TypeInfo(ISuperObject) = MemberValue.TypeInfo) then 2252 | IJsonData.O[Member] := MemberValue.AsType.Clone 2253 | else 2254 | if (TypeInfo(ISuperArray) = MemberValue.TypeInfo) then 2255 | IJsonData.A[Member] := MemberValue.AsType.Clone; 2256 | 2257 | end; 2258 | end; 2259 | 2260 | class procedure TSerializeParse.ReadSet(Val: TValue; IJsonData: ISuperArray); 2261 | var 2262 | S: TIntegerSet; 2263 | I: Integer; 2264 | begin 2265 | Integer(S) := TValueData(Val).FAsULong; 2266 | for I := 0 to SizeOf(Integer) * 8 - 1 do 2267 | if I in S then 2268 | IJsonData.Add(I); 2269 | end; 2270 | 2271 | {$IFDEF SP_STREAM} 2272 | 2273 | function Base64Encode(const Bytes: TIdBytes): String; 2274 | var 2275 | Encoder: TIdEncoderMIME; 2276 | begin 2277 | Encoder := TIdEncoderMIME.Create(nil); 2278 | try 2279 | Result := Encoder.EncodeBytes(Bytes) 2280 | finally 2281 | Encoder.Free; 2282 | end; 2283 | end; 2284 | 2285 | class procedure TSerializeParse.ReadStream(AStream: TStream; IResult: IJSONAncestor); 2286 | var 2287 | ByteArray: TIdBytes; 2288 | begin 2289 | SetLength(ByteArray, AStream.Size); 2290 | AStream.Position := 0; 2291 | AStream.Read(ByteArray[0], AStream.Size); 2292 | (IResult as TJSONString).Value := Base64Encode(ByteArray); 2293 | end; 2294 | {$ENDIF} 2295 | 2296 | class procedure TSerializeParse.ReadTValueOfArray(Val: TValue; 2297 | IJsonData: ISuperArray); 2298 | begin 2299 | 2300 | end; 2301 | 2302 | class procedure TSerializeParse.ReadVariantOfArray(Val: Variant; IJsonData: ISuperArray); 2303 | begin 2304 | IJSonData.Add(Val); 2305 | end; 2306 | 2307 | class procedure TSerializeParse.ReadVariantOfObject(Val: Variant; const Name: String; IJsonData: ISuperObject); 2308 | begin 2309 | IJsonData.SetData(Name, Val); 2310 | end; 2311 | 2312 | 2313 | 2314 | class procedure TSerializeParse.SetArrayRawData(Member: TRttiObject; 2315 | RawData: Pointer); 2316 | begin 2317 | if Member is TRttiProperty then 2318 | TSuperProperty(Member).ArrayRawData := RawData 2319 | 2320 | else if Member is TRttiField then 2321 | TSuperField(Member).ArrayRawData:= RawData 2322 | 2323 | else if Member is TRttiDynamicArrayType then 2324 | TSuperDynArr(Member).ArrayRawData := RawData 2325 | 2326 | else if Member is TRttiArrayType then 2327 | TSuperArr(Member).ArrayRawData := RawData; 2328 | end; 2329 | 2330 | class procedure TSerializeParse.SetValue(var Data: Pointer; Member: TRttiObject; MIdx: Typ; Val: TValue); 2331 | var 2332 | RVal: REVAL; 2333 | begin 2334 | if (TypeInfo(Typ) = TypeInfo(Integer) ) then 2335 | case GetMemberTypeInfo(Member, False).Kind of 2336 | tkArray: begin 2337 | Val.ExtractRawData(Data); 2338 | Exit; 2339 | end; 2340 | 2341 | tkDynArray: begin 2342 | GetValue(GetArrayRawData(Member), Member, '').SetArrayElement(PInteger(@MIdx)^, Val); 2343 | Exit; 2344 | end; 2345 | end; 2346 | 2347 | if Member is TRttiProperty then begin 2348 | RVal := GetREVAL(TRttiProperty(Member).GetAttributes); 2349 | if (RVal <> Nil) and (RVal.CheckEQ(Val)) then 2350 | Val := TValue.FromVariant(RVal.Value); 2351 | TRttiProperty(Member).SetValue(Data, Val) 2352 | 2353 | end else if Member is TRttiField then begin 2354 | RVal := GetREVAL(TRttiProperty(Member).GetAttributes); 2355 | if (RVal <> Nil) and (RVal.CheckEQ(Val)) then 2356 | Val := TValue.FromVariant(RVal.Value); 2357 | TRttiField(Member).SetValue(Data, Val); 2358 | 2359 | end else begin 2360 | if Val.IsObject then 2361 | PPointer(Data)^ := Val.AsObject 2362 | else 2363 | PPointer(Data)^ := Val.GetReferenceToRawData 2364 | end; 2365 | 2366 | end; 2367 | 2368 | class procedure TSerializeParse.WriteCollection(ACollection: TCollection; IData: ISuperArray); 2369 | var 2370 | ItemType: TRttiType; 2371 | Item: TCollectionItem; 2372 | JMembers: IMember; 2373 | begin 2374 | with TRttiContext.Create do 2375 | try 2376 | ItemType := GetType(ACollection.ItemClass) 2377 | finally 2378 | Free; 2379 | end; 2380 | 2381 | if ItemType = Nil then 2382 | raise ESerializeError.CreateFmt('Unknown collection item type (%s).', [ACollection.ItemClass.ClassName]); 2383 | 2384 | for JMembers in IData do 2385 | if JMembers.DataType <> dtObject then 2386 | Continue 2387 | else begin 2388 | Item := ACollection.Add; 2389 | WriteMembers(Item, ItemType, JMembers.AsObject); 2390 | end; 2391 | end; 2392 | 2393 | class procedure TSerializeParse.WriteGeneric(AObject: TObject; IData: ISuperArray); 2394 | var 2395 | Info: TGenericsInfo; 2396 | Item: TObject; 2397 | JMembers: IMember; 2398 | begin 2399 | if IData.DatatYpe = dtNil then 2400 | Exit; 2401 | 2402 | Info := FGenericsCache[AObject.ClassType]; 2403 | for JMembers in IData do 2404 | if JMembers.DataType <> dtObject then 2405 | Continue 2406 | else 2407 | begin 2408 | Item := ObjectConstructor(Info.Typ.AsInstance.MetaclassType); 2409 | WriteMembers(Item, Info.Typ, JMembers.AsObject); 2410 | Info.AddVal(AObject, Item); 2411 | end; 2412 | end; 2413 | 2414 | class procedure TSerializeParse.WriteMember(Data: Pointer; Member: Typ; 2415 | RType: PTypeInfo; MemberValue: TRttiObject; IJsonData: IBaseJSON); 2416 | var 2417 | I: Integer; 2418 | J: NativeInt; 2419 | P: Pointer; 2420 | V: Variant; 2421 | SubVal: TValue; 2422 | SubArr: ISuperArray; 2423 | DataType: TDataType; 2424 | Obj: TObject; 2425 | Ancestor: IJSONAncestor; 2426 | begin 2427 | if not IJsonData.Contains(Member) then 2428 | Exit; 2429 | 2430 | if (RType = TypeInfo(TDateTime)) or (RType = TypeInfo(TDate)) or (RType = TypeInfo(TTime)) then 2431 | begin 2432 | Ancestor := IJSONData.Ancestor[Member]; 2433 | if not (Ancestor.DataType in [dtNull, dtString]) then 2434 | SetValue(Data, MemberValue, Member, TValue.From(Ancestor.AsVariant)) 2435 | end 2436 | else 2437 | case RType.Kind of 2438 | tkInteger: 2439 | SetValue(Data, MemberValue, Member, Integer(IJSonData.I[Member])); 2440 | 2441 | tkInt64: 2442 | SetValue(Data, MemberValue, Member, IJSonData.I[Member]); 2443 | 2444 | tkChar, tkWChar: 2445 | if IJsonData.S[Member] > '' then 2446 | SetValue(Data, MemberValue, Member, TValue.From(IJSonData.S[Member]{$IFDEF XE2UP}.Chars[CharIndex]{$ELSE}[CharIndex]{$ENDIF})); 2447 | 2448 | tkString,tkLString, tkWString, tkUString: 2449 | SetValue(Data, MemberValue, Member, IJSonData.S[Member]); 2450 | 2451 | tkEnumeration: 2452 | if GetMemberTypeInfo(MemberValue) = TypeInfo(Boolean) then 2453 | begin 2454 | SetValue(Data, MemberValue, Member, IJSONData.B[Member]); 2455 | end 2456 | else 2457 | begin 2458 | TValue.Make(IJSONData.I[Member], GetMemberTypeInfo(MemberValue), SubVal ); 2459 | SetValue(Data, MemberValue, Member, SubVal); 2460 | end; 2461 | 2462 | 2463 | tkFloat: 2464 | SetValue(Data, MemberValue, Member, IJsonData.F[Member]); 2465 | 2466 | tkSet: 2467 | WriteSet(Data, MemberValue, IJsonData.A[Member]); 2468 | 2469 | tkClass: 2470 | begin 2471 | if CheckObject(Data, MemberValue, Member, Obj) then 2472 | if (Obj is TStream) then begin 2473 | {$IFDEF SP_STREAM} 2474 | if IJSONData.Null[Member] = jAssigned then 2475 | WriteStream(TStream(Obj), IJSonData.Ancestor[Member]) 2476 | {$ENDIF} 2477 | end else if IsGenerics(Obj.ClassType) then 2478 | WriteGeneric(Obj, IJSONData.A[Member]) 2479 | else if IsCollection(Obj.ClassType) then 2480 | WriteCollection(Obj as TCollection, IJSONData.A[Member]) 2481 | else 2482 | WriteObject(Obj, IJSonData.O[Member]); 2483 | end; 2484 | 2485 | tkVariant: 2486 | begin 2487 | V := IJSONData.V[Member]; 2488 | if not VarIsNull(V) then 2489 | begin 2490 | TValue.Make(@V, GetMemberTypeInfo(MemberValue), SubVal); 2491 | SetValue(Data, MemberValue, Member, SubVal); 2492 | end; 2493 | end; 2494 | 2495 | tkDynArray, tkArray: 2496 | begin 2497 | if IJSonData.Null[Member] = jAssigned then 2498 | begin 2499 | SetArrayRawData(MemberValue, Data); 2500 | try 2501 | DataType := IJSONData.DataType; 2502 | if DataType = dtArray then begin 2503 | SubArr := IJSONData.AsArray; 2504 | J := IJsonData.AsArray.Length; 2505 | if RType.Kind = tkDynArray then 2506 | DynArraySetLength(PPointer(Data)^, RType, 1, @J); 2507 | TValue.Make(Data, Rtype, SubVal); 2508 | 2509 | end else begin 2510 | J := IJSonData.A[Member].Length; 2511 | SubVal := GetValue(Data, MemberValue, Member); 2512 | if RType.Kind = tkDynArray then begin 2513 | DynArraySetLength(PPointer(SubVal.GetReferenceToRawData)^, SubVal.TypeInfo, 1, @J); 2514 | if (MemberValue is TRttiProperty) and (PropGetterType(TRttiProperty(MemberValue)) = pgtMethod) then begin 2515 | WriteMember(SubVal.GetReferenceToRawData, 2516 | 0, 2517 | RType, 2518 | TRttiProperty(MemberValue).PropertyType, 2519 | IJSONData.A[Member]); 2520 | SetValue(Data, MemberValue,'', SubVal ); 2521 | Exit; 2522 | 2523 | end else 2524 | SetValue(Data, MemberValue,'', SubVal ); 2525 | 2526 | end; 2527 | end; 2528 | 2529 | for I := 0 to J-1 do begin 2530 | if DataType <> dtArray then 2531 | SubArr := IJSONData.A[Member]; 2532 | WriteMember 2533 | (SubVal.GetReferenceToRawArrayElement(I), 2534 | I, 2535 | GetMemberTypeInfo(MemberValue), 2536 | MemberValue, 2537 | SubArr); 2538 | end; 2539 | 2540 | if DataType = dtArray then 2541 | SubVal.ExtractRawData(Data) 2542 | else SetValue(Data, MemberValue,'', SubVal ); 2543 | 2544 | finally 2545 | ClearArrayRawData(MemberValue); 2546 | end; 2547 | end; 2548 | end; 2549 | 2550 | tkRecord: 2551 | begin 2552 | if (MemberValue.ClassType = TRttiDynamicArrayType) or (MemberValue.ClassType = TRttiArrayType) then 2553 | WriteRecord(GetMemberTypeInfo(MemberValue), Data, IJSonData.O[Member]) 2554 | else begin 2555 | P := IValueData(TValueData( GetValue(Data, MemberValue, Member) ).FValueData).GetReferenceToRawData; 2556 | WriteRecord(GetMemberTypeInfo(MemberValue), P, IJSonData.O[Member]); 2557 | TValue.Make(P, GetMemberTypeInfo(MemberValue), SubVal); 2558 | SetValue(Data, MemberValue, Member, SubVal ); 2559 | end; 2560 | end; 2561 | 2562 | tkInterface: 2563 | if (TypeInfo(ISuperObject) = GetMemberTypeInfo(MemberValue)) And (IJsonData.Ancestor[Member].DataType = dtObject) then 2564 | SetValue(Data, MemberValue, Member, TValue.From(IJsonData.O[Member].Clone)) 2565 | else 2566 | if (TypeInfo(ISuperArray) = GetMemberTypeInfo(MemberValue)) And (IJsonData.Ancestor[Member].DataType = dtArray) then 2567 | SetValue(Data, MemberValue, Member, TValue.From(IJsonData.A[Member].Clone)); 2568 | end; 2569 | end; 2570 | 2571 | class procedure TSerializeParse.GetAliasName(const Attributes: TArray; var Result: String); 2572 | var 2573 | Attr: Alias; 2574 | begin 2575 | Attr := Alias(GetAttribute(Alias, Attributes)); 2576 | if Assigned(Attr) then 2577 | Result := Attr.Name; 2578 | end; 2579 | 2580 | class procedure TSerializeParse.WriteMembers(Data: Pointer; aType: TRttiType; 2581 | IJsonData: ISuperObject); 2582 | var 2583 | Prop: TRttiProperty; 2584 | Field: TRttiField; 2585 | MemberName: String; 2586 | begin 2587 | for Prop in aType.GetProperties do 2588 | if Prop.PropertyType <> Nil then 2589 | begin 2590 | if not (Prop.Visibility in TSerializeParseOptions.Visibilities) then Continue; 2591 | MemberName := Prop.Name; 2592 | if IsDisabled(Prop.GetAttributes) or IsDisabledRead(Prop.GetAttributes) then 2593 | Continue; 2594 | GetAliasName(Prop.GetAttributes, MemberName); 2595 | WriteMember(Data, MemberName, Prop.PropertyType.Handle, TSuperProperty(Prop), IJSonData); 2596 | end; 2597 | for Field in aType.GetFields do 2598 | if Field.FieldType <> Nil then 2599 | begin 2600 | if not (Field.Visibility in TSerializeParseOptions.Visibilities) then Continue; 2601 | MemberName := Field.Name; 2602 | if IsDisabled(Field.GetAttributes) or IsDisabledRead(Field.GetAttributes) then 2603 | Continue; 2604 | GetAliasName(Field.GetAttributes, MemberName); 2605 | WriteMember(Data, MemberName, Field.FieldType.Handle, TSuperField(Field), IJSonData); 2606 | end; 2607 | end; 2608 | 2609 | class procedure TSerializeParse.WriteObject(AObject: TObject; 2610 | IData: ISuperObject); 2611 | var 2612 | Ctx: TRttiContext; 2613 | Typ: TRttiType; 2614 | begin 2615 | Ctx := TRttiContext.Create; 2616 | try 2617 | Typ := Ctx.GetType(AObject.ClassType); 2618 | if (not Assigned(Typ)) or (IData.DataType = dtNil) then Exit; 2619 | WriteMembers(AObject, Typ, IData); 2620 | finally 2621 | Ctx.Free; 2622 | end; 2623 | end; 2624 | 2625 | class procedure TSerializeParse.WriteRecord(Info: PTypeInfo; ARecord: Pointer; 2626 | IData: ISuperObject); 2627 | var 2628 | Ctx: TRttiContext; 2629 | Typ: TRttiType; 2630 | begin 2631 | Ctx := TRttiContext.Create; 2632 | try 2633 | Typ := Ctx.GetType(Info); 2634 | if (not Assigned(Typ)) or (IData.DataType = dtNil) then 2635 | Exit; 2636 | WriteMembers(ARecord, Typ, IData); 2637 | finally 2638 | Ctx.Free; 2639 | end; 2640 | end; 2641 | 2642 | class procedure TSerializeParse.WriteRecordEx(Rec: T; 2643 | IData: ISuperObject); 2644 | begin 2645 | with TValue.From(Rec) do 2646 | WriteRecord(TypeInfo, GetReferenceToRawData, IData); 2647 | end; 2648 | 2649 | class procedure TSerializeParse.WriteSet(Data: Pointer; Member: TRttiObject; 2650 | IJSONData: ISuperArray); 2651 | var 2652 | Sets: TIntegerSet; 2653 | I: Integer; 2654 | Val: TValue; 2655 | begin 2656 | Sets := []; 2657 | for I := 0 to IJSONData.Length -1 do 2658 | Include(Sets, IJSONData.I[I]); 2659 | TValue.Make(Integer(Sets), GetMemberTypeInfo(Member), Val); 2660 | SetValue(Data, Member, '', Val); 2661 | end; 2662 | 2663 | {$IFDEF SP_STREAM} 2664 | function Base64Decode(const EncodedText: string): TBytesStream; 2665 | var 2666 | Decoder: TIdDecoderMIME; 2667 | begin 2668 | Decoder := TIdDecoderMIME.Create(nil); 2669 | try 2670 | Result := TBytesStream.Create; 2671 | try 2672 | Decoder.DecodeBegin(Result); 2673 | Decoder.Decode(EncodedText); 2674 | Decoder.DecodeEnd; 2675 | except 2676 | Result.Free; 2677 | raise; 2678 | end; 2679 | finally 2680 | Decoder.Free; 2681 | end; 2682 | end; 2683 | 2684 | class procedure TSerializeParse.WriteStream(AStream: TStream; IData: IJSONAncestor); 2685 | var 2686 | Setter: TBytesStream; 2687 | begin 2688 | Setter := Base64Decode((IData as TJSONString).Value); 2689 | try 2690 | Setter.Position := 0; 2691 | AStream.CopyFrom(Setter, Setter.Size); 2692 | finally 2693 | Setter.Free; 2694 | end; 2695 | end; 2696 | {$ENDIF} 2697 | 2698 | { TSuperRecord } 2699 | 2700 | class function TBaseSuperRecord.AsJSON(Rec: T): String; 2701 | begin 2702 | Result := AsJSONObject(Rec).AsJSON; 2703 | end; 2704 | 2705 | class function TBaseSuperRecord.FromJSON(JSON: String): T; 2706 | begin 2707 | Result := FromJSON(SO(JSON)); 2708 | end; 2709 | 2710 | class function TBaseSuperRecord.AsJSONObject(Rec: T): ISuperObject; 2711 | begin 2712 | Result := XSuperObject.TSerializeParse.ReadRecordEx(Rec); 2713 | end; 2714 | 2715 | class function TBaseSuperRecord.FromJSON(JSON: ISuperObject): T; 2716 | var 2717 | Val: TValue; 2718 | P: Pointer; 2719 | begin 2720 | FillChar(Result, SizeOf(T), 0); 2721 | Val := TValue.From(Result); 2722 | P := IValueData(TValueData(Val).FValueData).GetReferenceToRawData; 2723 | TSerializeParse.WriteRecord(Val.TypeInfo, P, JSON); 2724 | Result := T(P^); 2725 | end; 2726 | 2727 | { TJSONValueHelper } 2728 | 2729 | function TJSONValueHelper.ValueEx: Variant; 2730 | var 2731 | Valuable: Boolean; 2732 | pV: PTypeInfo; 2733 | const 2734 | Int = 0; 2735 | Str = ''; 2736 | begin 2737 | Valuable := (Self <> Nil) and not isNull; 2738 | pV := TypeInfo(T); 2739 | if pV = TypeInfo(Int64) then begin 2740 | if Valuable then 2741 | Result := (Self as TJSONInteger).Value 2742 | else 2743 | Result := Int; 2744 | end 2745 | else 2746 | if pV = TypeInfo(Double) then begin 2747 | if Valuable then 2748 | Result := (Self as TJSONFloat).Value 2749 | else 2750 | Result := Int 2751 | end 2752 | else 2753 | if pV = TypeInfo(Boolean) then begin 2754 | if Valuable then 2755 | Result := (Self as TJSONBoolean).Value 2756 | else 2757 | Result := False 2758 | end 2759 | else 2760 | if pV = TypeInfo(String) then 2761 | if Valuable then 2762 | Result := (Self as TJSONString).Value 2763 | else 2764 | Result := Str 2765 | end; 2766 | 2767 | { TSuperExpression } 2768 | 2769 | constructor TSuperExpression.Create(Base: IJSONAncestor; const Expr: String; const BlockException: Boolean); 2770 | begin 2771 | FInterpreter := TJSONInterpreter.Create(Expr, Base, BlockException); 2772 | inherited Create(FInterpreter.ReadExpression); 2773 | end; 2774 | 2775 | destructor TSuperExpression.Destroy; 2776 | begin 2777 | FInterpreter.Free; 2778 | inherited; 2779 | end; 2780 | 2781 | { TCast } 2782 | 2783 | constructor TCast.Create(Base: IJSONAncestor); 2784 | begin 2785 | FJSON := Base; 2786 | FName := ''; 2787 | end; 2788 | 2789 | constructor TCast.Create(Base: IJSONPair); 2790 | begin 2791 | FJSON := Base.JSONValue; 2792 | FName := Base.Name; 2793 | end; 2794 | 2795 | class function TCast.CreateFrom(Base: T): ICast; 2796 | var 2797 | IFace: IInterface; 2798 | begin 2799 | IFace := TValue.From(Base).AsInterface; 2800 | if IFace is TJSONAncestor then 2801 | Result := TCast.Create(IFace as TJSONAncestor) 2802 | else 2803 | if IFace is TJSONPair then 2804 | Result := TCast.Create(IFace as TJSONPair) 2805 | else 2806 | Result := TCast.Create(TJSONAncestor(Nil)); 2807 | end; 2808 | 2809 | destructor TCast.Destroy; 2810 | begin 2811 | FJSON := Nil; 2812 | inherited; 2813 | end; 2814 | 2815 | function TCast.GetArray: ISuperArray; 2816 | begin 2817 | if not Assigned(FJSON) then 2818 | Result := Nil 2819 | else 2820 | Result := TSuperArray.Create(FJSON as TJSONArray); 2821 | end; 2822 | 2823 | function TCast.GetBoolean: Boolean; 2824 | begin 2825 | if not Assigned(FJSON) then 2826 | Result := False 2827 | else 2828 | Result := TJSONBoolean(FJSON).Value; 2829 | end; 2830 | 2831 | function TCast.GetDataType: TDataType; 2832 | begin 2833 | if FJSON = Nil then 2834 | Result := dtNil 2835 | else if FJSON is TJSONNull then 2836 | Result := dtNull 2837 | else if FJSON is TJSONString then 2838 | Result := dtString 2839 | else if FJSON is TJSONInteger then 2840 | Result := dtInteger 2841 | else if FJSON is TJSONFloat then 2842 | Result := dtFloat 2843 | else if FJSON is TJSONBoolean then 2844 | Result := dtBoolean 2845 | else if FJSON is TJSONObject then 2846 | Result := dtObject 2847 | else if FJSON is TJSONArray then 2848 | Result := dtArray 2849 | else if FJSON is TJSONDateTime then 2850 | Result := dtDateTime 2851 | else if FJSON is TJSONDate then 2852 | Result := dtDate 2853 | else if FJSON is TJSONTime then 2854 | Result := dtTime 2855 | else 2856 | raise SOException.Create('Unknown JSON Type'); 2857 | end; 2858 | 2859 | function TCast.GetDate: TDate; 2860 | begin 2861 | if not Assigned(FJSON) then 2862 | Result := 0 2863 | else 2864 | Result := TJSONDate(FJSON).Value; 2865 | end; 2866 | 2867 | function TCast.GetDateTime: TDateTime; 2868 | begin 2869 | if not Assigned(FJSON) then 2870 | Result := 0 2871 | else 2872 | Result := TJSONDateTime(FJSON).Value; 2873 | end; 2874 | 2875 | function TCast.GetFloat: Double; 2876 | begin 2877 | if not Assigned(FJSON) then 2878 | Result := 0 2879 | else 2880 | if FJSON is TJSONInteger then 2881 | Result := TJSONInteger(FJSON).Value 2882 | else 2883 | Result := TJSONFloat(FJSON).Value; 2884 | end; 2885 | 2886 | function TCast.GetInteger: Int64; 2887 | begin 2888 | if not Assigned(FJSON) then 2889 | Result := 0 2890 | else 2891 | if DataType <> dtInteger then 2892 | Result := StrToIntDef(VarToStr(GetVariant), 0) 2893 | else 2894 | Result := TJSONInteger(FJSON).Value; 2895 | end; 2896 | 2897 | function TCast.GetName: String; 2898 | begin 2899 | Result := FName; 2900 | end; 2901 | 2902 | function TCast.GetObject: ISuperObject; 2903 | begin 2904 | if not Assigned(FJSON) then 2905 | Result := Nil 2906 | else 2907 | Result := TSuperObject.Create(FJSON as TJSONObject); 2908 | end; 2909 | 2910 | function TCast.GetString: String; 2911 | begin 2912 | if not Assigned(FJSON) then 2913 | Result := '' 2914 | else 2915 | if FJSON is TJSONString then 2916 | Result := TJSONString(FJSON).Value 2917 | else 2918 | Result := VarToStr(FJSON.AsVariant); 2919 | end; 2920 | 2921 | function TCast.GetTime: TTime; 2922 | begin 2923 | if not Assigned(FJSON) then 2924 | Result := 0 2925 | else 2926 | Result := TJSONTime(FJSON).Value; 2927 | end; 2928 | 2929 | function TCast.GetVariant: Variant; 2930 | begin 2931 | case DataType of 2932 | dtNil, dtNull, dtObject, dtArray: 2933 | Result := Null; 2934 | dtString: 2935 | Result := AsString; 2936 | dtInteger: 2937 | Result := AsInteger; 2938 | dtFloat: 2939 | Result := AsFloat; 2940 | dtBoolean: 2941 | Result := AsBoolean; 2942 | dtDateTime: 2943 | Result := AsDateTime; 2944 | dtDate: 2945 | Result := AsDate; 2946 | dtTime: 2947 | Result := AsTime; 2948 | end; 2949 | end; 2950 | 2951 | procedure TCast.SetBoolean(const Value: Boolean); 2952 | begin 2953 | if not Assigned(FJSON) then Exit; 2954 | TJSONBoolean(FJSON).Value := Value; 2955 | end; 2956 | 2957 | procedure TCast.SetDate(const Value: TDate); 2958 | begin 2959 | if not Assigned(FJSON) then Exit; 2960 | TJSONDate(FJSON).Value := Value; 2961 | 2962 | end; 2963 | 2964 | procedure TCast.SetDateTime(const Value: TDateTime); 2965 | begin 2966 | if not Assigned(FJSON) then Exit; 2967 | TJSONDateTime(FJSON).Value := Value; 2968 | end; 2969 | 2970 | procedure TCast.SetFloat(const Value: Double); 2971 | begin 2972 | if not Assigned(FJSON) then Exit; 2973 | TJSONFloat(FJSON).Value := Value; 2974 | end; 2975 | 2976 | procedure TCast.SetInteger(const Value: Int64); 2977 | begin 2978 | if not Assigned(FJSON) then Exit; 2979 | TJSONInteger(FJSON).Value := Value; 2980 | end; 2981 | 2982 | procedure TCast.SetString(const Value: String); 2983 | begin 2984 | if not Assigned(FJSON) then Exit; 2985 | TJSONString(FJSON).Value := Value; 2986 | end; 2987 | 2988 | 2989 | procedure TCast.SetTime(const Value: TTime); 2990 | begin 2991 | if not Assigned(FJSON) then Exit; 2992 | TJSONTime(FJSON).Value := Value; 2993 | end; 2994 | 2995 | procedure TCast.SetVariant(const Value: Variant); 2996 | begin 2997 | case DataType of 2998 | dtString: 2999 | AsString := VarToStr(Value); 3000 | dtInteger: 3001 | AsInteger := Value; 3002 | dtFloat: 3003 | AsFloat := Value; 3004 | dtBoolean: 3005 | AsBoolean := Value; 3006 | dtDateTime: 3007 | AsDateTime := Value; 3008 | dtDate: 3009 | AsDate := Value; 3010 | dtTime: 3011 | AsTime := Value; 3012 | end; 3013 | end; 3014 | 3015 | function TCast.ToString(const Ident, UniversalTime: Boolean): String; 3016 | var 3017 | SBuilder: TJSONWriter; 3018 | begin 3019 | SBuilder := TJSONWriter.Create(Ident, UniversalTime); 3020 | try 3021 | FJSON.AsJSONString(SBuilder); 3022 | Result := SBuilder.ToString; 3023 | finally 3024 | SBuilder.Free; 3025 | end; 3026 | end; 3027 | 3028 | { TJSONEnumerator } 3029 | 3030 | function TSuperEnumerator.GetCurrent: ICast; 3031 | begin 3032 | Result := TCast.CreateFrom(List.List[Index]); 3033 | end; 3034 | 3035 | function TSuperEnumerator.MoveNext: Boolean; 3036 | begin 3037 | Result := Index < List.List.Count - 1; 3038 | if Result then 3039 | Inc(Index); 3040 | end; 3041 | 3042 | { TBase } 3043 | 3044 | function TBase.AsArray: ISuperArray; 3045 | begin 3046 | Result := Nil; 3047 | end; 3048 | 3049 | function TBase.AsObject: ISuperObject; 3050 | begin 3051 | Result := Nil; 3052 | end; 3053 | 3054 | { TGenericsInfo } 3055 | 3056 | procedure TGenericsInfo.AddVal(Instance: TObject; Val: TValue); 3057 | begin 3058 | FAddMethod.Invoke(Instance, [Val]); 3059 | end; 3060 | 3061 | function TGenericsInfo.Count(Instance: TObject): Integer; 3062 | begin 3063 | Result := FCountProperty.GetValue(Instance).AsInteger; 3064 | end; 3065 | 3066 | constructor TGenericsInfo.Create(GenericClass: TClass;const AIsGeneric: Boolean; AType: TRttiType); 3067 | begin 3068 | IsGeneric := AIsGeneric; 3069 | Typ := AType; 3070 | if GenericClass <> Nil then 3071 | begin 3072 | FContext := TRttiContext.Create; 3073 | FType := FContext.GetType(GenericClass); 3074 | FAddMethod := FType.GetMethod('Add'); 3075 | FCountProperty := FType.GetProperty('Count'); 3076 | FGetItemMethod := FType.GetIndexedProperty('Items'); 3077 | end 3078 | end; 3079 | 3080 | destructor TGenericsInfo.Destroy; 3081 | begin 3082 | if IsGeneric then 3083 | FContext.Free; 3084 | inherited; 3085 | end; 3086 | 3087 | function TGenericsInfo.Item(Instance: TObject; const Index: Integer): TObject; 3088 | begin 3089 | Result := FGetItemMethod.GetValue(Instance, [Index]).AsObject; 3090 | end; 3091 | 3092 | { ReNameField } 3093 | 3094 | constructor Alias.Create(const AName: String); 3095 | begin 3096 | FName := AName; 3097 | end; 3098 | 3099 | { REVAL } 3100 | 3101 | function REVAL.CheckEQ(Val: TValue): Boolean; 3102 | begin 3103 | case FOption of 3104 | roNone: 3105 | Result := Val.AsVariant = FEqual; 3106 | roEmptyArrayToNull: 3107 | Result := Val.GetArrayLength = 0; 3108 | else raise Exception.CreateFmt('Unknown option: %d', [Ord(FOption)]); 3109 | end; 3110 | end; 3111 | 3112 | constructor REVAL.Create(EQVal, NewVal: Integer); 3113 | begin 3114 | FOption := roNone; 3115 | FEqual := EQVal; 3116 | FValue := NewVal; 3117 | end; 3118 | 3119 | constructor REVAL.Create(EQVal, NewVal: String); 3120 | begin 3121 | FOption := roNone; 3122 | FEqual := EQVal; 3123 | FValue := NewVal; 3124 | end; 3125 | 3126 | constructor REVAL.Create(EQVal, NewVal: Double); 3127 | begin 3128 | FOption := roNone; 3129 | FEqual := EQVal; 3130 | FValue := NewVal; 3131 | end; 3132 | 3133 | constructor REVAL.Create(EQVal: String); 3134 | begin 3135 | FOption := roNone; 3136 | FEqual := EQVal; 3137 | FValue := Variants.Null; 3138 | end; 3139 | 3140 | constructor REVAL.Create(EQVal, NewVal: Boolean); 3141 | begin 3142 | FOption := roNone; 3143 | FEqual := EQVal; 3144 | FValue := NewVal; 3145 | end; 3146 | 3147 | constructor REVAL.Create(EQVal: Integer); 3148 | begin 3149 | FOption := roNone; 3150 | FEqual := EQVal; 3151 | FValue := Variants.Null; 3152 | end; 3153 | 3154 | constructor REVAL.Create(EQVal: Double); 3155 | begin 3156 | FOption := roNone; 3157 | FEqual := EQVal; 3158 | FValue := Variants.Null; 3159 | end; 3160 | 3161 | constructor REVAL.Create(EQVal: Boolean); 3162 | begin 3163 | FOption := roNone; 3164 | FEqual := EQVal; 3165 | FValue := Variants.Null; 3166 | end; 3167 | 3168 | constructor REVAL.Create(Option: TRevalOption); 3169 | const 3170 | EMPTY_DATE: TDateTime = 0; 3171 | begin 3172 | FOption := Option; 3173 | case FOption of 3174 | roEmptyArrayToNull: 3175 | FValue := Variants.Null; 3176 | end; 3177 | end; 3178 | 3179 | { TSerializeParseOptions } 3180 | 3181 | class constructor TSerializeParseOptions.Create; 3182 | begin 3183 | FVisibilities := [mvPublic, mvPublished]; 3184 | end; 3185 | 3186 | { TSerialize } 3187 | 3188 | class function TJSON.SuperObject(Value: TValue): ISuperObject; 3189 | var 3190 | Ctx: TRttiContext; 3191 | Typ: TRttiType; 3192 | I: Integer; 3193 | SubVal: TValue; 3194 | _Array: ISuperArray; 3195 | begin 3196 | Ctx := TRttiContext.Create; 3197 | try 3198 | Typ := Ctx.GetType(Value.TypeInfo); 3199 | if not Assigned(Typ) then Exit(SO); 3200 | 3201 | if Typ.IsRecord then begin 3202 | Result := TSuperObject.Create; 3203 | TSerializeParse.ReadRecord(Value.TypeInfo, Value.GetReferenceToRawData, Result) 3204 | 3205 | end else if Typ.IsInstance then begin 3206 | Result := TSuperObject.Create; 3207 | TSerializeParse.ReadObject(Value.AsObject, Result); 3208 | 3209 | end else if Typ.TypeKind = tkInterface then begin 3210 | if Typ.Handle = TypeInfo(ISuperObject) then 3211 | Result := Value.AsType 3212 | else if Typ.Handle = TypeInfo(ISuperArray) then 3213 | Result := TSuperObject.CreateCasted(Value.AsType.Self) 3214 | 3215 | end else if Typ.Handle = TypeInfo(TDateTime) then begin 3216 | Result := TSuperObject.CreateCasted(TJSONDateTime.Create(Value.AsExtended)); 3217 | 3218 | end else if Typ.Handle = TypeInfo(TDate) then begin 3219 | Result := TSuperObject.CreateCasted(TJSONDate.Create(Value.AsExtended)); 3220 | 3221 | end else if Typ.Handle = TypeInfo(TTime) then begin 3222 | Result := TSuperObject.CreateCasted(TJSONTime.Create(Value.AsExtended)); 3223 | 3224 | end else if Typ.Handle = TypeInfo(Boolean) then begin 3225 | Result := TSuperObject.CreateCasted(TJSONBoolean.Create(Value.AsBoolean)); 3226 | 3227 | end else begin 3228 | case Typ.TypeKind of 3229 | tkInteger: 3230 | Result := TSuperObject.CreateCasted(TJSONInteger.Create(Int64(Value.AsInteger))); 3231 | 3232 | tkFloat: 3233 | Result := TSuperObject.CreateCasted(TJSONFloat.Create(Value.AsExtended)); 3234 | 3235 | tkInt64: 3236 | Result := TSuperObject.CreateCasted(TJSONInteger.Create(Value.AsInt64)); 3237 | 3238 | tkString: 3239 | Result := TSuperObject.CreateCasted(TJSONString.Create(Value.AsString)); 3240 | 3241 | tkDynArray, tkArray: begin 3242 | Result := TSuperObject.CreateCasted(TJSONArray.Create); 3243 | _Array := Result.AsArray; 3244 | for I := 0 to Value.GetArrayLength - 1 do begin 3245 | SubVal := Value.GetArrayElement(I); 3246 | TSerializeParse.ReadMember( 3247 | I, 3248 | SubVal.TypeInfo, 3249 | SubVal, 3250 | _Array); 3251 | end; 3252 | end; 3253 | 3254 | tkUString: 3255 | Result := TSuperObject.CreateCasted(TJSONString.Create(Value.AsString)); 3256 | end; 3257 | 3258 | end; 3259 | except 3260 | Ctx.Free; 3261 | raise; 3262 | end; 3263 | end; 3264 | 3265 | 3266 | class function TJSON.Parse(JSON: ISuperObject): T; 3267 | var 3268 | Ctx: TRttiContext; 3269 | Typ: TRttiType; 3270 | DType: TDataType; 3271 | _Array: ISuperArray; 3272 | _PResult: Pointer; 3273 | I: Integer; 3274 | type PTime = ^TTime; 3275 | begin 3276 | Ctx := TRttiContext.Create; 3277 | try 3278 | Typ := Ctx.GetType(TypeInfo(T)); 3279 | if not Assigned(Typ) then 3280 | Exit(Default(T)); 3281 | 3282 | if Typ.IsRecord then 3283 | Result := TBaseSuperRecord.FromJSON(JSON) 3284 | 3285 | else if Typ.IsInstance then begin 3286 | Result := Typ.GetMethod('Create').Invoke(Typ.AsInstance.MetaclassType, []).AsType; 3287 | TSerializeParse.WriteObject(TValue.From(Result).AsObject, JSON); 3288 | 3289 | end else if Typ.Handle = TypeInfo(TDateTime) then begin 3290 | PDateTime(@Result)^ := JSON.Cast.AsDateTime 3291 | 3292 | end else if Typ.Handle = TypeInfo(TDate) then begin 3293 | PDate(@Result)^ := JSON.Cast.AsDate 3294 | 3295 | end else if Typ.Handle = TypeInfo(TTime) then begin 3296 | PTime(@Result)^ := JSON.Cast.AsTime 3297 | 3298 | end else if Typ.Handle = TypeInfo(Boolean) then begin 3299 | PBoolean(@Result)^ := JSON.Cast.AsBoolean 3300 | 3301 | end else begin 3302 | case Typ.TypeKind of 3303 | tkInteger: 3304 | PInteger(@Result)^ := Integer(JSON.Cast.AsInteger); 3305 | 3306 | tkFloat: 3307 | PDouble(@Result)^ := JSON.Cast.AsFloat; 3308 | 3309 | tkInt64: 3310 | PInt64(@Result)^ := JSON.Cast.AsInteger; 3311 | 3312 | tkString: 3313 | {$IFDEF NEXTGEN} 3314 | PString(@Result)^ := JSON.Cast.AsString; 3315 | {$ELSE} 3316 | PAnsiString(@Result)^ := AnsiString(JSON.Cast.AsString); 3317 | {$ENDIF} 3318 | 3319 | tkDynArray, tkArray: begin 3320 | _Array := JSON.AsArray; 3321 | _PResult := @Result; 3322 | TSerializeParse.WriteMember( 3323 | _PResult, 3324 | 0, 3325 | Typ.Handle, 3326 | Typ, 3327 | _Array); 3328 | end; 3329 | 3330 | tkUString: 3331 | PString(@Result)^ := JSON.Cast.AsString; 3332 | end; 3333 | 3334 | end; 3335 | except 3336 | Ctx.Free; 3337 | raise; 3338 | end; 3339 | end; 3340 | 3341 | 3342 | class function TJSON.Parse(JSON: ISuperArray): T; 3343 | var 3344 | Ctx: TRttiContext; 3345 | _PResult: Pointer; 3346 | Typ: TRttiType; 3347 | begin 3348 | Ctx := TRttiContext.Create; 3349 | try 3350 | Typ := Ctx.GetType(TypeInfo(T)); 3351 | if not Assigned(Typ) then Exit(Default(T)); 3352 | _PResult := @Result; 3353 | TSerializeParse.WriteMember( 3354 | _PResult, 3355 | 0, 3356 | Typ.Handle, 3357 | Typ, 3358 | JSON); 3359 | finally 3360 | Ctx.Free; 3361 | end; 3362 | end; 3363 | 3364 | class function TJSON.Stringify(Value: TValue; Indent, UniversalTime: Boolean): String; 3365 | begin 3366 | Result := SuperObject(Value).AsJSON(Indent, UniversalTime); 3367 | end; 3368 | 3369 | {$IFDEF SP_DATASET} 3370 | 3371 | class function TJSON.Stringify(Value: TDataSet): String; 3372 | begin 3373 | Result := SuperObject(Value).AsJSON(False, True); 3374 | end; 3375 | 3376 | class function TJSON.SuperObject(Value: TDataSet): ISuperObject; 3377 | var 3378 | I, J, Z: Integer; 3379 | Rec: ISuperObject; 3380 | Return: ISuperArray; 3381 | Bookmark: TBookmark; 3382 | ABytes: TArray; 3383 | begin 3384 | Return := SA; 3385 | Bookmark := Value.Bookmark; 3386 | Value.DisableControls; 3387 | try 3388 | if not Value.Active then 3389 | Value.Active := True; 3390 | Value.First; 3391 | for I := 0 to Value.RecordCount - 1 do begin 3392 | Rec := SO; 3393 | for J := 0 to Value.FieldCount - 1 do with Value.Fields.Fields[J] do begin 3394 | case DataType of 3395 | ftString: 3396 | Rec.S[FieldName] := AsString; 3397 | ftSmallint, ftInteger: 3398 | Rec.I[FieldName] := AsInteger; 3399 | ftBoolean: 3400 | Rec.B[FieldName] := AsBoolean; 3401 | ftFloat: 3402 | Rec.F[FieldName] := AsFloat; 3403 | ftCurrency: 3404 | Rec.F[FieldName] := AsCurrency; 3405 | ftDate: 3406 | Rec.Date[FieldName] := TDate(AsDateTime); 3407 | ftTime: 3408 | Rec.Time[FieldName] := TTime(AsDateTime); 3409 | ftDateTime: 3410 | Rec.D[FieldName] := AsDateTime; 3411 | ftWideString: 3412 | Rec.S[FieldName] := AsWideString; 3413 | ftLargeint, ftAutoInc: 3414 | Rec.I[FieldName] := AsLargeInt; 3415 | ftVariant: 3416 | Rec.V[FieldName] := AsVariant; 3417 | ftShortint: 3418 | Rec.I[FieldName] := AsInteger; 3419 | ftByte: begin 3420 | ABytes := AsBytes; 3421 | with Rec.A[FieldName] do 3422 | for Z := 0 to High(ABytes) do 3423 | Add(ABytes[Z]); 3424 | end; 3425 | ftExtended: 3426 | Rec.D[FieldName] := AsExtended; 3427 | end; 3428 | end; 3429 | Return.Add(Rec); 3430 | Value.Next; 3431 | end; 3432 | finally 3433 | Value.Bookmark := Bookmark; 3434 | Value.EnableControls; 3435 | end; 3436 | Result := TSuperObject.CreateCasted(Return.Self); 3437 | end; 3438 | {$ENDIF} 3439 | 3440 | class function TJSON.Stringify(Value: T; Indent: Boolean; UniversalTime: Boolean): String; 3441 | begin 3442 | Result := SuperObject(Value).AsJSON(Indent, UniversalTime); 3443 | end; 3444 | 3445 | class function TJSON.Parse(const Value: String): T; 3446 | begin 3447 | Result := Parse(SO(Value)); 3448 | end; 3449 | 3450 | class function TJSON.SuperObject(Value: T): ISuperObject; 3451 | begin 3452 | Result := SuperObject(TValue.From(Value)); 3453 | end; 3454 | 3455 | initialization 3456 | 3457 | GenericsUnit := TEnumerable.UnitName; 3458 | 3459 | end. 3460 | -------------------------------------------------------------------------------- /readme.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | **Delphi Cross Platform Rapid JSON** 6 | ------------------------------------ 7 | [![](https://www.paypalobjects.com/en_US/i/btn/btn_donate_LG.gif)](https://www.paypal.com/cgi-bin/webscr?cmd=_s-xclick&hosted_button_id=7BPTUUP4DGD5C) 8 | 9 | ###Basic 10 | ```json 11 | { 12 | "name": "Onur YILDIZ", 13 | "vip": true, 14 | "telephones": ["000000000", "111111111111"], 15 | "age": 24, 16 | "size": 1.72, 17 | "adresses": [ 18 | { 19 | "adress": "blabla", 20 | "city": "Antalya", 21 | "pc": 7160 22 | }, 23 | { 24 | "adress": "blabla", 25 | "city": "Adana", 26 | "pc": 1170 27 | } 28 | ] 29 | } 30 | ``` 31 | 32 | 33 | ---------- 34 | 35 | 36 | ###Delphi Side 37 | 38 | ```pascal 39 | // foo 40 | var 41 | X: ISuperObject; 42 | begin 43 | X := SO; 44 | X.S['name'] := 'Onur YILDIZ'; 45 | X.B['vip'] := true; 46 | with X.A['telephones'] do 47 | begin 48 | Add('000000000'); 49 | Add('111111111111'); 50 | end; 51 | X.I['age'] := 24; 52 | X.F['size'] := 1.72; 53 | with X.A['adresses'].O[0] {Auto Create} do 54 | begin 55 | S['adress'] := 'blabla'; 56 | S['city'] := 'Antalya'; 57 | I['pc'] := 7160; 58 | end; 59 | // or 60 | X.A['adresses'].O[1].S['adress'] := 'blabla'; 61 | X.A['adresses'].O[1].S['city'] := 'Adana'; 62 | X.A['adresses'].O[1].I['pc'] := 1170; 63 | ``` 64 | ---------- 65 | ###Super Expressions 66 | ```pascal 67 | const 68 | JSON = '{ "o": { '+ 69 | ' "1234567890": {'+ 70 | ' "last use date": "2010-10-17T01:23:20",'+ 71 | ' "create date": "2010-10-17T01:23:20",'+ 72 | ' "name": "iPhone 8s"'+ 73 | ' }'+ 74 | ' },'+ 75 | ' "Index": 0, '+ 76 | ' "Data": {"Index2": 1}, '+ 77 | ' "a": [{'+ 78 | ' "last use date": "2010-10-17T01:23:20",'+ 79 | ' "create date": "2010-11-17T01:23:20",'+ 80 | ' "name": "iPhone 8s",'+ 81 | ' "arr": [1,2,3] '+ 82 | ' }, '+ 83 | ' {'+ 84 | ' message: "hello"'+ 85 | ' }]'+ 86 | '}'; 87 | 88 | var 89 | X: ISuperObject; 90 | NewJSon: ISuperObject; 91 | NewArray: ISuperArray; 92 | begin 93 | X := SO(JSON); 94 | ShowMessage( X['o."1234567890"."last use date"'].AsString ); 95 | ShowMessage( X['a[Index]."create date"'].AsString ); 96 | ShowMessage( X['a[Data.Index2].message'].AsString ); 97 | X['a[0].arr'].AsArray.Add('test1'); 98 | // ----- 99 | NewJSON := X['{a: a[Index], b: a[Data.Index2].message, c: o."1234567890".name, d: 4, e: a[0].arr[2], f: " :) "}'].AsObject; 100 | NewArray := X['[a[Index], a[Data.Index2].message, Data.Index2, Index, 1, "1", "test"]'].AsArray; 101 | end; 102 | ``` 103 | ---------- 104 | ###Where 105 | ```pascal 106 | var 107 | FilterJSON: ISuperObject; 108 | begin 109 | FilterJSON := SO('{ Table: [ '+ 110 | ' { '+ 111 | ' Name: "Sakar SHAKIR", ' + 112 | ' Sex: "M", ' + 113 | ' Size: 1.75 '+ 114 | ' }, '+ 115 | ' { '+ 116 | ' Name: "Bulent ERSOY", ' + 117 | ' Sex: "F", ' + 118 | ' Size: 1.60 '+ 119 | ' }, '+ 120 | ' { '+ 121 | ' Name: "Cicek ABBAS", ' + 122 | ' Sex: "M", ' + 123 | ' Size: 1.65 '+ 124 | ' } '+ 125 | ' ] '+ 126 | '}'); 127 | Memo1.Lines.Add( 128 | FilterJSON.A['Table'].Where(function(Arg: IMember): Boolean 129 | begin 130 | with Arg.AsObject do 131 | Result := (S['Sex'] = 'M') and (F['Size'] > 1.60) 132 | end).AsJSON 133 | ); 134 | end; 135 | ``` 136 | 137 | ***Output*** 138 | ```json 139 | [ 140 | { 141 | "Name":"Sakar SHAKIR", 142 | "Sex":"M", 143 | "Size":1.75 144 | }, 145 | { 146 | "Name":"Cicek ABBAS", 147 | "Sex":"M", 148 | "Size":1.65 149 | } 150 | ] 151 | ``` 152 | ---------- 153 | ###Delete 154 | ```pascal 155 | var 156 | FilterJSON: ISuperObject; 157 | begin 158 | FilterJSON := SO('{ Table: [ '+ 159 | ' { '+ 160 | ' Name: "Sakar SHAKIR", ' + 161 | ' Sex: "M", ' + 162 | ' Size: 1.75 '+ 163 | ' }, '+ 164 | ' { '+ 165 | ' Name: "Bulent ERSOY", ' + 166 | ' Sex: "F", ' + 167 | ' Size: 1.60 '+ 168 | ' }, '+ 169 | ' { '+ 170 | ' Name: "Cicek ABBAS", ' + 171 | ' Sex: "M", ' + 172 | ' Size: 1.65 '+ 173 | ' } '+ 174 | ' ] '+ 175 | '}'); 176 | Memo1.Lines.Add( 177 | FilterJSON.A['Table'].Delete(function(Arg: IMember): Boolean 178 | begin 179 | with Arg.AsObject do 180 | Result := (S['Sex'] = 'M') and (F['Size'] > 1.60) 181 | end).AsJSON 182 | ); 183 | end; 184 | ``` 185 | ***Output*** 186 | ```json 187 | [ 188 | { 189 | "Name":"Bulent ERSOY", 190 | "Sex":"F", 191 | "Size":1.6 192 | } 193 | ] 194 | ``` 195 | 196 | ---------- 197 | ###Sorting 198 | ```pascal 199 | var 200 | X: ISuperObject; 201 | A: ISuperArray; 202 | begin 203 | X := SO('{b:1, a:2, d:4, c:2}'); 204 | ShowMessage(X.AsJSON); 205 | X.Sort(function(Left, Right: IMember): Integer begin 206 | Result := CompareText(Left.Name, Right.Name); 207 | end); 208 | ShowMessage(X.AsJSON); 209 | 210 | A := SA('[{index:3}, {index:4}, {index:2}, {index:1}]'); 211 | ShowMessage(A.AsJSON); 212 | A.Sort(function(Left, Right: IMember): Integer begin 213 | Result := CompareValue(Left.AsObject.I['index'], Right.AsObject.I['index']); 214 | end); 215 | ShowMessage(A.AsJSON); 216 | end; 217 | ``` 218 | ***Output*** 219 | ```json 220 | {"b":1,"a":2,"d":4,"c":2} 221 | {"a":2,"b":1,"c":2,"d":4} 222 | [{"index":3},{"index":4},{"index":2},{"index":1}] 223 | [{"index":1},{"index":2},{"index":3},{"index":4}] 224 | ``` 225 | ---------- 226 | ###Variant 227 | ```pascal 228 | var 229 | X: ISuperObject; 230 | begin 231 | X := TSuperObject.Create; 232 | X.V['A'] := 1; 233 | X.V['B'] := '2'; 234 | X.V['C'] := 1.3; 235 | X.V['D'] := False; 236 | X.V['E'] := Null; 237 | X.V['F'] := Now; 238 | Memo1.Lines.Add(X.AsJSON); 239 | end; 240 | ``` 241 | ***Output*** 242 | ```json 243 | { 244 | "A": 1, 245 | "B": "2", 246 | "C": 1.3, 247 | "D": false, 248 | "E": null, 249 | "F": "2014-05-03T03:25:05.059" 250 | } 251 | ``` 252 | ---------- 253 | ###Loops 254 | ```pascal 255 | const 256 | JSN = '{ '+ 257 | ' "adresses": [ '+ 258 | ' { '+ 259 | ' "adress": "blabla", '+ 260 | ' "city": "Antalya", '+ 261 | ' "pc": 7160 '+ 262 | ' },'+ 263 | ' { '+ 264 | ' "adress": "blabla", '+ 265 | ' "city": "Adana", '+ 266 | ' "pc": 1170 '+ 267 | ' } '+ 268 | ' ] '+ 269 | '}'; 270 | var 271 | X, Obj: ISuperObject; 272 | J: Integer; 273 | begin 274 | X := TSuperObject.Create(JSN); 275 | with X.A['adresses'] do 276 | for J := 0 to Lenght -1 do 277 | begin 278 | Obj := O[J]; 279 | Obj.First; 280 | while not Obj.EoF do 281 | begin 282 | Memo1.Lines.Add( Obj.CurrentKey + ' = ' + VarToStr(Obj.CurrentValue.AsVariant)); 283 | Obj.Next; 284 | end; 285 | Memo1.Lines.Add('------'); 286 | end; 287 | end; 288 | ``` 289 | > **Output** 290 | > adress = blabla 291 | > city = Antalya 292 | > pc = 7160 293 | 294 | **Or Enumerator** 295 | ```pascal 296 | var 297 | X: ISuperObject; 298 | AMember, 299 | OMember: IMember; 300 | begin 301 | X := TSuperObject.Create(JSN); 302 | 303 | for AMember in X.A['adresses'] do 304 | begin 305 | for OMember in AMember.AsObject do 306 | Memo1.Lines.Add(OMember.Name + ' = ' + OMember.ToString); 307 | 308 | Memo1.Lines.Add('------'); 309 | end; 310 | ``` 311 | > **Output** 312 | > adress = blabla 313 | > city = Adana 314 | > pc = 1170 315 | 316 | ---------- 317 | ###Marshalling 318 | ```pascal 319 | type 320 | 321 | TTestSet = (ttA, ttB, ttC); 322 | 323 | TTestSets = set of TTestSet; 324 | 325 | TSubRec = record 326 | A: Integer; 327 | B: String; 328 | end; 329 | 330 | TSubObj = class 331 | A: Integer; 332 | B: Integer; 333 | end; 334 | 335 | TTest = class // Field, Property Support 336 | private 337 | FB: String; 338 | FSubObj: TSubObj; 339 | FSubRec: TSubRec; 340 | FTestSets: TTestSets; 341 | FH: TDateTime; 342 | FJ: TDate; 343 | FK: TTime; 344 | FList: TObjectList; // or TList<>; But only object types are supported 345 | public 346 | A: Integer; 347 | B: TTestSet; 348 | C: Boolean; 349 | property D: String read FB write FB; 350 | property E: TSubRec read FSubRec write FSubRec; 351 | property F: TSubObj read FSubObj write FSubObj; 352 | property G: TTestSets read FTestSets write FTestSets; 353 | property H: TDateTime read FH write FH; 354 | property J: TDate read FJ write FJ; 355 | property K: TTime read FK write FK; 356 | property L: TObjectList read FList write FList; 357 | end; 358 | 359 | TTestRec = record // Only Field Support 360 | A: Integer; 361 | B: TTestSet; 362 | C: Boolean; 363 | D: String; 364 | E: TSubRec; 365 | F: TSubObj; 366 | G: TTestSets; 367 | H: TDateTime; 368 | J: TDate; 369 | K: TTime; 370 | L: TObjectList; // or TList<>; But only object types are supported 371 | end; 372 | 373 | implementation 374 | ... 375 | 376 | var 377 | Parse: TTest; // For Class; 378 | S: String; 379 | begin 380 | Parse := TTest.FromJSON('{"A": 1, "B": 0, "C": true, "D": "Hello", "E":{"A": 3, "B": "Delphi"}, "F": {"A": 4, "B": 5}, "G": [0,2], "H": "2014-05-03T03:25:05.059", "J": "2014-05-03", "K": "03:25:05", "L":[{"A": 4, "B": 5},{"A": 6, "B": 7}] }'); 381 | S := Parse.AsJSON; 382 | end; 383 | 384 | 385 | ... 386 | var 387 | Parse: TTestRec; // For Record; 388 | S: String; 389 | begin 390 | Parse := TJSON.Parse('{"A": 1, "B": 0, "C": true, "D": "Hello", "E":{"A": 3, "B": "Delphi"}, "F": {"A": 4, "B": 5}, "G": [0,2], "H": "2014-05-03T03:25:05.059", "J": "2014-05-03", "K": "03:25:05", "L":[{"A": 4, "B": 5},{"A": 6, "B": 7}]}'); 391 | S := TJSON.Stringify(Parse); 392 | end; 393 | 394 | ``` 395 | ```pascal 396 | type 397 | TRec = record // or class 398 | A: Integer; 399 | B: String; 400 | end; 401 | 402 | implementation 403 | ... 404 | 405 | var 406 | Test: TArray; 407 | S: String; 408 | begin 409 | Test := TJSON.Parse>('[{"A": 1, "B": "1"}, {"A": 2, "B": "2"}]'); 410 | S := TJSON.Stringify>(Test); 411 | end; 412 | ``` 413 | Collection (Limited) 414 | ```pascal 415 | type 416 | TXCollectionItem = class(TCollectionItem) 417 | private 418 | FA: String; 419 | FB: Integer; 420 | public 421 | property A: String read FA write FA; 422 | property B: Integer read FB write FB; 423 | end; 424 | 425 | TXCollection = class(TCollection) 426 | public 427 | constructor Create; reintroduce; 428 | end; 429 | 430 | TTest = class 431 | private 432 | FCollection: TXColleciton; 433 | public 434 | destructor Destroy; override; 435 | property Collection: TCollection read FCollection write FCollection; 436 | end; 437 | 438 | implementation 439 | ... 440 | 441 | constructor TXCollection.Create; 442 | begin 443 | inherited Create(TXCollectionItem); 444 | end; 445 | 446 | destructor TTest.Destroy; 447 | begin 448 | FCollection.Free; 449 | inherited; 450 | end; 451 | 452 | var 453 | Test: TTest; 454 | begin 455 | Test := TTest.FromJSON('{"Collection": [{"A": "Item 1", "B": 1}, {"A": "Item 2", "B": 1}]}'); 456 | S := Test.AsJSON; 457 | end; 458 | ``` 459 | ---------- 460 | ###Marshalling **Attributes** 461 | ```pascal 462 | TTest = class 463 | public 464 | [ALIAS('Type')] 465 | Typ: String; 466 | [ALIAS('Unit')] 467 | Unt: Integer; 468 | [REVAL('', '*')] 469 | Filter: String; 470 | [DISABLE] 471 | BlaBlaBla: String; 472 | [REVAL(roEmptyArrayToNull)] 473 | Arr: TArray; 474 | end; 475 | 476 | var X: Test; 477 | begin 478 | X := TTest.Create; 479 | X.Typ := 'XType'; 480 | X.Unt := 2; 481 | X.Filter := ''; 482 | X.BlaBlaBla := ':)'; 483 | SetLength(X.Arr, 0); 484 | ShowMessage(X.AsJSON); 485 | end; 486 | ``` 487 | ***Output*** 488 | ```json 489 | { 490 | "Type": "XType", 491 | "Unit": 2, 492 | "Filter": "*", 493 | "Arr": null 494 | } 495 | ``` 496 | --------------------------------------------------------------------------------