From f20a57624542bd88cce4d9a8db45e768f5ce1350 Mon Sep 17 00:00:00 2001 From: Basile Burg Date: Thu, 29 Dec 2016 09:43:45 +0100 Subject: [PATCH] switch to FPC 3.0.2 --- etc/fcl-json/src/README.txt | 229 --- etc/fcl-json/src/xfpjson.pp | 3135 ------------------------------ etc/fcl-json/src/xfpjsonrtti.pp | 1119 ----------- etc/fcl-json/src/xjsonconf.pp | 809 -------- etc/fcl-json/src/xjsonparser.pp | 382 ---- etc/fcl-json/src/xjsonscanner.pp | 481 ----- lazproj/coedit.lpi | 2 +- src/ce_common.pas | 34 +- src/ce_dastworx.pas | 2 +- src/ce_dubproject.pas | 5 +- src/ce_dubprojeditor.pas | 2 +- src/ce_gdb.pas | 2 +- src/ce_halstead.pas | 2 +- src/ce_libman.pas | 10 +- src/ce_libmaneditor.pas | 2 +- src/ce_main.pas | 2 +- src/ce_symstring.pas | 4 +- 17 files changed, 29 insertions(+), 6193 deletions(-) delete mode 100644 etc/fcl-json/src/README.txt delete mode 100644 etc/fcl-json/src/xfpjson.pp delete mode 100644 etc/fcl-json/src/xfpjsonrtti.pp delete mode 100644 etc/fcl-json/src/xjsonconf.pp delete mode 100644 etc/fcl-json/src/xjsonparser.pp delete mode 100644 etc/fcl-json/src/xjsonscanner.pp diff --git a/etc/fcl-json/src/README.txt b/etc/fcl-json/src/README.txt deleted file mode 100644 index 45d8eaa6..00000000 --- a/etc/fcl-json/src/README.txt +++ /dev/null @@ -1,229 +0,0 @@ -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/xfpjson.pp b/etc/fcl-json/src/xfpjson.pp deleted file mode 100644 index 14053d62..00000000 --- a/etc/fcl-json/src/xfpjson.pp +++ /dev/null @@ -1,3135 +0,0 @@ -{ - 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 xfpjson; - -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; - C : AnsiChar; - -begin - I:=1; - J:=1; - Result:=''; - L:=Length(S); - P:=PJSONCharType(S); - While I<=L do - begin - C:=AnsiChar(P^); - if (C in ['"','/','\',#0..#31]) then - begin - Result:=Result+Copy(S,J,I-J); - Case C 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'; - else - Result:=Result+'\u'+HexStr(Ord(C),4); - 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/xfpjsonrtti.pp b/etc/fcl-json/src/xfpjsonrtti.pp deleted file mode 100644 index 5f0a5387..00000000 --- a/etc/fcl-json/src/xfpjsonrtti.pp +++ /dev/null @@ -1,1119 +0,0 @@ -unit xfpjsonrtti; - -{$mode objfpc} - -interface - -uses - Classes, SysUtils, contnrs, typinfo, xfpjson, rttiutils, xjsonparser; - -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/xjsonconf.pp b/etc/fcl-json/src/xjsonconf.pp deleted file mode 100644 index f1f096a8..00000000 --- a/etc/fcl-json/src/xjsonconf.pp +++ /dev/null @@ -1,809 +0,0 @@ -{ - 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 xjsonConf; - -interface - -uses - SysUtils, Classes, xfpjson, xjsonscanner, xjsonparser; - -Const - DefaultJSONOptions = [joUTF8,joComments]; - -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; - FJSONOptions: TJSONOptions; - FKey: TJSONObject; - procedure DoSetFilename(const AFilename: String; ForceReload: Boolean); - procedure SetFilename(const AFilename: String); - procedure SetJSONOptions(AValue: TJSONOptions); - 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; - Property JSONOptions : TJSONOptions Read FJSONOptions Write SetJSONOptions Default DefaultJSONOptions; - 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; - FJSONOptions:=DefaultJSONOptions; -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 : TFileStream; - S : TJSONStringType; - -begin - if Modified then - begin - F:=TFileStream.Create(FileName,fmCreate); - Try - if Formatted then - S:=FJSON.FormatJSON(Formatoptions,FormatIndentSize) - else - S:=FJSON.AsJSON; - if S>'' then - F.WriteBuffer(S[1],Length(S)); - Finally - F.Free; - 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,FJSONOptions); - 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; - -procedure TJSONConfig.SetJSONOptions(AValue: TJSONOptions); -begin - if FJSONOptions=AValue then Exit; - FJSONOptions:=AValue; - if csLoading in ComponentState then - exit; - if (FFileName<>'') then - Reload; -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/xjsonparser.pp b/etc/fcl-json/src/xjsonparser.pp deleted file mode 100644 index fa6f0b7d..00000000 --- a/etc/fcl-json/src/xjsonparser.pp +++ /dev/null @@ -1,382 +0,0 @@ -{ - 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 xjsonparser; - -interface - -uses - Classes, SysUtils, xfpJSON, xjsonscanner; - -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/xjsonscanner.pp b/etc/fcl-json/src/xjsonscanner.pp deleted file mode 100644 index 10f0b275..00000000 --- a/etc/fcl-json/src/xjsonscanner.pp +++ /dev/null @@ -1,481 +0,0 @@ -{ - 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 xjsonscanner; - -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 20c371e8..b7b260fb 100644 --- a/lazproj/coedit.lpi +++ b/lazproj/coedit.lpi @@ -543,7 +543,7 @@ - + diff --git a/src/ce_common.pas b/src/ce_common.pas index 05b9ce14..edc06f90 100644 --- a/src/ce_common.pas +++ b/src/ce_common.pas @@ -16,7 +16,7 @@ uses forms, ComCtrls, {$ENDIF} LazFileUtils, process, asyncprocess, ghashmap, ghashset, LCLIntf, strutils, - xfpjson; + fpjson; const exeExt = {$IFDEF WINDOWS} '.exe' {$ELSE} '' {$ENDIF}; @@ -67,7 +67,7 @@ type end; // sugar for strings - TStringHelper = type helper for string + TCEStringHelper = type helper(TStringHelper) for string function isEmpty: boolean; function isNotEmpty: boolean; function isBlank: boolean; @@ -397,77 +397,77 @@ begin exit(self <> nil); end; -function TStringHelper.isEmpty: boolean; +function TCEStringHelper.isEmpty: boolean; begin exit(self = ''); end; -function TStringHelper.isNotEmpty: boolean; +function TCEStringHelper.isNotEmpty: boolean; begin exit(self <> ''); end; -function TStringHelper.isBlank: boolean; +function TCEStringHelper.isBlank: boolean; begin exit(ce_common.isBlank(self)); end; -function TStringHelper.extractFileName: string; +function TCEStringHelper.extractFileName: string; begin exit(sysutils.extractFileName(self)); end; -function TStringHelper.extractFileExt: string; +function TCEStringHelper.extractFileExt: string; begin exit(sysutils.extractFileExt(self)); end; -function TStringHelper.extractFilePath: string; +function TCEStringHelper.extractFilePath: string; begin exit(sysutils.extractFilePath(self)); end; -function TStringHelper.extractFileDir: string; +function TCEStringHelper.extractFileDir: string; begin exit(sysutils.extractFileDir(self)); end; -function TStringHelper.stripFileExt: string; +function TCEStringHelper.stripFileExt: string; begin exit(ce_common.stripFileExt(self)); end; -function TStringHelper.fileExists: boolean; +function TCEStringHelper.fileExists: boolean; begin exit(sysutils.FileExists(self)); end; -function TStringHelper.dirExists: boolean; +function TCEStringHelper.dirExists: boolean; begin exit(sysutils.DirectoryExists(self)); end; -function TStringHelper.upperCase: string; +function TCEStringHelper.upperCase: string; begin exit(sysutils.upperCase(self)); end; -function TStringHelper.length: integer; +function TCEStringHelper.length: integer; begin exit(system.length(self)); end; -function TStringHelper.toInt: integer; +function TCEStringHelper.toInt: integer; begin exit(strToInt(self)); end; -function TStringHelper.toIntNoExcept(default: integer = -1): integer; +function TCEStringHelper.toIntNoExcept(default: integer = -1): integer; begin exit(StrToIntDef(self, default)); end; -function TStringHelper.normalizePath: string; +function TCEStringHelper.normalizePath: string; begin exit(TrimFilename(self)); end; diff --git a/src/ce_dastworx.pas b/src/ce_dastworx.pas index aa951579..470922b1 100644 --- a/src/ce_dastworx.pas +++ b/src/ce_dastworx.pas @@ -4,7 +4,7 @@ unit ce_dastworx; interface uses - Classes, SysUtils, process, xjsonscanner, xfpjson, xjsonparser, ce_common; + Classes, SysUtils, process, jsonscanner, fpjson, jsonparser, ce_common; (** * Gets the module name and the imports of the source code located in diff --git a/src/ce_dubproject.pas b/src/ce_dubproject.pas index a0242698..352ff5ab 100644 --- a/src/ce_dubproject.pas +++ b/src/ce_dubproject.pas @@ -5,7 +5,7 @@ unit ce_dubproject; interface uses - Classes, SysUtils, xfpjson, xjsonparser, xjsonscanner, process, strutils, + Classes, SysUtils, fpjson, jsonparser, jsonscanner, process, strutils, LazFileUtils, RegExpr, ce_common, ce_interfaces, ce_observer, ce_dialogs, ce_processes, ce_writableComponent, ce_compilers; @@ -424,9 +424,6 @@ begin // FreeAndNil(fJSON); parser := TJSONParser.Create(loader, [joIgnoreTrailingComma, joUTF8]); - //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/ - //latest in etc = rev 34196. try try fJSON := parser.Parse as TJSONObject; diff --git a/src/ce_dubprojeditor.pas b/src/ce_dubprojeditor.pas index 5db923a7..243482c6 100644 --- a/src/ce_dubprojeditor.pas +++ b/src/ce_dubprojeditor.pas @@ -6,7 +6,7 @@ interface uses Classes, SysUtils, FileUtil, TreeFilterEdit, Forms, Controls, Graphics, - Dialogs, ExtCtrls, Menus, StdCtrls, Buttons, ComCtrls, xjsonparser, xfpjson, + Dialogs, ExtCtrls, Menus, StdCtrls, Buttons, ComCtrls, jsonparser, fpjson, ce_widget, ce_common, ce_interfaces, ce_observer, ce_dubproject, ce_sharedres, ce_dsgncontrols; diff --git a/src/ce_gdb.pas b/src/ce_gdb.pas index 179a0187..c3bc8ce3 100644 --- a/src/ce_gdb.pas +++ b/src/ce_gdb.pas @@ -7,7 +7,7 @@ interface uses Classes, SysUtils, FileUtil, Forms, Controls, Graphics, RegExpr, ComCtrls, PropEdits, GraphPropEdits, RTTIGrids, Dialogs, ExtCtrls, Menus, Buttons, - StdCtrls, process, xfpjson, typinfo, Unix, ListViewFilterEdit, SynEdit, + StdCtrls, process, fpjson, typinfo, Unix, ListViewFilterEdit, SynEdit, ce_common, ce_interfaces, ce_widget, ce_processes, ce_observer, ce_synmemo, ce_sharedres, ce_stringrange, ce_dsgncontrols, ce_dialogs, ce_dbgitf, ce_ddemangle, ce_writableComponent, EditBtn, strutils, ObjectInspector; diff --git a/src/ce_halstead.pas b/src/ce_halstead.pas index 4f598cbd..ec877cc9 100644 --- a/src/ce_halstead.pas +++ b/src/ce_halstead.pas @@ -5,7 +5,7 @@ unit ce_halstead; interface uses - Classes, SysUtils, xfpjson, math, + Classes, SysUtils, fpjson, math, ce_common, ce_observer, ce_interfaces, ce_dastworx, ce_writableComponent, ce_synmemo; diff --git a/src/ce_libman.pas b/src/ce_libman.pas index 07d34a81..ec6385c0 100644 --- a/src/ce_libman.pas +++ b/src/ce_libman.pas @@ -195,10 +195,7 @@ end; function TLibraryItem.getModule(const value: string): TModuleInfo; begin - //TODO-cFCL/LCL: use THashMap.GetValue from next FPC rlz - result := nil; - if fModulesByName.contains(value) then - exit(fModulesByName.GetData(value)); + fModulesByName.GetValue(value, result); end; function TLibraryItem.addModuleInfo: TModuleInfo; @@ -431,10 +428,7 @@ end; function TLibraryManager.getLibraryByAlias(const value: string): TLibraryItem; begin - //TODO-cFCL/LCL: use THashMap.GetValue from next FPC rlz - result := nil; - if fItemsByAlias.contains(value) then - exit(fItemsByAlias.GetData(value)); + fItemsByAlias.GetValue(value, result); end; function TLibraryManager.getLibraryByImport(const value: string): TLibraryItem; diff --git a/src/ce_libmaneditor.pas b/src/ce_libmaneditor.pas index 8e6cb27d..8967365a 100644 --- a/src/ce_libmaneditor.pas +++ b/src/ce_libmaneditor.pas @@ -7,7 +7,7 @@ interface uses Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls, Menus, ComCtrls, Buttons, LazFileUtils, fphttpclient, StdCtrls, - xfpjson, xjsonparser, + fpjson, jsonparser, ce_widget, ce_interfaces, ce_ceproject, ce_dmdwrap, ce_common, ce_dialogs, ce_sharedres, process, ce_dubproject, ce_observer, ce_dlang, ce_libman, ce_projutils, ce_dsgncontrols, ce_stringrange; diff --git a/src/ce_main.pas b/src/ce_main.pas index 7f630a05..f2ef207f 100644 --- a/src/ce_main.pas +++ b/src/ce_main.pas @@ -9,7 +9,7 @@ uses StdCtrls, AnchorDocking, AnchorDockStorage, AnchorDockOptionsDlg, Controls, Graphics, strutils, Dialogs, Menus, ActnList, ExtCtrls, process, {$IFDEF WINDOWS}Windows, {$ENDIF} XMLPropStorage, SynExportHTML, fphttpclient, - xfpjson, xjsonparser, xjsonscanner, + fpjson, jsonparser, jsonscanner, ce_common, ce_dmdwrap, ce_ceproject, ce_synmemo, ce_writableComponent, ce_widget, ce_messages, ce_interfaces, ce_editor, ce_projinspect, ce_ceprojeditor, ce_search, ce_miniexplorer, ce_libman, ce_libmaneditor, ce_todolist, ce_observer, diff --git a/src/ce_symstring.pas b/src/ce_symstring.pas index 753dd7ad..c2fd5ae4 100644 --- a/src/ce_symstring.pas +++ b/src/ce_symstring.pas @@ -5,7 +5,7 @@ unit ce_symstring; interface uses - ce_observer, ce_interfaces, ce_ceproject, ce_synmemo, ce_common, + ce_observer, sysutils, ce_interfaces, ce_ceproject, ce_synmemo, ce_common, ce_stringrange; type @@ -56,7 +56,7 @@ type implementation uses - Forms, SysUtils, Classes; + Forms, Classes; var symbolExpander: TCESymbolExpander;