diff --git a/etc/fcl-json/src/README.txt b/etc/fcl-json/src/README.txt new file mode 100644 index 00000000..45d8eaa6 --- /dev/null +++ b/etc/fcl-json/src/README.txt @@ -0,0 +1,229 @@ +This package implements JSON support for FPC. + +You might want to have a look at the lazarus jsonviewer tool, written using +fpJSON (see lazarus/tools/jsonviewer). It visualizes the fpJSON data and +shows how to program using fpjson. + +JSON support consists of 3 parts: + +unit fpJSON contains the data representation. Basically, it defines a set of +classes: + +TJSONData ++- TJSONNumber + +- TJSONIntegerNumber + +- TJSONFloatNumber + +- TJSONInt64Number ++- TJSONString ++- TJSONBoolean ++- TJSONNull ++- TJSONObject ++- TJSONArray + +The TJSONData.JSONType property is an enumerated: +TJSONtype = (jtUnknown, jtNumber, jtString, jtBoolean, jtNull, jtArray, jtObject); + +Which allows to determine the type of a value. + +The following methods exist: + +Procedure Clear; + Clears the value. For arrays and objects, removes all elements/members +Function Clone : TJSONData; + Creates an exact replica of the valye +property Count: Integer; + For simple values this is zero, for complex values this is the number of + elements/members. Read only. +property Items[Index: Integer]: TJSONData + For simple values, reading this will result in an error. For complex + values, this gives access to the members. +property Value: variant; + The value as a variant. Only for simple values. +Property AsString : TJSONStringType: + The value as a string. Only for simple values. +Property AsFloat : TJSONFloat; + The value as a float (double). only for simple values. +Property AsInteger : Integer ; + The value as an integer. only for simple values. +Property AsInt64 : Int64; + The value as an 64-bit integer. only for simple values. +Property AsBoolean : Boolean ; + The value as a boolean. +Property IsNull : Boolean ; + Is the value Null ? +Property AsJSON : TJSONStringType + Return the value in JSON notation. For simple and complex values. + +The TJSONArray type provides access to the elements in the array in the +following ways: + +Property Types[Index : Integer] : TJSONType; + Indexed access to the types of the elements in the array. +Property Nulls[Index : Integer] : Boolean + Checks if the Index-the element is NULL. +Property Integers[Index : Integer] : Integer + Read/Write element values as integers. +Property Int64s[Index : Integer] : Int64 + Read/Write element values as 64-bit integers. +Property Strings[Index : Integer] : TJSONStringType; + Read/Write element values as strings. +Property Floats[Index : Integer] : TJSONFloat ; + Read/Write element values as floats (doubles). +Property Booleans[Index : Integer] : Boolean; + Read/Write element values as booleans. +Property Arrays[Index : Integer] : TJSONArray; + Read/Write element values as arrays. +Property Objects[Index : Integer] : TJSONObject; + Read/Write element values a strings + +Reading an element as a type which is incompatible, will result in an +exception. For instance if element 5 is an object value, then the following +will result in an exception: + i:=i+Array.Integers[5] + +The TJSONObject type similarly provides access to the elements in the array +using the member names: +property Names[Index : Integer] : TJSONStringType; + Indexed access to the member names. +property Elements[AName: string] : TJSONData; + Read/Write a member as a raw TJSONData value. +Property Types[AName : String] : TJSONType Read GetTypes; + Read/Write the type of a member. +Property Nulls[AName : String] : Boolean; + Read/Write a member as a NULL value. +Property Floats[AName : String] : TJSONFloat; + Read/Write a member as a float value (double) +Property Integers[AName : String] : Integer; + Read/Write a member as an integer value +Property Int64s[AName : String] : Int64; + Read/Write a member as an 64-bit integer value +Property Strings[AName : String] : TJSONStringType; + Read/Write a member as a string value. +Property Booleans[AName : String] : Boolean; + Read/Write a member as a boolean value. +Property Arrays[AName : String] : TJSONArray; + Read/Write a member as an array value. +Property Objects[AName : String] : TJSONObject + Read/Write a member as an object value. + +Members can be added with the Add() call, which exists in various overloaded +forms: + function Add(const AName: TJSONStringType; Const AValue): Integer; +Where the type of AVAlue is one of the supported types: +integer, int64, double, string, TJSONArray or TJSONObject. + +The Delete() call deletes an element from an array or object. The element is +freed. + +Important remark: +The array and object classes own their members: the members are destroyed as +they are deleted. For this, the Extract() call exists: it removes an +element/member from the array/object, without destroying it. + +Converting from string/stream to JSONData +========================================= + +The fpjson unit contains a GetJSON() function which accepts a string or a +stream as a parameter. The function will parse the JSON in the stream and +the return value is a TJSONData value corresponding to the JSON. +The function works with a callback, which is set by the JSONParser unit. +The JSONParser unit simply needs to be included in the project. + +The parsing happens with default settings for the parser class. +You can override this behaviour by creating your own callback, +and creating the parser with different settings. + +Enumerator support +================== + +the TJSONData class offers support for an enumerator, hence the +For e in JSON do +construct can be used. The enumerator is a TJSONEnum value, which has 3 +members: +Key : The key of the element + (name in TJSONObject, Index in TJSONArray, empty otherwise) +KeyNum: The index of the element. + (Index in TJSONArray/TJSONObject, 0 otherwise) +Value : The value of the element + (These are the member values for TJSONArray/TJSONObject, and is the + element itself otherwise) + +While the enumerator is looping, it is not allowed to change the content of +the array or object, and the value may not be freed. + +Scanner/Parser +============== + +The JSONSCanner unit contains a scanner for JSON data: TJSONScanner. +Currently it does not support full unicode, only UTF-8 is supported. + +The JSONParser unit contains the parser for JSON data: TJSONParser. +It uses to scanner to read the tokens. The scanner is created automatically. + + +The Parse method will parse the data that was passed to the parser and will +return the JSON value. + +Sample use: + +Var + P : TJSONParser; + S : String; + D : TJSONObject; + +begin + P:=TJSONParser.Create('{ "top": 10, "left": 20}'); + try + D:=P.Parse as TJSONObject; + Writeln('Top : ',D.Integers['top']); + Writeln('Left : ',D.Integers['left']); + D.free; + Finally + P.free; + end; +end; + +Note that the member names are case sensitive. + +As an alternative, a stream may be passed to the constructor of TJSONParser. + +The scanner and parser support the 'Strict' property. +Strict JSON syntax requires the member names of an object to be strings: +{ "top": 10, "left": 20} +However, due to the sloppy definition of Javascript (and hence JSON), +the following type of JSON notation is frequently encountered: +{ top: 10, left: 20} +By default, this sloppy notation is accepted. Setting 'Strict' to true will +reject this. + +A second effect of the Strict property is the requirement of " as a string +delimiter. A single quote is also often found in Javascript and JSON: +{ title: 'A nice title' } +By default, this is accepted. Setting 'Strict' to true will reject this. + +Customizing the classes : Factory support +========================================= + +The various classes created by the methods can be customized. +This can be useful to create customized descendents, for example to attach +extra data to the various values. All instances of TJSONData are created +through the CreateJSON() functions, which use a set of customizable classes +to create the JSONData structures. + +All functions which somehow create a new instance (clone, add, insert, parsing) +use the CreateJSON functions. + +Which classes need to be created for a specific value is enumerated in + +TJSONInstanceType = (jitUnknown, jitNumberInteger,jitNumberInt64,jitNumberFloat, + jitString, jitBoolean, jitNull, jitArray, jitObject); + +when a Int64 value must be instantiated, the class identified with +jitNumberInt64 is instantiated. + +To customize the classes, the new class can be set using SetJSONInstanceType: + +Procedure SetJSONInstanceType(AType : TJSONInstanceType; AClass : TJSONDataClass); +Function GetJSONInstanceType(AType : TJSONInstanceType) : TJSONDataClass; + +The function checks whether sane classes are specified.; \ No newline at end of file diff --git a/etc/fcl-json/src/fpjson.pp b/etc/fcl-json/src/fpjson.pp new file mode 100644 index 00000000..dd3dff58 --- /dev/null +++ b/etc/fcl-json/src/fpjson.pp @@ -0,0 +1,3131 @@ +{ + This file is part of the Free Component Library + + JSON Data structures + Copyright (c) 2007 by Michael Van Canneyt michael@freepascal.org + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} +{$mode objfpc} +{$h+} +unit fpjson; + +interface + +uses + variants, + SysUtils, + classes, + contnrs; + +type + + TJSONtype = (jtUnknown, jtNumber, jtString, jtBoolean, jtNull, jtArray, jtObject); + TJSONInstanceType = (jitUnknown, jitNumberInteger,jitNumberInt64,jitNumberQWord,jitNumberFloat, + jitString, jitBoolean, jitNull, jitArray, jitObject); + TJSONFloat = Double; + TJSONStringType = UTF8String; + TJSONUnicodeStringType = Unicodestring; + TJSONCharType = AnsiChar; + PJSONCharType = ^TJSONCharType; + TFormatOption = (foSingleLineArray, // Array without CR/LF : all on one line + foSingleLineObject, // Object without CR/LF : all on one line + foDoNotQuoteMembers, // Do not quote object member names. + foUseTabchar, // Use tab characters instead of spaces. + foSkipWhiteSpace); // Do not use whitespace at all + TFormatOptions = set of TFormatOption; + +Const + DefaultIndentSize = 2; + DefaultFormat = []; + AsJSONFormat = [foSingleLineArray,foSingleLineObject]; // These options make FormatJSON behave as AsJSON + AsCompressedJSON = [foSingleLineArray,foSingleLineObject,foskipWhiteSpace]; // These options make FormatJSON behave as AsJSON with TJSONData.CompressedJSON=True + AsCompactJSON = [foSingleLineArray,foSingleLineObject,foskipWhiteSpace,foDoNotQuoteMembers]; // These options make FormatJSON behave as AsJSON with TJSONData.CompressedJSON=True and TJSONObject.UnquotedMemberNames=True + ValueJSONTypes = [jtNumber, jtString, jtBoolean, jtNull]; + ActualValueJSONTypes = ValueJSONTypes - [jtNull]; + StructuredJSONTypes = [jtArray,jtObject]; + +Type + TJSONData = Class; + + { TMJBaseObjectEnumerator } + TJSONEnum = Record + Key : TJSONStringType; + KeyNum : Integer; + Value : TJSONData; + end; + + TBaseJSONEnumerator = class + public + function GetCurrent: TJSONEnum; virtual; abstract; + function MoveNext : Boolean; virtual; abstract; + property Current: TJSONEnum read GetCurrent; + end; + + { TMJObjectEnumerator } + + + { TJSONData } + + TJSONData = class(TObject) + private + Const + ElementSeps : Array[Boolean] of TJSONStringType = (', ',','); + Class Var FCompressedJSON : Boolean; + Class Var FElementSep : TJSONStringType; + class procedure DetermineElementSeparators; + class function GetCompressedJSON: Boolean; static; + class procedure SetCompressedJSON(AValue: Boolean); static; + protected + Class Procedure DoError(Const Msg : String); + Class Procedure DoError(Const Fmt : String; const Args : Array of const); + Function DoFindPath(Const APath : TJSONStringType; Out NotFound : TJSONStringType) : TJSONdata; virtual; + function GetAsBoolean: Boolean; virtual; abstract; + function GetAsFloat: TJSONFloat; virtual; abstract; + function GetAsInteger: Integer; virtual; abstract; + function GetAsInt64: Int64; virtual; abstract; + function GetAsQWord: QWord; virtual; abstract; + function GetIsNull: Boolean; virtual; + procedure SetAsBoolean(const AValue: Boolean); virtual; abstract; + procedure SetAsFloat(const AValue: TJSONFloat); virtual; abstract; + procedure SetAsInteger(const AValue: Integer); virtual; abstract; + procedure SetAsInt64(const AValue: Int64); virtual; abstract; + procedure SetAsQword(const AValue: QWord); virtual; abstract; + function GetAsJSON: TJSONStringType; virtual; abstract; + function GetAsString: TJSONStringType; virtual; abstract; + procedure SetAsString(const AValue: TJSONStringType); virtual; abstract; + function GetAsUnicodeString: TJSONUnicodeStringType; virtual; + procedure SetAsUnicodeString(const AValue: TJSONUnicodeStringType); virtual; + function GetValue: variant; virtual; abstract; + procedure SetValue(const AValue: variant); virtual; abstract; + function GetItem(Index : Integer): TJSONData; virtual; + procedure SetItem(Index : Integer; const AValue: TJSONData); virtual; + Function DoFormatJSON(Options : TFormatOptions; CurrentIndent, Indent : Integer) : TJSONStringType; virtual; + function GetCount: Integer; virtual; + Public + Class function JSONType: TJSONType; virtual; + Class Property CompressedJSON : Boolean Read GetCompressedJSON Write SetCompressedJSON; + public + Constructor Create; virtual; + Procedure Clear; virtual; Abstract; + Procedure DumpJSON(S : TStream); + // Get enumerator + function GetEnumerator: TBaseJSONEnumerator; virtual; + Function FindPath(Const APath : TJSONStringType) : TJSONdata; + Function GetPath(Const APath : TJSONStringType) : TJSONdata; + Function Clone : TJSONData; virtual; abstract; + Function FormatJSON(Options : TFormatOptions = DefaultFormat; Indentsize : Integer = DefaultIndentSize) : TJSONStringType; + property Count: Integer read GetCount; + property Items[Index: Integer]: TJSONData read GetItem write SetItem; + property Value: variant read GetValue write SetValue; + Property AsString : TJSONStringType Read GetAsString Write SetAsString; + Property AsUnicodeString : TJSONUnicodeStringType Read GetAsUnicodeString Write SetAsUnicodeString; + Property AsFloat : TJSONFloat Read GetAsFloat Write SetAsFloat; + Property AsInteger : Integer Read GetAsInteger Write SetAsInteger; + Property AsInt64 : Int64 Read GetAsInt64 Write SetAsInt64; + Property AsQWord : QWord Read GetAsQWord Write SetAsQword; + Property AsBoolean : Boolean Read GetAsBoolean Write SetAsBoolean; + Property IsNull : Boolean Read GetIsNull; + Property AsJSON : TJSONStringType Read GetAsJSON; + end; + + TJSONDataClass = Class of TJSONData; + TJSONNumberType = (ntFloat,ntInteger,ntInt64,ntQWord); + + TJSONNumber = class(TJSONData) + protected + public + class function JSONType: TJSONType; override; + class function NumberType : TJSONNumberType; virtual; abstract; + end; + + { TJSONFloatNumber } + + TJSONFloatNumber = class(TJSONNumber) + Private + FValue : TJSONFloat; + protected + function GetAsBoolean: Boolean; override; + function GetAsFloat: TJSONFloat; override; + function GetAsInteger: Integer; override; + function GetAsInt64: Int64; override; + function GetAsQWord: QWord; override; + procedure SetAsBoolean(const AValue: Boolean); override; + procedure SetAsFloat(const AValue: TJSONFloat); override; + procedure SetAsInteger(const AValue: Integer); override; + procedure SetAsInt64(const AValue: Int64); override; + procedure SetAsQword(const AValue: QWord); override; + function GetAsJSON: TJSONStringType; override; + function GetAsString: TJSONStringType; override; + procedure SetAsString(const AValue: TJSONStringType); override; + function GetValue: variant; override; + procedure SetValue(const AValue: variant); override; + public + Constructor Create(AValue : TJSONFloat); reintroduce; + class function NumberType : TJSONNumberType; override; + Procedure Clear; override; + Function Clone : TJSONData; override; + end; + TJSONFloatNumberClass = Class of TJSONFloatNumber; + + { TJSONIntegerNumber } + + TJSONIntegerNumber = class(TJSONNumber) + Private + FValue : Integer; + protected + function GetAsBoolean: Boolean; override; + function GetAsFloat: TJSONFloat; override; + function GetAsInteger: Integer; override; + function GetAsInt64: Int64; override; + function GetAsQWord: QWord; override; + procedure SetAsBoolean(const AValue: Boolean); override; + procedure SetAsFloat(const AValue: TJSONFloat); override; + procedure SetAsInteger(const AValue: Integer); override; + procedure SetAsInt64(const AValue: Int64); override; + procedure SetAsQword(const AValue: QWord); override; + function GetAsJSON: TJSONStringType; override; + function GetAsString: TJSONStringType; override; + procedure SetAsString(const AValue: TJSONStringType); override; + function GetValue: variant; override; + procedure SetValue(const AValue: variant); override; + public + Constructor Create(AValue : Integer); reintroduce; + class function NumberType : TJSONNumberType; override; + Procedure Clear; override; + Function Clone : TJSONData; override; + end; + TJSONIntegerNumberClass = Class of TJSONIntegerNumber; + + { TJSONInt64Number } + + TJSONInt64Number = class(TJSONNumber) + Private + FValue : Int64; + protected + function GetAsBoolean: Boolean; override; + function GetAsFloat: TJSONFloat; override; + function GetAsInteger: Integer; override; + function GetAsInt64: Int64; override; + function GetAsQWord: QWord; override; + procedure SetAsBoolean(const AValue: Boolean); override; + procedure SetAsFloat(const AValue: TJSONFloat); override; + procedure SetAsInteger(const AValue: Integer); override; + procedure SetAsInt64(const AValue: Int64); override; + procedure SetAsQword(const AValue: QWord); override; + function GetAsJSON: TJSONStringType; override; + function GetAsString: TJSONStringType; override; + procedure SetAsString(const AValue: TJSONStringType); override; + function GetValue: variant; override; + procedure SetValue(const AValue: variant); override; + public + Constructor Create(AValue : Int64); reintroduce; + class function NumberType : TJSONNumberType; override; + Procedure Clear; override; + Function Clone : TJSONData; override; + end; + TJSONInt64NumberClass = Class of TJSONInt64Number; + + { TJSONQWordNumber } + + TJSONQWordNumber = class(TJSONNumber) + Private + FValue : Qword; + protected + function GetAsBoolean: Boolean; override; + function GetAsFloat: TJSONFloat; override; + function GetAsInteger: Integer; override; + function GetAsInt64: Int64; override; + function GetAsQWord: QWord; override; + procedure SetAsBoolean(const AValue: Boolean); override; + procedure SetAsFloat(const AValue: TJSONFloat); override; + procedure SetAsInteger(const AValue: Integer); override; + procedure SetAsInt64(const AValue: Int64); override; + procedure SetAsQword(const AValue: QWord); override; + function GetAsJSON: TJSONStringType; override; + function GetAsString: TJSONStringType; override; + procedure SetAsString(const AValue: TJSONStringType); override; + function GetValue: variant; override; + procedure SetValue(const AValue: variant); override; + public + Constructor Create(AValue : QWord); reintroduce; + class function NumberType : TJSONNumberType; override; + Procedure Clear; override; + Function Clone : TJSONData; override; + end; + TJSONQWordNumberClass = Class of TJSONQWordNumber; + + + { TJSONString } + + TJSONString = class(TJSONData) + Private + FValue: TJSONStringType; + protected + function GetValue: Variant; override; + procedure SetValue(const AValue: Variant); override; + function GetAsBoolean: Boolean; override; + function GetAsFloat: TJSONFloat; override; + function GetAsInteger: Integer; override; + function GetAsInt64: Int64; override; + function GetAsQWord: QWord; override; + procedure SetAsBoolean(const AValue: Boolean); override; + procedure SetAsFloat(const AValue: TJSONFloat); override; + procedure SetAsInteger(const AValue: Integer); override; + procedure SetAsInt64(const AValue: Int64); override; + procedure SetAsQword(const AValue: QWord); override; + function GetAsJSON: TJSONStringType; override; + function GetAsString: TJSONStringType; override; + procedure SetAsString(const AValue: TJSONStringType); override; + public + Constructor Create(const AValue : TJSONStringType); reintroduce; + Constructor Create(const AValue : TJSONUnicodeStringType); reintroduce; + class function JSONType: TJSONType; override; + Procedure Clear; override; + Function Clone : TJSONData; override; + end; + TJSONStringClass = Class of TJSONString; + + { TJSONboolean } + + TJSONBoolean = class(TJSONData) + Private + FValue: Boolean; + protected + function GetValue: Variant; override; + procedure SetValue(const AValue: Variant); override; + function GetAsBoolean: Boolean; override; + function GetAsFloat: TJSONFloat; override; + function GetAsInteger: Integer; override; + function GetAsInt64: Int64; override; + function GetAsQWord: QWord; override; + procedure SetAsBoolean(const AValue: Boolean); override; + procedure SetAsFloat(const AValue: TJSONFloat); override; + procedure SetAsInteger(const AValue: Integer); override; + procedure SetAsInt64(const AValue: Int64); override; + procedure SetAsQword(const AValue: QWord); override; + function GetAsJSON: TJSONStringType; override; + function GetAsString: TJSONStringType; override; + procedure SetAsString(const AValue: TJSONStringType); override; + public + Constructor Create(AValue : Boolean); reintroduce; + class function JSONType: TJSONType; override; + Procedure Clear; override; + Function Clone : TJSONData; override; + end; + TJSONBooleanClass = Class of TJSONBoolean; + + { TJSONnull } + + TJSONNull = class(TJSONData) + protected + Procedure Converterror(From : Boolean); + function GetAsBoolean: Boolean; override; + function GetAsFloat: TJSONFloat; override; + function GetAsInteger: Integer; override; + function GetAsInt64: Int64; override; + function GetAsQWord: QWord; override; + function GetIsNull: Boolean; override; + procedure SetAsBoolean(const AValue: Boolean); override; + procedure SetAsFloat(const AValue: TJSONFloat); override; + procedure SetAsInteger(const AValue: Integer); override; + procedure SetAsInt64(const AValue: Int64); override; + procedure SetAsQword(const AValue: QWord); override; + function GetAsJSON: TJSONStringType; override; + function GetAsString: TJSONStringType; override; + procedure SetAsString(const AValue: TJSONStringType); override; + function GetValue: variant; override; + procedure SetValue(const AValue: variant); override; + public + class function JSONType: TJSONType; override; + Procedure Clear; override; + Function Clone : TJSONData; override; + end; + TJSONNullClass = Class of TJSONNull; + + TJSONArrayIterator = procedure(Item: TJSONData; Data: TObject; var Continue: Boolean) of object; + + { TJSONArray } + TJSONObject = Class; + + TJSONArray = class(TJSONData) + Private + FList : TFPObjectList; + function GetArrays(Index : Integer): TJSONArray; + function GetBooleans(Index : Integer): Boolean; + function GetFloats(Index : Integer): TJSONFloat; + function GetIntegers(Index : Integer): Integer; + function GetInt64s(Index : Integer): Int64; + function GetNulls(Index : Integer): Boolean; + function GetObjects(Index : Integer): TJSONObject; + function GetQWords(Index : Integer): QWord; + function GetStrings(Index : Integer): TJSONStringType; + function GetUnicodeStrings(Index : Integer): TJSONUnicodeStringType; + function GetTypes(Index : Integer): TJSONType; + procedure SetArrays(Index : Integer; const AValue: TJSONArray); + procedure SetBooleans(Index : Integer; const AValue: Boolean); + procedure SetFloats(Index : Integer; const AValue: TJSONFloat); + procedure SetIntegers(Index : Integer; const AValue: Integer); + procedure SetInt64s(Index : Integer; const AValue: Int64); + procedure SetObjects(Index : Integer; const AValue: TJSONObject); + procedure SetQWords(Index : Integer; AValue: QWord); + procedure SetStrings(Index : Integer; const AValue: TJSONStringType); + procedure SetUnicodeStrings(Index : Integer; const AValue: TJSONUnicodeStringType); + protected + Function DoFindPath(Const APath : TJSONStringType; Out NotFound : TJSONStringType) : TJSONdata; override; + Procedure Converterror(From : Boolean); + function GetAsBoolean: Boolean; override; + function GetAsFloat: TJSONFloat; override; + function GetAsInteger: Integer; override; + function GetAsInt64: Int64; override; + function GetAsQWord: QWord; override; + procedure SetAsBoolean(const AValue: Boolean); override; + procedure SetAsFloat(const AValue: TJSONFloat); override; + procedure SetAsInteger(const AValue: Integer); override; + procedure SetAsInt64(const AValue: Int64); override; + procedure SetAsQword(const AValue: QWord); override; + function GetAsJSON: TJSONStringType; override; + function GetAsString: TJSONStringType; override; + procedure SetAsString(const AValue: TJSONStringType); override; + function GetValue: variant; override; + procedure SetValue(const AValue: variant); override; + function GetCount: Integer; override; + function GetItem(Index : Integer): TJSONData; override; + procedure SetItem(Index : Integer; const AValue: TJSONData); override; + Function DoFormatJSON(Options : TFormatOptions; CurrentIndent, Indent : Integer) : TJSONStringType; override; + public + Constructor Create; overload; reintroduce; + Constructor Create(const Elements : Array of Const); overload; + Destructor Destroy; override; + class function JSONType: TJSONType; override; + Function Clone : TJSONData; override; + // Examine + procedure Iterate(Iterator : TJSONArrayIterator; Data: TObject); + function IndexOf(obj: TJSONData): Integer; + function GetEnumerator: TBaseJSONEnumerator; override; + // Manipulate + Procedure Clear; override; + function Add(Item : TJSONData): Integer; + function Add(I : Integer): Integer; + function Add(I : Int64): Int64; + function Add(I : QWord): QWord; + function Add(const S : String): Integer; + function Add(const S : UnicodeString): Integer; + function Add: Integer; + function Add(F : TJSONFloat): Integer; + function Add(B : Boolean): Integer; + function Add(AnArray : TJSONArray): Integer; + function Add(AnObject: TJSONObject): Integer; + Procedure Delete(Index : Integer); + procedure Exchange(Index1, Index2: Integer); + function Extract(Item: TJSONData): TJSONData; + function Extract(Index : Integer): TJSONData; + procedure Insert(Index: Integer); + procedure Insert(Index: Integer; Item : TJSONData); + procedure Insert(Index: Integer; I : Integer); + procedure Insert(Index: Integer; I : Int64); + procedure Insert(Index: Integer; I : QWord); + procedure Insert(Index: Integer; const S : String); + procedure Insert(Index: Integer; const S : UnicodeString); + procedure Insert(Index: Integer; F : TJSONFloat); + procedure Insert(Index: Integer; B : Boolean); + procedure Insert(Index: Integer; AnArray : TJSONArray); + procedure Insert(Index: Integer; AnObject: TJSONObject); + procedure Move(CurIndex, NewIndex: Integer); + Procedure Remove(Item : TJSONData); + Procedure Sort(Compare: TListSortCompare); + // Easy Access Properties. + property Items;default; + Property Types[Index : Integer] : TJSONType Read GetTypes; + Property Nulls[Index : Integer] : Boolean Read GetNulls; + Property Integers[Index : Integer] : Integer Read GetIntegers Write SetIntegers; + Property Int64s[Index : Integer] : Int64 Read GetInt64s Write SetInt64s; + Property QWords[Index : Integer] : QWord Read GetQWords Write SetQWords; + Property Strings[Index : Integer] : TJSONStringType Read GetStrings Write SetStrings; + Property UnicodeStrings[Index : Integer] : TJSONUnicodeStringType Read GetUnicodeStrings Write SetUnicodeStrings; + Property Floats[Index : Integer] : TJSONFloat Read GetFloats Write SetFloats; + Property Booleans[Index : Integer] : Boolean Read GetBooleans Write SetBooleans; + Property Arrays[Index : Integer] : TJSONArray Read GetArrays Write SetArrays; + Property Objects[Index : Integer] : TJSONObject Read GetObjects Write SetObjects; + end; + TJSONArrayClass = Class of TJSONArray; + + TJSONObjectIterator = procedure(Const AName : TJSONStringType; Item: TJSONData; Data: TObject; var Continue: Boolean) of object; + + { TJSONObject } + + TJSONObject = class(TJSONData) + private + Const + ElementStart : Array[Boolean] of TJSONStringType = ('"',''); + SpacedQuoted : Array[Boolean] of TJSONStringType = ('" : ',' : '); + UnSpacedQuoted : Array[Boolean] of TJSONStringType = ('":',':'); + ObjStartSeps : Array[Boolean] of TJSONStringType = ('{ ','{'); + ObjEndSeps : Array[Boolean] of TJSONStringType = (' }','}'); + Class var FUnquotedMemberNames: Boolean; + Class var FObjStartSep,FObjEndSep,FElementEnd,FElementStart : TJSONStringType; + Class procedure DetermineElementQuotes; + Private + FHash : TFPHashObjectList; // Careful : Names limited to 255 chars. + function GetArrays(const AName : String): TJSONArray; + function GetBooleans(const AName : String): Boolean; + function GetElements(const AName: string): TJSONData; + function GetFloats(const AName : String): TJSONFloat; + function GetIntegers(const AName : String): Integer; + function GetInt64s(const AName : String): Int64; + function GetIsNull(const AName : String): Boolean; reintroduce; + function GetNameOf(Index : Integer): TJSONStringType; + function GetObjects(const AName : String): TJSONObject; + function GetQWords(AName : String): QWord; + function GetStrings(const AName : String): TJSONStringType; + function GetUnicodeStrings(const AName : String): TJSONUnicodeStringType; + function GetTypes(const AName : String): TJSONType; + procedure SetArrays(const AName : String; const AValue: TJSONArray); + procedure SetBooleans(const AName : String; const AValue: Boolean); + procedure SetElements(const AName: string; const AValue: TJSONData); + procedure SetFloats(const AName : String; const AValue: TJSONFloat); + procedure SetIntegers(const AName : String; const AValue: Integer); + procedure SetInt64s(const AName : String; const AValue: Int64); + procedure SetIsNull(const AName : String; const AValue: Boolean); + procedure SetObjects(const AName : String; const AValue: TJSONObject); + procedure SetQWords(AName : String; AValue: QWord); + procedure SetStrings(const AName : String; const AValue: TJSONStringType); + procedure SetUnicodeStrings(const AName : String; const AValue: TJSONUnicodeStringType); + class function GetUnquotedMemberNames: Boolean; static; + class procedure SetUnquotedMemberNames(AValue: Boolean); static; + protected + Function DoFindPath(Const APath : TJSONStringType; Out NotFound : TJSONStringType) : TJSONdata; override; + Procedure Converterror(From : Boolean); + function GetAsBoolean: Boolean; override; + function GetAsFloat: TJSONFloat; override; + function GetAsInteger: Integer; override; + function GetAsInt64: Int64; override; + function GetAsQWord: QWord; override; + procedure SetAsBoolean(const AValue: Boolean); override; + procedure SetAsFloat(const AValue: TJSONFloat); override; + procedure SetAsInteger(const AValue: Integer); override; + procedure SetAsInt64(const AValue: Int64); override; + procedure SetAsQword(const AValue: QWord); override; + function GetAsJSON: TJSONStringType; override; + function GetAsString: TJSONStringType; override; + procedure SetAsString(const AValue: TJSONStringType); override; + function GetValue: variant; override; + procedure SetValue(const AValue: variant); override; + function GetCount: Integer; override; + function GetItem(Index : Integer): TJSONData; override; + procedure SetItem(Index : Integer; const AValue: TJSONData); override; + Function DoFormatJSON(Options : TFormatOptions; CurrentIndent, Indent : Integer) : TJSONStringType; override; + public + constructor Create; reintroduce; + Constructor Create(const Elements : Array of Const); overload; + destructor Destroy; override; + class function JSONType: TJSONType; override; + Class Property UnquotedMemberNames : Boolean Read GetUnquotedMemberNames Write SetUnquotedMemberNames; + Function Clone : TJSONData; override; + function GetEnumerator: TBaseJSONEnumerator; override; + // Examine + procedure Iterate(Iterator : TJSONObjectIterator; Data: TObject); + function IndexOf(Item: TJSONData): Integer; + Function IndexOfName(const AName: TJSONStringType; CaseInsensitive : Boolean = False): Integer; + Function Find(Const AName : String) : TJSONData; overload; + Function Find(Const AName : String; AType : TJSONType) : TJSONData; overload; + Function Get(Const AName : String) : Variant; + Function Get(Const AName : String; ADefault : TJSONFloat) : TJSONFloat; + Function Get(Const AName : String; ADefault : Integer) : Integer; + Function Get(Const AName : String; ADefault : Int64) : Int64; + Function Get(Const AName : String; ADefault : QWord) : QWord; + Function Get(Const AName : String; ADefault : Boolean) : Boolean; + Function Get(Const AName : String; ADefault : TJSONStringType) : TJSONStringType; + Function Get(Const AName : String; ADefault : TJSONUnicodeStringType) : TJSONUnicodeStringType; + Function Get(Const AName : String; ADefault : TJSONArray) : TJSONArray; + Function Get(Const AName : String; ADefault : TJSONObject) : TJSONObject; + // Manipulate + Procedure Clear; override; + function Add(const AName: TJSONStringType; AValue: TJSONData): Integer; overload; + function Add(const AName: TJSONStringType; AValue: Boolean): Integer; overload; + function Add(const AName: TJSONStringType; AValue: TJSONFloat): Integer; overload; + function Add(const AName, AValue: TJSONStringType): Integer; overload; + function Add(const AName : String; AValue: TJSONUnicodeStringType): Integer; overload; + function Add(const AName: TJSONStringType; Avalue: Integer): Integer; overload; + function Add(const AName: TJSONStringType; Avalue: Int64): Integer; overload; + function Add(const AName: TJSONStringType; Avalue: QWord): Integer; overload; + function Add(const AName: TJSONStringType): Integer; overload; + function Add(const AName: TJSONStringType; AValue : TJSONArray): Integer; overload; + procedure Delete(Index : Integer); + procedure Delete(Const AName : string); + procedure Remove(Item : TJSONData); + Function Extract(Index : Integer) : TJSONData; + Function Extract(Const AName : string) : TJSONData; + + // Easy access properties. + property Names[Index : Integer] : TJSONStringType read GetNameOf; + property Elements[AName: string] : TJSONData read GetElements write SetElements; default; + + Property Types[AName : String] : TJSONType Read GetTypes; + Property Nulls[AName : String] : Boolean Read GetIsNull Write SetIsNull; + Property Floats[AName : String] : TJSONFloat Read GetFloats Write SetFloats; + Property Integers[AName : String] : Integer Read GetIntegers Write SetIntegers; + Property Int64s[AName : String] : Int64 Read GetInt64s Write SetInt64s; + Property QWords[AName : String] : QWord Read GetQWords Write SetQWords; + Property Strings[AName : String] : TJSONStringType Read GetStrings Write SetStrings; + Property UnicodeStrings[AName : String] : TJSONUnicodeStringType Read GetUnicodeStrings Write SetUnicodeStrings; + Property Booleans[AName : String] : Boolean Read GetBooleans Write SetBooleans; + Property Arrays[AName : String] : TJSONArray Read GetArrays Write SetArrays; + Property Objects[AName : String] : TJSONObject Read GetObjects Write SetObjects; + end; + TJSONObjectClass = Class of TJSONObject; + + EJSON = Class(Exception); + + TJSONParserHandler = Procedure(AStream : TStream; Const AUseUTF8 : Boolean; Out Data : TJSONData); + +Function SetJSONInstanceType(AType : TJSONInstanceType; AClass : TJSONDataClass) : TJSONDataClass; +Function GetJSONInstanceType(AType : TJSONInstanceType) : TJSONDataClass; + +Function StringToJSONString(const S : TJSONStringType) : TJSONStringType; +Function JSONStringToString(const S : TJSONStringType) : TJSONStringType; +Function JSONTypeName(JSONType : TJSONType) : String; + +// These functions create JSONData structures, taking into account the instance types +Function CreateJSON : TJSONNull; +Function CreateJSON(Data : Boolean) : TJSONBoolean; +Function CreateJSON(Data : Integer) : TJSONIntegerNumber; +Function CreateJSON(Data : Int64) : TJSONInt64Number; +Function CreateJSON(Data : QWord) : TJSONQWordNumber; +Function CreateJSON(Data : TJSONFloat) : TJSONFloatNumber; +Function CreateJSON(Data : TJSONStringType) : TJSONString; +Function CreateJSON(Data : TJSONUnicodeStringType) : TJSONString; +Function CreateJSONArray(Data : Array of const) : TJSONArray; +Function CreateJSONObject(Data : Array of const) : TJSONObject; + +// These functions rely on a callback. If the callback is not set, they will raise an error. +// When the jsonparser unit is included in the project, the callback is automatically set. +Function GetJSON(Const JSON : TJSONStringType; Const UseUTF8 : Boolean = True) : TJSONData; +Function GetJSON(Const JSON : TStream; Const UseUTF8 : Boolean = True) : TJSONData; +Function SetJSONParserHandler(AHandler : TJSONParserHandler) : TJSONParserHandler; +Function GetJSONParserHandler : TJSONParserHandler; + +implementation + +Uses typinfo; + +Resourcestring + SErrCannotConvertFromNull = 'Cannot convert data from Null value'; + SErrCannotConvertToNull = 'Cannot convert data to Null value'; + SErrCannotConvertFromArray = 'Cannot convert data from array value'; + SErrCannotConvertToArray = 'Cannot convert data to array value'; + SErrCannotConvertFromObject = 'Cannot convert data from object value'; + SErrCannotConvertToObject = 'Cannot convert data to object value'; + SErrInvalidFloat = 'Invalid float value : %s'; + SErrInvalidInteger = 'Invalid float value : %s'; + SErrCannotSetNotIsNull = 'IsNull cannot be set to False'; + SErrCannotAddArrayTwice = 'Adding an array object to an array twice is not allowed'; + SErrCannotAddObjectTwice = 'Adding an object to an array twice is not allowed'; + SErrUnknownTypeInConstructor = 'Unknown type in JSON%s constructor: %d'; + SErrNotJSONData = 'Cannot add object of type %s to TJSON%s'; + SErrPointerNotNil = 'Cannot add non-nil pointer to JSON%s'; + SErrOddNumber = 'TJSONObject must be constructed with name,value pairs'; + SErrNameMustBeString = 'TJSONObject constructor element name at pos %d is not a string'; + SErrNonexistentElement = 'Unknown object member: "%s"'; + SErrPathElementNotFound = 'Path "%s" invalid: element "%s" not found.'; + SErrWrongInstanceClass = 'Cannot set instance class: %s does not descend from %s.'; + SErrNoParserHandler = 'No JSON parser handler installed. Recompile your project with the jsonparser unit included'; + +Var + DefaultJSONInstanceTypes : + Array [TJSONInstanceType] of TJSONDataClass = (TJSONData, TJSONIntegerNumber, + TJSONInt64Number, TJSONQWordNumber, TJSONFloatNumber, TJSONString, TJSONBoolean, TJSONNull, TJSONArray, + TJSONObject); +Const + MinJSONInstanceTypes : + Array [TJSONInstanceType] of TJSONDataClass = (TJSONData, TJSONIntegerNumber, + TJSONInt64Number, TJSONQWordNumber, TJSONFloatNumber, TJSONString, TJSONBoolean, TJSONNull, TJSONArray, + TJSONObject); + +function SetJSONInstanceType(AType: TJSONInstanceType; AClass: TJSONDataClass): TJSONDataClass; +begin + if AClass=Nil then + TJSONData.DoError(SErrWrongInstanceClass,['Nil',MinJSONInstanceTypes[AType].ClassName]); + if Not AClass.InheritsFrom(MinJSONINstanceTypes[AType]) then + TJSONData.DoError(SErrWrongInstanceClass,[AClass.ClassName,MinJSONInstanceTypes[AType].ClassName]); + Result:=DefaultJSONInstanceTypes[AType]; + DefaultJSONINstanceTypes[AType]:=AClass; +end; + +function GetJSONInstanceType(AType: TJSONInstanceType): TJSONDataClass; +begin + Result:=DefaultJSONInstanceTypes[AType] +end; + +function StringToJSONString(const S: TJSONStringType): TJSONStringType; + +Var + I,J,L : Integer; + P : PJSONCharType; + +begin + I:=1; + J:=1; + Result:=''; + L:=Length(S); + P:=PJSONCharType(S); + While I<=L do + begin + if (AnsiChar(P^) in ['"','/','\',#8,#9,#10,#12,#13]) then + begin + Result:=Result+Copy(S,J,I-J); + Case P^ of + '\' : Result:=Result+'\\'; + '/' : Result:=Result+'\/'; + '"' : Result:=Result+'\"'; + #8 : Result:=Result+'\b'; + #9 : Result:=Result+'\t'; + #10 : Result:=Result+'\n'; + #12 : Result:=Result+'\f'; + #13 : Result:=Result+'\r'; + end; + J:=I+1; + end; + Inc(I); + Inc(P); + end; + Result:=Result+Copy(S,J,I-1); +end; + +function JSONStringToString(const S: TJSONStringType): TJSONStringType; + +Var + I,J,L : Integer; + P : PJSONCharType; + w : String; + +begin + I:=1; + J:=1; + L:=Length(S); + Result:=''; + P:=PJSONCharType(S); + While (I<=L) do + begin + if (P^='\') then + begin + Result:=Result+Copy(S,J,I-J); + Inc(P); + If (P^<>#0) then + begin + Inc(I); + Case AnsiChar(P^) of + '\','"','/' + : Result:=Result+P^; + 'b' : Result:=Result+#8; + 't' : Result:=Result+#9; + 'n' : Result:=Result+#10; + 'f' : Result:=Result+#12; + 'r' : Result:=Result+#13; + 'u' : begin + W:=Copy(S,I+1,4); + Inc(I,4); + Inc(P,4); + Result:=Result+WideChar(StrToInt('$'+W)); + end; + end; + end; + J:=I+1; + end; + Inc(I); + Inc(P); + end; + Result:=Result+Copy(S,J,I-J+1); +end; + +function JSONTypeName(JSONType: TJSONType): String; +begin + Result:=GetEnumName(TypeInfo(TJSONType),Ord(JSONType)); +end; + +function CreateJSON: TJSONNull; +begin + Result:=TJSONNullClass(DefaultJSONInstanceTypes[jitNull]).Create +end; + +function CreateJSON(Data: Boolean): TJSONBoolean; +begin + Result:=TJSONBooleanClass(DefaultJSONInstanceTypes[jitBoolean]).Create(Data); +end; + +function CreateJSON(Data: Integer): TJSONIntegerNumber; +begin + Result:=TJSONIntegerNumberCLass(DefaultJSONInstanceTypes[jitNumberInteger]).Create(Data); +end; + +function CreateJSON(Data: Int64): TJSONInt64Number; +begin + Result:=TJSONInt64NumberCLass(DefaultJSONInstanceTypes[jitNumberInt64]).Create(Data); +end; + +function CreateJSON(Data: QWord): TJSONQWordNumber; +begin + Result:=TJSONQWordNumberClass(DefaultJSONInstanceTypes[jitNumberQWord]).Create(Data); +end; + +function CreateJSON(Data: TJSONFloat): TJSONFloatNumber; +begin + Result:=TJSONFloatNumberCLass(DefaultJSONInstanceTypes[jitNumberFloat]).Create(Data); +end; + +function CreateJSON(Data: TJSONStringType): TJSONString; +begin + Result:=TJSONStringCLass(DefaultJSONInstanceTypes[jitString]).Create(Data); +end; + +function CreateJSON(Data: TJSONUnicodeStringType): TJSONString; +begin + Result:=TJSONStringCLass(DefaultJSONInstanceTypes[jitString]).Create(Data); +end; + +function CreateJSONArray(Data: array of const): TJSONArray; +begin + Result:=TJSONArrayCLass(DefaultJSONInstanceTypes[jitArray]).Create(Data); +end; + +function CreateJSONObject(Data: array of const): TJSONObject; +begin + Result:=TJSONObjectCLass(DefaultJSONInstanceTypes[jitObject]).Create(Data); +end; + +Var + JPH : TJSONParserHandler; + +function GetJSON(const JSON: TJSONStringType; const UseUTF8: Boolean + ): TJSONData; + +Var + SS : TStringStream; +begin + SS:=TStringStream.Create(JSON); + try + Result:=GetJSON(SS,UseUTF8); + finally + SS.Free; + end; +end; + +function GetJSON(const JSON: TStream; const UseUTF8: Boolean): TJSONData; + +begin + Result:=Nil; + If (JPH=Nil) then + TJSONData.DoError(SErrNoParserHandler); + JPH(JSON,UseUTF8,Result); +end; + +function SetJSONParserHandler(AHandler: TJSONParserHandler): TJSONParserHandler; +begin + Result:=JPH; + JPH:=AHandler; +end; + +function GetJSONParserHandler: TJSONParserHandler; +begin + Result:=JPH; +end; + +Type + { TJSONEnumerator } + + TJSONEnumerator = class(TBaseJSONEnumerator) + Private + FData : TJSONData; + public + Constructor Create(AData : TJSONData); + function GetCurrent: TJSONEnum; override; + function MoveNext : Boolean; override; + end; + + { TJSONArrayEnumerator } + + TJSONArrayEnumerator = class(TBaseJSONEnumerator) + Private + FData : TJSONArray; + FCurrent : Integer; + public + Constructor Create(AData : TJSONArray); + function GetCurrent: TJSONEnum; override; + function MoveNext : Boolean; override; + end; + + { TJSONObjectEnumerator } + + TJSONObjectEnumerator = class(TBaseJSONEnumerator) + Private + FData : TJSONObject; + FCurrent : Integer; + public + Constructor Create(AData : TJSONObject); + function GetCurrent: TJSONEnum; override; + function MoveNext : Boolean; override; + end; + +{ TJSONQWordNumber } + +function TJSONQWordNumber.GetAsBoolean: Boolean; +begin + Result:=FValue<>0; +end; + +function TJSONQWordNumber.GetAsFloat: TJSONFloat; +begin + Result:= FValue; +end; + +function TJSONQWordNumber.GetAsInteger: Integer; +begin + Result := FValue; +end; + +function TJSONQWordNumber.GetAsInt64: Int64; +begin + Result := FValue; +end; + +function TJSONQWordNumber.GetAsQWord: QWord; +begin + Result := FValue; +end; + +procedure TJSONQWordNumber.SetAsBoolean(const AValue: Boolean); +begin + FValue:=Ord(AValue); +end; + +procedure TJSONQWordNumber.SetAsFloat(const AValue: TJSONFloat); +begin + FValue:=Round(AValue); +end; + +procedure TJSONQWordNumber.SetAsInteger(const AValue: Integer); +begin + FValue:=AValue; +end; + +procedure TJSONQWordNumber.SetAsInt64(const AValue: Int64); +begin + FValue := AValue; +end; + +procedure TJSONQWordNumber.SetAsQword(const AValue: QWord); +begin + FValue:=AValue; +end; + +function TJSONQWordNumber.GetAsJSON: TJSONStringType; +begin + Result:=AsString; +end; + +function TJSONQWordNumber.GetAsString: TJSONStringType; +begin + Result:=IntToStr(FValue); +end; + +procedure TJSONQWordNumber.SetAsString(const AValue: TJSONStringType); +begin + FValue:=StrToQWord(AValue); +end; + +function TJSONQWordNumber.GetValue: variant; +begin + Result:=FValue; +end; + +procedure TJSONQWordNumber.SetValue(const AValue: variant); +begin + FValue:=AValue; +end; + +constructor TJSONQWordNumber.Create(AValue: QWord); +begin + FValue := AValue; +end; + +class function TJSONQWordNumber.NumberType: TJSONNumberType; +begin + Result:=ntQWord; +end; + +procedure TJSONQWordNumber.Clear; +begin + FValue:=0; +end; + +function TJSONQWordNumber.Clone: TJSONData; +begin + Result:=TJSONQWordNumberClass(ClassType).Create(Self.FValue); +end; + +constructor TJSONObjectEnumerator.Create(AData: TJSONObject); +begin + FData:=AData; + FCurrent:=-1; +end; + +function TJSONObjectEnumerator.GetCurrent: TJSONEnum; +begin + Result.KeyNum:=FCurrent; + Result.Key:=FData.Names[FCurrent]; + Result.Value:=FData.Items[FCurrent]; +end; + +function TJSONObjectEnumerator.MoveNext: Boolean; +begin + Inc(FCurrent); + Result:=FCurrentNil; +end; + + + +{ TJSONData } + +function TJSONData.GetAsUnicodeString: TJSONUnicodeStringType; + +begin + Result:=UTF8Decode(AsString); +end; + +procedure TJSONData.SetAsUnicodeString(const AValue: TJSONUnicodeStringType); + +begin + AsString:=UTF8Encode(AValue); +end; + +function TJSONData.GetItem(Index : Integer): TJSONData; +begin + Result:=nil; +end; + +function TJSONData.GetCount: Integer; +begin + Result:=0; +end; + +constructor TJSONData.Create; +begin + Clear; +end; + +procedure TJSONData.DumpJSON(S: TStream); + + Procedure W(T : String); + + begin + if (T<>'') then + S.WriteBuffer(T[1],Length(T)*SizeOf(Char)); + end; + +Var + I,C : Integer; + O : TJSONObject; + +begin + Case JSONType of + jtObject : + begin + O:=TJSONObject(Self); + W('{'); + For I:=0 to O.Count-1 do + begin + if (I>0) then + W(','); + W('"'); + W(StringToJSONString(O.Names[i])); + W('":'); + O.Items[I].DumpJSON(S); + end; + W('}'); + end; + jtArray : + begin + W('['); + For I:=0 to Count-1 do + begin + if (I>0) then + W(','); + Items[I].DumpJSON(S); + end; + W(']'); + end + else + W(AsJSON) + end; +end; + +class function TJSONData.GetCompressedJSON: Boolean; static; +begin + Result:=FCompressedJSON; +end; + +class procedure TJSONData.DetermineElementSeparators; + + +begin + FElementSep:=ElementSeps[FCompressedJSON]; +end; + +class procedure TJSONData.SetCompressedJSON(AValue: Boolean); static; + + +begin + if AValue=FCompressedJSON then exit; + FCompressedJSON:=AValue; + DetermineElementSeparators; + TJSONObject.DetermineElementQuotes; +end; + +class procedure TJSONData.DoError(const Msg: String); +begin + Raise EJSON.Create(Msg); +end; + +class procedure TJSONData.DoError(const Fmt: String; + const Args: array of const); +begin + Raise EJSON.CreateFmt(Fmt,Args); +end; + +function TJSONData.DoFindPath(const APath: TJSONStringType; out + NotFound: TJSONStringType): TJSONdata; +begin + If APath<>'' then + begin + NotFound:=APath; + Result:=Nil; + end + else + Result:=Self; +end; + +function TJSONData.GetIsNull: Boolean; +begin + Result:=False; +end; + +class function TJSONData.JSONType: TJSONType; +begin + JSONType:=jtUnknown; +end; + +function TJSONData.GetEnumerator: TBaseJSONEnumerator; +begin + Result:=TJSONEnumerator.Create(Self); +end; + +function TJSONData.FindPath(const APath: TJSONStringType): TJSONdata; + +Var + M : TJSONStringType; + +begin + Result:=DoFindPath(APath,M); +end; + +function TJSONData.GetPath(const APath: TJSONStringType): TJSONdata; + +Var + M : TJSONStringType; +begin + Result:=DoFindPath(APath,M); + If Result=Nil then + DoError(SErrPathElementNotFound,[APath,M]); +end; + +procedure TJSONData.SetItem(Index : Integer; const AValue: + TJSONData); +begin + // Do Nothing +end; + +function TJSONData.FormatJSON(Options: TFormatOptions; Indentsize: Integer + ): TJSONStringType; + +begin + Result:=DoFormatJSON(Options,0,IndentSize); +end; + +function TJSONData.DoFormatJSON(Options: TFormatOptions; CurrentIndent, + Indent: Integer): TJSONStringType; + +begin + Result:=AsJSON; +end; + +{ TJSONnumber } + +class function TJSONnumber.JSONType: TJSONType; +begin + Result:=jtNumber; +end; + + +{ TJSONstring } + +class function TJSONString.JSONType: TJSONType; +begin + Result:=jtString; +end; + +procedure TJSONString.Clear; +begin + FValue:=''; +end; + +function TJSONString.Clone: TJSONData; + +begin + Result:=TJSONStringClass(ClassType).Create(Self.FValue); +end; + +function TJSONString.GetValue: Variant; +begin + Result:=FValue; +end; + +procedure TJSONString.SetValue(const AValue: Variant); +begin + FValue:=AValue; +end; + + +function TJSONString.GetAsBoolean: Boolean; +begin + Result:=StrToBool(FValue); +end; + +function TJSONString.GetAsFloat: TJSONFloat; + +Var + C : Integer; + +begin + Val(FValue,Result,C); + If (C<>0) then + If Not TryStrToFloat(FValue,Result) then + Raise EConvertError.CreateFmt(SErrInvalidFloat,[FValue]); +end; + +function TJSONString.GetAsInteger: Integer; +begin + Result:=StrToInt(FValue); +end; + +function TJSONString.GetAsInt64: Int64; +begin + Result:=StrToInt64(FValue); +end; + +function TJSONString.GetAsQWord: QWord; +begin + Result:=StrToQWord(FValue); +end; + +procedure TJSONString.SetAsBoolean(const AValue: Boolean); +begin + FValue:=BoolToStr(AValue); +end; + +procedure TJSONString.SetAsFloat(const AValue: TJSONFloat); +begin + FValue:=FloatToStr(AValue); +end; + +procedure TJSONString.SetAsInteger(const AValue: Integer); +begin + FValue:=IntToStr(AValue); +end; + +procedure TJSONString.SetAsInt64(const AValue: Int64); +begin + FValue:=IntToStr(AValue); +end; + +procedure TJSONString.SetAsQword(const AValue: QWord); +begin + FValue:=IntToStr(AValue); +end; + +function TJSONString.GetAsJSON: TJSONStringType; +begin + Result:='"'+StringToJSONString(FValue)+'"'; +end; + +function TJSONString.GetAsString: TJSONStringType; +begin + Result:=FValue; +end; + +procedure TJSONString.SetAsString(const AValue: TJSONStringType); +begin + FValue:=AValue; +end; + +constructor TJSONString.Create(const AValue: TJSONStringType); +begin + FValue:=AValue; +end; + +constructor TJSONString.Create(const AValue: TJSONUnicodeStringType); +begin + FValue:=UTF8Encode(AValue); +end; + +{ TJSONboolean } + + +function TJSONBoolean.GetValue: Variant; +begin + Result:=FValue; +end; + +class function TJSONBoolean.JSONType: TJSONType; +begin + Result:=jtBoolean; +end; + +procedure TJSONBoolean.Clear; +begin + FValue:=False; +end; + +function TJSONBoolean.Clone: TJSONData; +begin + Result:=TJSONBooleanClass(Self.ClassType).Create(Self.Fvalue); +end; + + +procedure TJSONBoolean.SetValue(const AValue: Variant); +begin + FValue:=boolean(AValue); +end; + +function TJSONBoolean.GetAsBoolean: Boolean; +begin + Result:=FValue; +end; + +function TJSONBoolean.GetAsFloat: TJSONFloat; +begin + Result:=Ord(FValue); +end; + +function TJSONBoolean.GetAsInteger: Integer; +begin + Result:=Ord(FValue); +end; + +function TJSONBoolean.GetAsInt64: Int64; +begin + Result:=Ord(FValue); +end; + +function TJSONBoolean.GetAsQWord: QWord; +begin + Result:=Ord(FValue); +end; + +procedure TJSONBoolean.SetAsBoolean(const AValue: Boolean); +begin + FValue:=AValue; +end; + +procedure TJSONBoolean.SetAsFloat(const AValue: TJSONFloat); +begin + FValue:=(AValue<>0) +end; + +procedure TJSONBoolean.SetAsInteger(const AValue: Integer); +begin + FValue:=(AValue<>0) +end; + +procedure TJSONBoolean.SetAsInt64(const AValue: Int64); +begin + FValue:=(AValue<>0) +end; + +procedure TJSONBoolean.SetAsQword(const AValue: QWord); +begin + FValue:=(AValue<>0) +end; + +function TJSONBoolean.GetAsJSON: TJSONStringType; +begin + If FValue then + Result:='true' + else + Result:='false'; +end; + +function TJSONBoolean.GetAsString: TJSONStringType; +begin + Result:=BoolToStr(FValue, True); +end; + +procedure TJSONBoolean.SetAsString(const AValue: TJSONStringType); +begin + FValue:=StrToBool(AValue); +end; + + +constructor TJSONBoolean.Create(AValue: Boolean); +begin + FValue:=AValue; +end; + +{ TJSONnull } + +procedure TJSONNull.Converterror(From: Boolean); +begin + If From then + DoError(SErrCannotConvertFromNull) + else + DoError(SErrCannotConvertToNull); +end; + +{$warnings off} +function TJSONNull.GetAsBoolean: Boolean; +begin + ConvertError(True); +end; + +function TJSONNull.GetAsFloat: TJSONFloat; +begin + ConvertError(True); +end; + +function TJSONNull.GetAsInteger: Integer; +begin + ConvertError(True); +end; + +function TJSONNull.GetAsInt64: Int64; +begin + ConvertError(True); +end; + +function TJSONNull.GetAsQWord: QWord; +begin + ConvertError(True); +end; + +function TJSONNull.GetIsNull: Boolean; +begin + Result:=True; +end; + +procedure TJSONNull.SetAsBoolean(const AValue: Boolean); +begin + ConvertError(False); +end; + +procedure TJSONNull.SetAsFloat(const AValue: TJSONFloat); +begin + ConvertError(False); +end; + +procedure TJSONNull.SetAsInteger(const AValue: Integer); +begin + ConvertError(False); +end; + +procedure TJSONNull.SetAsInt64(const AValue: Int64); +begin + ConvertError(False); +end; + +procedure TJSONNull.SetAsQword(const AValue: QWord); +begin + ConvertError(False); +end; + +function TJSONNull.GetAsJSON: TJSONStringType; +begin + Result:='null'; +end; + +function TJSONNull.GetAsString: TJSONStringType; +begin + ConvertError(True); +end; + +procedure TJSONNull.SetAsString(const AValue: TJSONStringType); +begin + ConvertError(True); +end; + + +function TJSONNull.GetValue: variant; +begin + Result:=variants.Null; +end; + +procedure TJSONNull.SetValue(const AValue: variant); +begin + ConvertError(False); +end; + +class function TJSONNull.JSONType: TJSONType; +begin + Result:=jtNull; +end; + +procedure TJSONNull.Clear; +begin + // Do nothing +end; + +function TJSONNull.Clone: TJSONData; +begin + Result:=TJSONNullClass(Self.ClassType).Create; +end; + +{$warnings on} + + + +{ TJSONFloatNumber } + +function TJSONFloatNumber.GetAsBoolean: Boolean; +begin + Result:=(FValue<>0); +end; + +function TJSONFloatNumber.GetAsFloat: TJSONFloat; +begin + Result:=FValue; +end; + +function TJSONFloatNumber.GetAsInteger: Integer; +begin + Result:=Round(FValue); +end; + +function TJSONFloatNumber.GetAsInt64: Int64; +begin + Result:=Round(FValue); +end; + +function TJSONFloatNumber.GetAsQWord: QWord; +begin + Result:=Round(FValue); +end; + +procedure TJSONFloatNumber.SetAsBoolean(const AValue: Boolean); +begin + FValue:=Ord(AValue); +end; + +procedure TJSONFloatNumber.SetAsFloat(const AValue: TJSONFloat); +begin + FValue:=AValue; +end; + +procedure TJSONFloatNumber.SetAsInteger(const AValue: Integer); +begin + FValue:=AValue; +end; + +procedure TJSONFloatNumber.SetAsInt64(const AValue: Int64); +begin + FValue:=AValue; +end; + +procedure TJSONFloatNumber.SetAsQword(const AValue: QWord); +begin + FValue:=AValue; +end; + +function TJSONFloatNumber.GetAsJSON: TJSONStringType; +begin + Result:=AsString; +end; + +function TJSONFloatNumber.GetAsString: TJSONStringType; +begin + Str(FValue,Result); + // Str produces a ' ' in front where the - can go. + if (Result<>'') and (Result[1]=' ') then + Delete(Result,1,1); +end; + +procedure TJSONFloatNumber.SetAsString(const AValue: TJSONStringType); +Var + C : Integer; +begin + Val(AValue,FValue,C); + If (C<>0) then + Raise EConvertError.CreateFmt(SErrInvalidFloat,[AValue]); +end; + + +function TJSONFloatNumber.GetValue: variant; +begin + Result:=FValue; +end; + +procedure TJSONFloatNumber.SetValue(const AValue: variant); +begin + FValue:=AValue; +end; + +constructor TJSONFloatNumber.Create(AValue: TJSONFloat); +begin + FValue:=AValue; +end; + +class function TJSONFloatNumber.NumberType: TJSONNumberType; +begin + Result:=ntFloat; +end; + +procedure TJSONFloatNumber.Clear; +begin + FValue:=0; +end; + +function TJSONFloatNumber.Clone: TJSONData; + +begin + Result:=TJSONFloatNumberClass(ClassType).Create(Self.FValue); +end; + +{ TJSONIntegerNumber } + +function TJSONIntegerNumber.GetAsBoolean: Boolean; +begin + Result:=FValue<>0; +end; + +function TJSONIntegerNumber.GetAsFloat: TJSONFloat; +begin + Result:=Ord(FValue); +end; + +function TJSONIntegerNumber.GetAsInteger: Integer; +begin + Result:=FValue; +end; + +function TJSONIntegerNumber.GetAsInt64: Int64; +begin + Result:=FValue; +end; + +function TJSONIntegerNumber.GetAsQWord: QWord; +begin + result:=FValue; +end; + +procedure TJSONIntegerNumber.SetAsBoolean(const AValue: Boolean); +begin + FValue:=Ord(AValue); +end; + +procedure TJSONIntegerNumber.SetAsFloat(const AValue: TJSONFloat); +begin + FValue:=Round(AValue); +end; + +procedure TJSONIntegerNumber.SetAsInteger(const AValue: Integer); +begin + FValue:=AValue; +end; + +procedure TJSONIntegerNumber.SetAsInt64(const AValue: Int64); +begin + FValue:=AValue; +end; + +procedure TJSONIntegerNumber.SetAsQword(const AValue: QWord); +begin + FValue:=AValue; +end; + +function TJSONIntegerNumber.GetAsJSON: TJSONStringType; +begin + Result:=AsString; +end; + +function TJSONIntegerNumber.GetAsString: TJSONStringType; +begin + Result:=IntToStr(FValue) +end; + +procedure TJSONIntegerNumber.SetAsString(const AValue: TJSONStringType); +begin + FValue:=StrToInt(AValue); +end; + + +function TJSONIntegerNumber.GetValue: variant; +begin + Result:=FValue; +end; + +procedure TJSONIntegerNumber.SetValue(const AValue: variant); +begin + FValue:=AValue; +end; + +constructor TJSONIntegerNumber.Create(AValue: Integer); +begin + FValue:=AValue; +end; + +class function TJSONIntegerNumber.NumberType: TJSONNumberType; +begin + Result:=ntInteger; +end; + +procedure TJSONIntegerNumber.Clear; +begin + FValue:=0; +end; + +function TJSONIntegerNumber.Clone: TJSONData; + +begin + Result:=TJSONIntegerNumberClass(ClassType).Create(Self.FValue); +end; + +{ TJSONInt64Number } + +function TJSONInt64Number.GetAsInt64: Int64; +begin + Result := FValue; +end; + +function TJSONInt64Number.GetAsQWord: QWord; +begin + Result := FValue; +end; + +procedure TJSONInt64Number.SetAsInt64(const AValue: Int64); +begin + FValue := AValue; +end; + +procedure TJSONInt64Number.SetAsQword(const AValue: QWord); +begin + FValue := AValue; +end; + +function TJSONInt64Number.GetAsBoolean: Boolean; +begin + Result:=FValue<>0; +end; + +function TJSONInt64Number.GetAsFloat: TJSONFloat; +begin + Result:= FValue; +end; + +function TJSONInt64Number.GetAsInteger: Integer; +begin + Result := FValue; +end; + +procedure TJSONInt64Number.SetAsBoolean(const AValue: Boolean); +begin + FValue:=Ord(AValue); +end; + +procedure TJSONInt64Number.SetAsFloat(const AValue: TJSONFloat); +begin + FValue:=Round(AValue); +end; + +procedure TJSONInt64Number.SetAsInteger(const AValue: Integer); +begin + FValue:=AValue; +end; + +function TJSONInt64Number.GetAsJSON: TJSONStringType; +begin + Result:=AsString; +end; + +function TJSONInt64Number.GetAsString: TJSONStringType; +begin + Result:=IntToStr(FValue) +end; + +procedure TJSONInt64Number.SetAsString(const AValue: TJSONStringType); +begin + FValue:=StrToInt64(AValue); +end; + +function TJSONInt64Number.GetValue: variant; +begin + Result:=FValue; +end; + +procedure TJSONInt64Number.SetValue(const AValue: variant); +begin + FValue:=AValue; +end; + +constructor TJSONInt64Number.Create(AValue: Int64); +begin + FValue := AValue; +end; + +class function TJSONInt64Number.NumberType: TJSONNumberType; +begin + Result:=ntInt64; +end; + +procedure TJSONInt64Number.Clear; +begin + FValue:=0; +end; + +function TJSONInt64Number.Clone: TJSONData; + +begin + Result:=TJSONInt64NumberClass(ClassType).Create(Self.FValue); +end; + +{ TJSONArray } + +function TJSONArray.GetBooleans(Index : Integer): Boolean; +begin + Result:=Items[Index].AsBoolean; +end; + +function TJSONArray.GetArrays(Index : Integer): TJSONArray; +begin + Result:=Items[Index] as TJSONArray; +end; + +function TJSONArray.GetFloats(Index : Integer): TJSONFloat; +begin + Result:=Items[Index].AsFloat; +end; + +function TJSONArray.GetIntegers(Index : Integer): Integer; +begin + Result:=Items[Index].AsInteger; +end; + +function TJSONArray.GetInt64s(Index : Integer): Int64; +begin + Result:=Items[Index].AsInt64; +end; + +function TJSONArray.GetNulls(Index : Integer): Boolean; +begin + Result:=Items[Index].IsNull; +end; + +function TJSONArray.GetObjects(Index : Integer): TJSONObject; +begin + Result:=Items[Index] as TJSONObject; +end; + +function TJSONArray.GetQWords(Index : Integer): QWord; +begin + Result:=Items[Index].AsQWord; +end; + +function TJSONArray.GetStrings(Index : Integer): TJSONStringType; +begin + Result:=Items[Index].AsString; +end; + +function TJSONArray.GetUnicodeStrings(Index : Integer): TJSONUnicodeStringType; +begin + Result:=Items[Index].AsUnicodeString; +end; + +function TJSONArray.GetTypes(Index : Integer): TJSONType; +begin + Result:=Items[Index].JSONType; +end; + +procedure TJSONArray.SetArrays(Index : Integer; const AValue: TJSONArray); +begin + Items[Index]:=AValue; +end; + +procedure TJSONArray.SetBooleans(Index : Integer; const AValue: Boolean); + +begin + Items[Index]:=CreateJSON(AValue); +end; + +procedure TJSONArray.SetFloats(Index : Integer; const AValue: TJSONFloat); +begin + Items[Index]:=CreateJSON(AValue); +end; + +procedure TJSONArray.SetIntegers(Index : Integer; const AValue: Integer); +begin + Items[Index]:=CreateJSON(AValue); +end; + +procedure TJSONArray.SetInt64s(Index : Integer; const AValue: Int64); +begin + Items[Index]:=CreateJSON(AValue); +end; + +procedure TJSONArray.SetObjects(Index : Integer; const AValue: TJSONObject); +begin + Items[Index]:=AValue; +end; + +procedure TJSONArray.SetQWords(Index : Integer; AValue: QWord); +begin + Items[Index]:=CreateJSON(AValue); +end; + +procedure TJSONArray.SetStrings(Index : Integer; const AValue: TJSONStringType); +begin + Items[Index]:=CreateJSON(AValue); +end; + +procedure TJSONArray.SetUnicodeStrings(Index: Integer; + const AValue: TJSONUnicodeStringType); +begin + Items[Index]:=CreateJSON(AValue); +end; + +function TJSONArray.DoFindPath(const APath: TJSONStringType; out + NotFound: TJSONStringType): TJSONdata; + +Var + P,I : integer; + E : String; + +begin + if (APath<>'') and (APath[1]='[') then + begin + P:=Pos(']',APath); + I:=-1; + If (P>2) then + I:=StrToIntDef(Copy(APath,2,P-2),-1); + If (I>=0) and (I0) then + NotFound:=Copy(APath,1,P) + else + NotFound:=APath; + end; + end + else + Result:=inherited DoFindPath(APath, NotFound); +end; + +procedure TJSONArray.Converterror(From: Boolean); +begin + If From then + DoError(SErrCannotConvertFromArray) + else + DoError(SErrCannotConvertToArray); +end; + +{$warnings off} +function TJSONArray.GetAsBoolean: Boolean; +begin + ConvertError(True); +end; + +function TJSONArray.GetAsFloat: TJSONFloat; +begin + ConvertError(True); +end; + +function TJSONArray.GetAsInteger: Integer; +begin + ConvertError(True); +end; + +function TJSONArray.GetAsInt64: Int64; +begin + ConvertError(True); +end; + +function TJSONArray.GetAsQWord: QWord; +begin + ConvertError(True); +end; + +procedure TJSONArray.SetAsBoolean(const AValue: Boolean); +begin + ConvertError(False); +end; + +procedure TJSONArray.SetAsFloat(const AValue: TJSONFloat); +begin + ConvertError(False); +end; + +procedure TJSONArray.SetAsInteger(const AValue: Integer); +begin + ConvertError(False); +end; + +procedure TJSONArray.SetAsInt64(const AValue: Int64); +begin + ConvertError(False); +end; + +procedure TJSONArray.SetAsQword(const AValue: QWord); +begin + ConvertError(False); +end; + +{$warnings on} + + +function TJSONArray.GetAsJSON: TJSONStringType; + +Var + I : Integer; + Sep : String; + +begin + Sep:=TJSONData.FElementSep; + Result:='['; + For I:=0 to Count-1 do + begin + Result:=Result+Items[i].AsJSON; + If (INil) then + TJSONData.DoError(SErrPointerNotNil,[SourceType]) + else + Result:=CreateJSON(); + vtCurrency : Result:=CreateJSON(vCurrency^); + vtInt64 : Result:=CreateJSON(vInt64^); + vtObject : if (VObject is TJSONData) then + Result:=TJSONData(VObject) + else + TJSONData.DoError(SErrNotJSONData,[VObject.ClassName,SourceType]); + //vtVariant : + else + TJSONData.DoError(SErrUnknownTypeInConstructor,[SourceType,VType]) + end; +end; + +constructor TJSONArray.Create(const Elements: array of const); + +Var + I : integer; + J : TJSONData; + +begin + Create; + For I:=Low(Elements) to High(Elements) do + begin + J:=VarRecToJSON(Elements[i],'Array'); + Add(J); + end; +end; + +destructor TJSONArray.Destroy; +begin + FreeAndNil(FList); + inherited Destroy; +end; + +class function TJSONArray.JSONType: TJSONType; +begin + Result:=jtArray; +end; + +function TJSONArray.Clone: TJSONData; + +Var + A : TJSONArray; + I : Integer; + +begin + A:=TJSONArrayClass(ClassType).Create; + try + For I:=0 to Count-1 do + A.Add(Self.Items[I].Clone); + Result:=A; + except + A.Free; + Raise; + end; +end; + +procedure TJSONArray.Iterate(Iterator: TJSONArrayIterator; Data: TObject); + +Var + I : Integer; + Cont : Boolean; + +begin + I:=0; + Cont:=True; + While (I-1) then + DoError(SErrCannotAddArrayTwice); + Result:=Add(TJSONData(AnArray)); +end; + +function TJSONArray.Add(AnObject: TJSONObject): Integer; +begin + If (IndexOf(AnObject)<>-1) then + DoError(SErrCannotAddObjectTwice); + Result:=Add(TJSONData(AnObject)); +end; + +procedure TJSONArray.Delete(Index: Integer); +begin + FList.Delete(Index); +end; + +procedure TJSONArray.Exchange(Index1, Index2: Integer); +begin + FList.Exchange(Index1, Index2); +end; + +function TJSONArray.Extract(Item: TJSONData): TJSONData; +begin + Result := TJSONData(FList.Extract(Item)); +end; + +function TJSONArray.Extract(Index: Integer): TJSONData; +begin + Result := TJSONData(FList.Extract(FList.Items[Index])); +end; + +procedure TJSONArray.Insert(Index: Integer); +begin + Insert(Index,CreateJSON); +end; + +procedure TJSONArray.Insert(Index: Integer; Item: TJSONData); +begin + FList.Insert(Index, Item); +end; + +procedure TJSONArray.Insert(Index: Integer; I: Integer); +begin + FList.Insert(Index, CreateJSON(I)); +end; + +procedure TJSONArray.Insert(Index: Integer; I: Int64); +begin + FList.Insert(Index, CreateJSON(I)); +end; + +procedure TJSONArray.Insert(Index: Integer; I: QWord); +begin + FList.Insert(Index, CreateJSON(I)); +end; + +procedure TJSONArray.Insert(Index: Integer; const S: String); +begin + FList.Insert(Index, CreateJSON(S)); +end; + +procedure TJSONArray.Insert(Index: Integer; const S: UnicodeString); +begin + FList.Insert(Index, CreateJSON(S)); +end; + +procedure TJSONArray.Insert(Index: Integer; F: TJSONFloat); +begin + FList.Insert(Index, CreateJSON(F)); +end; + +procedure TJSONArray.Insert(Index: Integer; B: Boolean); +begin + FList.Insert(Index, CreateJSON(B)); +end; + +procedure TJSONArray.Insert(Index: Integer; AnArray: TJSONArray); +begin + if (IndexOf(AnArray)<>-1) then + DoError(SErrCannotAddArrayTwice); + FList.Insert(Index, AnArray); +end; + +procedure TJSONArray.Insert(Index: Integer; AnObject: TJSONObject); +begin + if (IndexOf(AnObject)<>-1) then + DoError(SErrCannotAddObjectTwice); + FList.Insert(Index, AnObject); +end; + +procedure TJSONArray.Move(CurIndex, NewIndex: Integer); +begin + FList.Move(CurIndex, NewIndex); +end; + +procedure TJSONArray.Remove(Item: TJSONData); +begin + FList.Remove(Item); +end; + +procedure TJSONArray.Sort(Compare: TListSortCompare); +begin + FList.Sort(Compare); +end; + +{ TJSONObject } + +function TJSONObject.GetArrays(const AName: String): TJSONArray; +begin + Result:=GetElements(AName) as TJSONArray; +end; + +function TJSONObject.GetBooleans(const AName: String): Boolean; +begin + Result:=GetElements(AName).AsBoolean; +end; + +function TJSONObject.GetElements(const AName: string): TJSONData; +begin + Result:=TJSONData(FHash.Find(AName)); + If (Result=Nil) then + DoError(SErrNonexistentElement,[AName]); +end; + +function TJSONObject.GetFloats(const AName: String): TJSONFloat; +begin + Result:=GetElements(AName).AsFloat; +end; + +function TJSONObject.GetIntegers(const AName: String): Integer; +begin + Result:=GetElements(AName).AsInteger; +end; + +function TJSONObject.GetInt64s(const AName: String): Int64; +begin + Result:=GetElements(AName).AsInt64; +end; + +function TJSONObject.GetIsNull(const AName: String): Boolean; +begin + Result:=GetElements(AName).IsNull; +end; + +function TJSONObject.GetNameOf(Index: Integer): TJSONStringType; +begin + Result:=FHash.NameOfIndex(Index); +end; + +function TJSONObject.GetObjects(const AName : String): TJSONObject; +begin + Result:=GetElements(AName) as TJSONObject; +end; + +function TJSONObject.GetQWords(AName : String): QWord; +begin + Result:=GetElements(AName).AsQWord; +end; + +function TJSONObject.GetStrings(const AName : String): TJSONStringType; +begin + Result:=GetElements(AName).AsString; +end; + +function TJSONObject.GetUnicodeStrings(const AName: String + ): TJSONUnicodeStringType; +begin + Result:=GetElements(AName).AsUnicodeString; +end; + +function TJSONObject.GetTypes(const AName : String): TJSONType; +begin + Result:=Getelements(Aname).JSONType; +end; + +class function TJSONObject.GetUnquotedMemberNames: Boolean; static; +begin + Result:=FUnquotedMemberNames; +end; + +procedure TJSONObject.SetArrays(const AName : String; const AValue: TJSONArray); + +begin + SetElements(AName,AVAlue); +end; + +procedure TJSONObject.SetBooleans(const AName : String; const AValue: Boolean); +begin + SetElements(AName,CreateJSON(AVAlue)); +end; + +procedure TJSONObject.SetElements(const AName: string; const AValue: TJSONData); +Var + Index : Integer; + +begin + Index:=FHash.FindIndexOf(AName); + If (Index=-1) then + FHash.Add(AName,AValue) + else + FHash.Items[Index]:=AValue; // Will free the previous value. +end; + +procedure TJSONObject.SetFloats(const AName : String; const AValue: TJSONFloat); +begin + SetElements(AName,CreateJSON(AVAlue)); +end; + +procedure TJSONObject.SetIntegers(const AName : String; const AValue: Integer); +begin + SetElements(AName,CreateJSON(AVAlue)); +end; + +procedure TJSONObject.SetInt64s(const AName : String; const AValue: Int64); +begin + SetElements(AName,CreateJSON(AVAlue)); +end; + +procedure TJSONObject.SetIsNull(const AName : String; const AValue: Boolean); +begin + If Not AValue then + DoError(SErrCannotSetNotIsNull); + SetElements(AName,CreateJSON); +end; + +procedure TJSONObject.SetObjects(const AName : String; const AValue: TJSONObject); +begin + SetElements(AName,AValue); +end; + +procedure TJSONObject.SetQWords(AName : String; AValue: QWord); +begin + SetElements(AName,CreateJSON(AVAlue)); +end; + +procedure TJSONObject.SetStrings(const AName : String; const AValue: TJSONStringType); +begin + SetElements(AName,CreateJSON(AValue)); +end; + +procedure TJSONObject.SetUnicodeStrings(const AName: String; + const AValue: TJSONUnicodeStringType); +begin + SetElements(AName,CreateJSON(AValue)); +end; + +class procedure TJSONObject.DetermineElementQuotes; + +begin + FObjStartSep:=ObjStartSeps[TJSONData.FCompressedJSON]; + FObjEndSep:=ObjEndSeps[TJSONData.FCompressedJSON]; + if TJSONData.FCompressedJSON then + FElementEnd:=UnSpacedQuoted[FUnquotedMemberNames] + else + FElementEnd:=SpacedQuoted[FUnquotedMemberNames]; + FElementStart:=ElementStart[FUnquotedMemberNames] +end; + +class procedure TJSONObject.SetUnquotedMemberNames(AValue: Boolean); static; + +begin + if FUnquotedMemberNames=AValue then exit; + FUnquotedMemberNames:=AValue; + DetermineElementQuotes; +end; + +function TJSONObject.DoFindPath(const APath: TJSONStringType; out + NotFound: TJSONStringType): TJSONdata; + +Var + N: TJSONStringType; + L,P,P2 : Integer; + +begin + If (APath='') then + Exit(Self); + N:=APath; + L:=Length(N); + P:=1; + While (P'') then + Result:=Result+Sep; + Result:=Result+FElementStart+StringToJSONString(Names[i])+FElementEnd+Items[I].AsJSON; + end; + If (Result<>'') then + Result:=FObjStartSep+Result+FObjEndSep + else + Result:='{}'; +end; + +{$warnings off} +function TJSONObject.GetAsString: TJSONStringType; +begin + ConvertError(True); +end; + +procedure TJSONObject.SetAsString(const AValue: TJSONStringType); +begin + ConvertError(False); +end; + +function TJSONObject.GetValue: variant; +begin + ConvertError(True); +end; + +procedure TJSONObject.SetValue(const AValue: variant); +begin + ConvertError(False); +end; +{$warnings on} + +function TJSONObject.GetCount: Integer; +begin + Result:=FHash.Count; +end; + +function TJSONObject.GetItem(Index: Integer): TJSONData; +begin + Result:=TJSONData(FHash.Items[Index]); +end; + +procedure TJSONObject.SetItem(Index: Integer; const AValue: TJSONData); +begin + FHash.Items[Index]:=AValue; +end; + +constructor TJSONObject.Create; +begin + FHash:=TFPHashObjectList.Create(True); +end; + + + +constructor TJSONObject.Create(const Elements: array of const); + +Var + I : integer; + AName : String; + J : TJSONData; + +begin + Create; + If ((High(Elements)-Low(Elements)) mod 2)=0 then + DoError(SErrOddNumber); + I:=Low(Elements); + While I<=High(Elements) do + begin + With Elements[i] do + Case VType of + vtChar : AName:=VChar; + vtString : AName:=vString^; + vtAnsiString : AName:=(AnsiString(vAnsiString)); + vtPChar : AName:=StrPas(VPChar); + else + DoError(SErrNameMustBeString,[I+1]); + end; + If (ANAme='') then + DoError(SErrNameMustBeString,[I+1]); + Inc(I); + J:=VarRecToJSON(Elements[i],'Object'); + Add(AName,J); + Inc(I); + end; +end; + + +destructor TJSONObject.Destroy; +begin + FreeAndNil(FHash); + inherited Destroy; +end; + +class function TJSONObject.JSONType: TJSONType; +begin + Result:=jtObject; +end; + +function TJSONObject.Clone: TJSONData; + +Var + O : TJSONObject; + I: Integer; + +begin + O:=TJSONObjectClass(ClassType).Create; + try + For I:=0 to Count-1 do + O.Add(Self.Names[I],Self.Items[I].Clone); + Result:=O; + except + FreeAndNil(O); + Raise; + end; +end; + +function TJSONObject.GetEnumerator: TBaseJSONEnumerator; +begin + Result:=TJSONObjectEnumerator.Create(Self); +end; + + +function TJSONObject.DoFormatJSON(Options: TFormatOptions; CurrentIndent, + Indent: Integer): TJSONStringType; + +Var + i : Integer; + S : TJSONStringType; + MultiLine,UseQuotes, SkipWhiteSpace : Boolean; + NSep,Sep,Ind : String; +begin + Result:=''; + UseQuotes:=Not (foDoNotQuoteMembers in options); + MultiLine:=Not (foSingleLineObject in Options); + SkipWhiteSpace:=foSkipWhiteSpace in Options; + CurrentIndent:=CurrentIndent+Indent; + Ind:=IndentString(Options, CurrentIndent); + If SkipWhiteSpace then + NSep:=':' + else + NSep:=' : '; + If MultiLine then + Sep:=','+SLineBreak+Ind + else if SkipWhiteSpace then + Sep:=',' + else + Sep:=', '; + For I:=0 to Count-1 do + begin + If (I>0) then + Result:=Result+Sep + else If MultiLine then + Result:=Result+Ind; + S:=StringToJSONString(Names[i]); + If UseQuotes then + S:='"'+S+'"'; + Result:=Result+S+NSep+Items[I].DoFormatJSON(Options,CurrentIndent,Indent); + end; + If (Result<>'') then + begin + if MultiLine then + Result:='{'+sLineBreak+Result+sLineBreak+indentString(options,CurrentIndent-Indent)+'}' + else + Result:=ObjStartSeps[SkipWhiteSpace]+Result+ObjEndSeps[SkipWhiteSpace] + end + else + Result:='{}'; +end; + +procedure TJSONObject.Iterate(Iterator: TJSONObjectIterator; Data: TObject); + +Var + I : Integer; + Cont : Boolean; + +begin + I:=0; + Cont:=True; + While (I=0) and (CompareText(Names[Result],AName)<>0) do + Dec(Result); + end; +end; + +procedure TJSONObject.Clear; +begin + FHash.Clear; +end; + +function TJSONObject.Add(const AName: TJSONStringType; AValue: TJSONData + ): Integer; +begin + Result:=FHash.Add(AName,AValue); +end; + +function TJSONObject.Add(const AName: TJSONStringType; AValue: Boolean + ): Integer; +begin + Result:=Add(AName,CreateJSON(AValue)); +end; + +function TJSONObject.Add(const AName: TJSONStringType; AValue: TJSONFloat): Integer; +begin + Result:=Add(AName,CreateJSON(AValue)); +end; + +function TJSONObject.Add(const AName, AValue: TJSONStringType): Integer; +begin + Result:=Add(AName,CreateJSON(AValue)); +end; + +function TJSONObject.Add(const AName: String; AValue: TJSONUnicodeStringType + ): Integer; +begin + Result:=Add(AName,CreateJSON(AValue)); +end; + +function TJSONObject.Add(const AName: TJSONStringType; Avalue: Integer): Integer; +begin + Result:=Add(AName,CreateJSON(AValue)); +end; + +function TJSONObject.Add(const AName: TJSONStringType; Avalue: Int64): Integer; +begin + Result:=Add(AName,CreateJSON(AValue)); +end; + +function TJSONObject.Add(const AName: TJSONStringType; Avalue: QWord): Integer; +begin + Result:=Add(AName,CreateJSON(AValue)); +end; + +function TJSONObject.Add(const AName: TJSONStringType): Integer; +begin + Result:=Add(AName,CreateJSON); +end; + +function TJSONObject.Add(const AName: TJSONStringType; AValue: TJSONArray + ): Integer; +begin + Result:=Add(AName,TJSONData(AValue)); +end; + +procedure TJSONObject.Delete(Index: Integer); +begin + FHash.Delete(Index); +end; + +procedure TJSONObject.Delete(const AName: string); + +Var + I : Integer; + +begin + I:=IndexOfName(AName); + if (I<>-1) then + Delete(I); +end; + +procedure TJSONObject.Remove(Item: TJSONData); +begin + FHash.Remove(Item); +end; + +function TJSONObject.Extract(Index: Integer): TJSONData; +begin + Result:=Items[Index]; + FHash.Extract(Result); +end; + +function TJSONObject.Extract(const AName: string): TJSONData; + +Var + I : Integer; + +begin + I:=IndexOfName(AName); + if (I<>-1) then + Result:=Extract(I) + else + Result:=Nil +end; + +function TJSONObject.Get(const AName: String): Variant; +Var + I : Integer; + +begin + I:=IndexOfName(AName); + If (I<>-1) then + Result:=Items[i].Value + else + Result:=Null; +end; + +function TJSONObject.Get(const AName: String; ADefault: TJSONFloat + ): TJSONFloat; + +Var + D : TJSONData; + +begin + D:=Find(AName,jtNumber); + If D<>Nil then + Result:=D.AsFloat + else + Result:=ADefault; +end; + +function TJSONObject.Get(const AName: String; ADefault: Integer + ): Integer; + +Var + D : TJSONData; + +begin + D:=Find(AName,jtNumber); + If D<>Nil then + Result:=D.AsInteger + else + Result:=ADefault; +end; + +function TJSONObject.Get(const AName: String; ADefault: Int64): Int64; +Var + D : TJSONData; + +begin + D:=Find(AName,jtNumber); + If D<>Nil then + Result:=D.AsInt64 + else + Result:=ADefault; +end; + +function TJSONObject.Get(const AName: String; ADefault: QWord): QWord; +Var + D : TJSONData; + +begin + D:=Find(AName,jtNumber); + If D<>Nil then + Result:=D.AsQWord + else + Result:=ADefault; +end; + +function TJSONObject.Get(const AName: String; ADefault: Boolean + ): Boolean; +Var + D : TJSONData; + +begin + D:=Find(AName,jtBoolean); + If D<>Nil then + Result:=D.AsBoolean + else + Result:=ADefault; +end; + +function TJSONObject.Get(const AName: String; ADefault: TJSONStringType + ): TJSONStringType; +Var + D : TJSONData; + +begin + D:=Find(AName,jtString); + If (D<>Nil) then + Result:=D.AsString + else + Result:=ADefault; +end; + +function TJSONObject.Get(const AName: String; ADefault: TJSONUnicodeStringType + ): TJSONUnicodeStringType; +Var + D : TJSONData; + +begin + D:=Find(AName,jtString); + If (D<>Nil) then + Result:=D.AsUnicodeString + else + Result:=ADefault; +end; + +function TJSONObject.Get(const AName: String; ADefault: TJSONArray + ): TJSONArray; +Var + D : TJSONData; + +begin + D:=Find(AName,jtArray); + If (D<>Nil) then + Result:=TJSONArray(D) + else + Result:=ADefault; +end; + +function TJSONObject.Get(const AName: String; ADefault: TJSONObject + ): TJSONObject; +Var + D : TJSONData; + +begin + D:=Find(AName,jtObject); + If (D<>Nil) then + Result:=TJSONObject(D) + else + Result:=ADefault; +end; + +function TJSONObject.Find(const AName: String): TJSONData; + +Var + I : Integer; + +begin + I:=IndexOfName(AName); + If (I<>-1) then + Result:=Items[i] + else + Result:=Nil; +end; + +function TJSONObject.Find(const AName: String; AType: TJSONType): TJSONData; +begin + Result:=Find(AName); + If Assigned(Result) and (Result.JSONType<>AType) then + Result:=Nil; +end; + +initialization + // Need to force initialization; + TJSONData.DetermineElementSeparators; + TJSONObject.DetermineElementQuotes; +end. + diff --git a/etc/fcl-json/src/fpjsonrtti.pp b/etc/fcl-json/src/fpjsonrtti.pp new file mode 100644 index 00000000..e5381e07 --- /dev/null +++ b/etc/fcl-json/src/fpjsonrtti.pp @@ -0,0 +1,1119 @@ +unit fpjsonrtti; + +{$mode objfpc} + +interface + +uses + Classes, SysUtils, contnrs, typinfo, fpjson, rttiutils, jsonparser; + +Const + RFC3339DateTimeFormat = 'yyyy"-"mm"-"dd"T"hh":"nn":"ss'; + RFC3339DateTimeFormatMsec = RFC3339DateTimeFormat+'.zzz'; + + +Type + + TJSONStreamEvent = Procedure (Sender : TObject; AObject : TObject; JSON : TJSONObject) of object; + TJSONPropertyEvent = Procedure (Sender : TObject; AObject : TObject; Info : PPropInfo; var Res : TJSONData) of object; + + TJSONStreamOption = (jsoStreamChildren, // If set, children will be streamed in 'Children' Property + jsoEnumeratedAsInteger, // Write enumerated as integer. Default is string. + jsoSetAsString, // Write Set as a string. Default is an array. + jsoSetEnumeratedAsInteger, // Write enumerateds in set array as integers. + jsoSetBrackets, // Use brackets when creating set as array + jsoComponentsInline, // Always stream components inline. Default is to stream name, unless csSubcomponent in ComponentStyle + jsoTStringsAsArray, // Stream TStrings as an array of strings. Associated objects are not streamed. + jsoTStringsAsObject, // Stream TStrings as an object : string = { object } + jsoDateTimeAsString, // Format a TDateTime value as a string + jsoUseFormatString, // Use FormatString when creating JSON strings. + jsoCheckEmptyDateTime, // If TDateTime value is empty and jsoDateTimeAsString is used, 0 date returns empty string + jsoLegacyDateTime); // Set this to enable old date/time formatting. Current behaviour is to save date/time as a ISO 9601 value. + TJSONStreamOptions = Set of TJSONStreamOption; + + TJSONFiler = Class(TComponent) + Protected + Procedure Error(Const Msg : String); + Procedure Error(Const FMT : String; Args : Array of const); + end; + + { TJSONStreamer } + + TJSONStreamer = Class(TJSONFiler) + private + FAfterStreamObject: TJSONStreamEvent; + FBeforeStreamObject: TJSONStreamEvent; + FChildProperty: String; + FDateTimeFormat: String; + FOnStreamProperty: TJSONPropertyEvent; + FOptions: TJSONStreamOptions; + function GetChildProperty: String; + function IsChildStored: boolean; + function StreamChildren(AComp: TComponent): TJSONArray; + protected + function StreamClassProperty(Const AObject: TObject): TJSONData; virtual; + Function StreamProperty(Const AObject : TObject; Const PropertyName : String) : TJSONData; + Function StreamProperty(Const AObject : TObject; PropertyInfo : PPropInfo) : TJSONData; + Function FormatDateProp(const DateTime : TDateTime) : TJSONString; + Public + Constructor Create(AOwner : TComponent); override; + Destructor Destroy;override; + // + // Basic functions + // + // Use RTTI to stream object. + // If AObject is of type TStrings or TCollection, special treatment occurs: + // TStrings results in { Strings: [S,S,S] } or { Strings: { "S1" : O1, "S2" : O2 }} depending on Options. + // Collection results in { Items: [I,I,I] } + Function ObjectToJSON(Const AObject : TObject) : TJSONObject; + // Stream a collection - always returns an array + function StreamCollection(Const ACollection: TCollection): TJSONArray; + // Stream an objectlist - always returns an array + function StreamObjectList(Const AnObjectList: TObjectList): TJSONArray; + // Stream a TStrings instance as an array + function StreamTStringsArray(Const AStrings: TStrings): TJSONArray; + // Stream a TStrings instance as an object + function StreamTStringsObject(Const AStrings: TStrings): TJSONObject; + // Stream a TStrings instance. Takes into account Options. + function StreamTStrings(Const AStrings: TStrings): TJSONData; + // Stream a variant as JSON. + function StreamVariant(const Data: Variant): TJSONData; virtual; + // + // Some utility functions. + // + // Call ObjectToJSON and convert result to JSON String. + Function ObjectToJSONString(AObject : TObject) : TJSONStringType; + // Convert TSTrings to JSON string with array or Object. + Function StringsToJSON(Const Strings : TStrings; AsObject : Boolean = False) : TJSONStringType; + // Convert collection to JSON string + Function CollectionToJSON(Const ACollection : TCollection) : TJSONStringType; + // Convert variant to JSON String + Function VariantToJSON(Const Data : Variant) : TJSONStringType; + Published + // Format used when formatting DateTime values. Only used in conjunction with jsoDateTimeToString + Property DateTimeFormat : String Read FDateTimeFormat Write FDateTimeFormat; + // Options to use when streaming + Property Options : TJSONStreamOptions Read FOptions Write FOptions; + // Called before streaming an object with ObjectToJSON + Property BeforeStreamObject : TJSONStreamEvent Read FBeforeStreamObject Write FBeforeStreamObject; + // Called After streaming an object with ObjectToJSON + Property AfterStreamObject : TJSONStreamEvent Read FAfterStreamObject Write FAfterStreamObject; + // Called whenever a property was streamed. If Res is nil on return, no property is added. + Property OnStreamProperty : TJSONPropertyEvent Read FOnStreamProperty Write FOnStreamProperty; + // Property name to use when streaming child components. Default is "Children" + Property ChildProperty : String Read GetChildProperty Write FChildProperty Stored IsChildStored; + end; + + { TJSONDeStreamer } + TJSONRestorePropertyEvent = Procedure (Sender : TObject; AObject : TObject; Info : PPropInfo; AValue : TJSONData; Var Handled : Boolean) of object; + TJSONPropertyErrorEvent = Procedure (Sender : TObject; AObject : TObject; Info : PPropInfo; AValue : TJSONData; Error : Exception; Var Continue : Boolean) of object; + TJSONGetObjectEvent = Procedure (Sender : TOBject; AObject : TObject; Info : PPropInfo; AData : TJSONObject; DataName : TJSONStringType; Var AValue : TObject); + TJSONDestreamOption = (jdoCaseInsensitive,jdoIgnorePropertyErrors); + TJSONDestreamOptions = set of TJSONDestreamOption; + + TJSONDeStreamer = Class(TJSONFiler) + private + FAfterReadObject: TJSONStreamEvent; + FBeforeReadObject: TJSONStreamEvent; + FDateTimeFormat: String; + FOnGetObject: TJSONGetObjectEvent; + FOnPropError: TJSONpropertyErrorEvent; + FOnRestoreProp: TJSONRestorePropertyEvent; + FCaseInsensitive : Boolean; + FOptions: TJSONDestreamOptions; + procedure DeStreamClassProperty(AObject: TObject; PropInfo: PPropInfo; PropData: TJSONData); + function GetCaseInsensitive: Boolean; + procedure SetCaseInsensitive(AValue: Boolean); + protected + // Try to parse a date. + Function ExtractDateTime(S : String): TDateTime; + function GetObject(AInstance : TObject; const APropName: TJSONStringType; D: TJSONObject; PropInfo: PPropInfo): TObject; + procedure DoRestoreProperty(AObject: TObject; PropInfo: PPropInfo; PropData: TJSONData); virtual; + Function ObjectFromString(Const JSON : TJSONStringType) : TJSONData; virtual; + procedure RestoreProperty(AObject: TObject; PropInfo: PPropInfo; PropData: TJSONData); + Public + Constructor Create(AOwner : TComponent); override; + Destructor Destroy; override; + // Convert JSON object to properties of AObject + Procedure JSONToObject(Const JSON : TJSONStringType; AObject : TObject); + Procedure JSONToObject(Const JSON : TJSONObject; AObject : TObject); + // Convert JSON object/array to collection. + Procedure JSONToCollection(Const JSON : TJSONStringType; ACollection : TCollection); + Procedure JSONToCollection(Const JSON : TJSONData; ACollection : TCollection); + // Convert JSON array/object/string to TStrings + Procedure JSONToStrings(Const JSON : TJSONStringType; AStrings : TSTrings); + Procedure JSONToStrings(Const JSON : TJSONData; AStrings : TSTrings); + // Convert JSON data to a variant. Supports simple data types and arrays. + Function JSONToVariant(Data: TJSONData): Variant; + Function JSONToVariant(Data: TJSONStringType): Variant; + // Triggered at the start of each call to JSONToObject + Property BeforeReadObject : TJSONStreamEvent Read FBeforeReadObject Write FBeforeReadObject; + // Triggered at the end of each call to JSONToObject (not if exception happens) + Property AfterReadObject : TJSONStreamEvent Read FAfterReadObject Write FAfterReadObject; + // Called when a property will be restored. If 'Handled' is True on return, property is considered restored. + Property OnRestoreProperty : TJSONRestorePropertyEvent Read FOnRestoreProp Write FOnRestoreProp; + // Called when an error occurs when restoring a property. If Continue is False on return, exception is re-raised. + Property OnPropertyError : TJSONpropertyErrorEvent Read FOnPropError Write FOnPropError; + // Called when a object-typed property must be restored, and the property is Nil. Must return an instance for the property. + // Published Properties of the instance will be further restored with available data. + Property OngetObject : TJSONGetObjectEvent Read FOnGetObject Write FOnGetObject; + // JSON is by definition case sensitive. Should properties be looked up case-insentive ? + Property CaseInsensitive : Boolean Read GetCaseInsensitive Write SetCaseInsensitive ; deprecated; + // DateTime format. If not set, RFC3339DateTimeFormat is assumed. + // If set, it will be used as an argument to ScanDateTime. If that fails, StrToDateTime is used. + Property DateTimeFormat : String Read FDateTimeFormat Write FDateTimeFormat; + // Options overning the behaviour + Property Options : TJSONDestreamOptions Read FOptions Write FOptions; + end; + + EJSONRTTI = Class(Exception); + + +implementation + +uses dateutils, variants, rtlconsts; + +ResourceString + SErrUnknownPropertyKind = 'Unknown property kind for property : "%s"'; + SErrUnsupportedPropertyKind = 'Unsupported property kind for property: "%s"'; + SErrUnsupportedVariantType = 'Unsupported variant type : %d'; + SErrUnsupportedArrayType = 'JSON array cannot be streamed to object of class "%s"'; + SErrUnsupportedJSONType = 'Cannot destream object from JSON data of type "%s"'; + SErrUnsupportedCollectionType = 'Unsupported JSON type for collections: "%s"'; + SErrUnsupportedCollectionItemType = 'Array element %d is not a valid type for a collection item: "%s"'; + SErrUnsupportedStringsItemType = 'Array element %d is not a valid type for a stringlist item: "%s"'; + SErrUnsupportedStringsType = 'Unsupported JSON type for stringlists: "%s"'; + SErrUnsupportedStringsObjectType = 'Object Element %s is not a valid type for a stringlist object: "%s"'; + SErrUnSupportedEnumDataType = 'Unsupported JSON type for enumerated property "%s" : "%s"'; + SErrUnsupportedVariantJSONType = 'Unsupported JSON type for variant value : "%s"'; + SErrUnsupportedObjectData = 'Unsupported JSON type for object property: "%s"'; + +{ TStreamChildrenHelper } + +Type + TSet = set of 0..31; // Used to (de)stream set properties. + + TStreamChildrenHelper = Class + Private + FChildren : TJSONArray; + FStreamer:TJSONStreamer; + procedure StreamChild(AChild: TComponent); + public + Function StreamChildren(AComponent : TComponent; AStreamer : TJSONStreamer): TJSONArray; + end; + + THackComponent = Class(TComponent); + +{ TJSONDeStreamer } + +function TJSONDeStreamer.ObjectFromString(const JSON: TJSONStringType): TJSONData; + +begin + With TJSONParser.Create(JSON) do + try + Result:=Parse; + finally + Free; + end; +end; + +constructor TJSONDeStreamer.Create(AOwner: TComponent); +begin + inherited Create(AOwner); +end; + +destructor TJSONDeStreamer.Destroy; +begin + inherited Destroy; +end; + +procedure TJSONDeStreamer.JSONToObject(const JSON: TJSONStringType; + AObject: TObject); + +Var + D : TJSONData; + +begin + D:=ObjectFromString(JSON); + try + If D.JSONType=jtObject then + JSONToObject(D as TJSONObject,AObject) + else if D.JSONType=jtArray then + begin + If AObject is TStrings then + JSONToStrings(D,AObject as TSTrings) + else if AObject is TCollection then + JSONTOCollection(D,AObject as TCollection) + else + Error(SErrUnsupportedArrayType,[AObject.ClassName]) + end + else if (D.JSONType=jtString) and (AObject is TStrings) then + JSONToStrings(D,AObject as TStrings) + else + Error(SErrUnsupportedJSONType,[JSONTypeName(D.JSONType)]); + finally + FreeAndNil(D); + end; +end; + +function TJSONDeStreamer.JSONToVariant(Data: TJSONData): Variant; + +Var + I : integer; + +begin + Case Data.JSONType of + jtNumber : + Case TJSONNumber(Data).NumberType of + ntFloat : Result:=Data.AsFloat; + ntInteger : Result:=Data.AsInteger; + ntInt64 : Result:=Data.Asint64; + ntQWord : Result:=Data.AsQWord; + end; + jtString : + Result:=Data.AsString; + jtBoolean: + Result:=Data.AsBoolean; + jtNull: + Result:=Null; + jtArray : + begin + Result:=VarArrayCreate([0,Data.Count-1],varVariant); + For I:=0 to Data.Count-1 do + Result[i]:=JSONToVariant(Data.Items[i]); + end; + else + Error(SErrUnsupportedVariantJSONType,[GetEnumName(TypeInfo(TJSONType),Ord(Data.JSONType))]); + end; +end; + +function TJSONDeStreamer.JSONToVariant(Data: TJSONStringType): Variant; + +Var + D : TJSONData; + +begin + D:=ObjectFromString(Data); + try + Result:=JSONToVariant(D); + finally + D.Free; + end; +end; + +procedure TJSONDeStreamer.DeStreamClassProperty(AObject : TObject;PropInfo : PPropInfo; PropData : TJSONData); + +Var + O : TObject; + +begin + O:=GetObjectProp(AObject,PropInfo); + If O is TStrings then + JSONToStrings(PropData,O as TStrings) + else if (O is TCollection) then + JSONToCollection(PropData,O as TCollection) + else + begin + If (O=Nil) then + begin + If (PropData.JSONType=jtString) then + O:=GetObject(AObject,PropData.AsString,Nil,PropInfo) + else if (PropData.JSONType=jtObject) then + O:=GetObject(AObject,'',PropData as TJSONObject,PropInfo) + else + Error(SErrUnsupportedObjectData,[JsonTypeName(PropData.JSONType){GetEnumName(TypeInfo(TJSONType),Ord(PropData.JSONType))}]); + SetObjectProp(AObject,PropInfo,O); + end; + If (O<>Nil) and (PropData.JSONType=jtObject) then + JSONToObject(PropData as TJSONObject,O); + end; +end; + +function TJSONDeStreamer.GetCaseInsensitive: Boolean; +begin + Result:=jdoCaseInsensitive in Options; +end; + +procedure TJSONDeStreamer.SetCaseInsensitive(AValue: Boolean); +begin + if AValue then + Include(Foptions,jdoCaseInsensitive) + else + Exclude(Foptions,jdoCaseInsensitive); +end; + +function TJSONDeStreamer.ExtractDateTime(S: String): TDateTime; + +Var + Fmt : String; + E,fmtSpecified : Boolean; + +begin + E:=False; + FMT:=DateTimeFormat; + fmtSpecified:=Fmt<>''; + if Not fmtSpecified then + FMT:=RFC3339DateTimeFormat; + Try + // No TryScanDateTime + Result:=ScanDatetime(FMT,S); + except + if fmtSpecified then + Raise + else + E:=True; + end; + if E then + if not TryStrToDateTime(S,Result) then + if not TryStrToDate(S,Result) then + if not TryStrToTime(S,Result) then + Raise EConvertError.CreateFmt(SInvalidDateTime,[S]); +// ExtractDateTime(PropData.AsString) +end; + +procedure TJSONDeStreamer.RestoreProperty(AObject : TObject;PropInfo : PPropInfo; PropData : TJSONData); + +Var + B : Boolean; + +begin + try + B:=Not Assigned(FOnRestoreProp); + If Not B then + begin + FOnRestoreProp(Self,AObject,PropInfo,PropData,B); + If B then + exit; + end; + DoRestoreProperty(AObject,PropInfo,PropData); + except + On E : Exception do + If Assigned(FOnPropError) then + begin + B:=False; + FOnPropError(Self,AObject,PropInfo,PropData,E,B); + If Not B then + Raise; + end + else if Not (jdoIgnorePropertyErrors in Options) then + Raise; + end; +end; + +procedure TJSONDeStreamer.DoRestoreProperty(AObject : TObject;PropInfo : PPropInfo; PropData : TJSONData); + +Var + PI : PPropInfo; + TI : PTypeInfo; + I,J,S : Integer; + D : Double; + A : TJSONArray; + JS : TJSONStringType; +begin + PI:=PropInfo; + TI:=PropInfo^.PropType; + case TI^.Kind of + tkUnknown : + Error(SErrUnknownPropertyKind,[PI^.Name]); + tkInteger : + SetOrdProp(AObject,PI,PropData.AsInteger); + tkInt64 : + SetOrdProp(AObject,PI,PropData.AsInt64); + tkEnumeration : + begin + if (PropData.JSONType=jtNumber) then + I:=PropData.AsInteger + else if PropData.JSONType=jtString then + I:=GetEnumValue(TI,PropData.AsString) + else + Error(SErrUnSupportedEnumDataType,[PI^.Name,GetEnumName(TypeInfo(TJSONType),Ord(PropData.JSONType))]); + SetOrdProp(AObject,PI,I); + end; + tkFloat : + begin + if (TI=TypeInfo(TDateTime)) and (PropData.JSONType=jtString) then + SetFloatProp(AObject,PI,ExtractDateTime(PropData.AsString)) + else + SetFloatProp(AObject,PI,PropData.AsFloat) + end; + tkSet : + If PropData.JSONType=jtString then + SetSetProp(AObject,PI,PropData.AsString) + else if (PropData.JSONType=jtArray) then + begin + A:=PropData as TJSONArray; + TI:=GetTypeData(TI)^.CompType; + S:=0; + For I:=0 to A.Count-1 do + begin + if A.types[i]=jtNumber then + J:=A.Integers[i] + else + J:=GetEnumValue(TI,A.strings[i]); + TSet(S):=TSet(S)+[j]; + end; + SetOrdProp(AObject,PI,S); + end; + tkChar: + begin + JS:=PropData.AsString; + If (JS<>'') then + SetOrdProp(AObject,PI,Ord(JS[1])); + end; + tkSString, + tkLString, + tkAString: + SetStrProp(AObject,PI,PropData.AsString); + tkWString : + SetWideStrProp(AObject,PI,PropData.AsUnicodeString); + tkVariant: + SetVariantProp(AObject,PI,JSONToVariant(PropData)); + tkClass: + DeStreamClassProperty(AObject,PI,PropData); + tkWChar : + begin + JS:=PropData.asString; + If (JS<>'') then + SetOrdProp(AObject,PI,Ord(JS[1])); + end; + tkBool : + SetOrdProp(AObject,PI,Ord(PropData.AsBoolean)); + tkQWord : + SetOrdProp(AObject,PI,Trunc(PropData.AsFloat)); + tkObject, + tkArray, + tkRecord, + tkInterface, + tkDynArray, + tkInterfaceRaw, + tkProcVar, + tkMethod : + Error(SErrUnsupportedPropertyKind,[PI^.Name]); + tkUString : + SetUnicodeStrProp(AObject,PI,PropData.AsUnicodeString); + tkUChar: + begin + JS:=PropData.asString; + If (JS<>'') then + SetOrdProp(AObject,PI,Ord(JS[1])); + end; + end; +end; + +procedure TJSONDeStreamer.JSONToObject(const JSON: TJSONObject; AObject: TObject + ); +Var + I,J : Integer; + PIL : TPropInfoList; + +begin + If Assigned(FBeforeReadObject) then + FBeforeReadObject(Self,AObject,JSON); + If (AObject is TStrings) then + JSONToStrings(JSON,AObject as TStrings) + else If (AObject is TCollection) then + JSONToCollection(JSON, AObject as TCollection) + else + begin + Pil:=TPropInfoList.Create(AObject,tkProperties); + try + For I:=0 to PIL.Count-1 do + begin + J:=JSON.IndexOfName(Pil.Items[i]^.Name,FCaseInsensitive); + If (J<>-1) then + RestoreProperty(AObject,PIL.Items[i],JSON.Items[J]); + end; + finally + FreeAndNil(PIL); + end; + end; + If Assigned(FAfterReadObject) then + FAfterReadObject(Self,AObject,JSON) +end; + +procedure TJSONDeStreamer.JSONToCollection(const JSON: TJSONStringType; + ACollection: TCollection); +Var + D : TJSONData; + +begin + D:=ObjectFromString(JSON); + try + JSONToCollection(D,ACollection); + finally + D.Free; + end; +end; + +procedure TJSONDeStreamer.JSONToCollection(const JSON: TJSONData; + ACollection: TCollection); + +Var + I : integer; + A : TJSONArray; + O : TJSONObject; + +begin + If (JSON.JSONType=jtArray) then + A:=JSON As TJSONArray + else if JSON.JSONType=jtObject then + A:=(JSON as TJSONObject).Arrays['Items'] + else + Error(SErrUnsupportedCollectionType,[JSONTypeName(JSON.JSONType)]); + ACollection.Clear; + For I:=0 to A.Count-1 do + If (A.Types[i]<>jtObject) then + Error(SErrUnsupportedCollectionItemType,[I,JSONTypeName(A.Types[I])]) + else + JSONToObject(A.Objects[i],ACollection.Add); +end; + +procedure TJSONDeStreamer.JSONToStrings(const JSON: TJSONStringType; + AStrings: TSTrings); +Var + D : TJSONData; + +begin + D:=ObjectFromString(JSON); + try + JSONToStrings(D,AStrings); + finally + D.Free; + end; +end; + +function TJSONDeStreamer.GetObject(AInstance: TObject; + const APropName: TJSONStringType; D: TJSONObject; PropInfo: PPropInfo + ): TObject; + +Var + C : TClass; + +begin + Result:=Nil; + If Assigned(FOnGetObject) then + FOnGetObject(Self,AInstance,PropInfo,D,APropName,Result); + If (Result=Nil) and (AInstance is TComponent) and Assigned(PropInfo) then + begin + C:=GetTypeData(Propinfo^.PropType)^.ClassType; + If C.InheritsFrom(TComponent) then + Result:=TComponentClass(C).Create(TComponent(AInstance)); + end; +end; + +procedure TJSONDeStreamer.JSONToStrings(const JSON: TJSONData; + AStrings: TSTrings); + +Var + O : TJSONObject; + D : TJSONData; + I : Integer; + IO : TObject; + N : TJSONStringType; + +begin + Case JSON.JSONType of + jtString: + AStrings.Text:=JSON.AsString; + jtArray: + begin + AStrings.Clear; + For I:=0 to JSON.Count-1 do + begin + if not (JSON.Items[i].JSONType=jtString) then + Error(SErrUnsupportedStringsItemType,[i,JSONTypeName(JSON.Items[i].JSONType)]); + AStrings.Add(JSON.Items[i].AsString); + end; + end; + jtObject: + begin + O:=JSON As TJSONObject; + If (O.Count=1) and (O.Names[0]='Strings') and (O.Items[0].JSONType=jtArray) then + JSONToStrings(O.Items[0],AStrings) + else + begin + AStrings.Clear; + For I:=0 to O.Count-1 do + begin + D:=O.Items[i]; + N:=O.Names[i]; + If D.JSONType=jtNull then + IO:=Nil + else if D.JSONType=jtObject then + IO:=GetObject(AStrings,N,TJSONOBject(D),Nil) + else + Error(SErrUnsupportedStringsObjectType,[D,JSONTypeName(D.JSONType)]); + AStrings.AddObject(O.Names[i],IO); + end; + end; + end; + else + Error(SErrUnsupportedStringsType,[JSONTypeName(JSON.JSONType)]); + end; +end; + +Procedure TStreamChildrenHelper.StreamChild(AChild : TComponent); + +begin + FChildren.Add(FStreamer.ObjectToJSON(AChild)); +end; + +Function TStreamChildrenHelper.StreamChildren(AComponent : TComponent; AStreamer : TJSONStreamer): TJSONArray; + +begin + FStreamer:=AStreamer; + Result:=TJSONArray.Create; + try + FChildren:=Result; + THackComponent(AComponent).GetChildren(@StreamChild,AComponent); + except + FreeAndNil(Result); + Raise; + end; +end; + +{ TJSONFiler } + +procedure TJSONFiler.Error(Const Msg: String); +begin + Raise EJSONRTTI.Create(Name+' : '+Msg); +end; + +procedure TJSONFiler.Error(Const FMT: String; Args: array of const); +begin + Raise EJSONRTTI.CreateFmt(Name+' : '+FMT,Args); +end; + +{ TJSONStreamer } + +constructor TJSONStreamer.Create(AOwner: TComponent); +begin + Inherited; +end; + +destructor TJSONStreamer.Destroy; +begin + Inherited; +end; + + +Function TJSONStreamer.StreamChildren(AComp : TComponent) : TJSONArray; + +begin + With TStreamChildrenHelper.Create do + try + Result:=StreamChildren(AComp,Self); + finally + Free; + end; +end; + +function TJSONStreamer.GetChildProperty: String; +begin + Result:=FChildProperty; + If (Result='') then + Result:='Children'; +end; + +function TJSONStreamer.IsChildStored: boolean; +begin + Result:=(GetChildProperty<>'Children'); +end; + +function TJSONStreamer.ObjectToJSON(Const AObject: TObject): TJSONObject; + +Var + PIL : TPropInfoList; + PD : TJSONData; + I : Integer; + +begin + Result:=Nil; + If (AObject=Nil) then + Exit; + Result:=TJSONObject.Create; + try + If Assigned(FBeforeStreamObject) then + FBeforeStreamObject(Self,AObject,Result); + If AObject is TStrings then + Result.Add('Strings',StreamTStrings(Tstrings(AObject))) + else If AObject is TCollection then + Result.Add('Items',StreamCollection(TCollection(AObject))) + else If AObject is TObjectList then + Result.Add('Objects',StreamObjectList(TObjectList(AObject))) + else + begin + PIL:=TPropInfoList.Create(AObject,tkProperties); + try + For I:=0 to PIL.Count-1 do + begin + PD:=StreamProperty(AObject,PIL.Items[i]); + If (PD<>Nil) then + Result.Add(PIL.Items[I]^.Name,PD); + end; + finally + FReeAndNil(Pil); + end; + If (jsoStreamChildren in Options) and (AObject is TComponent) then + Result.Add(ChildProperty,StreamChildren(TComponent(AObject))); + If Assigned(FAfterStreamObject) then + FAfterStreamObject(Self,AObject,Result); + end; + except + FreeAndNil(Result); + Raise; + end; +end; + +function TJSONStreamer.StreamProperty(Const AObject: TObject; Const PropertyName : String): TJSONData; + +begin + Result:=StreamProperty(AObject,GetPropInfo(AObject,PropertyName)); +end; + +Function TJSONStreamer.StreamVariant(Const Data : Variant): TJSONData; + +Var + A : TJSONArray; + I : Integer; + +begin + Result:=Nil; + If VarIsArray(Data) then + begin + A:=TJSONArray.Create; + try + For I:=VarArrayLowBound(Data,1) to VarArrayHighBound(Data,1) do + A.Add(StreamVariant(Data[i])); + except + FreeAndNil(A); + Raise; + end; + Exit(A); + end; + If VarIsEmpty(Data) or VarisNull(Data) or (Data=UnAssigned) then + Exit(TJSONNull.Create); + Case VarType(Data) of + varshortint, + varbyte, + varword, + varsmallint, + varinteger : + Result:=TJSONIntegerNumber.Create(Data); + varlongword, + varint64 : + Result:=TJSONInt64Number.Create(Data); + vardecimal, + varqword, + varsingle, + vardouble, + varCurrency : + Result:=TJSONFloatNumber.Create(Data); + varString, + varolestr : + Result:=TJSONString.Create(Data); + varboolean : + Result:=TJSONBoolean.Create(Data); + varDate : + if jsoDateTimeAsString in Options then + Result:=FormatDateProp(Data) + else + Result:=TJSONFloatNumber.Create(Data); + else + Error(SErrUnsupportedVariantType,[VarType(Data)]) + end; +end; + +function TJSONStreamer.ObjectToJSONString(AObject: TObject): TJSONStringType; + +Var + O : TJSONData; + +begin + O:=ObjectToJSON(AObject); + try + if (jsoUseFormatString in Options) then + Result:=O.FormatJSON() + else + Result:=O.AsJSON; + finally + FreeAndNil(O); + end; +end; + +function TJSONStreamer.StringsToJSON(Const Strings: TStrings; AsObject: Boolean = False): TJSONStringType; + +Var + D : TJSONData; + +begin + If ASObject then + D:=StreamTSTringsObject(Strings) + else + D:=StreamTStringsArray(Strings); + try + if (jsoUseFormatString in Options) then + Result:=D.FormatJSON + else + Result:=D.AsJSON; + finally + FreeAndNil(D); + end; +end; + +function TJSONStreamer.CollectionToJSON(const ACollection: TCollection + ): TJSONStringType; + +Var + D : TJSONArray; + +begin + D:=StreamCollection(ACollection); + try + if (jsoUseFormatString in Options) then + Result:=D.FormatJSON() + else + Result:=D.AsJSON; + finally + FreeAndNil(D); + end; +end; + +function TJSONStreamer.VariantToJSON(const Data: Variant): TJSONStringType; + +Var + D : TJSONData; + +begin + D:=StreamVariant(Data); + try + if (jsoUseFormatString in Options) then + Result:=D.FormatJSON() + else + Result:=D.AsJSON; + finally + FreeAndNil(D); + end; +end; + +Function TJSONStreamer.StreamTStringsArray(Const AStrings : TStrings) : TJSONArray; + +Var + I : Integer; + +begin + Result:=TJSONArray.Create; + try + For I:=0 to AStrings.Count-1 do + Result.Add(AStrings[i]); + except + FreeAndNil(Result); + Raise; + end; +end; + +function TJSONStreamer.StreamTStringsObject(Const AStrings: TStrings): TJSONObject; + +Var + I : Integer; + O : TJSONData; + +begin + Result:=TJSONObject.Create; + try + For I:=0 to AStrings.Count-1 do + begin + O:=ObjectToJSON(AStrings.Objects[i]); + If O=Nil then + O:=TJSONNull.Create; + Result.Add(AStrings[i],O); + end; + except + FreeAndNil(Result); + Raise; + end; +end; + +function TJSONStreamer.StreamTStrings(Const AStrings: TStrings): TJSONData; +begin + If jsoTStringsAsArray in Options then + Result:=StreamTStringsArray(AStrings) + else If jsoTStringsAsObject in Options then + Result:=StreamTStringsObject(AStrings) + else + Result:=TJSONString.Create(AStrings.Text); +end; + + +Function TJSONStreamer.StreamCollection(Const ACollection : TCollection) : TJSONArray; + +Var + I : Integer; + +begin + Result:=TJSONArray.Create; + try + For I:=0 to ACollection.Count-1 do + Result.Add(ObjectToJSON(ACollection.Items[i])); + except + FreeAndNil(Result); + Raise; + end; +end; + +function TJSONStreamer.StreamObjectList(const AnObjectList: TObjectList): TJSONArray; +Var + I : Integer; + +begin + if not Assigned(AnObjectList) then + Result:=Nil; + Result:=TJSONArray.Create; + try + For I:=0 to AnObjectList.Count-1 do + Result.Add(ObjectToJSON(AnObjectList.Items[i])); + except + FreeAndNil(Result); + Raise; + end; +end; + +function TJSONStreamer.StreamClassProperty(const AObject: TObject): TJSONData; + +Var + C : TCollection; + I : integer; + +begin + Result:=Nil; + If (AObject=Nil) then + Result:=TJSONNull.Create() + else if (AObject is TComponent) then + begin + if (csSubComponent in TComponent(AObject).ComponentStyle) or (jsoComponentsInline in Options) then + Result:=ObjectToJSON(AObject) + else + Result:=TJSONString.Create(TComponent(AObject).Name); + end + else if (AObject is TStrings) then + Result:=StreamTStrings(TStrings(AObject)) + else if (AObject is TCollection) then + Result:=StreamCollection(TCollection(Aobject)) + else If AObject is TObjectList then + Result:=StreamObjectList(TObjectList(AObject)) + else // Normally, this is only TPersistent. + Result:=ObjectToJSON(AObject); +end; + +function TJSONStreamer.StreamProperty(Const AObject: TObject; PropertyInfo: PPropInfo): TJSONData; + +Var + PI : PPropInfo; + PT : PTypeInfo; + S,I : integer; + +begin + Result:=Nil; + PI:=PropertyInfo; + PT:=PI^.PropType; + Case PT^.Kind of + tkUnknown : + Error(SErrUnknownPropertyKind,[PI^.Name]); + tkInteger : + Result:=TJSONIntegerNumber.Create(GetOrdProp(AObject,PI)); + tkEnumeration : + if jsoEnumeratedAsInteger in Options then + Result:=TJSONIntegerNumber.Create(GetOrdProp(AObject,PI)) + else + Result:=TJSONString.Create(GetEnumName(PT,GetOrdProp(AObject,PI))); + tkFloat : + if (PT=TypeInfo(TDateTime)) and (jsoDateTimeAsString in Options) then + Result:=FormatDateProp(GetFloatProp(AObject,PI)) + else + Result:=TJSONFloatNumber.Create(GetFloatProp(AObject,PI)); + tkSet : + If jsoSetAsString in Options then + Result:=TJSONString.Create(GetSetProp(AObject,PI,jsoSetBrackets in Options)) + else + begin + PT:=GetTypeData(PT)^.CompType; + S:=GetOrdProp(AObject,PI); + Result:=TJSONArray.Create; + try + for i:=0 to 31 do + if (i in TSet(S)) then + if jsoSetEnumeratedAsInteger in Options then + TJSONArray(Result).Add(i) + else + TJSONArray(Result).Add(GetEnumName(PT, i)); + except + FreeAndNil(Result); + Raise; + end; + end; + tkChar: + Result:=TJSONString.Create(Char(GetOrdProp(AObject,PI))); + tkSString, + tkLString, + tkAString: + Result:=TJSONString.Create(GetStrProp(AObject,PI)); + tkWString : + Result:=TJSONString.Create(GetWideStrProp(AObject,PI)); + tkVariant: + Result:=StreamVariant(GetVariantProp(AObject,PI)); + tkClass: + Result:=StreamClassProperty(GetObjectProp(AObject,PI)); + tkWChar : + Result:=TJSONString.Create(WideChar(GetOrdProp(AObject,PI))); + tkBool : + Result:=TJSONBoolean.Create(GetOrdProp(AObject,PropertyInfo)<>0); + tkInt64 : + Result:=TJSONInt64Number.Create(GetOrdProp(AObject,PropertyInfo)); + tkQWord : + Result:=TJSONFloatNumber.Create(GetOrdProp(AObject,PropertyInfo)); + tkObject : + Result:=ObjectToJSON(GetObjectProp(AObject,PropertyInfo)); + tkArray, + tkRecord, + tkInterface, + tkDynArray, + tkInterfaceRaw, + tkProcVar, + tkMethod : + Error(SErrUnsupportedPropertyKind,[PI^.Name]); + tkUString : + Result:=TJSONString.Create(GetWideStrProp(AObject,PI)); + tkUChar: + Result:=TJSONString.Create(UnicodeChar(GetOrdProp(AObject,PI))); + end; + If Assigned(FOnStreamProperty) then + FOnStreamProperty(Self,AObject,PI,Result); +end; + +function TJSONStreamer.FormatDateProp(Const DateTime: TDateTime): TJSONString; + +Var + S: String; + +begin + if (jsoCheckEmptyDateTime in Options) and (DateTime=0) then + S:='' + else if (DateTimeFormat<>'') then + S:=FormatDateTime(DateTimeFormat,DateTime) + else if (jsoLegacyDateTime in options) then + begin + if Frac(DateTime)=0 then + S:=DateToStr(DateTime) + else if Trunc(DateTime)=0 then + S:=TimeToStr(DateTime) + else + S:=DateTimeToStr(DateTime); + end + else + S:=FormatDateTime(RFC3339DateTimeFormat,DateTime); + + Result:=TJSONString.Create(S); +end; + +end. + diff --git a/etc/fcl-json/src/jsonconf.pp b/etc/fcl-json/src/jsonconf.pp new file mode 100644 index 00000000..0d547552 --- /dev/null +++ b/etc/fcl-json/src/jsonconf.pp @@ -0,0 +1,793 @@ +{ + This file is part of the Free Component Library + + Implementation of TJSONConfig class + Copyright (c) 2007 Michael Van Canneyt michael@freepascal.org + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} + +{ + TJSONConfig enables applications to use JSON files for storing their + configuration data +} + +{$IFDEF FPC} +{$MODE objfpc} +{$H+} +{$ENDIF} + +unit jsonConf; + +interface + +uses + SysUtils, Classes, fpjson, jsonscanner, jsonparser; + + +type + EJSONConfigError = class(Exception); + +(* ******************************************************************** + "APath" is the path and name of a value: A JSON configuration file + is hierachical. "/" is the path delimiter, the part after the last + "/" is the name of the value. The path components will be mapped + to nested JSON objects, with the name equal to the part. In practice + this means that "/my/path/value" will be written as: + { + "my" : { + "path" : { + "value" : Value + } + } + } + ******************************************************************** *) + + { TJSONConfig } + + TJSONConfig = class(TComponent) + private + FFilename: String; + FFormatIndentSize: Integer; + FFormatoptions: TFormatOptions; + FFormatted: Boolean; + FKey: TJSONObject; + procedure DoSetFilename(const AFilename: String; ForceReload: Boolean); + procedure SetFilename(const AFilename: String); + Function StripSlash(Const P : UnicodeString) : UnicodeString; + protected + FJSON: TJSONObject; + FModified: Boolean; + procedure Loaded; override; + function FindPath(Const APath: UnicodeString; AllowCreate : Boolean) : TJSONObject; + function FindObject(Const APath: UnicodeString; AllowCreate : Boolean) : TJSONObject; + function FindObject(Const APath: UnicodeString; AllowCreate : Boolean;Out ElName : UnicodeString) : TJSONObject; + function FindElement(Const APath: UnicodeString; CreateParent : Boolean; AllowObject : Boolean = False) : TJSONData; + function FindElement(Const APath: UnicodeString; CreateParent : Boolean; out AParent : TJSONObject; Out ElName : UnicodeString; AllowObject : Boolean = False) : TJSONData; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + Procedure Reload; + procedure Clear; + procedure Flush; // Writes the JSON file + procedure OpenKey(const aPath: UnicodeString; AllowCreate : Boolean); + procedure CloseKey; + procedure ResetKey; + Procedure EnumSubKeys(Const APath : UnicodeString; List : TStrings); + Procedure EnumValues(Const APath : UnicodeString; List : TStrings); + + function GetValue(const APath: UnicodeString; const ADefault: UnicodeString): UnicodeString; overload; + function GetValue(const APath: UnicodeString; ADefault: Integer): Integer; overload; + function GetValue(const APath: UnicodeString; ADefault: Int64): Int64; overload; + function GetValue(const APath: UnicodeString; ADefault: Boolean): Boolean; overload; + function GetValue(const APath: UnicodeString; ADefault: Double): Double; overload; + Function GetValue(const APath: UnicodeString; AValue: TStrings; Const ADefault: String) : Boolean; overload; + Function GetValue(const APath: UnicodeString; AValue: TStrings; Const ADefault: TStrings): Boolean; overload; + procedure SetValue(const APath: UnicodeString; const AValue: UnicodeString); overload; + procedure SetValue(const APath: UnicodeString; AValue: Integer); overload; + procedure SetValue(const APath: UnicodeString; AValue: Int64); overload; + procedure SetValue(const APath: UnicodeString; AValue: Boolean); overload; + procedure SetValue(const APath: UnicodeString; AValue: Double); overload; + procedure SetValue(const APath: UnicodeString; AValue: TStrings; AsObject : Boolean = False); overload; + + procedure SetDeleteValue(const APath: UnicodeString; const AValue, DefValue: UnicodeString); overload; + procedure SetDeleteValue(const APath: UnicodeString; AValue, DefValue: Integer); overload; + procedure SetDeleteValue(const APath: UnicodeString; AValue, DefValue: Int64); overload; + procedure SetDeleteValue(const APath: UnicodeString; AValue, DefValue: Boolean); overload; + + procedure DeletePath(const APath: UnicodeString); + procedure DeleteValue(const APath: UnicodeString); + property Modified: Boolean read FModified; + published + Property Filename: String read FFilename write SetFilename; + Property Formatted : Boolean Read FFormatted Write FFormatted; + Property FormatOptions : TFormatOptions Read FFormatoptions Write FFormatOptions Default DefaultFormat; + Property FormatIndentsize : Integer Read FFormatIndentSize Write FFormatIndentSize Default DefaultIndentSize; + end; + + +// =================================================================== + +implementation + +Resourcestring + SErrInvalidJSONFile = '"%s" is not a valid JSON configuration file.'; + SErrCouldNotOpenKey = 'Could not open key "%s".'; + +constructor TJSONConfig.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FJSON:=TJSONObject.Create; + FKey:=FJSON; + FFormatOptions:=DefaultFormat; + FFormatIndentsize:=DefaultIndentSize; +end; + +destructor TJSONConfig.Destroy; +begin + if Assigned(FJSON) then + begin + Flush; + FreeANdNil(FJSON); + end; + inherited Destroy; +end; + +procedure TJSONConfig.Clear; +begin + FJSON.Clear; + FKey:=FJSON; +end; + +procedure TJSONConfig.Flush; + +Var + F : Text; + S : TJSONStringType; + +begin + if Modified then + begin + AssignFile(F,FileName); + Rewrite(F); + Try + if Formatted then + S:=FJSON.FormatJSON(Formatoptions,FormatIndentSize) + else + S:=FJSON.AsJSON; + Writeln(F,S); + Finally + CloseFile(F); + end; + FModified := False; + end; +end; + + +function TJSONConfig.FindObject(const APath: UnicodeString; AllowCreate: Boolean + ): TJSONObject; + +Var + Dummy : UnicodeString; + +begin + Result:=FindObject(APath,AllowCreate,Dummy); +end; + +function TJSONConfig.FindObject(const APath: UnicodeString; AllowCreate: Boolean; + out ElName: UnicodeString): TJSONObject; + +Var + S,El : UnicodeString; + P,I : Integer; + T : TJSonObject; + +begin +// Writeln('Looking for : ', APath); + S:=APath; + If Pos('/',S)=1 then + Result:=FJSON + else + Result:=FKey; + Repeat + P:=Pos('/',S); + If (P<>0) then + begin + // Only real paths, ignore double slash + If (P<>1) then + begin + El:=Copy(S,1,P-1); + If (Result.Count=0) then + I:=-1 + else + I:=Result.IndexOfName(UTF8Encode(El)); + If (I=-1) then + // No element with this name. + begin + If AllowCreate then + begin + // Create new node. + T:=Result; + Result:=TJSonObject.Create; + T.Add(UTF8Encode(El),Result); + end + else + Result:=Nil + end + else + // Node found, check if it is an object + begin + if (Result.Items[i].JSONtype=jtObject) then + Result:=Result.Objects[UTF8Encode(el)] + else + begin +// Writeln(el,' type wrong'); + If AllowCreate then + begin +// Writeln('Creating ',el); + Result.Delete(I); + T:=Result; + Result:=TJSonObject.Create; + T.Add(UTF8Encode(El),Result); + end + else + Result:=Nil + end; + end; + end; + Delete(S,1,P); + end; + Until (P=0) or (Result=Nil); + ElName:=S; +end; + +function TJSONConfig.FindElement(const APath: UnicodeString; CreateParent: Boolean; AllowObject : Boolean = False): TJSONData; + +Var + O : TJSONObject; + ElName : UnicodeString; + +begin + Result:=FindElement(APath,CreateParent,O,ElName,AllowObject); +end; + +function TJSONConfig.FindElement(const APath: UnicodeString; + CreateParent: Boolean; out AParent: TJSONObject; out ElName: UnicodeString; + AllowObject : Boolean = False): TJSONData; + +Var + I : Integer; + +begin + Result:=Nil; + Aparent:=FindObject(APath,CreateParent,ElName); + If Assigned(Aparent) then + begin +// Writeln('Found parent, looking for element:',elName); + I:=AParent.IndexOfName(UTF8Encode(ElName)); +// Writeln('Element index is',I); + If (I<>-1) And ((AParent.items[I].JSONType<>jtObject) or AllowObject) then + Result:=AParent.Items[i]; + end; +// Writeln('Find ',aPath,' in "',FJSON.AsJSOn,'" : ',Elname,' : ',Result<>NIl); +end; + + +function TJSONConfig.GetValue(const APath: UnicodeString; const ADefault: UnicodeString): UnicodeString; + +var + El : TJSONData; + +begin + El:=FindElement(StripSlash(APath),False); + If Assigned(El) then + Result:=El.AsUnicodeString + else + Result:=ADefault; +end; + +function TJSONConfig.GetValue(const APath: UnicodeString; ADefault: Integer): Integer; +var + El : TJSONData; + +begin + El:=FindElement(StripSlash(APath),False); + If Not Assigned(el) then + Result:=ADefault + else if (el is TJSONNumber) then + Result:=El.AsInteger + else + Result:=StrToIntDef(El.AsString,ADefault); +end; + +function TJSONConfig.GetValue(const APath: UnicodeString; ADefault: Int64): Int64; +var + El : TJSONData; + +begin + El:=FindElement(StripSlash(APath),False); + If Not Assigned(el) then + Result:=ADefault + else if (el is TJSONNumber) then + Result:=El.AsInt64 + else + Result:=StrToInt64Def(El.AsString,ADefault); +end; + +function TJSONConfig.GetValue(const APath: UnicodeString; ADefault: Boolean): Boolean; + +var + El : TJSONData; + +begin + El:=FindElement(StripSlash(APath),False); + If Not Assigned(el) then + Result:=ADefault + else if (el is TJSONBoolean) then + Result:=El.AsBoolean + else + Result:=StrToBoolDef(El.AsString,ADefault); +end; + +function TJSONConfig.GetValue(const APath: UnicodeString; ADefault: Double): Double; + +var + El : TJSONData; + +begin + El:=FindElement(StripSlash(APath),False); + If Not Assigned(el) then + Result:=ADefault + else if (el is TJSONNumber) then + Result:=El.AsFloat + else + Result:=StrToFloatDef(El.AsString,ADefault); +end; + +function TJSONConfig.GetValue(const APath: UnicodeString; AValue: TStrings; + const ADefault: String): Boolean; +var + El : TJSONData; + D : TJSONEnum; + +begin + AValue.Clear; + El:=FindElement(StripSlash(APath),False,True); + Result:=Assigned(el); + If Not Result then + begin + AValue.Text:=ADefault; + exit; + end; + Case El.JSONType of + jtArray: + For D in El do + if D.Value.JSONType in ActualValueJSONTypes then + AValue.Add(D.Value.AsString); + jtObject: + For D in El do + if D.Value.JSONType in ActualValueJSONTypes then + AValue.Add(D.Key+'='+D.Value.AsString); + else + AValue.Text:=EL.AsString + end; + +end; + +function TJSONConfig.GetValue(const APath: UnicodeString; AValue: TStrings; + const ADefault: TStrings): Boolean; +begin + Result:=GetValue(APath,AValue,''); + If Not Result then + AValue.Assign(ADefault); +end; + + +procedure TJSONConfig.SetValue(const APath: UnicodeString; const AValue: UnicodeString); + +var + El : TJSONData; + ElName : UnicodeString; + O : TJSONObject; + I : integer; + +begin + El:=FindElement(StripSlash(APath),True,O,ElName); + if Assigned(El) and (El.JSONType<>jtString) then + begin + I:=O.IndexOfName(UTF8Encode(elName)); + O.Delete(i); + El:=Nil; + end; + If Not Assigned(el) then + begin + El:=TJSONString.Create(AValue); + O.Add(UTF8Encode(ElName),El); + end + else + El.AsUnicodeString:=AValue; + FModified:=True; +end; + +procedure TJSONConfig.SetDeleteValue(const APath: UnicodeString; const AValue, DefValue: UnicodeString); +begin + if AValue = DefValue then + DeleteValue(APath) + else + SetValue(APath, AValue); +end; + +procedure TJSONConfig.SetValue(const APath: UnicodeString; AValue: Integer); + +var + El : TJSONData; + ElName : UnicodeString; + O : TJSONObject; + I : integer; + +begin + El:=FindElement(StripSlash(APath),True,O,ElName); + if Assigned(El) and (Not (El is TJSONIntegerNumber)) then + begin + I:=O.IndexOfName(UTF8Encode(elName)); + If (I<>-1) then // Normally not needed... + O.Delete(i); + El:=Nil; + end; + If Not Assigned(el) then + begin + El:=TJSONIntegerNumber.Create(AValue); + O.Add(UTF8Encode(ElName),El); + end + else + El.AsInteger:=AValue; + FModified:=True; +end; + +procedure TJSONConfig.SetValue(const APath: UnicodeString; AValue: Int64); + +var + El : TJSONData; + ElName : UnicodeString; + O : TJSONObject; + I : integer; + +begin + El:=FindElement(StripSlash(APath),True,O,ElName); + if Assigned(El) and (Not (El is TJSONInt64Number)) then + begin + I:=O.IndexOfName(UTF8Encode(elName)); + If (I<>-1) then // Normally not needed... + O.Delete(i); + El:=Nil; + end; + If Not Assigned(el) then + begin + El:=TJSONInt64Number.Create(AValue); + O.Add(UTF8Encode(ElName),El); + end + else + El.AsInt64:=AValue; + FModified:=True; +end; + +procedure TJSONConfig.SetDeleteValue(const APath: UnicodeString; AValue, + DefValue: Integer); +begin + if AValue = DefValue then + DeleteValue(APath) + else + SetValue(APath, AValue); +end; + +procedure TJSONConfig.SetDeleteValue(const APath: UnicodeString; AValue, + DefValue: Int64); +begin + if AValue = DefValue then + DeleteValue(APath) + else + SetValue(APath, AValue); +end; + +procedure TJSONConfig.SetValue(const APath: UnicodeString; AValue: Boolean); + +var + El : TJSONData; + ElName : UnicodeString; + O : TJSONObject; + I : integer; + +begin + El:=FindElement(StripSlash(APath),True,O,ElName); + if Assigned(El) and (el.JSONType<>jtBoolean) then + begin + I:=O.IndexOfName(UTF8Encode(elName)); + O.Delete(i); + El:=Nil; + end; + If Not Assigned(el) then + begin + El:=TJSONBoolean.Create(AValue); + O.Add(UTF8Encode(ElName),El); + end + else + El.AsBoolean:=AValue; + FModified:=True; +end; + +procedure TJSONConfig.SetValue(const APath: UnicodeString; AValue: Double); + +var + El : TJSONData; + ElName : UnicodeString; + O : TJSONObject; + I : integer; + +begin + El:=FindElement(StripSlash(APath),True,O,ElName); + if Assigned(El) and (Not (El is TJSONFloatNumber)) then + begin + I:=O.IndexOfName(UTF8Encode(elName)); + O.Delete(i); + El:=Nil; + end; + If Not Assigned(el) then + begin + El:=TJSONFloatNumber.Create(AValue); + O.Add(UTF8Encode(ElName),El); + end + else + El.AsFloat:=AValue; + FModified:=True; +end; + +procedure TJSONConfig.SetValue(const APath: UnicodeString; AValue: TStrings; AsObject : Boolean = False); +var + El : TJSONData; + ElName : UnicodeString; + O : TJSONObject; + I : integer; + A : TJSONArray; + N,V : String; + DoDelete: Boolean; + +begin + El:=FindElement(StripSlash(APath),True,O,ElName,True); + if Assigned(El) then + begin + if AsObject then + DoDelete:=(Not (El is TJSONObject)) + else + DoDelete:=(Not (El is TJSONArray)); + if DoDelete then + begin + I:=O.IndexOfName(UTF8Encode(elName)); + O.Delete(i); + El:=Nil; + end; + end; + If Not Assigned(el) then + begin + if AsObject then + El:=TJSONObject.Create + else + El:=TJSONArray.Create; + O.Add(UTF8Encode(ElName),El); + end; + if Not AsObject then + begin + A:=El as TJSONArray; + A.Clear; + For N in Avalue do + A.Add(N); + end + else + begin + O:=El as TJSONObject; + For I:=0 to AValue.Count-1 do + begin + AValue.GetNameValue(I,N,V); + O.Add(N,V); + end; + end; + FModified:=True; +end; + +procedure TJSONConfig.SetDeleteValue(const APath: UnicodeString; AValue, + DefValue: Boolean); +begin + if AValue = DefValue then + DeleteValue(APath) + else + SetValue(APath,AValue); +end; + +procedure TJSONConfig.DeletePath(const APath: UnicodeString); + +Var + P : UnicodeString; + L : integer; + Node : TJSONObject; + ElName : UnicodeString; + +begin + P:=StripSlash(APath); + L:=Length(P); + If (L>0) then + begin + Node := FindObject(P,False,ElName); + If Assigned(Node) then + begin + L:=Node.IndexOfName(UTF8Encode(ElName)); + If (L<>-1) then + Node.Delete(L); + end; + end; +end; + +procedure TJSONConfig.DeleteValue(const APath: UnicodeString); + +begin + DeletePath(APath); +end; + +procedure TJSONConfig.Reload; + +begin + if Length(Filename) > 0 then + DoSetFilename(Filename,True); +end; + +procedure TJSONConfig.Loaded; +begin + inherited Loaded; + Reload; +end; + +function TJSONConfig.FindPath(const APath: UnicodeString; AllowCreate: Boolean + ): TJSONObject; + +Var + P : UnicodeString; + L : Integer; + +begin + P:=APath; + L:=Length(P); + If (L=0) or (P[L]<>'/') then + P:=P+'/'; + Result:=FindObject(P,AllowCreate); +end; + +procedure TJSONConfig.DoSetFilename(const AFilename: String; ForceReload: Boolean); + +Var + P : TJSONParser; + J : TJSONData; + F : TFileStream; + +begin + if (not ForceReload) and (FFilename = AFilename) then + exit; + FFilename := AFilename; + + if csLoading in ComponentState then + exit; + + Flush; + If Not FileExists(AFileName) then + Clear + else + begin + F:=TFileStream.Create(AFileName,fmopenRead); + try + P:=TJSONParser.Create(F,[joUTF8,joComments]); + try + J:=P.Parse; + If (J is TJSONObject) then + begin + FreeAndNil(FJSON); + FJSON:=J as TJSONObject; + FKey:=FJSON; + end + else + Raise EJSONConfigError.CreateFmt(SErrInvalidJSONFile,[AFileName]); + finally + P.Free; + end; + finally + F.Free; + end; + end; +end; + +procedure TJSONConfig.SetFilename(const AFilename: String); +begin + DoSetFilename(AFilename, False); +end; + +function TJSONConfig.StripSlash(const P: UnicodeString): UnicodeString; + +Var + L : Integer; + +begin + L:=Length(P); + If (L>0) and (P[l]='/') then + Result:=Copy(P,1,L-1) + else + Result:=P; +end; + + +procedure TJSONConfig.CloseKey; +begin + ResetKey; +end; + +procedure TJSONConfig.OpenKey(const aPath: UnicodeString; AllowCreate: Boolean); + +Var + P : UnicodeString; + L : Integer; + +begin + P:=APath; + L:=Length(P); + If (L=0) then + FKey:=FJSON + else + begin + if (P[L]<>'/') then + P:=P+'/'; + FKey:=FindObject(P,AllowCreate); + If (FKey=Nil) Then + Raise EJSONConfigError.CreateFmt(SErrCouldNotOpenKey,[APath]); + end; +end; + +procedure TJSONConfig.ResetKey; +begin + FKey:=FJSON; +end; + +procedure TJSONConfig.EnumSubKeys(const APath: UnicodeString; List: TStrings); + +Var + AKey : TJSONObject; + I : Integer; + +begin + AKey:=FindPath(APath,False); + If Assigned(AKey) then + begin + For I:=0 to AKey.Count-1 do + If AKey.Items[i] is TJSONObject then + List.Add(AKey.Names[i]); + end; +end; + +procedure TJSONConfig.EnumValues(const APath: UnicodeString; List: TStrings); + +Var + AKey : TJSONObject; + I : Integer; + +begin + AKey:=FindPath(APath,False); + If Assigned(AKey) then + begin + For I:=0 to AKey.Count-1 do + If Not (AKey.Items[i] is TJSONObject) then + List.Add(AKey.Names[i]); + end; +end; + + +end. diff --git a/etc/fcl-json/src/jsonparser.pp b/etc/fcl-json/src/jsonparser.pp new file mode 100644 index 00000000..5d9df0cf --- /dev/null +++ b/etc/fcl-json/src/jsonparser.pp @@ -0,0 +1,382 @@ +{ + This file is part of the Free Component Library + + JSON source parser + Copyright (c) 2007 by Michael Van Canneyt michael@freepascal.org + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} +{$mode objfpc} +{$h+} +unit jsonparser; + +interface + +uses + Classes, SysUtils, fpJSON, jsonscanner; + +Type + + { TJSONParser } + + TJSONParser = Class(TObject) + Private + FScanner : TJSONScanner; + function GetO(AIndex: TJSONOption): Boolean; + function GetOptions: TJSONOptions; + function ParseNumber: TJSONNumber; + procedure SetO(AIndex: TJSONOption; AValue: Boolean); + procedure SetOptions(AValue: TJSONOptions); + Protected + procedure DoError(const Msg: String); + function DoParse(AtCurrent,AllowEOF: Boolean): TJSONData; + function GetNextToken: TJSONToken; + function CurrentTokenString: String; + function CurrentToken: TJSONToken; + function ParseArray: TJSONArray; + function ParseObject: TJSONObject; + Property Scanner : TJSONScanner read FScanner; + Public + function Parse: TJSONData; + Constructor Create(Source : TStream; AUseUTF8 : Boolean = True); overload;deprecated 'use options form instead'; + Constructor Create(Source : TJSONStringType; AUseUTF8 : Boolean = True); overload;deprecated 'use options form instead'; + constructor Create(Source: TStream; AOptions: TJSONOptions); overload; + constructor Create(const Source: String; AOptions: TJSONOptions); overload; + destructor Destroy();override; + // Use strict JSON: " for strings, object members are strings, not identifiers + Property Strict : Boolean Index joStrict Read GetO Write SetO ; deprecated 'use options instead'; + // if set to TRUE, then strings will be converted to UTF8 ansistrings, not system codepage ansistrings. + Property UseUTF8 : Boolean index joUTF8 Read GetO Write SetO; deprecated 'Use options instead'; + // Parsing options + Property Options : TJSONOptions Read GetOptions Write SetOptions; + end; + + EJSONParser = Class(EParserError); + +implementation + +Resourcestring + SErrUnexpectedEOF = 'Unexpected EOF encountered.'; + SErrUnexpectedToken = 'Unexpected token (%s) encountered.'; + SErrExpectedColon = 'Expected colon (:), got token "%s".'; + SErrUnexpectedComma = 'Invalid comma encountered.'; + SErrEmptyElement = 'Empty element encountered.'; + SErrExpectedElementName = 'Expected element name, got token "%s"'; + SExpectedCommaorBraceClose = 'Expected , or ], got token "%s".'; + SErrInvalidNumber = 'Number is not an integer or real number: %s'; + SErrNoScanner = 'No scanner. No source specified ?'; + +{ TJSONParser } + +procedure DefJSONParserHandler(AStream: TStream; const AUseUTF8: Boolean; out + Data: TJSONData); + +Var + P : TJSONParser; + +begin + Data:=Nil; + P:=TJSONParser.Create(AStream,[joUTF8]); + try + Data:=P.Parse; + finally + P.Free; + end; +end; + +function TJSONParser.Parse: TJSONData; + +begin + if (FScanner=Nil) then + DoError(SErrNoScanner); + Result:=DoParse(False,True); +end; + +{ + Consume next token and convert to JSON data structure. + If AtCurrent is true, the current token is used. If false, + a token is gotten from the scanner. + If AllowEOF is false, encountering a tkEOF will result in an exception. +} + +function TJSONParser.CurrentToken: TJSONToken; + +begin + Result:=FScanner.CurToken; +end; + +function TJSONParser.CurrentTokenString: String; + +begin + If CurrentToken in [tkString,tkIdentifier,tkNumber,tkComment] then + Result:=FScanner.CurTokenString + else + Result:=TokenInfos[CurrentToken]; +end; + +function TJSONParser.DoParse(AtCurrent, AllowEOF: Boolean): TJSONData; + +var + T : TJSONToken; + +begin + Result:=nil; + try + If not AtCurrent then + T:=GetNextToken + else + T:=FScanner.CurToken; + Case T of + tkEof : If Not AllowEof then + DoError(SErrUnexpectedEOF); + tkNull : Result:=CreateJSON; + tkTrue, + tkFalse : Result:=CreateJSON(t=tkTrue); + tkString : if joUTF8 in Options then + Result:=CreateJSON(UTF8Decode(CurrentTokenString)) + else + Result:=CreateJSON(CurrentTokenString); + tkCurlyBraceOpen : Result:=ParseObject; + tkCurlyBraceClose : DoError(SErrUnexpectedToken); + tkSQuaredBraceOpen : Result:=ParseArray; + tkSQuaredBraceClose : DoError(SErrUnexpectedToken); + tkNumber : Result:=ParseNumber; + tkComma : DoError(SErrUnexpectedToken); + end; + except + FreeAndNil(Result); + Raise; + end; +end; + + +// Creates the correct JSON number type, based on the current token. +function TJSONParser.ParseNumber: TJSONNumber; + +Var + I : Integer; + I64 : Int64; + QW : QWord; + F : TJSONFloat; + S : String; + +begin + S:=CurrentTokenString; + I:=0; + if TryStrToQWord(S,QW) then + begin + if QW>qword(high(Int64)) then + Result:=CreateJSON(QW) + else + if QW>MaxInt then + begin + I64 := QW; + Result:=CreateJSON(I64); + end + else + begin + I := QW; + Result:=CreateJSON(I); + end + end + else + begin + If TryStrToInt64(S,I64) then + if (I64>Maxint) or (I64<-MaxInt) then + Result:=CreateJSON(I64) + Else + begin + I:=I64; + Result:=CreateJSON(I); + end + else + begin + I:=0; + Val(S,F,I); + If (I<>0) then + DoError(SErrInvalidNumber); + Result:=CreateJSON(F); + end; + end; + +end; + +function TJSONParser.GetO(AIndex: TJSONOption): Boolean; +begin + Result:=AIndex in Options; +end; + +function TJSONParser.GetOptions: TJSONOptions; +begin + Result:=FScanner.Options +end; + +procedure TJSONParser.SetO(AIndex: TJSONOption; AValue: Boolean); +begin + if aValue then + FScanner.Options:=FScanner.Options+[AINdex] + else + FScanner.Options:=FScanner.Options-[AINdex] +end; + +procedure TJSONParser.SetOptions(AValue: TJSONOptions); +begin + FScanner.Options:=AValue; +end; + + +// Current token is {, on exit current token is } +function TJSONParser.ParseObject: TJSONObject; + +Var + T : TJSONtoken; + E : TJSONData; + N : String; + LastComma : Boolean; + +begin + LastComma:=False; + Result:=CreateJSONObject([]); + Try + T:=GetNextToken; + While T<>tkCurlyBraceClose do + begin + If (T<>tkString) and (T<>tkIdentifier) then + DoError(SErrExpectedElementName); + N:=CurrentTokenString; + T:=GetNextToken; + If (T<>tkColon) then + DoError(SErrExpectedColon); + E:=DoParse(False,False); + Result.Add(N,E); + T:=GetNextToken; + If Not (T in [tkComma,tkCurlyBraceClose]) then + DoError(SExpectedCommaorBraceClose); + If T=tkComma then + begin + T:=GetNextToken; + LastComma:=(t=tkCurlyBraceClose); + end; + end; + If LastComma and ((joStrict in Options) or not (joIgnoreTrailingComma in Options)) then // Test for ,} case + DoError(SErrUnExpectedToken); + Except + FreeAndNil(Result); + Raise; + end; +end; + +// Current token is [, on exit current token is ] +function TJSONParser.ParseArray: TJSONArray; + +Var + T : TJSONtoken; + E : TJSONData; + LastComma : Boolean; + S : TJSONOPTions; +begin + Result:=CreateJSONArray([]); + LastComma:=False; + Try + Repeat + T:=GetNextToken; + If (T<>tkSquaredBraceClose) then + begin + E:=DoParse(True,False); + If (E<>Nil) then + Result.Add(E) + else if (Result.Count>0) then + DoError(SErrEmptyElement); + T:=GetNextToken; + If Not (T in [tkComma,tkSquaredBraceClose]) then + DoError(SExpectedCommaorBraceClose); + LastComma:=(t=TkComma); + end; + Until (T=tkSquaredBraceClose); + S:=Options; + If LastComma and ((joStrict in S) or not (joIgnoreTrailingComma in S)) then // Test for ,] case + DoError(SErrUnExpectedToken); + Except + FreeAndNil(Result); + Raise; + end; +end; + +// Get next token, discarding whitespace +function TJSONParser.GetNextToken: TJSONToken; + +begin + Repeat + Result:=FScanner.FetchToken; + Until (Not (Result in [tkComment,tkWhiteSpace])); +end; + +procedure TJSONParser.DoError(const Msg: String); + +Var + S : String; + +begin + S:=Format(Msg,[CurrentTokenString]); + S:=Format('Error at line %d, Pos %d:',[FScanner.CurRow,FSCanner.CurColumn])+S; + Raise EJSONParser.Create(S); +end; + +constructor TJSONParser.Create(Source: TStream; AUseUTF8 : Boolean = True); +begin + Inherited Create; + FScanner:=TJSONScanner.Create(Source,[joUTF8]); + if AUseUTF8 then + Options:=Options + [joUTF8]; +end; + +constructor TJSONParser.Create(Source: TJSONStringType; AUseUTF8 : Boolean = True); +begin + Inherited Create; + FScanner:=TJSONScanner.Create(Source,[joUTF8]); + if AUseUTF8 then + Options:=Options + [joUTF8]; +end; + +constructor TJSONParser.Create(Source: TStream; AOptions: TJSONOptions); +begin + FScanner:=TJSONScanner.Create(Source,AOptions); +end; + +constructor TJSONParser.Create(const Source: String; AOptions: TJSONOptions); +begin + FScanner:=TJSONScanner.Create(Source,AOptions); +end; + +destructor TJSONParser.Destroy(); +begin + FreeAndNil(FScanner); + inherited Destroy(); +end; + +Procedure InitJSONHandler; + +begin + if GetJSONParserHandler=Nil then + SetJSONParserHandler(@DefJSONParserHandler); +end; + +Procedure DoneJSONHandler; + +begin + if GetJSONParserHandler=@DefJSONParserHandler then + SetJSONParserHandler(Nil); +end; + +initialization + InitJSONHandler; +finalization + DoneJSONHandler; +end. + diff --git a/etc/fcl-json/src/jsonscanner.pp b/etc/fcl-json/src/jsonscanner.pp new file mode 100644 index 00000000..43da6e41 --- /dev/null +++ b/etc/fcl-json/src/jsonscanner.pp @@ -0,0 +1,481 @@ +{ + This file is part of the Free Component Library + + JSON source lexical scanner + Copyright (c) 2007 by Michael Van Canneyt michael@freepascal.org + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} +{$mode objfpc} +{$h+} + +unit jsonscanner; + +interface + +uses SysUtils, Classes; + +resourcestring + SErrInvalidCharacter = 'Invalid character at line %d, pos %d: ''%s'''; + SUnterminatedComment = 'Unterminated comment at line %d, pos %d: ''%s'''; + SErrOpenString = 'string exceeds end of line'; + +type + + TJSONToken = ( + tkEOF, + tkWhitespace, + tkString, + tkNumber, + tkTrue, + tkFalse, + tkNull, + // Simple (one-character) tokens + tkComma, // ',' + tkColon, // ':' + tkCurlyBraceOpen, // '{' + tkCurlyBraceClose, // '}' + tkSquaredBraceOpen, // '[' + tkSquaredBraceClose, // ']' + tkIdentifier, // Any Javascript identifier + tkComment, + tkUnknown + ); + + EScannerError = class(EParserError); + + TJSONOption = (joUTF8,joStrict,joComments,joIgnoreTrailingComma); + TJSONOptions = set of TJSONOption; + +Const + DefaultOptions = [joUTF8]; + +Type + + { TJSONScanner } + + TJSONScanner = class + private + FAllowComments: Boolean; + FSource : TStringList; + FCurRow: Integer; + FCurToken: TJSONToken; + FCurTokenString: string; + FCurLine: string; + TokenStr: PChar; + FOptions : TJSONOptions; + function GetCurColumn: Integer; + function GetO(AIndex: TJSONOption): Boolean; + procedure SetO(AIndex: TJSONOption; AValue: Boolean); + protected + procedure Error(const Msg: string);overload; + procedure Error(const Msg: string; Const Args: array of Const);overload; + function DoFetchToken: TJSONToken; + public + constructor Create(Source : TStream; AUseUTF8 : Boolean = True); overload; deprecated 'use options form instead'; + constructor Create(const Source : String; AUseUTF8 : Boolean = True); overload; deprecated 'use options form instead'; + constructor Create(Source: TStream; AOptions: TJSONOptions); overload; + constructor Create(const Source: String; AOptions: TJSONOptions); overload; + destructor Destroy; override; + function FetchToken: TJSONToken; + + + property CurLine: string read FCurLine; + property CurRow: Integer read FCurRow; + property CurColumn: Integer read GetCurColumn; + + property CurToken: TJSONToken read FCurToken; + property CurTokenString: string read FCurTokenString; + // Use strict JSON: " for strings, object members are strings, not identifiers + Property Strict : Boolean Index joStrict Read GetO Write SetO ; deprecated 'use options instead'; + // if set to TRUE, then strings will be converted to UTF8 ansistrings, not system codepage ansistrings. + Property UseUTF8 : Boolean index joUTF8 Read GetO Write SetO; deprecated 'Use options instead'; + // Parsing options + Property Options : TJSONOptions Read FOptions Write FOptions; + end; + +const + TokenInfos: array[TJSONToken] of string = ( + 'EOF', + 'Whitespace', + 'String', + 'Number', + 'True', + 'False', + 'Null', + ',', + ':', + '{', + '}', + '[', + ']', + 'identifier', + 'comment', + '' + ); + + +implementation + +constructor TJSONScanner.Create(Source : TStream; AUseUTF8 : Boolean = True); + +Var + O : TJSONOptions; + +begin + O:=DefaultOptions; + if AUseUTF8 then + Include(O,joUTF8) + else + Exclude(O,joUTF8); + Create(Source,O); +end; + +constructor TJSONScanner.Create(const Source : String; AUseUTF8 : Boolean = True); +Var + O : TJSONOptions; + +begin + O:=DefaultOptions; + if AUseUTF8 then + Include(O,joUTF8) + else + Exclude(O,joUTF8); + Create(Source,O); +end; + +constructor TJSONScanner.Create(Source: TStream; AOptions: TJSONOptions); +begin + FSource:=TStringList.Create; + FSource.LoadFromStream(Source); + FOptions:=AOptions; +end; + +constructor TJSONScanner.Create(const Source: String; AOptions: TJSONOptions); +begin + FSource:=TStringList.Create; + FSource.Text:=Source; + FOptions:=AOptions; +end; + +destructor TJSONScanner.Destroy; +begin + FreeAndNil(FSource); + Inherited; +end; + + +function TJSONScanner.FetchToken: TJSONToken; + +begin + Result:=DoFetchToken; +end; + +procedure TJSONScanner.Error(const Msg: string); +begin + raise EScannerError.Create(Msg); +end; + +procedure TJSONScanner.Error(const Msg: string; const Args: array of const); +begin + raise EScannerError.CreateFmt(Msg, Args); +end; + +function TJSONScanner.DoFetchToken: TJSONToken; + + function FetchLine: Boolean; + begin + Result:=FCurRow 0 then + Move(TokenStart^, FCurTokenString[OldLength + 1], SectionLength); + Move(S[1],FCurTokenString[OldLength + SectionLength+1],Length(S)); + Inc(OldLength, SectionLength+Length(S)); + // Next char + // Inc(TokenStr); + TokenStart := TokenStr+1; + end; + if TokenStr[0] = #0 then + Error(SErrOpenString); + Inc(TokenStr); + end; + if TokenStr[0] = #0 then + Error(SErrOpenString); + SectionLength := TokenStr - TokenStart; + SetLength(FCurTokenString, OldLength + SectionLength); + if SectionLength > 0 then + Move(TokenStart^, FCurTokenString[OldLength + 1], SectionLength); + Inc(TokenStr); + Result := tkString; + end; + ',': + begin + Inc(TokenStr); + Result := tkComma; + end; + '0'..'9','.','-': + begin + TokenStart := TokenStr; + while true do + begin + Inc(TokenStr); + case TokenStr[0] of + '.': + begin + if TokenStr[1] in ['0'..'9', 'e', 'E'] then + begin + Inc(TokenStr); + repeat + Inc(TokenStr); + until not (TokenStr[0] in ['0'..'9', 'e', 'E','-','+']); + end; + break; + end; + '0'..'9': ; + 'e', 'E': + begin + Inc(TokenStr); + if TokenStr[0] in ['-','+'] then + Inc(TokenStr); + while TokenStr[0] in ['0'..'9'] do + Inc(TokenStr); + break; + end; + else + break; + end; + end; + SectionLength := TokenStr - TokenStart; + FCurTokenString:=''; + SetString(FCurTokenString, TokenStart, SectionLength); + If (FCurTokenString[1]='.') then + FCurTokenString:='0'+FCurTokenString; + Result := tkNumber; + end; + ':': + begin + Inc(TokenStr); + Result := tkColon; + end; + '{': + begin + Inc(TokenStr); + Result := tkCurlyBraceOpen; + end; + '}': + begin + Inc(TokenStr); + Result := tkCurlyBraceClose; + end; + '[': + begin + Inc(TokenStr); + Result := tkSquaredBraceOpen; + end; + ']': + begin + Inc(TokenStr); + Result := tkSquaredBraceClose; + end; + '/' : + begin + if Not (joComments in Options) then + Error(SErrInvalidCharacter, [CurRow,CurCOlumn,TokenStr[0]]); + TokenStart:=TokenStr; + Inc(TokenStr); + Case Tokenstr[0] of + '/' : begin + SectionLength := Length(FCurLine)- (TokenStr - PChar(FCurLine)); + Inc(TokenStr); + FCurTokenString:=''; + SetString(FCurTokenString, TokenStr, SectionLength); + Fetchline; + end; + '*' : + begin + IsStar:=False; + Inc(TokenStr); + TokenStart:=TokenStr; + Repeat + if (TokenStr[0]=#0) then + begin + SectionLength := (TokenStr - TokenStart); + S:=''; + SetString(S, TokenStart, SectionLength); + FCurtokenString:=FCurtokenString+S; + if not fetchLine then + Error(SUnterminatedComment, [CurRow,CurCOlumn,TokenStr[0]]); + TokenStart:=TokenStr; + end; + IsStar:=TokenStr[0]='*'; + Inc(TokenStr); + EOC:=(isStar and (TokenStr[0]='/')); + Until EOC; + if EOC then + begin + SectionLength := (TokenStr - TokenStart-1); + S:=''; + SetString(S, TokenStart, SectionLength); + FCurtokenString:=FCurtokenString+S; + Inc(TokenStr); + end; + end; + else + Error(SErrInvalidCharacter, [CurRow,CurCOlumn,TokenStr[0]]); + end; + Result:=tkComment; + end; + 'a'..'z','A'..'Z','_': + begin + TokenStart := TokenStr; + repeat + Inc(TokenStr); + until not (TokenStr[0] in ['A'..'Z', 'a'..'z', '0'..'9', '_']); + SectionLength := TokenStr - TokenStart; + FCurTokenString:=''; + SetString(FCurTokenString, TokenStart, SectionLength); + for it := tkTrue to tkNull do + if CompareText(CurTokenString, TokenInfos[it]) = 0 then + begin + Result := it; + FCurToken := Result; + exit; + end; + if (joStrict in Options) then + Error(SErrInvalidCharacter, [CurRow,CurColumn,TokenStr[0]]) + else + Result:=tkIdentifier; + end; + else + Error(SErrInvalidCharacter, [CurRow,CurCOlumn,TokenStr[0]]); + end; + + FCurToken := Result; +end; + +function TJSONScanner.GetCurColumn: Integer; +begin + Result := TokenStr - PChar(CurLine); +end; + +function TJSONScanner.GetO(AIndex: TJSONOption): Boolean; +begin + Result:=AIndex in FOptions; +end; + +procedure TJSONScanner.SetO(AIndex: TJSONOption; AValue: Boolean); +begin + If AValue then + Include(Foptions,AIndex) + else + Exclude(Foptions,AIndex) +end; + +end. diff --git a/lazproj/coedit.lpi b/lazproj/coedit.lpi index 7769fb35..986cc121 100644 --- a/lazproj/coedit.lpi +++ b/lazproj/coedit.lpi @@ -31,7 +31,7 @@ - + @@ -73,7 +73,7 @@ - + @@ -390,7 +390,7 @@ - + diff --git a/src/ce_dubproject.pas b/src/ce_dubproject.pas index 35cc521b..22d6eb9b 100644 --- a/src/ce_dubproject.pas +++ b/src/ce_dubproject.pas @@ -209,8 +209,9 @@ begin // FreeAndNil(fJSON); parser := TJSONParser.Create(loader, true); - //TODO-cgonnawork: from FPC 3.02, uses parser.options to allow trailing comma in DUB descriptions - // http://bugs.freepascal.org/view.php?id=29357 + parser.Options:= parser.Options + [joIgnoreTrailingComma] - [joStrict]; + //TODO-cfcl-json: remove etc/fcl-json the day they'll merge and rlz the version with 'Options' + //TODO-cfcl-json: track possible changes and fixes at http://svn.freepascal.org/cgi-bin/viewvc.cgi/trunk/packages/fcl-json/ try try fJSON := parser.Parse as TJSONObject; diff --git a/wiki/wiki.txt b/wiki/wiki.txt index 39a4e7e3..b913c9af 100644 --- a/wiki/wiki.txt +++ b/wiki/wiki.txt @@ -300,10 +300,9 @@ To do so, the application option _Native project compiler_ must be set according Since the version 2 alpha 1, Coedit also handles DUB projects. -DUB project description must be in JSON format. JSON format must be strictly compliant with RFC 4627 and trailing commas will cause errors. -This restriction will be removed in the future (when CE will be build with FPC 3.0.2). +DUB project description must be in JSON format, SDL in not handled. -Dub projects are handled exactly as the native projects are. The _project_ menu proposes the same features. +DUB projects are handled exactly as the CE projects are. The _project_ menu proposes the same features. However the configuration is done in another widget, see the [dedicated paragraph][lnk_widg_dub]. # D Completion Daemon integration