├── README.md ├── src ├── Jsons.pas └── JsonsUtilsEx.pas └── test └── TestJson.dpr /README.md: -------------------------------------------------------------------------------- 1 | json4delphi 2 | =========== 3 | 4 | JSON for Delphi, support for older versions of Delphi (6 or above) 5 | 6 | Object-pascal native code, using classes only TList, TStrings and TStringList 7 | 8 | Example: 9 | 10 | ```pascal 11 | var 12 | Json: TJson; 13 | Str: String 14 | begin 15 | Json := TJson.Create(); 16 | 17 | //put 18 | Json.Put('field1', null); 19 | Json.Put('field2', True); 20 | Json.Put('field3', 3.14); 21 | Json.Put('field4', 'hello world'); 22 | 23 | //another way 24 | Json['field5'].AsBoolean := False; 25 | Json['field6'].AsString := 'hello world'; 26 | 27 | //object 28 | with Json['field7'].AsObject do 29 | begin 30 | Put('subfield1', 2.7182818284); 31 | Put('subfield2', 'json4delphi'); 32 | end; 33 | 34 | //array 35 | with Json['field8'].AsArray do 36 | begin 37 | Put(6.6260755e-34); 38 | Put('The magic words are squeamish ossifrage'); 39 | end; 40 | 41 | //get 42 | Str := Json['field4'].AsString; 43 | 44 | //parse 45 | Json.Parse('{"a":1}'); 46 | 47 | //stringify 48 | Str := Json.Stringify; 49 | end; 50 | ``` 51 | -------------------------------------------------------------------------------- /src/Jsons.pas: -------------------------------------------------------------------------------- 1 | {**************************************************************************** 2 | Copyright (c) 2014 Randolph 3 | 4 | mail: rilyu@sina.com 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy 7 | of this software and associated documentation files (the "Software"), to deal 8 | in the Software without restriction, including without limitation the rights 9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | copies of the Software, and to permit persons to whom the Software is 11 | furnished to do so, subject to the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be included in 14 | all copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 21 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 22 | THE SOFTWARE. 23 | 24 | 201804 - Fiy - VGS - Refactor FixedFloatToStr (best use case and optimization) 25 | 201805 - Add - VGS - Add OBjectToJson and JsonToObject, rtti based, cross platform Delphi10+ and FPC 3+Refactor 26 | 201807 - Fix - VGS - String unicode (\uxxx) encoding and decoding. 27 | 28 | ****************************************************************************} 29 | 30 | unit Jsons; 31 | 32 | {$IFDEF FPC} 33 | {$MODE Delphi} 34 | {$ENDIF} 35 | 36 | interface 37 | 38 | uses Classes, SysUtils, jsonsutilsEx; 39 | 40 | type 41 | TJsonValueType = (jvNone, jvNull, jvString, jvNumber, jvBoolean, jvObject, jvArray); 42 | TJsonStructType = (jsNone, jsArray, jsObject); 43 | TJsonNull = (null); 44 | TJsonEmpty = (empty); 45 | 46 | type 47 | TJsonValue = class; 48 | TJsonBase = class(TObject) 49 | private 50 | FOwner : TJsonBase; 51 | function GetOwner: TJsonBase; 52 | procedure InternalStringify(Stream:TStringStream;AName:string;AValue:TJsonValue); 53 | protected 54 | function GetOwnerName: String; 55 | procedure RaiseError(const Msg: String); 56 | procedure RaiseParseError(const JsonString: String); 57 | procedure RaiseAssignError(Source: TJsonBase); 58 | public 59 | constructor Create(AOwner: TJsonBase); 60 | destructor Destroy; override; 61 | 62 | procedure Parse(JsonString: String); virtual; abstract; 63 | function Stringify:string;virtual; 64 | 65 | procedure Assign(Source: TJsonBase); virtual; abstract; 66 | 67 | function Encode(const S: String): String; 68 | function Decode(const S: String): String; 69 | 70 | procedure Split(const S: String; const Delimiter: Char; Strings: TStrings); 71 | 72 | function IsJsonObject(const S: String): Boolean; 73 | function IsJsonArray(const S: String): Boolean; 74 | function IsJsonString(const S: String): Boolean; 75 | function IsJsonNumber(const S: String): Boolean; 76 | function IsJsonBoolean(const S: String): Boolean; 77 | function IsJsonNull(const S: String): Boolean; 78 | 79 | function AnalyzeJsonValueType(const S: String): TJsonValueType; 80 | 81 | public 82 | property Owner: TJsonBase read GetOwner; 83 | 84 | end; 85 | 86 | TJsonObject = class; 87 | TJsonArray = class; 88 | TJsonValue = class(TJsonBase) 89 | private 90 | FValueType: TJsonValueType; 91 | FStringValue: String; 92 | FNumberValue: Extended; 93 | FBooleanValue: Boolean; 94 | FObjectValue: TJsonObject; 95 | FArrayValue: TJsonArray; 96 | 97 | function GetAsArray: TJsonArray; 98 | function GetAsBoolean: Boolean; 99 | function GetAsInteger: Integer; 100 | function GetAsNumber: Extended; 101 | function GetAsObject: TJsonObject; 102 | function GetAsString: String; 103 | function GetIsNull: Boolean; 104 | procedure SetAsBoolean(const Value: Boolean); 105 | procedure SetAsInteger(const Value: Integer); 106 | procedure SetAsNumber(const Value: Extended); 107 | procedure SetAsString(const Value: String); 108 | procedure SetIsNull(const Value: Boolean); 109 | procedure SetAsArray(const Value: TJsonArray); 110 | procedure SetAsObject(const Value: TJsonObject); 111 | function GetIsEmpty: Boolean; 112 | procedure SetIsEmpty(const Value: Boolean); 113 | 114 | protected 115 | procedure RaiseValueTypeError(const AsValueType: TJsonValueType); 116 | public 117 | constructor Create(AOwner: TJsonBase); 118 | destructor Destroy; override; 119 | 120 | procedure Parse(JsonString: String); override; 121 | 122 | procedure Assign(Source: TJsonBase); override; 123 | 124 | procedure Clear; 125 | 126 | public 127 | property ValueType: TJsonValueType read FValueType; 128 | property AsString: String read GetAsString write SetAsString; 129 | property AsNumber: Extended read GetAsNumber write SetAsNumber; 130 | property AsInteger: Integer read GetAsInteger write SetAsInteger; 131 | property AsBoolean: Boolean read GetAsBoolean write SetAsBoolean; 132 | property AsObject: TJsonObject read GetAsObject write SetAsObject; 133 | property AsArray: TJsonArray read GetAsArray write SetAsArray; 134 | property IsNull: Boolean read GetIsNull write SetIsNull; 135 | property IsEmpty: Boolean read GetIsEmpty write SetIsEmpty; 136 | 137 | end; 138 | 139 | TJsonArray = class(TJsonBase) 140 | private 141 | FList: TList; 142 | function GetItems(Index: Integer): TJsonValue; 143 | function GetCount: Integer; 144 | public 145 | constructor Create(AOwner: TJsonBase = nil); 146 | destructor Destroy; override; 147 | 148 | procedure Parse(JsonString: String); override; 149 | 150 | procedure Assign(Source: TJsonBase); override; 151 | procedure Merge(Addition: TJsonArray); 152 | 153 | function Add: TJsonValue; 154 | function Insert(const Index: Integer): TJsonValue; 155 | 156 | function Put(const Value: TJsonEmpty): TJsonValue; overload; 157 | function Put(const Value: TJsonNull): TJsonValue; overload; 158 | function Put(const Value: Boolean): TJsonValue; overload; 159 | function Put(const Value: Integer): TJsonValue; overload; 160 | function Put(const Value: Extended): TJsonValue; overload; 161 | function Put(const Value: String): TJsonValue; overload; 162 | function Put(const Value: TJsonArray): TJsonValue; overload; 163 | function Put(const Value: TJsonObject): TJsonValue; overload; 164 | function Put(const Value: TJsonValue): TJsonValue; overload; 165 | 166 | procedure Delete(const Index: Integer); 167 | procedure Clear; 168 | 169 | public 170 | property Count: Integer read GetCount; 171 | property Items[Index: Integer]: TJsonValue read GetItems; default; 172 | 173 | end; 174 | 175 | TJsonPair = class(TJsonBase) 176 | private 177 | FName: String; 178 | FValue: TJsonValue; 179 | 180 | procedure SetName(const Value: String); 181 | 182 | public 183 | constructor Create(AOwner: TJsonBase; const AName: String = ''); 184 | destructor Destroy; override; 185 | 186 | procedure Parse(JsonString: String); override; 187 | 188 | procedure Assign(Source: TJsonBase); override; 189 | 190 | public 191 | property Name: String read FName write SetName; 192 | property Value: TJsonValue read FValue; 193 | 194 | end; 195 | 196 | TJsonObject = class(TJsonBase) 197 | private 198 | FList: TList; 199 | FAutoAdd: Boolean; 200 | function GetCount: Integer; 201 | function GetItems(Index: Integer): TJsonPair; 202 | function GetValues(Name: String): TJsonValue; 203 | public 204 | constructor Create(AOwner: TJsonBase = nil); 205 | destructor Destroy; override; 206 | 207 | procedure Parse(JsonString: String); override; 208 | 209 | procedure Assign(Source: TJsonBase); override; 210 | procedure Merge(Addition: TJsonObject); 211 | 212 | function Add(const Name: String = ''): TJsonPair; 213 | function Insert(const Index: Integer; const Name: String = ''): TJsonPair; 214 | 215 | function Put(const Name: String; const Value: TJsonEmpty): TJsonValue; overload; 216 | function Put(const Name: String; const Value: TJsonNull): TJsonValue; overload; 217 | function Put(const Name: String; const Value: Boolean): TJsonValue; overload; 218 | function Put(const Name: String; const Value: Integer): TJsonValue; overload; 219 | function Put(const Name: String; const Value: Extended): TJsonValue; overload; 220 | function Put(const Name: String; const Value: String): TJsonValue; overload; 221 | function Put(const Name: String; const Value: TJsonArray): TJsonValue; overload; 222 | function Put(const Name: String; const Value: TJsonObject): TJsonValue; overload; 223 | function Put(const Name: String; const Value: TJsonValue): TJsonValue; overload; 224 | function Put(const Value: TJsonPair): TJsonValue; overload; 225 | 226 | function Find(const Name: String): Integer; 227 | 228 | procedure Delete(const Index: Integer); overload; 229 | procedure Delete(const Name: String); overload; 230 | 231 | procedure Clear; 232 | 233 | public 234 | property Count: Integer read GetCount; 235 | property Items[Index: Integer]: TJsonPair read GetItems; 236 | property Values[Name: String]: TJsonValue read GetValues; default; 237 | property AutoAdd: Boolean read FAutoAdd write FAutoAdd; 238 | 239 | end; 240 | 241 | TJson = class(TJsonBase) 242 | private 243 | FStructType: TJsonStructType; 244 | FJsonArray: TJsonArray; 245 | FJsonObject: TJsonObject; 246 | 247 | function GetCount: Integer; 248 | function GetJsonArray: TJsonArray; 249 | function GetJsonObject: TJsonObject; 250 | function GetValues(Name: String): TJsonValue; 251 | protected 252 | procedure CreateArrayIfNone; 253 | procedure CreateObjectIfNone; 254 | 255 | procedure RaiseIfNone; 256 | procedure RaiseIfNotArray; 257 | procedure RaiseIfNotObject; 258 | 259 | procedure CheckJsonArray; 260 | procedure CheckJsonObject; 261 | 262 | public 263 | constructor Create; 264 | destructor Destroy; override; 265 | 266 | procedure Parse(JsonString: String); override; 267 | function Stringify: String; override; 268 | 269 | procedure Assign(Source: TJsonBase); override; 270 | 271 | procedure Delete(const Index: Integer); overload; 272 | procedure Delete(const Name: String); overload; 273 | 274 | procedure Clear; 275 | 276 | function Get(const Index: Integer): TJsonValue; overload; //for both 277 | function Get(const Name: String): TJsonValue; overload; //for JsonObject 278 | 279 | //for JsonArray 280 | function Put(const Value: TJsonEmpty): TJsonValue; overload; 281 | function Put(const Value: TJsonNull): TJsonValue; overload; 282 | function Put(const Value: Boolean): TJsonValue; overload; 283 | function Put(const Value: Integer): TJsonValue; overload; 284 | function Put(const Value: Extended): TJsonValue; overload; 285 | function Put(const Value: String): TJsonValue; overload; 286 | function Put(const Value: TJsonArray): TJsonValue; overload; 287 | function Put(const Value: TJsonObject): TJsonValue; overload; 288 | function Put(const Value: TJsonValue): TJsonValue; overload; 289 | function Put(const Value: TJson): TJsonValue; overload; 290 | 291 | //for JsonObject 292 | function Put(const Name: String; const Value: TJsonEmpty): TJsonValue; overload; 293 | function Put(const Name: String; const Value: TJsonNull): TJsonValue; overload; 294 | function Put(const Name: String; const Value: Boolean): TJsonValue; overload; 295 | function Put(const Name: String; const Value: Integer): TJsonValue; overload; 296 | function Put(const Name: String; const Value: Extended): TJsonValue; overload; 297 | function Put(const Name: String; const Value: String): TJsonValue; overload; 298 | function Put(const Name: String; const Value: TJsonArray): TJsonValue; overload; 299 | function Put(const Name: String; const Value: TJsonObject): TJsonValue; overload; 300 | function Put(const Name: String; const Value: TJsonValue): TJsonValue; overload; 301 | function Put(const Name: String; const Value: TJson): TJsonValue; overload; 302 | function Put(const Value: TJsonPair): TJsonValue; overload; 303 | 304 | public 305 | property StructType: TJsonStructType read FStructType; 306 | property JsonObject: TJsonObject read GetJsonObject; 307 | property JsonArray: TJsonArray read GetJsonArray; 308 | 309 | property Count: Integer read GetCount; 310 | property Values[Name: String]: TJsonValue read GetValues; default; //for JsonObject 311 | 312 | end; 313 | 314 | implementation 315 | 316 | { TJsonBase } 317 | 318 | function TJsonBase.AnalyzeJsonValueType(const S: String): TJsonValueType; 319 | var 320 | Len: Integer; 321 | Number: Extended; 322 | begin 323 | Result := jvNone; 324 | Len := Length(S); 325 | if Len >= 2 then 326 | begin 327 | if (S[1] = '{') and (S[Len] = '}') then Result := jvObject 328 | else if (S[1] = '[') and (S[Len] = ']') then Result := jvArray 329 | else if (S[1] = '"') and (S[Len] = '"') then Result := jvString 330 | else if SameText(S, 'null') then Result := jvNull 331 | else if SameText(S, 'true') or SameText(S, 'false') then Result := jvBoolean 332 | else if FixedTryStrToFloat(S, Number) then Result := jvNumber; 333 | end 334 | else if FixedTryStrToFloat(S, Number) then Result := jvNumber; 335 | end; 336 | 337 | constructor TJsonBase.Create(AOwner: TJsonBase); 338 | begin 339 | FOwner := AOwner; 340 | end; 341 | 342 | function TJsonBase.Decode(const S: String): String; 343 | 344 | function HexValue(C: Char): Byte; 345 | begin 346 | case C of 347 | '0'..'9': Result := Byte(C) - Byte('0'); 348 | 'a'..'f': Result := (Byte(C) - Byte('a')) + 10; 349 | 'A'..'F': Result := (Byte(C) - Byte('A')) + 10; 350 | else raise Exception.Create('Illegal hexadecimal characters "' + C + '"'); 351 | end; 352 | end; 353 | 354 | var 355 | I : Integer; 356 | C : Char; 357 | ubuf : integer; 358 | Stream : TStringStream; 359 | begin 360 | Stream := TStringStream.Create; 361 | I := 1; 362 | while I <= Length(S) do 363 | begin 364 | C := S[I]; 365 | Inc(I); 366 | if C = '\' then 367 | begin 368 | C := S[I]; 369 | Inc(I); 370 | case C of 371 | 'b': Stream.WriteString(#8); 372 | 't': Stream.WriteString(#9); 373 | 'n': Stream.WriteString(#10); 374 | 'f': Stream.WriteString(#12); 375 | 'r': Stream.WriteString(#13); 376 | 'u': 377 | begin 378 | if not TryStrToInt('$' + Copy(S, I, 4), ubuf) then 379 | raise Exception.Create(format('Invalid unicode \u%s',[Copy(S, I, 4)])); 380 | Stream.WriteString(WideChar(ubuf)); 381 | Inc(I, 4); 382 | end; 383 | else Stream.WriteString(C); 384 | end; 385 | end 386 | else Stream.WriteString(C); 387 | end; 388 | Result := Stream.DataString; 389 | Stream.Free; 390 | end; 391 | 392 | destructor TJsonBase.Destroy; 393 | begin 394 | inherited Destroy; 395 | end; 396 | 397 | function TJsonBase.Encode(const S: String): String; 398 | var 399 | I , 400 | UnicodeValue : Integer; 401 | C : Char; 402 | Stream : TStringStream; 403 | begin 404 | Stream := TStringStream.Create; 405 | for I := 1 to Length(S) do 406 | begin 407 | C := S[I]; 408 | case C of 409 | '"': Stream.WriteString('\'+C); 410 | '\': Stream.WriteString('\'+C); 411 | '/': Stream.WriteString('\'+C); 412 | #8: Stream.WriteString('\b'); 413 | #9: Stream.WriteString('\t'); 414 | #10: Stream.WriteString('\n'); 415 | #12: Stream.WriteString('\f'); 416 | #13: Stream.WriteString('\r'); 417 | else 418 | if (C < WideChar(32)) or (C > WideChar(127)) then 419 | begin 420 | Stream.WriteString('\u'); 421 | UnicodeValue := Ord(C); 422 | Stream.WriteString(lowercase(IntToHex((UnicodeValue and 61440) shr 12,1))); 423 | Stream.WriteString(lowercase(IntToHex((UnicodeValue and 3840) shr 8,1))); 424 | Stream.WriteString(lowercase(IntToHex((UnicodeValue and 240) shr 4,1))); 425 | Stream.WriteString(lowercase(IntToHex((UnicodeValue and 15),1))); 426 | end 427 | else Stream.WriteString(C); 428 | end; 429 | end; 430 | Result := Stream.DataString; 431 | Stream.Free; 432 | end; 433 | 434 | function TJsonBase.GetOwner: TJsonBase; 435 | begin 436 | Result := FOwner; 437 | end; 438 | 439 | function TJsonBase.GetOwnerName: String; 440 | var 441 | TheOwner: TJsonBase; 442 | begin 443 | Result := ''; 444 | TheOwner := Owner; 445 | while True do 446 | begin 447 | if not Assigned(TheOwner) then Break 448 | else if TheOwner is TJsonPair then 449 | begin 450 | Result := (TheOwner as TJsonPair).Name; 451 | Break; 452 | end 453 | else TheOwner := TheOwner.Owner; 454 | end; 455 | end; 456 | 457 | procedure TJsonBase.InternalStringify(Stream:TStringStream;AName:string;AValue:TJsonValue); 458 | const 459 | StrBoolean : array[Boolean] of string = ('false', 'true'); 460 | procedure ObjectStringify(JsonObject:Jsons.TJsonObject); 461 | var 462 | i : Integer; 463 | Item : TJsonPair; 464 | begin 465 | Stream.WriteString('{'); 466 | for i:=0 to JsonObject.Count-1 do 467 | begin 468 | Item := JsonObject.Items[i]; 469 | if i>0 then Stream.WriteString(','); 470 | InternalStringify(Stream,Item.Name,Item.Value); 471 | end; 472 | Stream.WriteString('}'); 473 | end; 474 | procedure ArrayStringify(JsonArray:Jsons.TJsonArray); 475 | var 476 | i : Integer; 477 | Item : TJsonValue; 478 | begin 479 | Stream.WriteString('['); 480 | for i:=0 to JsonArray.Count-1 do 481 | begin 482 | Item := JsonArray.Items[i]; 483 | if i>0 then Stream.WriteString(','); 484 | InternalStringify(Stream,'',Item); 485 | end; 486 | Stream.WriteString(']'); 487 | end; 488 | begin 489 | if AName<>'' then Stream.WriteString('"'+AValue.Encode(AName)+'":'); 490 | case AValue.ValueType of 491 | jvNone , 492 | jvNull : Stream.WriteString('null'); 493 | jvString : Stream.WriteString('"'+AValue.Encode(AValue.AsString)+'"'); 494 | jvNumber : Stream.WriteString(FixedFloatToStr(AValue.AsNumber)); 495 | jvBoolean : Stream.WriteString(StrBoolean[AValue.AsBoolean]); 496 | jvObject : ObjectStringify(AValue.AsObject); 497 | jvArray : ArrayStringify(AValue.AsArray); 498 | end; 499 | end; 500 | 501 | function TJsonBase.Stringify:string; 502 | var 503 | Stream : TStringStream; 504 | begin 505 | Stream := TStringStream.Create; 506 | InternalStringify(Stream,'',TJsonValue(Self)); 507 | Result := Stream.DataString; 508 | Stream.Free; 509 | end; 510 | 511 | function TJsonBase.IsJsonArray(const S: String): Boolean; 512 | var 513 | Len: Integer; 514 | begin 515 | Len := Length(S); 516 | Result := (Len >= 2) and (S[1] = '[') and (S[Len] = ']'); 517 | end; 518 | 519 | function TJsonBase.IsJsonBoolean(const S: String): Boolean; 520 | begin 521 | Result := SameText(lowercase(S), 'true') or SameText(lowercase(S), 'false'); 522 | end; 523 | 524 | function TJsonBase.IsJsonNull(const S: String): Boolean; 525 | begin 526 | Result := SameText(S, 'null'); 527 | end; 528 | 529 | function TJsonBase.IsJsonNumber(const S: String): Boolean; 530 | var 531 | Number: Extended; 532 | begin 533 | Result := FixedTryStrToFloat(S, Number); 534 | end; 535 | 536 | function TJsonBase.IsJsonObject(const S: String): Boolean; 537 | var 538 | Len: Integer; 539 | begin 540 | Len := Length(S); 541 | Result := (Len >= 2) and (S[1] = '{') and (S[Len] = '}'); 542 | end; 543 | 544 | function TJsonBase.IsJsonString(const S: String): Boolean; 545 | var 546 | Len: Integer; 547 | begin 548 | Len := Length(S); 549 | Result := (Len >= 2) and (S[1] = '"') and (S[Len] = '"'); 550 | end; 551 | 552 | procedure TJsonBase.RaiseAssignError(Source: TJsonBase); 553 | var 554 | SourceClassName: String; 555 | begin 556 | if Source is TObject then SourceClassName := Source.ClassName 557 | else SourceClassName := 'nil'; 558 | RaiseError(Format('assign error: %s to %s', [SourceClassName, ClassName])); 559 | end; 560 | 561 | procedure TJsonBase.RaiseError(const Msg: String); 562 | var 563 | S: String; 564 | begin 565 | S := Format('<%s>%s', [ClassName, Msg]); 566 | raise Exception.Create(S); 567 | end; 568 | 569 | procedure TJsonBase.RaiseParseError(const JsonString: String); 570 | begin 571 | RaiseError(Format('"%s" parse error: %s', [GetOwnerName, JsonString])); 572 | end; 573 | 574 | procedure TJsonBase.Split(const S: String; const Delimiter: Char; 575 | Strings: TStrings); 576 | 577 | function IsPairBegin(C: Char): Boolean; 578 | begin 579 | Result := (C = '{') or (C = '[') or (C = '"'); 580 | end; 581 | 582 | function GetPairEnd(C: Char): Char; 583 | begin 584 | case C of 585 | '{': Result := '}'; 586 | '[': Result := ']'; 587 | '"': Result := '"'; 588 | else Result := #0; 589 | end; 590 | end; 591 | 592 | function MoveToPair(P: PChar): PChar; 593 | var 594 | PairBegin, PairEnd: Char; 595 | C: Char; 596 | begin 597 | PairBegin := P^; 598 | PairEnd := GetPairEnd(PairBegin); 599 | Result := P; 600 | while Result^ <> #0 do 601 | begin 602 | Inc(Result); 603 | C := Result^; 604 | if C = PairEnd then Break 605 | else if (PairBegin = '"') and (C = '\') then Inc(Result) 606 | else if (PairBegin <> '"') and IsPairBegin(C) then Result := MoveToPair(Result); 607 | end; 608 | end; 609 | 610 | var 611 | PtrBegin, PtrEnd: PChar; 612 | C: Char; 613 | StrItem: String; 614 | begin 615 | PtrBegin := PChar(S); 616 | PtrEnd := PtrBegin; 617 | while PtrEnd^ <> #0 do 618 | begin 619 | C := PtrEnd^; 620 | if C = Delimiter then 621 | begin 622 | StrItem := Trim(Copy(PtrBegin, 1, PtrEnd - PtrBegin)); 623 | Strings.Add(StrItem); 624 | PtrBegin := PtrEnd + 1; 625 | PtrEnd := PtrBegin; 626 | Continue; 627 | end 628 | else if IsPairBegin(C) then PtrEnd := MoveToPair(PtrEnd); 629 | Inc(PtrEnd); 630 | end; 631 | StrItem := Trim(Copy(PtrBegin, 1, PtrEnd - PtrBegin)); 632 | if StrItem <> '' then Strings.Add(StrItem); 633 | end; 634 | 635 | { TJsonValue } 636 | 637 | procedure TJsonValue.Assign(Source: TJsonBase); 638 | var 639 | Src: TJsonValue; 640 | begin 641 | Clear; 642 | if not(Source is TJsonValue) and not(Source is TJsonObject) and not(Source is TJsonArray) then 643 | RaiseAssignError(Source); 644 | if Source is TJsonObject then 645 | begin 646 | FValueType := jvObject; 647 | FObjectValue := TJsonObject.Create(Self); 648 | FObjectValue.Assign(Source); 649 | end 650 | else if Source is TJsonArray then 651 | begin 652 | FValueType := jvArray; 653 | FArrayValue := TJsonArray.Create(Self); 654 | FArrayValue.Assign(Source); 655 | end 656 | else if Source is TJsonValue then 657 | begin 658 | Src := Source as TJsonValue; 659 | FValueType := Src.FValueType; 660 | case FValueType of 661 | jvNone, jvNull: ; 662 | jvString: FStringValue := Src.FStringValue; 663 | jvNumber: FNumberValue := Src.FNumberValue; 664 | jvBoolean: FBooleanValue := Src.FBooleanValue; 665 | jvObject: 666 | begin 667 | FObjectValue := TJsonObject.Create(Self); 668 | FObjectValue.Assign(Src.FObjectValue); 669 | end; 670 | jvArray: 671 | begin 672 | FArrayValue := TJsonArray.Create(Self); 673 | FArrayValue.Assign(Src.FArrayValue); 674 | end; 675 | end; 676 | end; 677 | end; 678 | 679 | procedure TJsonValue.Clear; 680 | begin 681 | case FValueType of 682 | jvNone, jvNull: ; 683 | jvString: FStringValue := ''; 684 | jvNumber: FNumberValue := 0; 685 | jvBoolean: FBooleanValue := False; 686 | jvObject: 687 | begin 688 | FObjectValue.Free; 689 | FObjectValue := nil; 690 | end; 691 | jvArray: 692 | begin 693 | FArrayValue.Free; 694 | FArrayValue := nil; 695 | end; 696 | end; 697 | FValueType := jvNone; 698 | end; 699 | 700 | constructor TJsonValue.Create(AOwner: TJsonBase); 701 | begin 702 | inherited Create(AOwner); 703 | FStringValue := ''; 704 | FNumberValue := 0; 705 | FBooleanValue := False; 706 | FObjectValue := nil; 707 | FArrayValue := nil; 708 | FValueType := jvNone; 709 | end; 710 | 711 | destructor TJsonValue.Destroy; 712 | begin 713 | Clear; 714 | inherited Destroy; 715 | end; 716 | 717 | function TJsonValue.GetAsArray: TJsonArray; 718 | begin 719 | if IsEmpty then 720 | begin 721 | FValueType := jvArray; 722 | FArrayValue := TJsonArray.Create(Self); 723 | end; 724 | if FValueType <> jvArray then RaiseValueTypeError(jvArray); 725 | Result := FArrayValue; 726 | end; 727 | 728 | function TJsonValue.GetAsBoolean: Boolean; 729 | begin 730 | Result := False; 731 | case FValueType of 732 | jvNone, jvNull: Result := False; 733 | jvString: Result := SameText(lowercase(FStringValue), 'true'); 734 | jvNumber: Result := (FNumberValue <> 0); 735 | jvBoolean: Result := FBooleanValue; 736 | jvObject, jvArray: RaiseValueTypeError(jvBoolean); 737 | end; 738 | end; 739 | 740 | function TJsonValue.GetAsInteger: Integer; 741 | begin 742 | Result := 0; 743 | case FValueType of 744 | jvNone, jvNull: Result := 0; 745 | jvString: Result := Trunc(StrToInt(FStringValue)); 746 | jvNumber: Result := Trunc(FNumberValue); 747 | jvBoolean: Result := Ord(FBooleanValue); 748 | jvObject, jvArray: RaiseValueTypeError(jvNumber); 749 | end; 750 | end; 751 | 752 | function TJsonValue.GetAsNumber: Extended; 753 | begin 754 | Result := 0; 755 | case FValueType of 756 | jvNone, jvNull: Result := 0; 757 | jvString: Result := FixedStrToFloat(FStringValue); 758 | jvNumber: Result := FNumberValue; 759 | jvBoolean: Result := Ord(FBooleanValue); 760 | jvObject, jvArray: RaiseValueTypeError(jvNumber); 761 | end; 762 | end; 763 | 764 | function TJsonValue.GetAsObject: TJsonObject; 765 | begin 766 | if IsEmpty then 767 | begin 768 | FValueType := jvObject; 769 | FObjectValue := TJsonObject.Create(Self); 770 | end; 771 | if FValueType <> jvObject then RaiseValueTypeError(jvObject); 772 | Result := FObjectValue; 773 | end; 774 | 775 | function TJsonValue.GetAsString: String; 776 | const 777 | BooleanStr: array[Boolean] of String = ('false', 'true'); 778 | begin 779 | Result := ''; 780 | case FValueType of 781 | jvNone, jvNull: Result := ''; 782 | jvString: Result := FStringValue; 783 | jvNumber: Result := FixedFloatToStr(FNumberValue); 784 | jvBoolean: Result := BooleanStr[FBooleanValue]; 785 | jvObject, jvArray: RaiseValueTypeError(jvString); 786 | end; 787 | end; 788 | 789 | function TJsonValue.GetIsEmpty: Boolean; 790 | begin 791 | Result := (FValueType = jvNone); 792 | end; 793 | 794 | function TJsonValue.GetIsNull: Boolean; 795 | begin 796 | Result := (FValueType = jvNull); 797 | end; 798 | 799 | procedure TJsonValue.Parse(JsonString: String); 800 | begin 801 | Clear; 802 | JsonString := Trim(JsonString); 803 | FValueType := AnalyzeJsonValueType(JsonString); 804 | case FValueType of 805 | jvNone: RaiseParseError(JsonString); 806 | jvNull: ; 807 | jvString: FStringValue := Decode(Copy(JsonString, 2, Length(JsonString) - 2)); 808 | jvNumber: FNumberValue := FixedStrToFloat(JsonString); 809 | jvBoolean: FBooleanValue := SameText(JsonString, 'true'); 810 | jvObject: 811 | begin 812 | FObjectValue := TJsonObject.Create(Self); 813 | FObjectValue.Parse(JsonString); 814 | end; 815 | jvArray: 816 | begin 817 | FArrayValue := TJsonArray.Create(Self); 818 | FArrayValue.Parse(JsonString); 819 | end; 820 | end; 821 | end; 822 | 823 | procedure TJsonValue.RaiseValueTypeError(const AsValueType: TJsonValueType); 824 | const 825 | StrJsonValueType: array[TJsonValueType] of String = ('jvNone', 'jvNull', 'jvString', 'jvNumber', 'jvBoolean', 'jvObject', 'jvArray'); 826 | var 827 | S: String; 828 | begin 829 | S := Format('"%s" value type error: %s to %s', [GetOwnerName, StrJsonValueType[FValueType], StrJsonValueType[AsValueType]]); 830 | RaiseError(S); 831 | end; 832 | 833 | procedure TJsonValue.SetAsArray(const Value: TJsonArray); 834 | begin 835 | if FValueType <> jvArray then 836 | begin 837 | Clear; 838 | FValueType := jvArray; 839 | FArrayValue := TJsonArray.Create(Self); 840 | end; 841 | FArrayValue.Assign(Value); 842 | end; 843 | 844 | procedure TJsonValue.SetAsBoolean(const Value: Boolean); 845 | begin 846 | if FValueType <> jvBoolean then 847 | begin 848 | Clear; 849 | FValueType := jvBoolean; 850 | end; 851 | FBooleanValue := Value; 852 | end; 853 | 854 | procedure TJsonValue.SetAsInteger(const Value: Integer); 855 | begin 856 | SetAsNumber(Value); 857 | end; 858 | 859 | procedure TJsonValue.SetAsNumber(const Value: Extended); 860 | begin 861 | if FValueType <> jvNumber then 862 | begin 863 | Clear; 864 | FValueType := jvNumber; 865 | end; 866 | FNumberValue := Value; 867 | end; 868 | 869 | procedure TJsonValue.SetAsObject(const Value: TJsonObject); 870 | begin 871 | if FValueType <> jvObject then 872 | begin 873 | Clear; 874 | FValueType := jvObject; 875 | FObjectValue := TJsonObject.Create(Self); 876 | end; 877 | FObjectValue.Assign(Value); 878 | end; 879 | 880 | procedure TJsonValue.SetAsString(const Value: String); 881 | begin 882 | if FValueType <> jvString then 883 | begin 884 | Clear; 885 | FValueType := jvString; 886 | end; 887 | FStringValue := Value; 888 | end; 889 | 890 | procedure TJsonValue.SetIsEmpty(const Value: Boolean); 891 | const 892 | EmptyValueType: array[Boolean] of TJsonValueType = (jvNull, jvNone); 893 | begin 894 | if FValueType <> EmptyValueType[Value] then 895 | begin 896 | Clear; 897 | FValueType := EmptyValueType[Value]; 898 | end; 899 | end; 900 | 901 | procedure TJsonValue.SetIsNull(const Value: Boolean); 902 | const 903 | NullValueType: array[Boolean] of TJsonValueType = (jvNone, jvNull); 904 | begin 905 | if FValueType <> NullValueType[Value] then 906 | begin 907 | Clear; 908 | FValueType := NullValueType[Value]; 909 | end; 910 | end; 911 | 912 | { TJsonArray } 913 | 914 | function TJsonArray.Add: TJsonValue; 915 | begin 916 | Result := TJsonValue.Create(Self); 917 | FList.Add(Result); 918 | end; 919 | 920 | procedure TJsonArray.Assign(Source: TJsonBase); 921 | var 922 | Src: TJsonArray; 923 | I: Integer; 924 | begin 925 | Clear; 926 | if not(Source is TJsonArray) then RaiseAssignError(Source); 927 | Src := Source as TJsonArray; 928 | for I := 0 to Src.Count - 1 do Add.Assign(Src[I]); 929 | end; 930 | 931 | procedure TJsonArray.Clear; 932 | var 933 | I: Integer; 934 | Item: TJsonValue; 935 | begin 936 | for I := 0 to FList.Count - 1 do 937 | begin 938 | Item := TJsonValue(FList[I]); 939 | Item.Free; 940 | end; 941 | FList.Clear; 942 | end; 943 | 944 | constructor TJsonArray.Create(AOwner: TJsonBase); 945 | begin 946 | inherited Create(AOwner); 947 | FList := TList.Create; 948 | end; 949 | 950 | procedure TJsonArray.Delete(const Index: Integer); 951 | var 952 | Item: TJsonValue; 953 | begin 954 | Item := TJsonValue(FList[Index]); 955 | Item.Free; 956 | FList.Delete(Index); 957 | end; 958 | 959 | destructor TJsonArray.Destroy; 960 | begin 961 | Clear; 962 | FList.Free; 963 | inherited; 964 | end; 965 | 966 | function TJsonArray.GetCount: Integer; 967 | begin 968 | Result := FList.Count; 969 | end; 970 | 971 | function TJsonArray.GetItems(Index: Integer): TJsonValue; 972 | begin 973 | Result := TJsonValue(FList[Index]); 974 | end; 975 | 976 | function TJsonArray.Insert(const Index: Integer): TJsonValue; 977 | begin 978 | Result := TJsonValue.Create(Self); 979 | FList.Insert(Index, Result); 980 | end; 981 | 982 | procedure TJsonArray.Merge(Addition: TJsonArray); 983 | var 984 | I: Integer; 985 | begin 986 | for I := 0 to Addition.Count - 1 do Add.Assign(Addition[I]); 987 | end; 988 | 989 | procedure TJsonArray.Parse(JsonString: String); 990 | var 991 | I: Integer; 992 | S: String; 993 | List: TStringList; 994 | Item: TJsonValue; 995 | begin 996 | Clear; 997 | JsonString := Trim(JsonString); 998 | if not IsJsonArray(JsonString) then RaiseParseError(JsonString); 999 | S := Trim(Copy(JsonString, 2, Length(JsonString) - 2)); 1000 | List := TStringList.Create; 1001 | try 1002 | Split(S, ',', List); 1003 | for I := 0 to List.Count - 1 do 1004 | begin 1005 | Item := Add; 1006 | Item.Parse(List[I]); 1007 | end; 1008 | finally 1009 | List.Free; 1010 | end; 1011 | end; 1012 | 1013 | function TJsonArray.Put(const Value: Boolean): TJsonValue; 1014 | begin 1015 | Result := Add; 1016 | Result.AsBoolean := Value; 1017 | end; 1018 | 1019 | function TJsonArray.Put(const Value: Integer): TJsonValue; 1020 | begin 1021 | Result := Add; 1022 | Result.AsInteger := Value; 1023 | end; 1024 | 1025 | function TJsonArray.Put(const Value: TJsonEmpty): TJsonValue; 1026 | begin 1027 | Result := Add; 1028 | Result.IsEmpty := True; 1029 | end; 1030 | 1031 | function TJsonArray.Put(const Value: TJsonNull): TJsonValue; 1032 | begin 1033 | Result := Add; 1034 | Result.IsNull := True; 1035 | end; 1036 | 1037 | function TJsonArray.Put(const Value: Extended): TJsonValue; 1038 | begin 1039 | Result := Add; 1040 | Result.AsNumber := Value; 1041 | end; 1042 | 1043 | function TJsonArray.Put(const Value: TJsonObject): TJsonValue; 1044 | begin 1045 | Result := Add; 1046 | Result.Assign(Value); 1047 | end; 1048 | 1049 | function TJsonArray.Put(const Value: TJsonValue): TJsonValue; 1050 | begin 1051 | Result := Add; 1052 | Result.Assign(Value); 1053 | end; 1054 | 1055 | function TJsonArray.Put(const Value: String): TJsonValue; 1056 | begin 1057 | Result := Add; 1058 | Result.AsString := Value; 1059 | end; 1060 | 1061 | function TJsonArray.Put(const Value: TJsonArray): TJsonValue; 1062 | begin 1063 | Result := Add; 1064 | Result.Assign(Value); 1065 | end; 1066 | 1067 | { TJsonPair } 1068 | 1069 | procedure TJsonPair.Assign(Source: TJsonBase); 1070 | var 1071 | Src: TJsonPair; 1072 | begin 1073 | if not(Source is TJsonPair) then RaiseAssignError(Source); 1074 | Src := Source as TJsonPair; 1075 | FName := Src.FName; 1076 | FValue.Assign(Src.FValue); 1077 | end; 1078 | 1079 | constructor TJsonPair.Create(AOwner: TJsonBase; const AName: String); 1080 | begin 1081 | inherited Create(AOwner); 1082 | FName := AName; 1083 | FValue := TJsonValue.Create(Self); 1084 | end; 1085 | 1086 | destructor TJsonPair.Destroy; 1087 | begin 1088 | FValue.Free; 1089 | inherited Destroy; 1090 | end; 1091 | 1092 | procedure TJsonPair.Parse(JsonString: String); 1093 | var 1094 | List: TStringList; 1095 | StrName: String; 1096 | begin 1097 | List := TStringList.Create; 1098 | try 1099 | Split(JsonString, ':', List); 1100 | if List.Count <> 2 then RaiseParseError(JsonString); 1101 | StrName := List[0]; 1102 | if not IsJsonString(StrName) then RaiseParseError(StrName); 1103 | FName := Decode(Copy(StrName, 2, Length(StrName) - 2)); 1104 | FValue.Parse(List[1]); 1105 | finally 1106 | List.Free; 1107 | end; 1108 | end; 1109 | 1110 | procedure TJsonPair.SetName(const Value: String); 1111 | begin 1112 | FName := Value; 1113 | end; 1114 | 1115 | { TJsonObject } 1116 | 1117 | function TJsonObject.Add(const Name: String): TJsonPair; 1118 | begin 1119 | Result := TJsonPair.Create(Self, Name); 1120 | FList.Add(Result); 1121 | end; 1122 | 1123 | procedure TJsonObject.Assign(Source: TJsonBase); 1124 | var 1125 | Src: TJsonObject; 1126 | I: Integer; 1127 | begin 1128 | Clear; 1129 | if not(Source is TJsonObject) then RaiseAssignError(Source); 1130 | Src := Source as TJsonObject; 1131 | for I := 0 to Src.Count - 1 do Add.Assign(Src.Items[I]); 1132 | end; 1133 | 1134 | procedure TJsonObject.Clear; 1135 | var 1136 | I: Integer; 1137 | Item: TJsonPair; 1138 | begin 1139 | for I := 0 to FList.Count - 1 do 1140 | begin 1141 | Item := TJsonPair(FList[I]); 1142 | Item.Free; 1143 | end; 1144 | FList.Clear; 1145 | end; 1146 | 1147 | constructor TJsonObject.Create(AOwner: TJsonBase); 1148 | begin 1149 | inherited Create(AOwner); 1150 | FList := TList.Create; 1151 | FAutoAdd := True; 1152 | end; 1153 | 1154 | procedure TJsonObject.Delete(const Index: Integer); 1155 | var 1156 | Item: TJsonPair; 1157 | begin 1158 | Item := TJsonPair(FList[Index]); 1159 | Item.Free; 1160 | FList.Delete(Index); 1161 | end; 1162 | 1163 | procedure TJsonObject.Delete(const Name: String); 1164 | var 1165 | Index: Integer; 1166 | begin 1167 | Index := Find(Name); 1168 | if Index < 0 then RaiseError(Format('"%s" not found', [Name])); 1169 | Delete(Index); 1170 | end; 1171 | 1172 | destructor TJsonObject.Destroy; 1173 | begin 1174 | Clear; 1175 | FList.Free; 1176 | inherited Destroy; 1177 | end; 1178 | 1179 | function TJsonObject.Find(const Name: String): Integer; 1180 | var 1181 | I: Integer; 1182 | Pair: TJsonPair; 1183 | begin 1184 | Result := -1; 1185 | for I := 0 to FList.Count - 1 do 1186 | begin 1187 | Pair := TJsonPair(FList[I]); 1188 | if SameText(Name, Pair.Name) then 1189 | begin 1190 | Result := I; 1191 | Break; 1192 | end; 1193 | end; 1194 | end; 1195 | 1196 | function TJsonObject.GetCount: Integer; 1197 | begin 1198 | Result := FList.Count; 1199 | end; 1200 | 1201 | function TJsonObject.GetItems(Index: Integer): TJsonPair; 1202 | begin 1203 | Result := TJsonPair(FList[Index]); 1204 | end; 1205 | 1206 | function TJsonObject.GetValues(Name: String): TJsonValue; 1207 | var 1208 | Index: Integer; 1209 | Pair: TJsonPair; 1210 | begin 1211 | Index := Find(Name); 1212 | if Index < 0 then 1213 | begin 1214 | if not FAutoAdd then RaiseError(Format('%s not found', [Name])); 1215 | Pair := Add(Name); 1216 | end 1217 | else Pair := TJsonPair(FList[Index]); 1218 | Result := Pair.Value; 1219 | end; 1220 | 1221 | function TJsonObject.Insert(const Index: Integer; 1222 | const Name: String): TJsonPair; 1223 | begin 1224 | Result := TJsonPair.Create(Self, Name); 1225 | FList.Insert(Index, Result); 1226 | end; 1227 | 1228 | procedure TJsonObject.Merge(Addition: TJsonObject); 1229 | var 1230 | I: Integer; 1231 | begin 1232 | for I := 0 to Addition.Count - 1 do Add.Assign(Addition.Items[I]); 1233 | end; 1234 | 1235 | procedure TJsonObject.Parse(JsonString: String); 1236 | var 1237 | I: Integer; 1238 | S: String; 1239 | List: TStringList; 1240 | Item: TJsonPair; 1241 | begin 1242 | Clear; 1243 | JsonString := Trim(JsonString); 1244 | if not IsJsonObject(JsonString) then RaiseParseError(JsonString); 1245 | S := Trim(Copy(JsonString, 2, Length(JsonString) - 2)); 1246 | List := TStringList.Create; 1247 | try 1248 | Split(S, ',', List); 1249 | for I := 0 to List.Count - 1 do 1250 | begin 1251 | Item := Add; 1252 | Item.Parse(List[I]); 1253 | end; 1254 | finally 1255 | List.Free; 1256 | end; 1257 | end; 1258 | 1259 | function TJsonObject.Put(const Name: String; 1260 | const Value: Integer): TJsonValue; 1261 | begin 1262 | Result := Add(Name).Value; 1263 | Result.AsInteger := Value; 1264 | end; 1265 | 1266 | function TJsonObject.Put(const Name: String; 1267 | const Value: Extended): TJsonValue; 1268 | begin 1269 | Result := Add(Name).Value; 1270 | Result.AsNumber := Value; 1271 | end; 1272 | 1273 | function TJsonObject.Put(const Name: String; 1274 | const Value: Boolean): TJsonValue; 1275 | begin 1276 | Result := Add(Name).Value; 1277 | Result.AsBoolean := Value; 1278 | end; 1279 | 1280 | function TJsonObject.Put(const Name: String; 1281 | const Value: TJsonEmpty): TJsonValue; 1282 | begin 1283 | Result := Add(Name).Value; 1284 | Result.IsEmpty := True; 1285 | end; 1286 | 1287 | function TJsonObject.Put(const Name: String; 1288 | const Value: TJsonNull): TJsonValue; 1289 | begin 1290 | Result := Add(Name).Value; 1291 | Result.IsNull := True; 1292 | end; 1293 | 1294 | function TJsonObject.Put(const Name: String; 1295 | const Value: TJsonValue): TJsonValue; 1296 | begin 1297 | Result := Add(Name).Value; 1298 | Result.Assign(Value); 1299 | end; 1300 | 1301 | function TJsonObject.Put(const Value: TJsonPair): TJsonValue; 1302 | var 1303 | Pair: TJsonPair; 1304 | begin 1305 | Pair := Add; 1306 | Pair.Assign(Value); 1307 | Result := Pair.Value; 1308 | end; 1309 | 1310 | function TJsonObject.Put(const Name: String; 1311 | const Value: TJsonObject): TJsonValue; 1312 | begin 1313 | Result := Add(Name).Value; 1314 | Result.Assign(Value); 1315 | end; 1316 | 1317 | function TJsonObject.Put(const Name, Value: String): TJsonValue; 1318 | begin 1319 | Result := Add(Name).Value; 1320 | Result.AsString := Value; 1321 | end; 1322 | 1323 | function TJsonObject.Put(const Name: String; 1324 | const Value: TJsonArray): TJsonValue; 1325 | begin 1326 | Result := Add(Name).Value; 1327 | Result.Assign(Value); 1328 | end; 1329 | 1330 | { TJson } 1331 | 1332 | procedure TJson.Assign(Source: TJsonBase); 1333 | begin 1334 | Clear; 1335 | if Source is TJson then 1336 | begin 1337 | case (Source as TJson).FStructType of 1338 | jsNone: ; 1339 | jsArray: 1340 | begin 1341 | CreateArrayIfNone; 1342 | FJsonArray.Assign((Source as TJson).FJsonArray); 1343 | end; 1344 | jsObject: 1345 | begin 1346 | CreateObjectIfNone; 1347 | FJsonObject.Assign((Source as TJson).FJsonObject); 1348 | end; 1349 | end; 1350 | end 1351 | else if Source is TJsonArray then 1352 | begin 1353 | CreateArrayIfNone; 1354 | FJsonArray.Assign(Source); 1355 | end 1356 | else if Source is TJsonObject then 1357 | begin 1358 | CreateObjectIfNone; 1359 | FJsonObject.Assign(Source); 1360 | end 1361 | else if Source is TJsonValue then 1362 | begin 1363 | if (Source as TJsonValue).ValueType = jvArray then 1364 | begin 1365 | CreateArrayIfNone; 1366 | FJsonArray.Assign((Source as TJsonValue).AsArray); 1367 | end 1368 | else if (Source as TJsonValue).ValueType = jvObject then 1369 | begin 1370 | CreateObjectIfNone; 1371 | FJsonObject.Assign((Source as TJsonValue).AsObject); 1372 | end 1373 | else RaiseAssignError(Source); 1374 | end 1375 | else RaiseAssignError(Source); 1376 | end; 1377 | 1378 | procedure TJson.CheckJsonArray; 1379 | begin 1380 | CreateArrayIfNone; 1381 | RaiseIfNotArray; 1382 | end; 1383 | 1384 | procedure TJson.CheckJsonObject; 1385 | begin 1386 | CreateObjectIfNone; 1387 | RaiseIfNotObject; 1388 | end; 1389 | 1390 | procedure TJson.Clear; 1391 | begin 1392 | case FStructType of 1393 | jsNone: ; 1394 | jsArray: 1395 | begin 1396 | FJsonArray.Free; 1397 | FJsonArray := nil; 1398 | end; 1399 | jsObject: 1400 | begin 1401 | FJsonObject.Free; 1402 | FJsonObject := nil; 1403 | end; 1404 | end; 1405 | FStructType := jsNone; 1406 | end; 1407 | 1408 | constructor TJson.Create; 1409 | begin 1410 | inherited Create(nil); 1411 | FStructType := jsNone; 1412 | FJsonArray := nil; 1413 | FJsonObject := nil; 1414 | end; 1415 | 1416 | procedure TJson.CreateArrayIfNone; 1417 | begin 1418 | if FStructType = jsNone then 1419 | begin 1420 | FStructType := jsArray; 1421 | FJsonArray := TJsonArray.Create(Self); 1422 | end; 1423 | end; 1424 | 1425 | procedure TJson.CreateObjectIfNone; 1426 | begin 1427 | if FStructType = jsNone then 1428 | begin 1429 | FStructType := jsObject; 1430 | FJsonObject := TJsonObject.Create(Self); 1431 | end; 1432 | end; 1433 | 1434 | procedure TJson.Delete(const Index: Integer); 1435 | begin 1436 | RaiseIfNone; 1437 | case FStructType of 1438 | jsArray: FJsonArray.Delete(Index); 1439 | jsObject: FJsonObject.Delete(Index); 1440 | end; 1441 | end; 1442 | 1443 | procedure TJson.Delete(const Name: String); 1444 | begin 1445 | RaiseIfNotObject; 1446 | FJsonObject.Delete(Name); 1447 | end; 1448 | 1449 | destructor TJson.Destroy; 1450 | begin 1451 | Clear; 1452 | inherited Destroy; 1453 | end; 1454 | 1455 | function TJson.Get(const Index: Integer): TJsonValue; 1456 | begin 1457 | Result := nil; 1458 | RaiseIfNone; 1459 | case FStructType of 1460 | jsArray: Result := FJsonArray.Items[Index]; 1461 | jsObject: Result := FJsonObject.Items[Index].Value; 1462 | end; 1463 | end; 1464 | 1465 | function TJson.Get(const Name: String): TJsonValue; 1466 | begin 1467 | CheckJsonObject; 1468 | Result := FJsonObject.Values[Name]; 1469 | end; 1470 | 1471 | function TJson.GetCount: Integer; 1472 | begin 1473 | case FStructType of 1474 | jsArray: Result := FJsonArray.Count; 1475 | jsObject: Result := FJsonObject.Count; 1476 | else Result := 0; 1477 | end; 1478 | end; 1479 | 1480 | function TJson.GetJsonArray: TJsonArray; 1481 | begin 1482 | CheckJsonArray; 1483 | Result := FJsonArray; 1484 | end; 1485 | 1486 | function TJson.GetJsonObject: TJsonObject; 1487 | begin 1488 | CheckJsonObject; 1489 | Result := FJsonObject; 1490 | end; 1491 | 1492 | function TJson.GetValues(Name: String): TJsonValue; 1493 | begin 1494 | Result := Get(Name); 1495 | end; 1496 | 1497 | procedure TJson.Parse(JsonString: String); 1498 | begin 1499 | Clear; 1500 | JsonString := Trim(JsonString); 1501 | if IsJsonArray(JsonString) then 1502 | begin 1503 | CreateArrayIfNone; 1504 | FJsonArray.Parse(JsonString); 1505 | end 1506 | else if IsJsonObject(JsonString) then 1507 | begin 1508 | CreateObjectIfNone; 1509 | FJsonObject.Parse(JsonString); 1510 | end 1511 | else RaiseParseError(JsonString); 1512 | end; 1513 | 1514 | function TJson.Put(const Value: Integer): TJsonValue; 1515 | begin 1516 | CheckJsonArray; 1517 | Result := FJsonArray.Put(Value); 1518 | end; 1519 | 1520 | function TJson.Put(const Value: Extended): TJsonValue; 1521 | begin 1522 | CheckJsonArray; 1523 | Result := FJsonArray.Put(Value); 1524 | end; 1525 | 1526 | function TJson.Put(const Value: Boolean): TJsonValue; 1527 | begin 1528 | CheckJsonArray; 1529 | Result := FJsonArray.Put(Value); 1530 | end; 1531 | 1532 | function TJson.Put(const Value: TJsonEmpty): TJsonValue; 1533 | begin 1534 | CheckJsonArray; 1535 | Result := FJsonArray.Put(Value); 1536 | end; 1537 | 1538 | function TJson.Put(const Value: TJsonNull): TJsonValue; 1539 | begin 1540 | CheckJsonArray; 1541 | Result := FJsonArray.Put(Value); 1542 | end; 1543 | 1544 | function TJson.Put(const Value: String): TJsonValue; 1545 | begin 1546 | CheckJsonArray; 1547 | Result := FJsonArray.Put(Value); 1548 | end; 1549 | 1550 | function TJson.Put(const Value: TJsonValue): TJsonValue; 1551 | begin 1552 | CheckJsonArray; 1553 | Result := FJsonArray.Put(Value); 1554 | end; 1555 | 1556 | function TJson.Put(const Value: TJsonObject): TJsonValue; 1557 | begin 1558 | CheckJsonArray; 1559 | Result := FJsonArray.Put(Value); 1560 | end; 1561 | 1562 | function TJson.Put(const Value: TJsonArray): TJsonValue; 1563 | begin 1564 | CheckJsonArray; 1565 | Result := FJsonArray.Put(Value); 1566 | end; 1567 | 1568 | function TJson.Put(const Name: String; const Value: Integer): TJsonValue; 1569 | begin 1570 | CheckJsonObject; 1571 | Result := FJsonObject.Put(Name, Value); 1572 | end; 1573 | 1574 | function TJson.Put(const Name: String; const Value: Extended): TJsonValue; 1575 | begin 1576 | CheckJsonObject; 1577 | Result := FJsonObject.Put(Name, Value); 1578 | end; 1579 | 1580 | function TJson.Put(const Name: String; const Value: Boolean): TJsonValue; 1581 | begin 1582 | CheckJsonObject; 1583 | Result := FJsonObject.Put(Name, Value); 1584 | end; 1585 | 1586 | function TJson.Put(const Name: String; 1587 | const Value: TJsonEmpty): TJsonValue; 1588 | begin 1589 | CheckJsonObject; 1590 | Result := FJsonObject.Put(Name, Value); 1591 | end; 1592 | 1593 | function TJson.Put(const Name: String; const Value: TJsonNull): TJsonValue; 1594 | begin 1595 | CheckJsonObject; 1596 | Result := FJsonObject.Put(Name, Value); 1597 | end; 1598 | 1599 | function TJson.Put(const Name: String; 1600 | const Value: TJsonValue): TJsonValue; 1601 | begin 1602 | CheckJsonObject; 1603 | Result := FJsonObject.Put(Name, Value); 1604 | end; 1605 | 1606 | function TJson.Put(const Value: TJsonPair): TJsonValue; 1607 | begin 1608 | CheckJsonObject; 1609 | Result := FJsonObject.Put(Value); 1610 | end; 1611 | 1612 | function TJson.Put(const Name: String; 1613 | const Value: TJsonObject): TJsonValue; 1614 | begin 1615 | CheckJsonObject; 1616 | Result := FJsonObject.Put(Name, Value); 1617 | end; 1618 | 1619 | function TJson.Put(const Name, Value: String): TJsonValue; 1620 | begin 1621 | CheckJsonObject; 1622 | Result := FJsonObject.Put(Name, Value); 1623 | end; 1624 | 1625 | function TJson.Put(const Name: String; 1626 | const Value: TJsonArray): TJsonValue; 1627 | begin 1628 | CheckJsonObject; 1629 | Result := FJsonObject.Put(Name, Value); 1630 | end; 1631 | 1632 | function TJson.Put(const Value: TJson): TJsonValue; 1633 | begin 1634 | CheckJsonArray; 1635 | case Value.FStructType of 1636 | jsArray: Result := Put(Value.FJsonArray); 1637 | jsObject: Result := Put(Value.FJsonObject); 1638 | else Result := nil; 1639 | end; 1640 | end; 1641 | 1642 | function TJson.Put(const Name: String; const Value: TJson): TJsonValue; 1643 | begin 1644 | CheckJsonObject; 1645 | case Value.FStructType of 1646 | jsArray: Result := Put(Name, Value.FJsonArray); 1647 | jsObject: Result := Put(Name, Value.FJsonObject); 1648 | else Result := nil; 1649 | end; 1650 | end; 1651 | 1652 | procedure TJson.RaiseIfNone; 1653 | begin 1654 | if FStructType = jsNone then RaiseError('json struct type is jsNone'); 1655 | end; 1656 | 1657 | procedure TJson.RaiseIfNotArray; 1658 | begin 1659 | if FStructType <> jsArray then RaiseError('json struct type is not jsArray'); 1660 | end; 1661 | 1662 | procedure TJson.RaiseIfNotObject; 1663 | begin 1664 | if FStructType <> jsObject then RaiseError('json struct type is not jsObject'); 1665 | end; 1666 | 1667 | function TJson.Stringify: String; 1668 | begin 1669 | case FStructType of 1670 | jsArray: Result := FJsonArray.Stringify; 1671 | jsObject: Result := FJsonObject.Stringify; 1672 | else Result := ''; 1673 | end; 1674 | end; 1675 | 1676 | end. 1677 | -------------------------------------------------------------------------------- /src/JsonsUtilsEx.pas: -------------------------------------------------------------------------------- 1 | unit JsonsUtilsEx; 2 | 3 | interface 4 | 5 | {$IFDEF FPC} 6 | {$MODE Delphi} 7 | {$ENDIF} 8 | 9 | {$DEFINE LINEBREAKJSONFORMAT} //Desactivate for a non "minimal better human-readable format". 10 | 11 | uses SysUtils; 12 | 13 | function FixedFloatToStr(const Value: Extended): string; 14 | function FixedTryStrToFloat(const S: string; out Value: Extended): Boolean; 15 | function FixedStrToFloat(const S: string): Extended; 16 | 17 | Function __ObjectToJson(aObject : TObject) : String; 18 | Procedure __jsonToObject(Const aJSONString : String; Var aObject : TObject); 19 | 20 | Type 21 | TObjectDynArray = array of TObject; 22 | TStringDynArray = array of string; 23 | TIntegerDynArray = array of Integer; 24 | 25 | Const 26 | GLB_JSON_STD_DECIMALSEPARATOR = '.'; 27 | Var 28 | JsonsUtils_GLB_DECIMALSEPARATOR : Char; 29 | 30 | implementation 31 | 32 | Uses TypInfo, 33 | DateUtils, 34 | Jsons; 35 | 36 | Type 37 | PPPTypeInfo = ^PPTypeInfo; 38 | 39 | 40 | //JSON date base conversion utility : taken "as is" from but quite incomplete. Will be replaced. TODO. 41 | 42 | function ZeroFillStr(Number, Size : integer) : String; 43 | begin 44 | Result := IntToStr(Number); 45 | while length(Result) < Size do 46 | Result := '0'+Result; 47 | end; 48 | 49 | function JSONDateToString(aDate : TDateTime) : String; 50 | begin 51 | Result := '"'+ZeroFillStr(YearOf(aDate),4)+'-'+ 52 | ZeroFillStr(MonthOf(aDate),2)+'-'+ 53 | ZeroFillStr(DayOf(aDate),2)+'T'+ 54 | ZeroFillStr(HourOf(aDate),2)+':'+ 55 | ZeroFillStr(MinuteOf(aDate),2)+':'+ 56 | ZeroFillStr(SecondOf(aDate),2)+'.'+ 57 | ZeroFillStr(SecondOf(aDate),3)+'Z"'; 58 | end; 59 | 60 | function JSONStringToDate(aDate : String) : TDateTime; 61 | begin 62 | Result := 63 | EncodeDateTime( 64 | StrToInt(Copy(aDate,1,4)), 65 | StrToInt(Copy(aDate,6,2)), 66 | StrToInt(Copy(aDate,9,2)), 67 | StrToInt(Copy(aDate,12,2)), 68 | StrToInt(Copy(aDate,15,2)), 69 | StrToInt(Copy(aDate,18,2)), 70 | StrToInt(Copy(aDate,21,3))); 71 | end; 72 | 73 | function JSONStringIsCompatibleDate(aJSONDate : String) : boolean; 74 | var ldummy: integer; 75 | lval, lnum : Boolean; 76 | begin 77 | lval := TryStrToInt(Copy(aJSONDate,1,4),ldummy) and TryStrToInt(Copy(aJSONDate,6,2),ldummy) and 78 | TryStrToInt(Copy(aJSONDate,9,2),ldummy) and TryStrToInt(Copy(aJSONDate,12,2),ldummy) and 79 | TryStrToInt(Copy(aJSONDate,15,2),ldummy) and TryStrToInt(Copy(aJSONDate,18,2),ldummy) and 80 | TryStrToInt(Copy(aJSONDate,21,3),ldummy); 81 | 82 | lnum := (Length(aJSONDate)=24) and 83 | (aJSONDate[5] = '-') and 84 | (aJSONDate[8] = '-') and 85 | (aJSONDate[11] = 'T') and 86 | (aJSONDate[14] = ':') and 87 | (aJSONDate[17] = ':') and 88 | (aJSONDate[20] = '.') and 89 | (aJSONDate[24] = 'Z'); 90 | 91 | Result := lval and lNum; 92 | end; 93 | 94 | 95 | {** 96 | * Fixed FloatToStr to convert DecimalSeparator to dot (.) decimal separator, FloatToStr returns 97 | * DecimalSeparator as decimal separator, but JSON uses dot (.) as decimal separator. 98 | *} 99 | function GetDecimalSeparator : Char; 100 | {$IFDEF FPC} 101 | var 102 | LFormatSettings: TFormatSettings; 103 | {$ENDIF} 104 | begin 105 | {$IFNDEF FPC} 106 | Result := FormatSettings.DecimalSeparator; 107 | {$ELSE} 108 | LFormatSettings := DefaultFormatSettings; 109 | Result := LFormatSettings.DecimalSeparator; 110 | {$ENDIF} 111 | end; 112 | 113 | 114 | function FixedFloatToStr(const Value: Extended): string; 115 | var 116 | lS: string; 117 | begin 118 | lS := FloatToStr(Value); 119 | if JsonsUtils_GLB_DECIMALSEPARATOR = GLB_JSON_STD_DECIMALSEPARATOR then 120 | begin 121 | Result := LS; 122 | end 123 | else 124 | begin 125 | Result := StringReplace( lS, 126 | JsonsUtils_GLB_DECIMALSEPARATOR, 127 | GLB_JSON_STD_DECIMALSEPARATOR, 128 | [rfReplaceAll]); 129 | end; 130 | end; 131 | 132 | {** 133 | * Fixed TryStrToFloat to convert dot (.) decimal separator to DecimalSeparator, TryStrToFloat expects 134 | * decimal separator to be DecimalSeparator, but JSON uses dot (.) as decimal separator. 135 | *} 136 | function FixedTryStrToFloat(const S: string; out Value: Extended): Boolean; 137 | var 138 | FixedS: string; 139 | begin 140 | if JsonsUtils_GLB_DECIMALSEPARATOR = GLB_JSON_STD_DECIMALSEPARATOR then 141 | begin 142 | Result := TryStrToFloat(S, Value); 143 | end 144 | else 145 | begin 146 | FixedS := StringReplace( S, 147 | GLB_JSON_STD_DECIMALSEPARATOR, 148 | JsonsUtils_GLB_DECIMALSEPARATOR, 149 | [rfReplaceAll]); 150 | Result := TryStrToFloat(FixedS, Value); 151 | end; 152 | end; 153 | 154 | {** 155 | * Fixed StrToFloat to convert dot (.) decimal separator to DecimalSeparator, StrToFloat expects 156 | * decimal separator to be DecimalSeparator, but JSON uses dot (.) as decimal separator. 157 | *} 158 | function FixedStrToFloat(const S: string): Extended; 159 | var 160 | FixedS: string; 161 | begin 162 | if JsonsUtils_GLB_DECIMALSEPARATOR = GLB_JSON_STD_DECIMALSEPARATOR then 163 | begin 164 | Result := StrToFloat(S); 165 | end 166 | else 167 | begin 168 | FixedS := StringReplace( S, 169 | GLB_JSON_STD_DECIMALSEPARATOR, 170 | JsonsUtils_GLB_DECIMALSEPARATOR, 171 | [rfReplaceAll]); 172 | Result := StrToFloat(FixedS); 173 | end; 174 | end; 175 | 176 | function InArray(Str : string; ary : array of String) : boolean; 177 | var 178 | i: Integer; 179 | begin 180 | Result := Length(ary)=0; 181 | for i := 0 to Length(ary) - 1 do 182 | begin 183 | if CompareText(ary[i],Str) = 0 then 184 | begin 185 | Result := True; 186 | break; 187 | end; 188 | end; 189 | end; 190 | 191 | 192 | 193 | function InternalObjectToJSON(Obj : Tobject; PropList : array of String; WriteClass : boolean = false) : String; overload; 194 | const lcst_exceptheader = 'ObjectToJson : '; 195 | var 196 | pl : PPropList; 197 | iCnt : integer; 198 | i: Integer; 199 | sVal : string; 200 | o : TObject; 201 | //dyn array. 202 | lTypeData: PTypeData; 203 | {$IFDEF FPC} 204 | P : Pointer; 205 | lTypeInfoFPC : PTypeInfo; 206 | {$ENDIF} 207 | lTypeInfo: PPTypeInfo; 208 | lpTypeInfo: PPPTypeInfo; 209 | j : integeR; 210 | arrobj : TObjectDynArray; 211 | arrstr : TStringDynArray; 212 | arrint : TIntegerDynArray; 213 | jc : Integer; 214 | jcs : String; 215 | 216 | js : TJson; 217 | 218 | Procedure RT; 219 | begin 220 | raise Exception.Create(lcst_exceptheader + 'Type must be implemented'); 221 | end; 222 | 223 | 224 | begin 225 | if not Assigned(obj) then 226 | raise Exception.Create(lcst_exceptheader + 'Input object is null'); 227 | 228 | iCnt := GetPropList(Obj, pl); 229 | js := TJSon.Create; 230 | try 231 | Result := '{' {$IFDEF LINEBREAKJSONFORMAT}+ sLineBreak {$ENDIF}; 232 | if WriteClass then 233 | begin 234 | Result := Result+'"class" : "'+js.Encode(obj.ClassName)+'"'; 235 | end; 236 | for i := 0 to iCnt-1 do 237 | begin 238 | if not InArray(string(pl[i]^.Name), PropList) then 239 | Continue; 240 | sVal := ''; 241 | case pl[i]^.PropType^.Kind of 242 | tkInteger: sVal := IntToStr(GetOrdProp(obj,pl[i])); 243 | tkFloat : 244 | begin 245 | if pl[i]^.PropType^.Name = 'TDateTime' then 246 | sVal := JSONDateToString(GetFloatProp(obj,pl[i])) 247 | else if pl[i]^.PropType^.Name = 'TDate' then 248 | sVal := JSONDateToString(GetFloatProp(obj,pl[i])) 249 | else if pl[i]^.PropType^.Name = 'TTime' then 250 | sVal := JSONDateToString(GetFloatProp(obj,pl[i])) 251 | else 252 | sVal := FixedFloatToStr(GetFloatProp(obj,pl[i])); 253 | end; 254 | tkInt64 : sVal := IntToStr(GetInt64Prop(obj,pl[i])); 255 | 256 | tkChar : sVal := '"'+js.Encode(Char(GetOrdProp(obj,pl[i])))+'"'; 257 | {$IFDEF FPC} 258 | tkAString, 259 | {$ENDIF} 260 | tkLString, 261 | tkString, 262 | tkUString: sVal := '"'+js.Encode(GetStrProp(obj,pl[i]))+'"'; 263 | tkWChar : sVal := '"'+js.Encode(WideChar(GetOrdProp(obj,pl[i])))+'"'; 264 | tkWString: sVal := '"'+js.Encode(GetWideStrProp(obj,pl[i]))+'"'; 265 | tkEnumeration: 266 | begin 267 | sVal := GetEnumProp(obj,string(pl[i].Name)); 268 | sVal := '"'+js.Encode(IntToStr(GetEnumValue(pl[i]^.PropType^,sVal)))+'"'; //GetEnumValue(pl[i]^.PropType^,GetEnumProp(obj,pl[i].Name)) 269 | end; 270 | tkClass: 271 | begin 272 | o := GetObjectProp(Obj,pl[i]); 273 | if o is TObject then 274 | sVal := InternalObjectToJSON(TObject(o),PropList) 275 | else 276 | Continue; 277 | end; 278 | tkDynArray : 279 | begin 280 | sVal := '[ '; 281 | jcs :=','; 282 | 283 | lTypeData := GetTypeData(pl[i]^.PropType{$IFNDEF FPC}^{$ENDIF}); 284 | {$IFNDEF FPC} 285 | lpTypeInfo := PPPTypeInfo(lTypeData^.DynUnitNameFld.Tail); 286 | lTypeInfo := lpTypeInfo^; 287 | case lTypeInfo^.Kind of 288 | {$ELSE} 289 | lTypeInfoFPC := lTypeData^.ElType2; 290 | case lTypeInfoFPC^.Kind of 291 | tkAString, 292 | {$ENDIF} 293 | tkUString, tkString : //Warning, take care of {$IFDEF} just upside :) 294 | begin 295 | arrstr := TStringDynArray(GetDynArrayProp(Obj, pl[i])); 296 | jc := Length(arrstr)-1; 297 | for j := 0 to Length(arrstr)-1 do 298 | begin 299 | if j=jc then 300 | jcs := EmptyStr; 301 | sVal := sVal + js.Encode(arrstr[j]) + jcs; 302 | end; 303 | end; 304 | tkInteger : 305 | begin 306 | arrint := TIntegerDynArray(GetDynArrayProp(Obj, pl[i])); 307 | jc := Length(arrint)-1; 308 | for j := 0 to Length(arrint)-1 do 309 | begin 310 | if j=jc then 311 | jcs := EmptyStr; 312 | sVal := sVal + js.Encode(IntToStr(arrint[j])) + jcs; 313 | end; 314 | end; 315 | tkClass : 316 | begin 317 | arrobj := TObjectDynArray(GetDynArrayProp(Obj, pl[i])); 318 | jc := Length(arrobj)-1; 319 | for j := 0 to Length(arrobj)-1 do 320 | begin 321 | if j=jc then 322 | jcs := EmptyStr; 323 | sVal := sVal + InternalObjectToJSON(TObject(arrobj[j]),[]) + jcs; 324 | end; 325 | end; 326 | end; 327 | sVal :=sval + ' ]'; 328 | end; 329 | tkArray, 330 | tkUnknown, 331 | tkSet, 332 | tkMethod, 333 | tkVariant, 334 | tkRecord, //Record will not be supported because of discrepeancy between delphi and FPC for record rtti processing. 335 | tkInterface : RT; 336 | end; 337 | 338 | Result := Result + '"' + js.Encode(string(pl[i]^.Name))+'" : '+sVal; 339 | if Trim(Result) <> '{' then 340 | begin 341 | if i< icnt-1 then 342 | begin 343 | Result := Result+' , ' {$IFDEF LINEBREAKJSONFORMAT}+ sLineBreak {$ENDIF}; 344 | end 345 | else 346 | begin 347 | if Trim(Result) <> '{' then 348 | Result := Result {$IFDEF LINEBREAKJSONFORMAT}+ sLineBreak {$ENDIF}; 349 | end; 350 | end; 351 | end; 352 | finally 353 | FreeMem(pl); 354 | FreeAndNil(js); 355 | end; 356 | Result := Result+'}'; 357 | end; 358 | 359 | Procedure InternalJsonToObject(Const aJsonString : String; Var aObject : TObject); 360 | const lcst_exceptheader = 'JsonToObject : '; 361 | var //Json stuffs 362 | lJSON : TJson; 363 | lJsValue : TJsonValue; 364 | lJsArray : TJsonArray; 365 | 366 | //rtti 367 | lpl : PPropList; 368 | lTypeData: PTypeData; 369 | {$IFDEF FPC} 370 | lTypeInfoFPC : PTypeInfo; 371 | {$ENDIF} 372 | lTypeInfo: PPTypeInfo; 373 | lpTypeInfo: PPPTypeInfo; 374 | 375 | //General 376 | lo : TObject; 377 | loClass : TClass; 378 | lDynObjArray : TObjectDynArray; 379 | lIntegerArray : TIntegerDynArray; 380 | lstringArray : TStringDynArray; 381 | lpc : Cardinal; 382 | i,j : integer; 383 | lsTemp : String; 384 | 385 | Procedure RT; 386 | begin 387 | raise Exception.Create(lcst_exceptheader + 'Type must be implemented'); 388 | end; 389 | 390 | begin 391 | Assert((assigned(aObject))); 392 | lJSON := TJson.Create; 393 | try 394 | lJSON.Parse(aJsonString); 395 | if Not(lJSON.StructType = TJsonStructType.jsObject) then 396 | begin 397 | raise Exception.Create(lcst_exceptheader + 'JSON Parser fails : Json file is not an object representation.'); 398 | end; 399 | 400 | //JSON will drive by object structure. 401 | lpc := GetPropList(aObject, lpl); 402 | for i := 0 to lpc-1 do 403 | begin 404 | lJsValue := lJSON[string(lpl[i].Name)]; 405 | 406 | if lJsValue.IsNull then 407 | begin 408 | if lJsValue.IsEmpty then 409 | begin 410 | //JSON Porpety null, but exists. 411 | Continue; 412 | end 413 | else 414 | begin 415 | //Property is not in JSON, 416 | Continue; 417 | end; 418 | end; 419 | 420 | case lpl[i]^.PropType^.Kind of 421 | tkFloat : 422 | begin 423 | if lJsValue.ValueType = jvString then //According to JSON, it is parhaps a date ? Rtti reconize date as float. 424 | begin 425 | lsTemp := lJSON[string(lpl[i].Name)].AsString; 426 | if JSONStringIsCompatibleDate(lsTemp) then 427 | begin 428 | SetFloatProp(aObject,string(lpl[i].Name),JSONStringToDate(lsTemp)); 429 | end 430 | Else 431 | begin 432 | raise Exception.Create(lcst_exceptheader + 'Incompatible type (Perhaps unknow date format) Property "'+string(lpl[i].Name)+'"'); 433 | end; 434 | end 435 | else 436 | begin 437 | SetFloatProp(aObject,string(lpl[i].Name),lJSON[string(lpl[i].Name)].AsNumber); 438 | end; 439 | end; 440 | tkInt64 : SetInt64Prop(aObject,string(lpl[i].Name),lJSON[string(lpl[i].Name)].AsInteger); 441 | tkInteger: SetOrdProp(aObject,string(lpl[i].Name),lJSON[string(lpl[i].Name)].AsInteger); 442 | tkLString, 443 | tkString, 444 | tkUString, 445 | tkChar, 446 | tkWChar, 447 | {$IFDEF FPC} 448 | tkAString, 449 | {$ENDIF} 450 | tkWString: 451 | begin 452 | SetStrProp(aObject,string(lpl[i].Name),lJSON[string(lpl[i].Name)].AsString); 453 | end; 454 | tkEnumeration: SetOrdProp(aObject,string(lpl[i].Name),Integer(lJSON[string(lpl[i].Name)].AsInteger)); 455 | tkClass: 456 | begin 457 | if (lJsValue.ValueType = TJsonValueType.jvObject) or (lJsValue.ValueType = TJsonValueType.jvNone) then 458 | begin 459 | //In jvNone case, we do nothing (JSON has not this property, but it is object which driven our build. 460 | if (lJsValue.ValueType = TJsonValueType.jvObject) then 461 | begin 462 | lTypeData := GetTypeData(lpl[i]^.PropType{$IFNDEF FPC}^{$ENDIF}); 463 | loClass := lTypeData^.ClassType; 464 | lo := loClass.Create; 465 | try 466 | InternalJsonToObject(lJsValue.Stringify, lo); 467 | Except 468 | On E: Exception do 469 | raise Exception.Create(lcst_exceptheader + '[InternalJsonToObject reentrance single object] (Property '+string(lpl[i].Name)+') ' + E.Message); 470 | end; 471 | SetObjectProp(aObject,string(lpl[i]^.Name),lo); 472 | end; 473 | end 474 | else 475 | begin 476 | raise Exception.Create(lcst_exceptheader + 'Original JSON type not match with class type : Property "'+string(lpl[i].Name)+'"'); 477 | end; 478 | end; 479 | tkDynArray : 480 | begin 481 | if lJsValue.ValueType = TJsonValueType.jvArray then 482 | begin 483 | ljsArray := lJsValue.AsArray; 484 | for j := 0 to lJsArray.Count-1 do 485 | begin 486 | case lJsArray[j].ValueType of 487 | jvString : 488 | begin 489 | SetLength(lstringArray,Length(lstringArray)+1); 490 | lstringArray[Length(lstringArray)-1] := lJsArray[j].AsString; 491 | end; 492 | jvObject : 493 | begin 494 | lTypeData := GetTypeData(lpl[i]^.PropType{$IFNDEF FPC}^{$ENDIF}); 495 | {$IFNDEF FPC} 496 | //Delphi compiler : RTTI permit to get automaticaly dependance class. 497 | lpTypeInfo := PPPTypeInfo(lTypeData^.DynUnitNameFld.Tail); 498 | lTypeInfo := lpTypeInfo^; 499 | if (lTypeInfo^.Kind = tkClass) then 500 | begin 501 | loClass := lTypeInfo^.TypeData^.ClassType; 502 | //loClass := TGSJson.Configuration.GetPropertyConfiguration(lpl[i]^.Name).ItemArrayType; //as FPC ? switch ? 503 | end 504 | else 505 | begin 506 | raise Exception.Create(lcst_exceptheader + ' Delphi Class resolving : Not object Error : Property "'+string(lpl[i].Name)+'"'); 507 | end; 508 | {$ELSE} 509 | //FPC side : first view not possible :( Use kind of marshaller config instead. 510 | lTypeInfoFPC := lTypeData^.ElType2; 511 | if (lTypeInfoFPC^.Kind = tkClass) then 512 | begin 513 | loClass := TGSJson.Configuration.GetPropertyConfiguration(lpl[i]^.Name).ItemArrayType; 514 | end 515 | else 516 | begin 517 | raise Exception.Create(lcst_exceptheader + ' FPC Class resolving : Not object Error : Property "'+lpl[i].Name+'"'); 518 | end; 519 | {$ENDIF} 520 | lo := loClass.Create; 521 | try 522 | InternalJsonToObject(lJsArray[j].Stringify, lo); 523 | SetLength(lDynObjArray,Length(lDynObjArray)+1); 524 | lDynObjArray[Length(lDynObjArray)-1] := lo; 525 | Except 526 | On E: EXception do 527 | raise Exception.Create(lcst_exceptheader +'[InternalJsonToObject reentrance] : Property "'+string(lpl[i].Name)+'" - ' + E.Message); 528 | end; 529 | end; 530 | jvNumber: 531 | begin 532 | SetLength(lIntegerArray,Length(lIntegerArray)+1); 533 | lIntegerArray[Length(lIntegerArray)-1] := lJsArray[j].AsInteger; 534 | end 535 | else 536 | begin 537 | raise Exception.Create(lcst_exceptheader + 'type not implemented or supported : Property "'+string(lpl[i].Name)+'"'); 538 | end; 539 | end; 540 | end; 541 | if lJsArray.Count>0 then 542 | begin 543 | case lJsArray[0].ValueType of 544 | jvString : SetDynArrayProp(aObject,string(lpl[i].Name),lstringArray); 545 | jvObject : SetDynArrayProp(aObject,string(lpl[i].Name),lDynObjArray); 546 | jvNumber : SetDynArrayProp(aObject,string(lpl[i].Name),lIntegerArray); 547 | end; 548 | end; 549 | end 550 | else 551 | begin 552 | //empty element. 553 | if Not(lJsValue.IsNull) then 554 | begin 555 | //element does not exists in JSON. error ? 556 | //Todo : Property like "StrictElementCorrespondaceCheck" something like that ? 557 | //raise Exception.Create('type Error Message'); 558 | end; 559 | end; 560 | end; 561 | tkArray, 562 | tkUnknown, 563 | tkSet, 564 | tkMethod, 565 | tkVariant, 566 | tkRecord, 567 | tkInterface : RT; 568 | end; 569 | end; 570 | finally 571 | Dispose(lpl); 572 | FreeAndNil(lJSON); 573 | end; 574 | end; 575 | 576 | function __ObjectToJson(aObject: TObject): String; 577 | begin 578 | Result := InternalObjectToJSON(aObject,[]); 579 | end; 580 | 581 | Procedure __jsonToObject(Const aJSONString : String; Var aObject : TObject); 582 | begin 583 | InternalJsonToObject(aJSONString, aObject); 584 | end; 585 | 586 | 587 | Initialization 588 | 589 | JsonsUtils_GLB_DECIMALSEPARATOR := GetDecimalSeparator; 590 | 591 | Finalization 592 | 593 | end. 594 | -------------------------------------------------------------------------------- /test/TestJson.dpr: -------------------------------------------------------------------------------- 1 | program TestJson; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | uses 6 | SysUtils, 7 | Jsons in '..\src\Jsons.pas'; 8 | 9 | procedure RunTest; 10 | var 11 | Json: TJson; 12 | Str: String; 13 | begin 14 | Json := TJson.Create; 15 | 16 | try 17 | 18 | Json.Put('null-field', null); 19 | Json.Put('boolean-field-true', True); 20 | 21 | Json['boolean-field-false'].AsBoolean := not Json.Get('boolean-field-true').AsBoolean; 22 | Json['number-field'].AsNumber := 3.1415926535; 23 | Json['number-field-integer'].AsInteger := Json['number-field'].AsInteger; 24 | Json['string-field'].AsString := 'Hello world'; 25 | 26 | with Json.Put('array-field', empty).AsArray do 27 | begin 28 | Put(empty); 29 | Put(null); 30 | Put(False); 31 | Put(True); 32 | Put(299792458); 33 | Put(2.7182818284); 34 | Put('The magic words are squeamish ossifrage'); 35 | with Put(empty).AsObject do 36 | begin 37 | Put('array-object-field-1', null); 38 | Put('array-object-field-2', 'json4delphi'); 39 | end; 40 | end; 41 | with Json.Put('object-field', empty).AsObject do 42 | begin 43 | Put('object-field-1', True); 44 | Put('object-field-2', 6.6260755e-34); 45 | end; 46 | Str := Json.Stringify; 47 | Writeln(Str); 48 | Json.Clear; 49 | Json.Parse(Str); 50 | finally 51 | Json.Free; 52 | end; 53 | end; 54 | 55 | begin 56 | RunTest; 57 | ReadLn; 58 | end. 59 | --------------------------------------------------------------------------------