/// minimum standand-alone cross-platform JSON process using variants

// - this unit is a part of the freeware Synopse mORMot framework,

// licensed under a MPL/GPL/LGPL tri-license; version 1.18

unit SynCrossPlatformJSON;

{

This file is part of Synopse mORMot framework.

Synopse mORMot framework. Copyright (c) Arnaud Bouchez

Synopse Informatique - https://synopse.info

*** BEGIN LICENSE BLOCK *****

Version: MPL 1.1/GPL 2.0/LGPL 2.1

The contents of this file are subject to the Mozilla Public License Version

1.1 (the "License"); you may not use this file except in compliance with

the License. You may obtain a copy of the License at

http://www.mozilla.org/MPL

Software distributed under the License is distributed on an "AS IS" basis,

WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License

for the specific language governing rights and limitations under the License.

The Original Code is Synopse mORMot framework.

The Initial Developer of the Original Code is Arnaud Bouchez.

Portions created by the Initial Developer are Copyright (c)

the Initial Developer. All Rights Reserved.

Contributor(s):

- Witya

Alternatively, the contents of this file may be used under the terms of

either the GNU General Public License Version 2 or later (the "GPL"), or

the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),

in which case the provisions of the GPL or the LGPL are applicable instead

of those above. If you wish to allow use of your version of this file only

under the terms of either the GPL or the LGPL, and not to allow others to

use your version of this file under the terms of the MPL, indicate your

decision by deleting the provisions above and replace them with the notice

and other provisions required by the GPL or the LGPL. If you do not delete

the provisions above, a recipient may use your version of this file under

the terms of any one of the MPL, the GPL or the LGPL.

***** END LICENSE BLOCK *****

Should compile with Delphi for any platform (including NextGen for mobiles),

with FPC 2.7 or Kylix, and with SmartMobileStudio 2

- FPC prior to 2.7.1 has some issues with working with variants: UTF-8

encoding is sometimes lost, and TInvokeableVariantType.SetProperty is broken

}

{$i SynCrossPlatform.inc} // define e.g. HASINLINE

interface

uses

SysUtils,

Classes,

{$ifdef NEXTGEN}

System.Generics.Collections,

{$endif}

{$ifndef NEXTGEN}

Contnrs,

{$endif}

Variants,

TypInfo;

type

TStringDynArray = array of string;

TVariantDynArray = array of variant;

TIntegerDynArray = array of integer;

/// this type is used to store BLOB content

TByteDynArray = array of byte;

PByteDynArray = ^TByteDynArray;

{$ifdef FPC}

NativeInt = PtrInt;

NativeUInt = PtrUInt;

{$else}

{$ifndef ISDELPHI2010} // Delphi 2009 NativeUInt is buggy

NativeInt = integer;

NativeUInt = cardinal;

{$endif}

{$ifndef UNICODE}

RawByteString = AnsiString;

{$endif}

{$endif}

// this type will store UTF-8 encoded buffer (also on NextGen platform)

{$ifdef NEXTGEN}

TUTF8Buffer = TBytes;

// TObjecTList is not defined in Mobile platforms

TObjectList = TObjectList<TObject>;

{$else}

TUTF8Buffer = UTF8String;

{$endif}

/// exception used during standand-alone cross-platform JSON process

EJSONException = class(Exception);

/// which kind of document the TJSONVariantData contains

TJSONVariantKind = (jvUndefined, jvObject, jvArray);

PJSONVariantData = ^TJSONVariantData;

{$A-}

/// stores any JSON object or array as variant

// - this structure is not very optimized for speed or memory use, but is

// simple and strong enough for our client-side purpose

// - it is in fact already faster (and using less memory) than DBXJSON and

// SuperObject / XSuperObject libraries - of course, mORMot's TDocVariant

// is faster, as dwsJSON is in some cases, but those are not cross-platform

{$ifdef USEOBJECTINSTEADOFRECORD}

TJSONVariantData = object

protected

{$else}

TJSONVariantData = record

private

{$endif}

VType: TVarType;

_Align: byte;

VKind: TJSONVariantKind;

VCount: integer;

function GetKind: TJSONVariantKind;

function GetCount: integer;

function GetVarData(const aName: string; var Dest: TVarData): boolean;

function GetValue(const aName: string): variant;

function GetValueCopy(const aName: string): variant;

procedure SetValue(const aName: string; const aValue: variant);

function GetItem(aIndex: integer): variant;

procedure SetItem(aIndex: integer; const aItem: variant);

public

/// names of this jvObject

Names: TStringDynArray;

/// values of this jvObject or jvArray

Values: TVariantDynArray;

/// initialize the low-level memory structure

// - you should call Clear before calling overloaded Init several times

procedure Init; overload;

/// initialize the low-level memory structure with a given JSON content

// - you should call Clear before calling overloaded Init several times

procedure Init(const JSON: string); overload;

/// initialize the low-level memory structure with a given array of variant

// - you should call Clear before calling overloaded Init several times

procedure InitFrom(const aValues: TVariantDynArray); overload;

/// delete all internal stored data

// - basically the same as Finalize(aJsonVariantData) aJsonVariantData.Init

// - you should call this method before calling overloaded Init several times

procedure Clear;

/// access to a nested TJSONVariantData item

// - returns nil if aName was not found, or not a true TJSONVariantData item

function Data(const aName: string): PJSONVariantData;

{$ifdef HASINLINE}inline;{$endif}

/// access to a nested TJSONVariantData item, creating it if necessary

// - aPath can be specified with any depth, e.g. 'level1.level2.level3'

// - if the item does not exist or is not a true TJSONVariantData, a new

// one will be created, and returned as pointer

function EnsureData(const aPath: string): PJSONVariantData;

/// add a void TJSONVariantData to the jvArray and return a pointer to it

function AddItem: PJSONVariantData;

/// add a value to the jvArray

// - raise a ESJONException if the instance is a jvObject

procedure AddValue(const aValue: variant);

/// add a name/value pair to the jvObject

// - raise a ESJONException if the instance is a jvArray

procedure AddNameValue(const aName: string; const aValue: variant);

/// search for a name in this jvObject

function NameIndex(const aName: string): integer;

/// set a value of this jvObject to a given path

// - aPath can be specified with any depth, e.g. 'level1.level2.level3'

procedure SetPath(const aPath: string; const aValue: variant);

/// fill this document from a JSON array or object

function FromJSON(const JSON: string): boolean;

/// convert this document into JSON array or object

function ToJSON: string;

/// fill the published properties of supplied class from this JSON object

function ToObject(Instance: TObject): boolean;

/// create an instance, and fill its published properties from this JSON object

// - it should contain some "ClassName" properties, i.e. JSON should have

// been created by ObjectToJSON(Instance,true) and the class should have

// been registered with RegisterClassForJSON()

function ToNewObject: TObject;

/// kind of document this TJSONVariantData contains

// - returns jvUndefined if this instance is not a TJSONVariant custom variant

property Kind: TJSONVariantKind read GetKind;

/// number of items in this jvObject or jvArray

// - returns 0 if this instance is not a TJSONVariant custom variant

property Count: integer read GetCount;

/// access by name to a value of this jvObject

// - value is returned as (varVariant or varByRef) for best speed

// - will return UnAssigned if aName is not correct or this is not a jvObject

property Value[const aName: string]: variant read GetValue write SetValue; default;

/// access by name to a value of this jvObject

// - value is returned as a true copy (not varByRef) so this property is

// slower but safer than Value[], if the owning TJsonVariantData disappears

// - will return UnAssigned if aName is not correct or this is not a jvObject

property ValueCopy[const aName: string]: variant read GetValueCopy;

/// access by index to a value of this jvArray

// - will return UnAssigned if aIndex is not correct or this is not a jvArray

property Item[aIndex: integer]: variant read GetItem write SetItem;

end;

{$A }

/// low-level class used to register TJSONVariantData as custom type

// - allows late binding to values, e.g.

// ! jsonvar.avalue := jsonvar.avalue 1;

// - due to an issue with FPC implementation, you can only read properties,

// not set them, so you should write:

// ! TJSONVariantData(jsonvar)['avalue'] := jsonvar.avalue 1;

TJSONVariant = class(TInvokeableVariantType)

protected

{$ifndef FPC}

{$ifndef ISDELPHI6}

function FixupIdent(const AText: string): string; override;

{$endif}

{$endif}

public

procedure Copy(var Dest: TVarData; const Source: TVarData;

const Indirect: Boolean); override;

procedure Clear(var V: TVarData); override;

function GetProperty(var Dest: TVarData; const V: TVarData;

const Name: string): Boolean; override;

{$ifdef FPC_VARIANTSETVAR} // see http://mantis.freepascal.org/view.php?id=26773

function SetProperty(var V: TVarData; const Name: string;

const Value: TVarData): Boolean; override;

{$else}

function SetProperty(const V: TVarData; const Name: string;

const Value: TVarData): Boolean; override;

{$endif}

procedure Cast(var Dest: TVarData; const Source: TVarData); override;

procedure CastTo(var Dest: TVarData; const Source: TVarData;

const AVarType: TVarType); override;

end;

/// handle a JSON result table, as returned by mORMot's server

// - handle both expanded and non expanded layout

// - will be used e.g. on client side for variant-based ORM data parsing

TJSONTable = class

protected

fJSON: string;

fFieldNames: TStringDynArray;

fJSONExpanded: boolean;

fJSONIndexFirstValue: integer;

fJSONCurrentIndex: integer;

fRowValues: TVariantDynArray;

function Get(const FieldName: string): variant;

public

/// parse the supplied JSON content

constructor Create(const aJSON: string);

/// case-insensitive search for a field name

function FieldIndex(const FieldName: string): integer;

/// to be called in a loop to iterate through all data rows

// - if returned true, Value[] contains the fields of this row

function Step(SeekFirst: boolean=false): boolean;

/// to be called in a loop to iterate through all data rows

// - if returned true, RowValues contains this row as TJSONVariant

function StepValue(var RowValues: variant; SeekFirst: boolean=false): boolean;

/// after Step() returned true, can be used to retrieve a field value by name

property Value[const FieldName: string]: variant read Get; default;

/// after Step() returned true, can be used to retrieve a field value by index

property RowValues: TVariantDynArray read fRowValues;

/// the recognized field names

property FieldNames: TStringDynArray read fFieldNames;

/// the associated JSON content

property JSON: string read fJSON;

end;

/// an abstract type used for RTTI type information

TRTTITypeInfo = PPropInfo;

/// an abstract type used for RTTI property information

TRTTIPropInfo = PPropInfo;

TRTTIPropInfoDynArray = array of TRTTIPropInfo;

/// handle a JSON result table, as returned by mORMot's server

// - handle both expanded and non expanded layout

// - this class is able to use RTTI to fill all published properties of

// a TObject

TJSONTableObject = class(TJSONTable)

protected

fTypeInfo: pointer;

fPropInfo: array of TRTTIPropInfo;

procedure FillPropInfo(aTypeInfo: TRTTITypeInfo); virtual;

procedure FillInstance(Instance: TObject); virtual;

function GetPropInfo(aTypeInfo: TRTTITypeInfo; const PropName: string): TRTTIPropInfo; virtual;

public

/// to be called in a loop to iterate through all data rows

// - if returned true, Object published properties will contain this row

function StepObject(Instance: TObject; SeekFirst: boolean=false): boolean; virtual;

end;

/// used e.g. by TSynTest for each test case

TPublishedMethod = record

Name: string;

Method: TMethod;

end;

/// as filled by GetPublishedMethods()

TPublishedMethodDynArray = array of TPublishedMethod;

/// create a TJSONVariant instance from a given JSON content

// - typical usage may be:

//! var doc: variant;

//! json: string;

//! begin

//! doc := JSONVariant('{"test":1234,"name":"Joh\"n\r"}');

//! assert(doc.test=1234); // access via late binding

//! assert(doc.name='Joh"n'#13);

//! assert(doc.name2=null); // unknown properties returns null

//! json := doc; // to convert a TJSONVariant to JSON, just assign to a string

//! assert(json='{"test":1234,"name":"Joh\"n\r"}');

//! end;

// - note that FPC does not allow to set values by late-binding

function JSONVariant(const JSON: string): variant; overload;

/// create a TJSONVariant TJSONVariant array from a supplied array of values

function JSONVariant(const values: TVariantDynArray): variant; overload;

/// create a TJSONVariant TJSONVariant array from a supplied array of values

function JSONVariantFromConst(const constValues: array of variant): variant;

/// access to a TJSONVariant instance members

// - e.g. Kind, Count, Names[] or Values[]

// - will raise an exception if the supplied variant is not a TJSONVariant

// - this function is safer than TJSONVariant(JSONVariant)

function JSONVariantData(const JSONVariant: variant): PJSONVariantData;

/// access to a TJSONVariant instance members

// - e.g. Kind, Count, Names[] or Values[]

// - will return a read-only fake TJSONVariant with Kind=jvUndefined if the

// supplied variant is not a TJSONVariant

// - if ExpectedKind is jvArray of jvObject, it would return a fake TJSONVariant

// with Kind=jvUndefined if the JSONVariant kind does not match - so you can write:

// !var _a: integer;

// ! _arr: PJSONVariantData;

// !...

// ! _arr := JSONVariantDataSafe(_variant,jvArray);

// ! SetLength(result,_arr.Count);

// ! for _a := 0 to _arr.Count-1 do

// ! result[_a] := _arr.Values[_a];

// in the above code, _arr.Count will be 0 if _variant.Kind<>jvArray

// - this function is safer than TJSONVariant(JSONVariant)

function JSONVariantDataSafe(const JSONVariant: variant;

ExpectedKind: TJSONVariantKind=jvUndefined): PJSONVariantData;

var

/// the custom variant type definition registered for TJSONVariant

JSONVariantType: TInvokeableVariantType;

/// compute the quoted JSON string corresponding to the supplied text

function StringToJSON(const Text: string): string;

/// compute the JSON representation of a floating-point value

procedure DoubleToJSON(Value: double; var result: string);

/// compute the ISO-8601 JSON text representation of a date/time value

// - e.g. "YYYY-MM-DD" "Thh:mm:ss" or "YYYY-MM-DDThh:mm:ss"

// - if Date is 0, will return ""

function DateTimeToJSON(Value: TDateTime): string;

/// compute the JSON representation of a variant value

// - will work for simple types, or TJSONVariant object or array

function ValueToJSON(const Value: variant): string;

/// compute a variant from its JSON representation

// - will work for simple types, or TJSONVariant object or array

function JSONToValue(const JSON: string): variant;

/// compute the ISO-8601 JSON text representation of the current date/time value

// - e.g. "2015-06-27T20:59:29"

function NowToIso8601: string;

/// compute the unquoted ISO-8601 text representation of a date/time value

// - e.g. 'YYYY-MM-DD' 'Thh:mm:ss' or 'YYYY-MM-DDThh:mm:ss'

// - if Date is 0, will return ''

function DateTimeToIso8601(Value: TDateTime): string;

/// convert unquoted ISO-8601 text representation into a date/time value

// - e.g. 'YYYY-MM-DD' 'Thh:mm:ss' or 'YYYY-MM-DDThh:mm:ss'

function Iso8601ToDateTime(const Value: string): TDateTime;

/// compute the JSON representation of an object published properties

// - handle only simple types of properties, not nested class instances

// - any TList/TObjectList/TCollection will be serialized as JSON array

function ObjectToJSON(Instance: TObject; StoreClassName: boolean=false): string;

/// fill an object published properties from the supplied JSON object

// - handle only simple types of properties, not nested class instances

function JSONToObject(Instance: TObject; const JSON: string): boolean;

/// create a new object and fil its published properties from the supplied

// JSON object, which should include "ClassName":"..." properties

// - JSON should have been created with ObjectToJSON(Instance,true) and

// the class should have been registered with RegisterClassForJSON()

function JSONToNewObject(const JSON: string): pointer;

/// register the class types to be created from its name

// - used e.g. by JSONToNewObject() or TJSONVariantData.ToNewObject

procedure RegisterClassForJSON(const Classes: array of TClass);

/// create a class instance from its name

// - the class should have been registered previously via RegisterClassForJSON()

// - if the supplied class name is not found, will return nil

function CreateClassForJSON(const ClassName: string): TObject;

/// create a list of object published properties from the supplied JSON object

// - handle only simple types of properties, not nested class instances

function JSONToObjectList(ItemClass: TClass; const JSON: string): TObjectList;

/// return a string corresponding to the type name, as stored in the RTTI

// - e.g. 'TDateTime', 'TByteDynArray', 'TModTime', 'TCreateTime'

function RTTIPropInfoTypeName(PropInfo: TRTTIPropInfo): string;

/// retrieve the published properties type information about a given class

procedure GetPropsInfo(TypeInfo: TRTTITypeInfo; var PropNames: TStringDynArray;

var PropRTTI: TRTTIPropInfoDynArray);

/// retrieve the value of a published property as variant

function GetInstanceProp(Instance: TObject; PropInfo: TRTTIPropInfo; StoreClassName: boolean = False): variant;

/// set the value of a published property from a variant

procedure SetInstanceProp(Instance: TObject; PropInfo: TRTTIPropInfo;

const Value: variant);

/// retrieve all the published methods of a given class, using RTTI

procedure GetPublishedMethods(Instance: TObject; out Methods: TPublishedMethodDynArray);

/// convert an "array of const" parameter value into its string representation

function VarRecToValue(const V: TVarRec; out wasString: boolean): string;

/// convert the supplied text as "text", as expected by SQL standard

procedure DoubleQuoteStr(var text: string);

/// decode a Base64-encoded string

// - default withBase64Magic=TRUE will expect the string to start with our

// JSON_BASE64_MAGIC marker

function Base64JSONStringToBytes(const JSONString: string;

var Bytes: TByteDynArray; withBase64Magic: boolean=true): boolean;

/// Base-64 encode a BLOB into string

// - default withBase64Magic=TRUE will include our JSON_BASE64_MAGIC marker

function BytesToBase64JSONString(const Bytes: TByteDynArray;

withBase64Magic: boolean=true): string;

const

/// special code to mark Base64 binary content in JSON string

// - Unicode special char U FFF0 is UTF-8 encoded as EF BF B0 bytes

// - prior to Delphi 2009, it won't work as expected since U FFF0 won't be

// able to be converted into U FFF0

{$ifdef UNICODE}

JSON_BASE64_MAGIC: word = $fff0;

{$else}

JSON_BASE64_MAGIC: array[0..2] of byte = ($ef,$bf,$b0);

{$endif}

/// size, in platform chars, of our special code to mark Base64 binary

// content in JSON string

// - equals 1 since Delphi 2009 (UTF-16 encoded), or 3 for older versions

// (UTF-8encoded) of the compiler compiler

JSON_BASE64_MAGIC_LEN = sizeof(JSON_BASE64_MAGIC) div sizeof(char);

{$ifndef ISSMS}

/// read an UTF-8 (JSON) file into a native string

// - file should be existing, otherwise an exception is raised

function UTF8FileToString(const aFileName: TFileName): string;

{$endif}

/// this function is faster than str := str chr !

procedure AppendChar(var str: string; chr: Char);

{$ifdef HASINLINE}inline;{$endif}

/// check that two ASCII-7 latin text do match

function IdemPropName(const PropName1,PropName2: string): boolean; overload;

{$ifdef HASINLINE}inline;{$endif}

/// check that two ASCII-7 latin text do match

// - first parameter is expected to be a shortstring low-level buffer - as such,

// this overloaded function would work with NEXTGEN encoded RTTI

function IdemPropName(PropName1: PByteArray; const PropName2: string): boolean; overload;

{$ifdef HASINLINE}inline;{$endif}

/// convert ASCII-7 latin text, encoded as a shortstring buffer, into a string

// - as such, this function would work with NEXTGEN encoded RTTI

function ShortStringToString(Buffer: PByteArray): string;

/// check that two ASCII-7 latin text do match

function StartWithPropName(const PropName1,PropName2: string): boolean;

implementation

function IdemPropName(const PropName1,PropName2: string): boolean;

var L,i: integer;

begin

result := false;

L := length(PropName2);

if length(PropName1)<>L then

exit;

for i := 1 to L do

if (ord(PropName1[i]) xor ord(PropName2[i])) and

{$ifdef UNICODE}$ffdf{$else}$df{$endif}<>0 then

exit;

result := true;

end;

function ShortStringToString(Buffer: PByteArray): string;

{$ifdef UNICODE}

var i: integer;

begin

SetLength(result,Buffer^[0]);

for i := 1 to Buffer^[0] do

result[i] := chr(Buffer^[i]);

end;

{$else}

begin

SetString(result,PAnsiChar(@Buffer^[1]),Buffer^[0]);

end;

{$endif}

function IdemPropName(PropName1: PByteArray; const PropName2: string): boolean;

var L,i: integer;

begin

result := false;

L := length(PropName2);

if PropName1^[0]<>L then

exit;

for i := 1 to L do

if (PropName1^[i] xor ord(PropName2[i])) and

{$ifdef UNICODE}$ffdf{$else}$df{$endif}<>0 then

exit;

result := true;

end;

function StartWithPropName(const PropName1,PropName2: string): boolean;

var L,i: integer;

begin

result := false;

L := length(PropName2);

if length(PropName1)<L then

exit;

for i := 1 to L do

if (ord(PropName1[i]) xor ord(PropName2[i])) and

{$ifdef UNICODE}$ffdf{$else}$df{$endif}<>0 then

exit;

result := true;

end;

{$ifndef ISSMS} // there is no file within HTML5 DOM

{$ifdef FPC}

// assume string is UTF-8 encoded (as with Lazarus/LCL)

// note that when working with variants, FPC 2.7.1 sometimes clear the code page

type UTF8ToString = RawByteString;

{$else}

{$ifndef UNICODE}

function UTF8ToString(const utf8: TUTF8Buffer): string;

begin

result := UTF8ToAnsi(utf8);

end;

{$endif}

{$endif}

function UTF8FileToString(const aFileName: TFileName): string;

var F: TFileStream;

len: integer;

utf8: TUTF8Buffer;

begin

F := TFileStream.Create(aFileName,fmOpenRead);

try

len := F.Size;

SetLength(utf8,len);

{$ifdef NEXTGEN}

F.Read(utf8[0],len);

result := TEncoding.UTF8.GetString(utf8);

{$else}

F.Read(utf8[1],len);

result := UTF8ToString(utf8);

{$endif}

finally

F.Free;

end;

end;

{$endif}

function JSONVariant(const JSON: string): variant;

begin

VarClear(result);

TJSONVariantData(result).FromJSON(JSON);

end;

function JSONVariant(const values: TVariantDynArray): variant;

begin

VarClear(result);

TJSONVariantData(result).Init;

TJSONVariantData(result).VKind := jvArray;

TJSONVariantData(result).VCount := length(values);

TJSONVariantData(result).Values := values;

end;

function JSONVariantFromConst(const constValues: array of variant): variant;

var i: integer;

begin

VarClear(result);

with TJSONVariantData(result) do begin

Init;

VKind := jvArray;

VCount := length(values);

SetLength(Values,VCount);

for i := 0 to VCount-1 do

Values[i] := constValues[i];

end;

end;

function JSONVariantData(const JSONVariant: variant): PJSONVariantData;

begin

with TVarData(JSONVariant) do

if VType=JSONVariantType.VarType then

result := @JSONVariant else

if VType=varByRef or varVariant then

result := JSONVariantData(PVariant(VPointer)^) else

raise EJSONException.CreateFmt('JSONVariantData.Data(%d<>JSONVariant)',[VType]);

end;

const // will be in code section of the exe, so will be read-only by design

JSONVariantDataFake: TJSONVariantData = ();

function JSONVariantDataSafe(const JSONVariant: variant;

ExpectedKind: TJSONVariantKind=jvUndefined): PJSONVariantData;

begin

with TVarData(JSONVariant) do

if VType=JSONVariantType.VarType then

if (ExpectedKind=jvUndefined) or

(TJSONVariantData(JSONVariant).VKind=ExpectedKind) then

result := @JSONVariant else

result := @JSONVariantDataFake else

if VType=varByRef or varVariant then

result := JSONVariantDataSafe(PVariant(VPointer)^) else

result := @JSONVariantDataFake;

end;

procedure AppendChar(var str: string; chr: Char);

{$ifdef ISSMS} // JavaScript immutable strings

begin

str := str chr

end;

{$else}

var len: Integer;

begin // str := str chr would have created a temporary string for chr

len := length(str);

SetLength(str,len 1);

PChar(pointer(str))[len] := chr; // SetLength() made str unique

end;

{$endif}

function StringToJSON(const Text: string): string;

var len,j: integer;

procedure DoEscape;

var i: Integer;

begin

result := '"' copy(Text,1,j-1); // here FPC 2.7.1 erases UTF-8 encoding

for i := j to len do begin

case Text[i] of

#8: result := result '\b';

#9: result := result '\t';

#10: result := result '\n';

#12: result := result '\f';

#13: result := result '\r';

'\': result := result '\\';

'"': result := result '\"';

else

if Text[i]<' ' then

result := result '\u00' IntToHex(ord(Text[i]),2) else

AppendChar(result,Text[i]); // will be UTF-8 encoded later

end;

end;

AppendChar(result,'"');

end;

begin

len := length(Text);

for j := 1 to len do

case Text[j] of

#0..#31,'\','"': begin

DoEscape;

exit;

end;

end;

// if we reached here, no character needs to be escaped in this string

result := '"' Text '"'; // here FPC 2.7.1 erases UTF-8 encoding :(

end;

{$ifdef KYLIX}

{$define NOFORMATSETTINGS}

{$endif}

{$ifdef ISDELPHI6}

{$define NOFORMATSETTINGS}

{$endif}

{$ifdef NOFORMATSETTINGS}

procedure DoubleToJSON(Value: double; var result: string);

var decsep: Char;

begin // warning: this is NOT thread-safe if you mix settings

decsep := DecimalSeparator;

result := FloatToStr(Value);

DecimalSeparator := decsep;

end;

{$else}

var

SettingsUS: TFormatSettings

{$ifdef FPC} = (

CurrencyFormat: 1;

NegCurrFormat: 5;

ThousandSeparator: ',';

DecimalSeparator: '.';

CurrencyDecimals: 2;

DateSeparator: '-';

TimeSeparator: ':';

ListSeparator: ',';

CurrencyString: '$';

ShortDateFormat: 'd/m/y';

LongDateFormat: 'dd" "mmmm" "yyyy';

TimeAMString: 'AM';

TimePMString: 'PM';

ShortTimeFormat: 'hh:nn';

LongTimeFormat: 'hh:nn:ss';

ShortMonthNames: ('Jan','Feb','Mar','Apr','May','Jun',

'Jul','Aug','Sep','Oct','Nov','Dec');

LongMonthNames: ('January','February','March','April','May','June',

'July','August','September','October','November','December');

ShortDayNames: ('Sun','Mon','Tue','Wed','Thu','Fri','Sat');

LongDayNames: ('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday');

TwoDigitYearCenturyWindow: 50;)

{$endif};

procedure DoubleToJSON(Value: double; var result: string);

begin

result := FloatToStr(Value,SettingsUS);

end;

{$endif}

function DateTimeToJSON(Value: TDateTime): string;

begin // e.g. "YYYY-MM-DD" "Thh:mm:ss" or "YYYY-MM-DDThh:mm:ss"

result := '"' DateTimeToIso8601(Value) '"';

end;

function NowToIso8601: string;

begin

result := DateTimeToIso8601(Now);

end;

function DateTimeToIso8601(Value: TDateTime): string;

begin // e.g. YYYY-MM-DD Thh:mm:ss or YYYY-MM-DDThh:mm:ss

if Value=0 then

result := '' else

if frac(Value)=0 then

result := FormatDateTime('yyyy"-"mm"-"dd',Value) else

if trunc(Value)=0 then

result := FormatDateTime('"T"hh":"nn":"ss',Value) else

result := FormatDateTime('yyyy"-"mm"-"dd"T"hh":"nn":"ss',Value);

end;

function Iso8601ToDateTime(const Value: string): TDateTime;

var Y,M,D, HH,MI,SS: cardinal;

begin // YYYY-MM-DD Thh:mm:ss or YYYY-MM-DDThh:mm:ss

// 1234567890 123456789 1234567890123456789

result := 0;

case Length(Value) of

9: if (Value[1]='T') and (Value[4]=':') and (Value[7]=':') then begin

HH := ord(Value[2])*10 ord(Value[3])-(48 480);

MI := ord(Value[5])*10 ord(Value[6])-(48 480);

SS := ord(Value[8])*10 ord(Value[9])-(48 480);

if (HH<24) and (MI<60) and (SS<60) then

result := EncodeTime(HH,MI,SS,0);

end;

10: if (Value[5]=Value[8]) and (ord(Value[8]) in [ord('-'),ord('/')]) then begin

Y := ord(Value[1])*1000 ord(Value[2])*100

ord(Value[3])*10 ord(Value[4])-(48 480 4800 48000);

M := ord(Value[6])*10 ord(Value[7])-(48 480);

D := ord(Value[9])*10 ord(Value[10])-(48 480);

if (Y<=9999) and ((M-1)<12) and ((D-1)<31) then

result := EncodeDate(Y,M,D);

end;

19: if (Value[5]=Value[8]) and (ord(Value[8]) in [ord('-'),ord('/')]) and

(ord(Value[11]) in [ord(' '),ord('T')]) and (Value[14]=':') and (Value[17]=':') then begin

Y := ord(Value[1])*1000 ord(Value[2])*100

ord(Value[3])*10 ord(Value[4])-(48 480 4800 48000);

M := ord(Value[6])*10 ord(Value[7])-(48 480);

D := ord(Value[9])*10 ord(Value[10])-(48 480);

HH := ord(Value[12])*10 ord(Value[13])-(48 480);

MI := ord(Value[15])*10 ord(Value[16])-(48 480);

SS := ord(Value[18])*10 ord(Value[19])-(48 480);

if (Y<=9999) and ((M-1)<12) and ((D-1)<31) and

(HH<24) and (MI<60) and (SS<60) then

result := EncodeDate(Y,M,D) EncodeTime(HH,MI,SS,0);

end;

end;

end;

function ValueToJSON(const Value: variant): string;

var I64: Int64;

begin

if TVarData(Value).VType=JSONVariantType.VarType then

result := TJSONVariantData(Value).ToJSON else

if (TVarData(Value).VType=varByRef or varVariant) then

result := ValueToJSON(PVariant(TVarData(Value).VPointer)^) else

if TVarData(Value).VType<=varNull then

result := 'null' else

if TVarData(Value).VType=varBoolean then

if TVarData(Value).VBoolean then

result := 'true' else

result := 'false' else

if TVarData(Value).VType=varDate then

result := DateTimeToJSON(TVarData(Value).VDouble) else

if VarIsOrdinal(Value) then begin

I64 := Value;

result := IntToStr(I64);

end else

if VarIsFloat(Value) then

DoubleToJSON(Value,result) else

if VarIsStr(Value) then

result := StringToJSON(Value) else

result := Value;

end;

function VarRecToValue(const V: TVarRec; out wasString: boolean): string;

// http://smartmobilestudio.com/forums/topic/is-array-of-const-supported-in-sms

begin

wasString := not (V.VType in

[vtBoolean,vtInteger,vtInt64,vtCurrency,vtExtended,vtVariant]);

with V do

case VType of

{$ifndef NEXTGEN}

vtString: result := string(VString^);

vtAnsiString: result := string(AnsiString(VAnsiString));

vtChar: result := string(VChar);

vtPChar: result := string(VPChar);

vtWideString: result := string(WideString(VWideString));

{$endif}

{$ifdef UNICODE}

vtUnicodeString: result := string(VUnicodeString);

{$endif}

vtPWideChar: result := string(VPWideChar);

vtWideChar: result := string(VWideChar);

vtBoolean: if VBoolean then result := '1' else result := '0';

vtInteger: result := IntToStr(VInteger);

vtInt64: result := IntToStr(VInt64^);

{$ifdef FPC}

vtQWord: result := IntToStr(VQWord^);

{$endif}

vtCurrency: DoubleToJSON(VCurrency^,result);

vtExtended: DoubleToJSON(VExtended^,result);

vtObject: result := ObjectToJSON(VObject);

vtVariant: if TVarData(VVariant^).VType<=varNull then

result := 'null' else begin

wasString := VarIsStr(VVariant^);

result := VVariant^;

end;

else result := '';

end;

end;

procedure DoubleQuoteStr(var text: string);

var i,j: integer;

tmp: string;

begin

i := pos('"',text);

if i=0 then begin

text := '"' text '"';

exit;

end;

tmp := '"' copy(text,1,i) '"';

for j := i 1 to length(text) do

if text[j]='"' then

tmp := tmp '""' else

AppendChar(tmp,text[j]);

text := tmp '"';

end;

{ TJSONParser }

type

/// the JSON node types, as recognized by TJSONParser

TJSONParserKind = (

kNone, kNull, kFalse, kTrue, kString, kInteger, kFloat, kObject, kArray);

/// SAX parser for any JSON content

{$ifdef USEOBJECTINSTEADOFRECORD}

TJSONParser = object

{$else}

TJSONParser = record

{$endif}

JSON: string;

Index: integer;

JSONLength: integer;

procedure Init(const aJSON: string; aIndex: integer);

function GetNextChar: char; {$ifdef HASINLINE}inline;{$endif}

function GetNextNonWhiteChar: char; {$ifdef HASINLINE}inline;{$endif}

function CheckNextNonWhiteChar(aChar: char): boolean; {$ifdef HASINLINE}inline;{$endif}

function GetNextString(out str: string): boolean; overload;

function GetNextString: string; overload; {$ifdef HASINLINE}inline;{$endif}

function GetNextJSON(out Value: variant): TJSONParserKind;

function CheckNextIdent(const ExpectedIdent: string): Boolean;

function GetNextAlphaPropName(out fieldName: string): boolean;

function ParseJSONObject(var Data: TJSONVariantData): boolean;

function ParseJSONArray(var Data: TJSONVariantData): boolean;

procedure AppendNextStringUnEscape(var str: string);

end;

procedure TJSONParser.Init(const aJSON: string; aIndex: integer);

begin

JSON := aJSON;

JSONLength := length(JSON);

Index := aIndex;

end;

function TJSONParser.GetNextChar: char;

begin

if Index<=JSONLength then begin

result := JSON[Index];

inc(Index);

end else

result := #0;

end;

function TJSONParser.GetNextNonWhiteChar: char;

begin

if Index<=JSONLength then

repeat

if JSON[Index]>' ' then begin

result := JSON[Index];

inc(Index);

exit;

end;

inc(Index);

until Index>JSONLength;

result := #0;

end;

function TJSONParser.CheckNextNonWhiteChar(aChar: char): boolean;

begin

if Index<=JSONLength then

repeat

if JSON[Index]>' ' then begin

result := JSON[Index]=aChar;

if result then

inc(Index);

exit;

end;

inc(Index);

until Index>JSONLength;

result := false;

end;

procedure TJSONParser.AppendNextStringUnEscape(var str: string);

var c: char;

u: string;

unicode,err: integer;

begin

repeat

c := GetNextChar;

case c of

#0: exit;

'"': break;

'\': begin

c := GetNextChar;

case c of

#0: exit;

'b': AppendChar(str,#08);

't': AppendChar(str,#09);

'n': AppendChar(str,#$0a);

'f': AppendChar(str,#$0c);

'r': AppendChar(str,#$0d);

'u': begin

u := Copy(JSON,Index,4);

if length(u)<>4 then

exit;

inc(Index,4);

val('$' u,unicode,err);

if err<>0 then

exit;

AppendChar(str,char(unicode));

end;

else AppendChar(str,c);

end;

end;

else AppendChar(str,c);

end;

until false;

end;

function TJSONParser.GetNextString(out str: string): boolean;

var i: integer;

begin

for i := Index to JSONLength do

case JSON[i] of