(*

 *                         Super Object Toolkit

 *

 * Usage allowed under the restrictions of the Lesser GNU General Public License

 * or alternatively the restrictions of the Mozilla Public License 1.1

 *

 * 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.

 *

 * Unit owner : Henri Gourvest <hgourvest@gmail.com>

 * Web site   : http://www.progdigy.com

 *

 * This unit is inspired from the json c lib:

 *   Michael Clark <michael@metaparadigm.com>

 *   http://oss.metaparadigm.com/json-c/

 *

 *  CHANGES:

 *  v1.2

 *   + support of currency data type

 *   + right trim unquoted string

 *   + read Unicode Files and streams (Litle Endian with BOM)

 *   + Fix bug on javadate functions + windows nt compatibility

 *   + Now you can force to parse only the canonical syntax of JSON using the stric parameter

 *   + Delphi 2010 RTTI marshalling

 *  v1.1

 *   + Double licence MPL or LGPL.

 *   + Delphi 2009 compatibility & Unicode support.

 *   + AsString return a string instead of PChar.

 *   + Escaped and Unascaped JSON serialiser.

 *   + Missed FormFeed added \f

 *   - Removed @ trick, uses forcepath() method instead.

 *   + Fixed parse error with uppercase E symbol in numbers.

 *   + Fixed possible buffer overflow when enlarging array.

 *   + Added "delete", "pack", "insert" methods for arrays and/or objects

 *   + Multi parametters when calling methods

 *   + Delphi Enumerator (for obj1 in obj2 do ...)

 *   + Format method ex: obj.format('<%name%>%tab[1]%</%name%>')

 *   + ParseFile and ParseStream methods

 *   + Parser now understand hexdecimal c syntax ex: \xFF

 *   + Null Object Design Patern (ex: for obj in values.N['path'] do ...)

 *  v1.0

 *   + renamed class

 *   + interfaced object

 *   + added a new data type: the method

 *   + parser can now evaluate properties and call methods

 *   - removed obselet rpc class

 *   - removed "find" method, now you can use "parse" method instead

 *  v0.6

 *   + refactoring

 *  v0.5

 *   + new find method to get or set value using a path syntax

 *       ex: obj.s['obj.prop[1]'] := 'string value';

 *           obj.a['@obj.array'].b[n] := true; // @ -> create property if necessary

 *  v0.4

 *   + bug corrected: AVL tree badly balanced.

 *  v0.3

 *   + New validator partially based on the Kwalify syntax.

 *   + extended syntax to parse unquoted fields.

 *   + Freepascal compatibility win32/64 Linux32/64.

 *   + JavaToDelphiDateTime and DelphiToJavaDateTime improved for UTC.

 *   + new TJsonObject.Compare function.

 *  v0.2

 *   + Hashed string list replaced with a faster AVL tree

 *   + JsonInt data type can be changed to int64

 *   + JavaToDelphiDateTime and DelphiToJavaDateTime helper fonctions

 *   + from json-c v0.7

 *     + Add escaping of backslash to json output

 *     + Add escaping of foward slash on tokenizing and output

 *     + Changes to internal tokenizer from using recursion to

 *       using a depth state structure to allow incremental parsing

 *  v0.1

 *   + first release

 *)

{$IFDEF FPC}

  {$MODE OBJFPC}{$H+}

{$ENDIF}

{$DEFINE SUPER_METHOD}

{$DEFINE WINDOWSNT_COMPATIBILITY}

{$DEFINE DEBUG} // track memory leack

unit superobject;

interface

uses

  Classes

{$IFDEF VER210}

  ,Generics.Collections, RTTI, TypInfo

{$ENDIF}

  ;

type

{$IFNDEF FPC}

  PtrInt = longint;

  PtrUInt = Longword;

{$ENDIF}

  SuperInt = Int64;

{$if (sizeof(Char) = 1)}

  SOChar = WideChar;

  SOIChar = Word;

  PSOChar = PWideChar;

  SOString = WideString;

{$else}

  SOChar = Char;

  SOIChar = Word;

  PSOChar = PChar;

  SOString = string;

{$ifend}

const

  SUPER_ARRAY_LIST_DEFAULT_SIZE = ;

  SUPER_TOKENER_MAX_DEPTH = ;

  SUPER_AVL_MAX_DEPTH = sizeof(longint) * ;

  SUPER_AVL_MASK_HIGH_BIT = not ((not longword()) shr );

type

  // forward declarations

  TSuperObject = class;

  ISuperObject = interface;

  TSuperArray = class;

  // 2016.01.01 添加了排序方式

  TSOSortMode = (sosmDefault {默认的方式}, sosmAdd {添加的顺序}, sosmASC {升序}, sosmDesc {降序});

(* AVL Tree

 *  This is a "special" autobalanced AVL tree

 *  It use a hash value for fast compare

 *)

{$IFDEF SUPER_METHOD}

  TSuperMethod = procedure(const This, Params: ISuperObject; var Result: ISuperObject);

{$ENDIF}

  TSuperAvlBitArray = set of ..SUPER_AVL_MAX_DEPTH - ;

  TSuperAvlSearchType = (stEQual, stLess, stGreater);

  TSuperAvlSearchTypes = set of TSuperAvlSearchType;

  TSuperAvlIterator = class;

  TSuperAvlEntry = class

  private

    FGt, FLt: TSuperAvlEntry;

    FBf: integer;

    FHash: Cardinal;

    FName: SOString;

    FPtr: Pointer;

    function GetValue: ISuperObject;

    procedure SetValue(const val: ISuperObject);

  public

    class function Hash(const k: SOString): Cardinal; virtual;

    constructor Create(const AName: SOString; Obj: Pointer); virtual;

    property Name: SOString read FName;

    property Ptr: Pointer read FPtr;

    property Value: ISuperObject read GetValue write SetValue;

  end;

  TSuperAvlTree = class

  private

    FRoot: TSuperAvlEntry;

    FCount: Integer;

    function balance(bal: TSuperAvlEntry): TSuperAvlEntry;

  protected

    procedure doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); virtual;

    function CompareNodeNode(node1, node2: TSuperAvlEntry): integer; virtual;

    function CompareKeyNode(const k: SOString; h: TSuperAvlEntry): integer; virtual;

    function Insert(h: TSuperAvlEntry): TSuperAvlEntry; virtual;

    function Search(const k: SOString; st: TSuperAvlSearchTypes = [stEqual]): TSuperAvlEntry; virtual;

  public

    constructor Create; virtual;

    destructor Destroy; override;

    function IsEmpty: boolean;

    procedure Clear(all: boolean = false); virtual;

    procedure Pack(all: boolean);

    function Delete(const k: SOString): ISuperObject;

    function GetEnumerator: TSuperAvlIterator;

    // 2016.01.01 排序功能使用

    function CompareForSortModeString(pvKey1, pvKey2: SOString): Integer;

    property count: Integer read FCount;

  end;

  TSuperTableString = class(TSuperAvlTree)

  protected

    procedure doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); override;

    procedure PutO(const k: SOString; const value: ISuperObject);

    function GetO(const k: SOString): ISuperObject;

    procedure PutS(const k: SOString; const value: SOString);

    function GetS(const k: SOString): SOString;

    procedure PutI(const k: SOString; value: SuperInt);

    function GetI(const k: SOString): SuperInt;

    procedure PutD(const k: SOString; value: Double);

    function GetD(const k: SOString): Double;

    procedure PutB(const k: SOString; value: Boolean);

    function GetB(const k: SOString): Boolean;

{$IFDEF SUPER_METHOD}

    procedure PutM(const k: SOString; value: TSuperMethod);

    function GetM(const k: SOString): TSuperMethod;

{$ENDIF}

    procedure PutN(const k: SOString; const value: ISuperObject);

    function GetN(const k: SOString): ISuperObject;

    procedure PutC(const k: SOString; value: Currency);

    function GetC(const k: SOString): Currency;

  public

    property O[const k: SOString]: ISuperObject read GetO write PutO; default;

    property S[const k: SOString]: SOString read GetS write PutS;

    property I[const k: SOString]: SuperInt read GetI write PutI;

    property D[const k: SOString]: Double read GetD write PutD;

    property B[const k: SOString]: Boolean read GetB write PutB;

{$IFDEF SUPER_METHOD}

    property M[const k: SOString]: TSuperMethod read GetM write PutM;

{$ENDIF}

    property N[const k: SOString]: ISuperObject read GetN write PutN;

    property C[const k: SOString]: Currency read GetC write PutC;

    function GetValues: ISuperObject;

    function GetNames: ISuperObject;

  end;

  TSuperAvlIterator = class

  private

    FTree: TSuperAvlTree;

    FBranch: TSuperAvlBitArray;

    FDepth: LongInt;

    FPath: array[..SUPER_AVL_MAX_DEPTH - ] of TSuperAvlEntry;

  public

    constructor Create(tree: TSuperAvlTree); virtual;

    procedure Search(const k: SOString; st: TSuperAvlSearchTypes = [stEQual]);

    procedure First;

    procedure Last;

    function GetIter: TSuperAvlEntry;

    procedure Next;

    procedure Prior;

    // delphi enumerator

    function MoveNext: Boolean;

    property Current: TSuperAvlEntry read GetIter;

  end;

  TSuperObjectArray = array[..(high(PtrInt) div sizeof(TSuperObject))-] of ISuperObject;

  PSuperObjectArray = ^TSuperObjectArray;

  TSuperArray = class

  private

    FArray: PSuperObjectArray;

    FLength: Integer;

    FSize: Integer;

    procedure Expand(max: Integer);

  protected

    function GetO(const index: integer): ISuperObject;

    procedure PutO(const index: integer; const Value: ISuperObject);

    function GetB(const index: integer): Boolean;

    procedure PutB(const index: integer; Value: Boolean);

    function GetI(const index: integer): SuperInt;

    procedure PutI(const index: integer; Value: SuperInt);

    function GetD(const index: integer): Double;

    procedure PutD(const index: integer; Value: Double);

    function GetC(const index: integer): Currency;

    procedure PutC(const index: integer; Value: Currency);

    function GetS(const index: integer): SOString;

    procedure PutS(const index: integer; const Value: SOString);

{$IFDEF SUPER_METHOD}

    function GetM(const index: integer): TSuperMethod;

    procedure PutM(const index: integer; Value: TSuperMethod);

{$ENDIF}

    function GetN(const index: integer): ISuperObject;

    procedure PutN(const index: integer; const Value: ISuperObject);

  public

    constructor Create; virtual;

    destructor Destroy; override;

    function Add(const Data: ISuperObject): Integer;

    function Delete(index: Integer): ISuperObject;

    procedure Insert(index: Integer; const value: ISuperObject);

    procedure Clear(all: boolean = false);

    procedure Pack(all: boolean);

    property Length: Integer read FLength;

    property N[const index: integer]: ISuperObject read GetN write PutN;

    property O[const index: integer]: ISuperObject read GetO write PutO; default;

    property B[const index: integer]: boolean read GetB write PutB;

    property I[const index: integer]: SuperInt read GetI write PutI;

    property D[const index: integer]: Double read GetD write PutD;

    property C[const index: integer]: Currency read GetC write PutC;

    property S[const index: integer]: SOString read GetS write PutS;

{$IFDEF SUPER_METHOD}

    property M[const index: integer]: TSuperMethod read GetM write PutM;

{$ENDIF}

//    property A[const index: integer]: TSuperArray read GetA;

  end;

  TSuperWriter = class

  public

    // abstact methods to overide

    function Append(buf: PSOChar; Size: Integer): Integer; overload; virtual; abstract;

    function Append(buf: PSOChar): Integer; overload; virtual; abstract;

    procedure Reset; virtual; abstract;

  end;

  TSuperWriterString = class(TSuperWriter)

  private

    FBuf: PSOChar;

    FBPos: integer;

    FSize: integer;

  public

    function Append(buf: PSOChar; Size: Integer): Integer; overload; override;

    function Append(buf: PSOChar): Integer; overload; override;

    procedure Reset; override;

    procedure TrimRight;

    constructor Create; virtual;

    destructor Destroy; override;

    function GetString: SOString;

    property Data: PSOChar read FBuf;

    property Size: Integer read FSize;

    property Position: integer read FBPos;

  end;

  TSuperWriterStream = class(TSuperWriter)

  private

    FStream: TStream;

  public

    function Append(buf: PSOChar): Integer; override;

    procedure Reset; override;

    constructor Create(AStream: TStream); reintroduce; virtual;

  end;

  TSuperAnsiWriterStream = class(TSuperWriterStream)

  public

    function Append(buf: PSOChar; Size: Integer): Integer; override;

  end;

  TSuperUnicodeWriterStream = class(TSuperWriterStream)

  public

    function Append(buf: PSOChar; Size: Integer): Integer; override;

  end;

  TSuperWriterFake = class(TSuperWriter)

  private

    FSize: Integer;

  public

    function Append(buf: PSOChar; Size: Integer): Integer; override;

    function Append(buf: PSOChar): Integer; override;

    procedure Reset; override;

    constructor Create; reintroduce; virtual;

    property size: integer read FSize;

  end;

  TSuperWriterSock = class(TSuperWriter)

  private

    FSocket: longint;

    FSize: Integer;

  public

    function Append(buf: PSOChar; Size: Integer): Integer; override;

    function Append(buf: PSOChar): Integer; override;

    procedure Reset; override;

    constructor Create(ASocket: longint); reintroduce; virtual;

    property Socket: longint read FSocket;

    property Size: Integer read FSize;

  end;

  TSuperTokenizerError = (

    teSuccess,

    teContinue,

    teDepth,

    teParseEof,

    teParseUnexpected,

    teParseNull,

    teParseBoolean,

    teParseNumber,

    teParseArray,

    teParseObjectKeyName,

    teParseObjectKeySep,

    teParseObjectValueSep,

    teParseString,

    teParseComment,

    teEvalObject,

    teEvalArray,

    teEvalMethod,

    teEvalInt

  );

  TSuperTokenerState = (

    tsEatws,

    tsStart,

    tsFinish,

    tsNull,

    tsCommentStart,

    tsComment,

    tsCommentEol,

    tsCommentEnd,

    tsString,

    tsStringEscape,

    tsIdentifier,

    tsEscapeUnicode,

    tsEscapeHexadecimal,

    tsBoolean,

    tsNumber,

    tsArray,

    tsArrayAdd,

    tsArraySep,

    tsObjectFieldStart,

    tsObjectField,

    tsObjectUnquotedField,

    tsObjectFieldEnd,

    tsObjectValue,

    tsObjectValueAdd,

    tsObjectSep,

    tsEvalProperty,

    tsEvalArray,

    tsEvalMethod,

    tsParamValue,

    tsParamPut,

    tsMethodValue,

    tsMethodPut

  );

  PSuperTokenerSrec = ^TSuperTokenerSrec;

  TSuperTokenerSrec = record

    state, saved_state: TSuperTokenerState;

    obj: ISuperObject;

    current: ISuperObject;

    field_name: SOString;

    parent: ISuperObject;

    gparent: ISuperObject;

  end;

  TSuperTokenizer = class

  public

    str: PSOChar;

    pb: TSuperWriterString;

    depth, is_double, floatcount, st_pos, char_offset: Integer;

    err:  TSuperTokenizerError;

    ucs_char: Word;

    quote_char: SOChar;

    stack: array[..SUPER_TOKENER_MAX_DEPTH-] of TSuperTokenerSrec;

    line, col: Integer;

  public

    constructor Create; virtual;

    destructor Destroy; override;

    procedure ResetLevel(adepth: integer);

    procedure Reset;

  end;

  // supported object types

  TSuperType = (

    stNull,

    stBoolean,

    stDouble,

    stCurrency,

    stInt,

    stObject,

    stArray,

    stString

{$IFDEF SUPER_METHOD}

    ,stMethod

{$ENDIF}

  );

  TSuperValidateError = (

    veRuleMalformated,

    veFieldIsRequired,

    veInvalidDataType,

    veFieldNotFound,

    veUnexpectedField,

    veDuplicateEntry,

    veValueNotInEnum,

    veInvalidLength,

    veInvalidRange

  );

  TSuperFindOption = (

    foCreatePath,

    foPutValue,

    foDelete

{$IFDEF SUPER_METHOD}

    ,foCallMethod

{$ENDIF}

  );

  TSuperFindOptions = set of TSuperFindOption;

  TSuperCompareResult = (cpLess, cpEqu, cpGreat, cpError);

  TSuperOnValidateError = procedure(sender: Pointer; error: TSuperValidateError; const objpath: SOString);

  TSuperEnumerator = class

  private

    FObj: ISuperObject;

    FObjEnum: TSuperAvlIterator;

    FCount: Integer;

  public

    constructor Create(const obj: ISuperObject); virtual;

    destructor Destroy; override;

    function MoveNext: Boolean;

    function GetCurrent: ISuperObject;

    property Current: ISuperObject read GetCurrent;

  end;

  ISuperObject = interface

  ['{4B86A9E3-E094-4E5A-954A-69048B7B6327}']

    function GetEnumerator: TSuperEnumerator;

    function GetDataType: TSuperType;

    function GetProcessing: boolean;

    procedure SetProcessing(value: boolean);

    function ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject;

    function Format(const str: SOString; BeginSep: SOChar = '%'; EndSep: SOChar = '%'): SOString;

    function GetO(const path: SOString): ISuperObject;

    procedure PutO(const path: SOString; const Value: ISuperObject);

    function GetB(const path: SOString): Boolean;

    procedure PutB(const path: SOString; Value: Boolean);

    function GetI(const path: SOString): SuperInt;

    procedure PutI(const path: SOString; Value: SuperInt);

    function GetD(const path: SOString): Double;

    procedure PutC(const path: SOString; Value: Currency);

    function GetC(const path: SOString): Currency;

    procedure PutD(const path: SOString; Value: Double);

    function GetS(const path: SOString): SOString;

    procedure PutS(const path: SOString; const Value: SOString);

{$IFDEF SUPER_METHOD}

    function GetM(const path: SOString): TSuperMethod;

    procedure PutM(const path: SOString; Value: TSuperMethod);

{$ENDIF}

    function GetA(const path: SOString): TSuperArray;

    // Null Object Design patern

    function GetN(const path: SOString): ISuperObject;

    procedure PutN(const path: SOString; const Value: ISuperObject);

    // Writers

    function Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer;

    function SaveTo(stream: TStream; indent: boolean = false; escape: boolean = true): integer; overload;

    function SaveTo(const FileName: string; indent: boolean = false; escape: boolean = true): integer; overload;

    function SaveTo(socket: longint; indent: boolean = false; escape: boolean = true): integer; overload;

    function CalcSize(indent: boolean = false; escape: boolean = true): integer;

    // convert

    function AsBoolean: Boolean;

    function AsInteger: SuperInt;

    function AsDouble: Double;

    function AsCurrency: Currency;

    function AsString: SOString;

    function AsArray: TSuperArray;

    function AsObject: TSuperTableString;

{$IFDEF SUPER_METHOD}

    function AsMethod: TSuperMethod;

{$ENDIF}

    function AsJSon(indent: boolean = false; escape: boolean = true): SOString;

    procedure Clear(all: boolean = false);

    procedure Pack(all: boolean = false);

    property N[const path: SOString]: ISuperObject read GetN write PutN;

    property O[const path: SOString]: ISuperObject read GetO write PutO; default;

    property B[const path: SOString]: boolean read GetB write PutB;

    property I[const path: SOString]: SuperInt read GetI write PutI;

    property D[const path: SOString]: Double read GetD write PutD;

    property C[const path: SOString]: Currency read GetC write PutC;

    property S[const path: SOString]: SOString read GetS write PutS;

{$IFDEF SUPER_METHOD}

    property M[const path: SOString]: TSuperMethod read GetM write PutM;

{$ENDIF}

    property A[const path: SOString]: TSuperArray read GetA;

{$IFDEF SUPER_METHOD}

    function call(const path: SOString; const param: ISuperObject = nil): ISuperObject; overload;

    function call(const path, param: SOString): ISuperObject; overload;

{$ENDIF}

    // clone a node

    function Clone: ISuperObject;

    function Delete(const path: SOString): ISuperObject;

    // merges tow objects of same type, if reference is true then nodes are not cloned

    procedure Merge(const obj: ISuperObject; reference: boolean = false); overload;

    procedure Merge(const str: SOString); overload;

    // validate methods

    function Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload;

    function Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload;

    // compare

    function Compare(const obj: ISuperObject): TSuperCompareResult; overload;

    function Compare(const str: SOString): TSuperCompareResult; overload;

    // the data type

    function IsType(AType: TSuperType): boolean;

    property DataType: TSuperType read GetDataType;

    property Processing: boolean read GetProcessing write SetProcessing;

    function GetDataPtr: Pointer;

    procedure SetDataPtr(const Value: Pointer);

    property DataPtr: Pointer read GetDataPtr write SetDataPtr;

  end;

  TSuperObject = class(TObject, ISuperObject)

  private

    FRefCount: Integer;

    FProcessing: boolean;

    FDataType: TSuperType;

    FDataPtr: Pointer;

{.$if true}

    FO: record

      case TSuperType of

        stBoolean: (c_boolean: boolean);

        stDouble: (c_double: double);

        stCurrency: (c_currency: Currency);

        stInt: (c_int: SuperInt);

        stObject: (c_object: TSuperTableString);

        stArray: (c_array: TSuperArray);

{$IFDEF SUPER_METHOD}

        stMethod: (c_method: TSuperMethod);

{$ENDIF}

      end;

{.$ifend}

    FOString: SOString;

    function GetDataType: TSuperType;

    function GetDataPtr: Pointer;

    procedure SetDataPtr(const Value: Pointer);

  protected

    function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;

    function _AddRef: Integer; virtual; stdcall;

    function _Release: Integer; virtual; stdcall;

    function GetO(const path: SOString): ISuperObject;

    procedure PutO(const path: SOString; const Value: ISuperObject);

    function GetB(const path: SOString): Boolean;

    procedure PutB(const path: SOString; Value: Boolean);

    function GetI(const path: SOString): SuperInt;

    procedure PutI(const path: SOString; Value: SuperInt);

    function GetD(const path: SOString): Double;

    procedure PutD(const path: SOString; Value: Double);

    procedure PutC(const path: SOString; Value: Currency);

    function GetC(const path: SOString): Currency;

    function GetS(const path: SOString): SOString;

    procedure PutS(const path: SOString; const Value: SOString);

{$IFDEF SUPER_METHOD}

    function GetM(const path: SOString): TSuperMethod;

    procedure PutM(const path: SOString; Value: TSuperMethod);

{$ENDIF}

    function GetA(const path: SOString): TSuperArray;

    function Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer; virtual;

  public

    function GetEnumerator: TSuperEnumerator;

    procedure AfterConstruction; override;

    procedure BeforeDestruction; override;

    class function NewInstance: TObject; override;

    property RefCount: Integer read FRefCount;

    function GetProcessing: boolean;

    procedure SetProcessing(value: boolean);

    // Writers

    function SaveTo(stream: TStream; indent: boolean = false; escape: boolean = true): integer; overload;

    function SaveTo(const FileName: string; indent: boolean = false; escape: boolean = true): integer; overload;

    function SaveTo(socket: longint; indent: boolean = false; escape: boolean = true): integer; overload;

    function CalcSize(indent: boolean = false; escape: boolean = true): integer;

    function AsJSon(indent: boolean = false; escape: boolean = true): SOString;

    // parser  ... owned!

    class function ParseString(s: PSOChar; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = [];

       const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject;

    class function ParseStream(stream: TStream; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = [];

       const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject;

    class function ParseFile(const FileName: string; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = [];

       const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject;

    class function ParseEx(tok: TSuperTokenizer; str: PSOChar; len: integer; strict: Boolean; const this: ISuperObject = nil;

      options: TSuperFindOptions = []; const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject;

    // constructors / destructor

    constructor Create(jt: TSuperType = stObject); overload; virtual;

    constructor Create(b: boolean); overload; virtual;

    constructor Create(i: SuperInt); overload; virtual;

    constructor Create(d: double); overload; virtual;

    constructor CreateCurrency(c: Currency); overload; virtual;

    constructor Create(const s: SOString); overload; virtual;

{$IFDEF SUPER_METHOD}

    constructor Create(m: TSuperMethod); overload; virtual;

{$ENDIF}

    destructor Destroy; override;

    // convert

    function AsBoolean: Boolean; virtual;

    function AsInteger: SuperInt; virtual;

    function AsDouble: Double; virtual;

    function AsCurrency: Currency; virtual;

    function AsString: SOString; virtual;

    function AsArray: TSuperArray; virtual;

    function AsObject: TSuperTableString; virtual;

{$IFDEF SUPER_METHOD}

    function AsMethod: TSuperMethod; virtual;

{$ENDIF}

    procedure Clear(all: boolean = false); virtual;

    procedure Pack(all: boolean = false); virtual;

    function GetN(const path: SOString): ISuperObject;

    procedure PutN(const path: SOString; const Value: ISuperObject);

    function ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject;

    function Format(const str: SOString; BeginSep: SOChar = '%'; EndSep: SOChar = '%'): SOString;

    property N[const path: SOString]: ISuperObject read GetN write PutN;

    property O[const path: SOString]: ISuperObject read GetO write PutO; default;

    property B[const path: SOString]: boolean read GetB write PutB;

    property I[const path: SOString]: SuperInt read GetI write PutI;

    property D[const path: SOString]: Double read GetD write PutD;

    property C[const path: SOString]: Currency read GetC write PutC;

    property S[const path: SOString]: SOString read GetS write PutS;

{$IFDEF SUPER_METHOD}

    property M[const path: SOString]: TSuperMethod read GetM write PutM;

{$ENDIF}

    property A[const path: SOString]: TSuperArray read GetA;

{$IFDEF SUPER_METHOD}

    function call(const path: SOString; const param: ISuperObject = nil): ISuperObject; overload; virtual;

    function call(const path, param: SOString): ISuperObject; overload; virtual;

{$ENDIF}

    // clone a node

    function Clone: ISuperObject; virtual;

    function Delete(const path: SOString): ISuperObject;

    // merges tow objects of same type, if reference is true then nodes are not cloned

    procedure Merge(const obj: ISuperObject; reference: boolean = false); overload;

    procedure Merge(const str: SOString); overload;

    // validate methods

    function Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload;

    function Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload;

    // compare

    function Compare(const obj: ISuperObject): TSuperCompareResult; overload;

    function Compare(const str: SOString): TSuperCompareResult; overload;

    // the data type

    function IsType(AType: TSuperType): boolean;

    property DataType: TSuperType read GetDataType;

    // a data pointer to link to something ele, a treeview for example

    property DataPtr: Pointer read GetDataPtr write SetDataPtr;

    property Processing: boolean read GetProcessing;

  end;

{$IFDEF VER210}

  TSuperRttiContext = class;

  TSerialFromJson = function(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;

  TSerialToJson = function(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject;

  TSuperAttribute = class(TCustomAttribute)

  private

    FName: string;

  public

    constructor Create(const AName: string);

    property Name: string read FName;

  end;

  SOName = class(TSuperAttribute);

  SODefault = class(TSuperAttribute);

  TSuperRttiContext = class

  private

    class function GetFieldName(r: TRttiField): string;

    class function GetFieldDefault(r: TRttiField; const obj: ISuperObject): ISuperObject;

  public

    Context: TRttiContext;

    SerialFromJson: TDictionary<PTypeInfo, TSerialFromJson>;

    SerialToJson: TDictionary<PTypeInfo, TSerialToJson>;

    constructor Create; virtual;

    destructor Destroy; override;

    function FromJson(TypeInfo: PTypeInfo; const obj: ISuperObject; var Value: TValue): Boolean; virtual;

    function ToJson(var value: TValue; const index: ISuperObject): ISuperObject; virtual;

    function AsType<T>(const obj: ISuperObject): T;

    function AsJson<T>(const obj: T; const index: ISuperObject = nil): ISuperObject;

  end;

  TSuperObjectHelper = class helper for TObject

  public

    function ToJson(ctx: TSuperRttiContext = nil): ISuperObject;

    constructor FromJson(const obj: ISuperObject; ctx: TSuperRttiContext = nil); overload;

    constructor FromJson(const str: string; ctx: TSuperRttiContext = nil); overload;

  end;

{$ENDIF}

  TSuperObjectIter = record

    key: SOString;

    val: ISuperObject;

    Ite: TSuperAvlIterator;

  end;

function ObjectIsError(obj: TSuperObject): boolean;

function ObjectIsType(const obj: ISuperObject; typ: TSuperType): boolean;

function ObjectGetType(const obj: ISuperObject): TSuperType;

function ObjectFindFirst(const obj: ISuperObject; var F: TSuperObjectIter): boolean;

function ObjectFindNext(var F: TSuperObjectIter): boolean;

procedure ObjectFindClose(var F: TSuperObjectIter);

function SO(const s: SOString = '{}'): ISuperObject; overload;

function SO(const value: Variant): ISuperObject; overload;

function SO(const Args: array of const): ISuperObject; overload;

function SA(const Args: array of const): ISuperObject; overload;

function JavaToDelphiDateTime(const dt: int64): TDateTime;

function DelphiToJavaDateTime(const dt: TDateTime): int64;

{$IFDEF VER210}

type

  TSuperInvokeResult = (

    irSuccess,

    irMethothodError,  // method don't exist

    irParamError,     // invalid parametters

    irError            // other error

  );

function TrySOInvoke(var ctx: TSuperRttiContext; const obj: TValue; const method: string; const params: ISuperObject; var Return: ISuperObject): TSuperInvokeResult; overload;

function SOInvoke(const obj: TValue; const method: string; const params: ISuperObject; ctx: TSuperRttiContext = nil): ISuperObject; overload;

function SOInvoke(const obj: TValue; const method: string; const params: string; ctx: TSuperRttiContext = nil): ISuperObject; overload;

{$ENDIF}

/// 2016.01.01 设定排序方式

procedure SetSOSortMode(pvSortMode: TSOSortMode);

/// 2016.01.01 添加默认排序方式

var

  nowSortMode: TSOSortMode = sosmDefault;

implementation

uses sysutils,

{$IFDEF UNIX}

  baseunix, unix, DateUtils

{$ELSE}

  Windows

{$ENDIF}

{$IFDEF FPC}

  ,sockets

{$ELSE}

  ,WinSock

{$ENDIF};

{$IFDEF DEBUG}

var

  debugcount: integer = ;

{$ENDIF}

const

  super_number_chars_set = [''..'','.','+','-','e','E'];

  super_hex_chars: PSOChar = '0123456789abcdef';

  super_hex_chars_set = [''..'','a'..'f','A'..'F'];

  ESC_BS: PSOChar = '\b';

  ESC_LF: PSOChar = '\n';

  ESC_CR: PSOChar = '\r';

  ESC_TAB: PSOChar = '\t';

  ESC_FF: PSOChar = '\f';

  ESC_QUOT: PSOChar = '\"';

  ESC_SL: PSOChar = '\\';

  ESC_SR: PSOChar = '\/';

  ESC_ZERO: PSOChar = '\u0000';

  TOK_CRLF: PSOChar = ##;

  TOK_SP: PSOChar = #;

  TOK_BS: PSOChar = #;

  TOK_TAB: PSOChar = #;

  TOK_LF: PSOChar = #;

  TOK_FF: PSOChar = #;

  TOK_CR: PSOChar = #;

//  TOK_SL: PSOChar = '\';

//  TOK_SR: PSOChar = '/';

  TOK_NULL: PSOChar = 'null';

  TOK_CBL: PSOChar = '{'; // curly bracket left

  TOK_CBR: PSOChar = '}'; // curly bracket right

  TOK_ARL: PSOChar = '[';

  TOK_ARR: PSOChar = ']';

  TOK_ARRAY: PSOChar = '[]';

  TOK_OBJ: PSOChar = '{}'; // empty object

  TOK_COM: PSOChar = ','; // Comma

  TOK_DQT: PSOChar = '"'; // Double Quote

  TOK_TRUE: PSOChar = 'true';

  TOK_FALSE: PSOChar = 'false';

procedure SetSOSortMode(pvSortMode: TSOSortMode);

begin

  nowSortMode := pvSortMode;

end;

{$if (sizeof(Char) = 1)}

function StrLComp(const Str1, Str2: PSOChar; MaxLen: Cardinal): Integer;

var

  P1, P2: PWideChar;

  I: Cardinal;

  C1, C2: WideChar;

begin

  P1 := Str1;

  P2 := Str2;

  I := ;

  while I < MaxLen do

  begin

    C1 := P1^;

    C2 := P2^;

    if (C1 <> C2) or (C1 = #) then

    begin

      Result := Ord(C1) - Ord(C2);

      Exit;

    end;

    Inc(P1);

    Inc(P2);

    Inc(I);

  end;

  Result := ;

end;

function StrComp(const Str1, Str2: PSOChar): Integer;

var

  P1, P2: PWideChar;

  C1, C2: WideChar;

begin

  P1 := Str1;

  P2 := Str2;

  while True do

  begin

    C1 := P1^;

    C2 := P2^;

    if (C1 <> C2) or (C1 = #) then

    begin

      Result := Ord(C1) - Ord(C2);

      Exit;

    end;

    Inc(P1);

    Inc(P2);

  end;

end;

function StrLen(const Str: PSOChar): Cardinal;

var

  p: PSOChar;

begin

  Result := ;

  if Str <> nil then

  begin

    p := Str;

    while p^ <> # do inc(p);

    Result := (p - Str);

  end;

end;

{$ifend}

function CurrToStr(c: Currency): SOString;

var

  p: PSOChar;

  i, len: Integer;

begin

  Result := IntToStr(Abs(PInt64(@c)^));

  len := Length(Result);

  SetLength(Result, len+);

  if c <>  then

  begin

    while len <=  do

    begin

      Result := '' + Result;

      inc(len);

    end;

    p := PSOChar(Result);

    inc(p, len-);

    i := ;

    repeat

      if p^ <> '' then

      begin

        len := len - i + ;

        repeat

          p[] := p^;

          dec(p);

          inc(i);

        until i > ;

        Break;

      end;

      dec(p);

      inc(i);

      if i >  then

      begin

        len := len - i + ;

        Break;

      end;

    until false;

    p[] := '.';

    SetLength(Result, len);

    if c <  then

      Result := '-' + Result;

  end;

end;

{$IFDEF UNIX}

  {$linklib c}

{$ENDIF}

function gcvt(value: Double; ndigit: longint; buf: PAnsiChar): PAnsiChar; cdecl;

  external {$IFDEF MSWINDOWS} 'msvcrt.dll' name '_gcvt'{$ENDIF};

{$IFDEF UNIX}

type

  ptm = ^tm;

  tm = record

    tm_sec: Integer;        (* Seconds: 0-59 (K&R says 0-61?) *)

    tm_min: Integer;        (* Minutes: 0-59 *)

    tm_hour: Integer;    (* Hours since midnight: 0-23 *)

    tm_mday: Integer;    (* Day of the month: 1-31 *)

    tm_mon: Integer;        (* Months *since* january: 0-11 *)

    tm_year: Integer;    (* Years since 1900 *)

    tm_wday: Integer;    (* Days since Sunday (0-6) *)

    tm_yday: Integer;    (* Days since Jan. 1: 0-365 *)

    tm_isdst: Integer;    (* +1 Daylight Savings Time, 0 No DST, -1 don't know *)

  end;

function mktime(p: ptm): LongInt; cdecl; external;

function gmtime(const t: PLongint): ptm; cdecl; external;

function localtime (const t: PLongint): ptm; cdecl; external;

function DelphiToJavaDateTime(const dt: TDateTime): Int64;

var

  p: ptm;

  l, ms: Integer;

  v: Int64;

begin

  v := Round((dt - ) * );

  ms := v mod ;

  l := v div ;

  p := localtime(@l);

  Result := Int64(mktime(p)) *  + ms;

end;

function JavaToDelphiDateTime(const dt: int64): TDateTime;

var

  p: ptm;

  l, ms: Integer;

begin

  l := dt div ;

  ms := dt mod ;

  p := gmtime(@l);

  Result := EncodeDateTime(p^.tm_year+, p^.tm_mon+, p^.tm_mday, p^.tm_hour, p^.tm_min, p^.tm_sec, ms);

end;

{$ELSE}

{$IFDEF WINDOWSNT_COMPATIBILITY}

function DayLightCompareDate(const date: PSystemTime;

  const compareDate: PSystemTime): Integer;

var

  limit_day, dayinsecs, weekofmonth: Integer;

  First: Word;

begin

  if (date^.wMonth < compareDate^.wMonth) then

  begin

    Result := -; (* We are in a month before the date limit. *)

    Exit;

  end;

  if (date^.wMonth > compareDate^.wMonth) then

  begin

    Result := ; (* We are in a month after the date limit. *)

    Exit;

  end;

  (* if year is 0 then date is in day-of-week format, otherwise

   * it's absolute date.

   *)

  if (compareDate^.wYear = ) then

  begin

    (* compareDate.wDay is interpreted as number of the week in the month

     * 5 means: the last week in the month *)

    weekofmonth := compareDate^.wDay;

    (* calculate the day of the first DayOfWeek in the month *)

    First := ( + compareDate^.wDayOfWeek - date^.wDayOfWeek + date^.wDay) mod  + ;

    limit_day := First +  * (weekofmonth - );

    (* check needed for the 5th weekday of the month *)

    if (limit_day > MonthDays[(date^.wMonth=) and IsLeapYear(date^.wYear)][date^.wMonth - ]) then

      dec(limit_day, );

  end

  else

    limit_day := compareDate^.wDay;

  (* convert to seconds *)

  limit_day := ((limit_day *   + compareDate^.wHour) *  + compareDate^.wMinute ) * ;

  dayinsecs := ((date^.wDay *   + date^.wHour) *  + date^.wMinute ) *  + date^.wSecond;

  (* and compare *)

  if dayinsecs < limit_day then

    Result :=  - else

    if dayinsecs > limit_day then

      Result :=   else

      Result :=  ; (* date is equal to the date limit. *)

end;

function CompTimeZoneID(const pTZinfo: PTimeZoneInformation;

  lpFileTime: PFileTime; islocal: Boolean): LongWord;

var

  ret: Integer;

  beforeStandardDate, afterDaylightDate: Boolean;

  llTime: Int64;

  SysTime: TSystemTime;

  ftTemp: TFileTime;

begin

  llTime := ;

  if (pTZinfo^.DaylightDate.wMonth <> ) then

  begin

    (* if year is 0 then date is in day-of-week format, otherwise

     * it's absolute date.

     *)

    if ((pTZinfo^.StandardDate.wMonth = ) or

        ((pTZinfo^.StandardDate.wYear = ) and

        ((pTZinfo^.StandardDate.wDay < ) or

        (pTZinfo^.StandardDate.wDay > ) or

        (pTZinfo^.DaylightDate.wDay < ) or

        (pTZinfo^.DaylightDate.wDay > )))) then

    begin

      SetLastError(ERROR_INVALID_PARAMETER);

      Result := TIME_ZONE_ID_INVALID;

      Exit;

    end;

    if (not islocal) then

    begin

      llTime := PInt64(lpFileTime)^;

      dec(llTime, Int64(pTZinfo^.Bias + pTZinfo^.DaylightBias) * );

      PInt64(@ftTemp)^ := llTime;

      lpFileTime := @ftTemp;

    end;

    FileTimeToSystemTime(lpFileTime^, SysTime);

    (* check for daylight savings *)

    ret := DayLightCompareDate(@SysTime, @pTZinfo^.StandardDate);

    if (ret = -) then

    begin

      Result := TIME_ZONE_ID_INVALID;

      Exit;

    end;

    beforeStandardDate := ret < ;

    if (not islocal) then

    begin

      dec(llTime, Int64(pTZinfo^.StandardBias - pTZinfo^.DaylightBias) * );

      PInt64(@ftTemp)^ := llTime;

      FileTimeToSystemTime(lpFileTime^, SysTime);

    end;

    ret := DayLightCompareDate(@SysTime, @pTZinfo^.DaylightDate);

    if (ret = -) then

    begin

      Result := TIME_ZONE_ID_INVALID;

      Exit;

    end;

    afterDaylightDate := ret >= ;

    Result := TIME_ZONE_ID_STANDARD;

    if( pTZinfo^.DaylightDate.wMonth < pTZinfo^.StandardDate.wMonth ) then

    begin

      (* Northern hemisphere *)

      if( beforeStandardDate and afterDaylightDate) then

        Result := TIME_ZONE_ID_DAYLIGHT;

    end else    (* Down south *)

      if( beforeStandardDate or afterDaylightDate) then

        Result := TIME_ZONE_ID_DAYLIGHT;

  end else

    (* No transition date *)

    Result := TIME_ZONE_ID_UNKNOWN;

end;

function GetTimezoneBias(const pTZinfo: PTimeZoneInformation;

  lpFileTime: PFileTime; islocal: Boolean; pBias: PLongint): Boolean;

var

  bias: LongInt;

  tzid: LongWord;

begin

  bias := pTZinfo^.Bias;

  tzid := CompTimeZoneID(pTZinfo, lpFileTime, islocal);

  if( tzid = TIME_ZONE_ID_INVALID) then

  begin

    Result := False;

    Exit;

  end;

  if (tzid = TIME_ZONE_ID_DAYLIGHT) then

    inc(bias, pTZinfo^.DaylightBias)

  else if (tzid = TIME_ZONE_ID_STANDARD) then

    inc(bias, pTZinfo^.StandardBias);

  pBias^ := bias;

  Result := True;

end;

function SystemTimeToTzSpecificLocalTime(

  lpTimeZoneInformation: PTimeZoneInformation;

  lpUniversalTime, lpLocalTime: PSystemTime): BOOL;

var

  ft: TFileTime;

  lBias: LongInt;

  llTime: Int64;

  tzinfo: TTimeZoneInformation;

begin

  if (lpTimeZoneInformation <> nil) then

    tzinfo := lpTimeZoneInformation^ else

    if (GetTimeZoneInformation(tzinfo) = TIME_ZONE_ID_INVALID) then

    begin

      Result := False;

      Exit;

    end;

  if (not SystemTimeToFileTime(lpUniversalTime^, ft)) then

  begin

    Result := False;

    Exit;

  end;

  llTime := PInt64(@ft)^;

  if (not GetTimezoneBias(@tzinfo, @ft, False, @lBias)) then

  begin

    Result := False;

    Exit;

  end;

  (* convert minutes to 100-nanoseconds-ticks *)

  dec(llTime, Int64(lBias) * );

  PInt64(@ft)^ := llTime;

  Result := FileTimeToSystemTime(ft, lpLocalTime^);

end;

function TzSpecificLocalTimeToSystemTime(

    const lpTimeZoneInformation: PTimeZoneInformation;

    const lpLocalTime: PSystemTime; lpUniversalTime: PSystemTime): BOOL;

var

  ft: TFileTime;

  lBias: LongInt;

  t: Int64;

  tzinfo: TTimeZoneInformation;

begin

  if (lpTimeZoneInformation <> nil) then

    tzinfo := lpTimeZoneInformation^

  else

    if (GetTimeZoneInformation(tzinfo) = TIME_ZONE_ID_INVALID) then

    begin

      Result := False;

      Exit;

    end;

  if (not SystemTimeToFileTime(lpLocalTime^, ft)) then

  begin

    Result := False;

    Exit;

  end;

  t := PInt64(@ft)^;

  if (not GetTimezoneBias(@tzinfo, @ft, True, @lBias)) then

  begin

    Result := False;

    Exit;

  end;

  (* convert minutes to 100-nanoseconds-ticks *)

  inc(t, Int64(lBias) * );

  PInt64(@ft)^ := t;

  Result := FileTimeToSystemTime(ft, lpUniversalTime^);

end;

{$ELSE}

function TzSpecificLocalTimeToSystemTime(

  lpTimeZoneInformation: PTimeZoneInformation;

  lpLocalTime, lpUniversalTime: PSystemTime): BOOL; stdcall; external 'kernel32.dll';

function SystemTimeToTzSpecificLocalTime(

  lpTimeZoneInformation: PTimeZoneInformation;

  lpUniversalTime, lpLocalTime: PSystemTime): BOOL; stdcall; external 'kernel32.dll';

{$ENDIF}

function JavaToDelphiDateTime(const dt: int64): TDateTime;

var

  t: TSystemTime;

begin

  DateTimeToSystemTime( + (dt / ), t);

  SystemTimeToTzSpecificLocalTime(nil, @t, @t);

  Result := SystemTimeToDateTime(t);

end;

function DelphiToJavaDateTime(const dt: TDateTime): int64;

var

  t: TSystemTime;

begin

  DateTimeToSystemTime(dt, t);

  TzSpecificLocalTimeToSystemTime(nil, @t, @t);

  Result := Round((SystemTimeToDateTime(t) - ) * )

end;

{$ENDIF}

function SO(const s: SOString): ISuperObject; overload;

begin

  Result := TSuperObject.ParseString(PSOChar(s), False);

end;

function SA(const Args: array of const): ISuperObject; overload;

type

  TByteArray = array[..sizeof(integer) - ] of byte;

  PByteArray = ^TByteArray;

var

  j: Integer;

  intf: IInterface;

begin

  Result := TSuperObject.Create(stArray);

  for j :=  to length(Args) -  do

    with Result.AsArray do

    case TVarRec(Args[j]).VType of

      vtInteger : Add(TSuperObject.Create(TVarRec(Args[j]).VInteger));

      vtInt64   : Add(TSuperObject.Create(TVarRec(Args[j]).VInt64^));

      vtBoolean : Add(TSuperObject.Create(TVarRec(Args[j]).VBoolean));

      vtChar    : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VChar)));

      vtWideChar: Add(TSuperObject.Create(SOChar(TVarRec(Args[j]).VWideChar)));

      vtExtended: Add(TSuperObject.Create(TVarRec(Args[j]).VExtended^));

      vtCurrency: Add(TSuperObject.CreateCurrency(TVarRec(Args[j]).VCurrency^));

      vtString  : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VString^)));

      vtPChar   : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VPChar^)));

      vtAnsiString: Add(TSuperObject.Create(SOString(AnsiString(TVarRec(Args[j]).VAnsiString))));

      vtWideString: Add(TSuperObject.Create(SOString(PWideChar(TVarRec(Args[j]).VWideString))));

      vtInterface:

        if TVarRec(Args[j]).VInterface = nil then

          Add(nil) else

          if IInterface(TVarRec(Args[j]).VInterface).QueryInterface(ISuperObject, intf) =  then

            Add(ISuperObject(intf)) else

            Add(nil);

      vtPointer :

        if TVarRec(Args[j]).VPointer = nil then

          Add(nil) else

          Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer)));

      vtVariant:

        Add(SO(TVarRec(Args[j]).VVariant^));

      vtObject:

        if TVarRec(Args[j]).VPointer = nil then

          Add(nil) else

          Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer)));

      vtClass:

        if TVarRec(Args[j]).VPointer = nil then

          Add(nil) else

          Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer)));

{$if declared(vtUnicodeString)}

      vtUnicodeString:

          Add(TSuperObject.Create(SOString(string(TVarRec(Args[j]).VUnicodeString))));

{$ifend}

    else

      assert(false);

    end;

end;

function SO(const Args: array of const): ISuperObject; overload;

var

  j: Integer;

  arr: ISuperObject;

begin

  Result := TSuperObject.Create(stObject);

  arr := SA(Args);

  with arr.AsArray do

    for j :=  to (Length div ) -  do

      Result.AsObject.PutO(O[j*].AsString, O[(j*) + ]);

end;

function SO(const value: Variant): ISuperObject; overload;

begin

  with TVarData(value) do

  case VType of

    varNull:     Result := nil;

    varEmpty:    Result := nil;

    varSmallInt: Result := TSuperObject.Create(VSmallInt);

    varInteger:  Result := TSuperObject.Create(VInteger);

    varSingle:   Result := TSuperObject.Create(VSingle);

    varDouble:   Result := TSuperObject.Create(VDouble);

    varCurrency: Result := TSuperObject.CreateCurrency(VCurrency);

    varDate:     Result := TSuperObject.Create(DelphiToJavaDateTime(vDate));

    varOleStr:   Result := TSuperObject.Create(SOString(VOleStr));

    varBoolean:  Result := TSuperObject.Create(VBoolean);

    varShortInt: Result := TSuperObject.Create(VShortInt);

    varByte:     Result := TSuperObject.Create(VByte);

    varWord:     Result := TSuperObject.Create(VWord);

    varLongWord: Result := TSuperObject.Create(VLongWord);

    varInt64:    Result := TSuperObject.Create(VInt64);

    varString:   Result := TSuperObject.Create(SOString(AnsiString(VString)));

{$if declared(varUString)}

    varUString:  Result := TSuperObject.Create(SOString(string(VUString)));

{$ifend}

  else

    raise Exception.CreateFmt('Unsuported variant data type: %d', [VType]);

  end;

end;

function ObjectIsError(obj: TSuperObject): boolean;

begin

  Result := PtrUInt(obj) > PtrUInt(-);

end;

function ObjectIsType(const obj: ISuperObject; typ: TSuperType): boolean;

begin

  if obj <> nil then

    Result := typ = obj.DataType else

    Result := typ = stNull;

end;

function ObjectGetType(const obj: ISuperObject): TSuperType;

begin

  if obj <> nil then

    Result := obj.DataType else

    Result := stNull;

end;

function ObjectFindFirst(const obj: ISuperObject; var F: TSuperObjectIter): boolean;

var

  i: TSuperAvlEntry;

begin

  if ObjectIsType(obj, stObject) then

  begin

    F.Ite := TSuperAvlIterator.Create(obj.AsObject);

    F.Ite.First;

    i := F.Ite.GetIter;

    if i <> nil then

    begin

      f.key := i.Name;

      f.val := i.Value;

      Result := true;

    end else

      Result := False;

  end else

    Result := False;

end;

function ObjectFindNext(var F: TSuperObjectIter): boolean;

var

  i: TSuperAvlEntry;

begin

  F.Ite.Next;

  i := F.Ite.GetIter;

  if i <> nil then

  begin

    f.key := i.FName;

    f.val := i.Value;

    Result := true;

  end else

    Result := False;

end;

procedure ObjectFindClose(var F: TSuperObjectIter);

begin

  F.Ite.Free;

  F.val := nil;

end;

{$IFDEF VER210}

function serialtoboolean(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject;

begin

  Result := TSuperObject.Create(TValueData(value).FAsSLong <> );

end;

function serialtodatetime(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject;

begin

  Result := TSuperObject.Create(DelphiToJavaDateTime(TValueData(value).FAsDouble));

end;

function serialtoguid(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject;

var

  g: TGUID;

begin

  value.ExtractRawData(@g);

  Result := TSuperObject.Create(

    format('%.8x-%.4x-%.4x-%.2x%.2x-%.2x%.2x%.2x%.2x%.2x%.2x',

              [g.D1, g.D2, g.D3,

               g.D4[], g.D4[], g.D4[],

               g.D4[], g.D4[], g.D4[],

               g.D4[], g.D4[]])

  );

end;

function serialfromboolean(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;

var

  o: ISuperObject;

begin

  case ObjectGetType(obj) of

  stBoolean:

    begin

      TValueData(Value).FAsSLong := obj.AsInteger;

      Result := True;

    end;

  stInt:

    begin

      TValueData(Value).FAsSLong := ord(obj.AsInteger <> );

      Result := True;

    end;

  stString:

    begin

      o := SO(obj.AsString);

      if not ObjectIsType(o, stString) then

        Result := serialfromboolean(ctx, SO(obj.AsString), Value) else

        Result := False;

    end;

  else

    Result := False;

  end;

end;

function serialfromdatetime(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;

var

  dt: TDateTime;

begin

  case ObjectGetType(obj) of

  stInt:

    begin

      TValueData(Value).FAsDouble := JavaToDelphiDateTime(obj.AsInteger);

      Result := True;

    end;

  stString:

    begin

      if TryStrToDateTime(obj.AsString, dt) then

      begin

        TValueData(Value).FAsDouble := dt;

        Result := True;

      end else

        Result := False;

    end;

  else

    Result := False;

  end;

end;

function UuidFromString(const s: PSOChar; Uuid: PGUID): Boolean;

const

  hex2bin: array[#..#] of short = (

    -,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,        (* 0x00 *)

    -,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,        (* 0x10 *)

    -,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,        (* 0x20 *)

     , , , , , , , , , ,-,-,-,-,-,-,        (* 0x30 *)

    -,,,,,,,-,-,-,-,-,-,-,-,-,        (* 0x40 *)

    -,-,-,-,-,-,-,-,-,-,-,-,-,-,-,-,        (* 0x50 *)

    -,,,,,,);                                  (* 0x60 *)

var

  i: Integer;

begin

  if (strlen(s) <> ) then Exit(False);

  if ((s[] <> '-') or (s[] <> '-') or (s[] <> '-') or (s[] <> '-')) then

     Exit(False);

  for i :=  to  do

  begin

    if not i in [,,,] then

      if ((s[i] > 'f') or ((hex2bin[s[i]] = -) and (s[i] <> ''))) then

        Exit(False);

  end;

  uuid.D1 := ((hex2bin[s[]] shl ) or (hex2bin[s[]] shl ) or (hex2bin[s[]] shl ) or (hex2bin[s[]] shl ) or

                (hex2bin[s[]] shl ) or (hex2bin[s[]] shl ) or (hex2bin[s[]]  shl ) or hex2bin[s[]]);

  uuid.D2 := (hex2bin[s[]] shl ) or (hex2bin[s[]] shl ) or (hex2bin[s[]] shl ) or hex2bin[s[]];

  uuid.D3 := (hex2bin[s[]] shl ) or (hex2bin[s[]] shl ) or (hex2bin[s[]] shl ) or hex2bin[s[]];

  uuid.D4[] := (hex2bin[s[]] shl ) or hex2bin[s[]];

  uuid.D4[] := (hex2bin[s[]] shl ) or hex2bin[s[]];

  uuid.D4[] := (hex2bin[s[]] shl ) or hex2bin[s[]];

  uuid.D4[] := (hex2bin[s[]] shl ) or hex2bin[s[]];

  uuid.D4[] := (hex2bin[s[]] shl ) or hex2bin[s[]];

  uuid.D4[] := (hex2bin[s[]] shl ) or hex2bin[s[]];

  uuid.D4[] := (hex2bin[s[]] shl ) or hex2bin[s[]];

  uuid.D4[] := (hex2bin[s[]] shl ) or hex2bin[s[]];

  Result := True;

end;

function serialfromguid(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;

begin

  case ObjectGetType(obj) of

    stNull:

      begin

        FillChar(Value.GetReferenceToRawData^, SizeOf(TGUID), );

        Result := True;

      end;

    stString: Result := UuidFromString(PSOChar(obj.AsString), Value.GetReferenceToRawData);

  else

    Result := False;

  end;

end;

function SOInvoke(const obj: TValue; const method: string; const params: ISuperObject; ctx: TSuperRttiContext): ISuperObject; overload;

var

  owned: Boolean;

begin

  if ctx = nil then

  begin

    ctx := TSuperRttiContext.Create;

    owned := True;

  end else

    owned := False;

  try

    if TrySOInvoke(ctx, obj, method, params, Result) <> irSuccess then

      raise Exception.Create('Invalid method call');

  finally

    if owned then

      ctx.Free;

  end;

end;

function SOInvoke(const obj: TValue; const method: string; const params: string; ctx: TSuperRttiContext): ISuperObject; overload;

begin

  Result := SOInvoke(obj, method, so(params), ctx)

end;

function TrySOInvoke(var ctx: TSuperRttiContext; const obj: TValue;

  const method: string; const params: ISuperObject;

  var Return: ISuperObject): TSuperInvokeResult;

var

  t: TRttiInstanceType;

  m: TRttiMethod;

  a: TArray<TValue>;

  ps: TArray<TRttiParameter>;

  v: TValue;

  index: ISuperObject;

  function GetParams: Boolean;

  var

    i: Integer;

  begin

    case ObjectGetType(params) of

      stArray:

        for i :=  to Length(ps) -  do

          if (pfOut in ps[i].Flags) then

            TValue.Make(nil, ps[i].ParamType.Handle, a[i]) else

            if not ctx.FromJson(ps[i].ParamType.Handle, params.AsArray[i], a[i]) then

              Exit(False);

      stObject:

        for i :=  to Length(ps) -  do

          if (pfOut in ps[i].Flags) then

            TValue.Make(nil, ps[i].ParamType.Handle, a[i]) else

            if not ctx.FromJson(ps[i].ParamType.Handle, params.AsObject[ps[i].Name], a[i]) then

              Exit(False);

      stNull: ;

    else

      Exit(False);

    end;

    Result := True;

  end;

  procedure SetParams;

  var

    i: Integer;

  begin

    case ObjectGetType(params) of

      stArray:

        for i :=  to Length(ps) -  do

          if (ps[i].Flags * [pfVar, pfOut]) <> [] then

            params.AsArray[i] := ctx.ToJson(a[i], index);

      stObject:

        for i :=  to Length(ps) -  do

          if (ps[i].Flags * [pfVar, pfOut]) <> [] then

            params.AsObject[ps[i].Name] := ctx.ToJson(a[i], index);

    end;

  end;

begin

  Result := irSuccess;

  index := SO;

  case obj.Kind of

    tkClass:

      begin

        t := TRttiInstanceType(ctx.Context.GetType(obj.AsObject.ClassType));

        m := t.GetMethod(method);

        if m = nil then Exit(irMethothodError);

        ps := m.GetParameters;

        SetLength(a, Length(ps));

        if not GetParams then Exit(irParamError);

        if m.IsClassMethod then

        begin

          v := m.Invoke(obj.AsObject.ClassType, a);

          Return := ctx.ToJson(v, index);

          SetParams;

        end else

        begin

          v := m.Invoke(obj, a);

          Return := ctx.ToJson(v, index);

          SetParams;

        end;

      end;

    tkClassRef:

      begin

        t := TRttiInstanceType(ctx.Context.GetType(obj.AsClass));

        m := t.GetMethod(method);

        if m = nil then Exit(irMethothodError);

        ps := m.GetParameters;

        SetLength(a, Length(ps));

        if not GetParams then Exit(irParamError);

        if m.IsClassMethod then

        begin

          v := m.Invoke(obj, a);

          Return := ctx.ToJson(v, index);

          SetParams;

        end else

          Exit(irError);

      end;

  else

    Exit(irError);

  end;

end;

{$ENDIF}

{ TSuperEnumerator }

constructor TSuperEnumerator.Create(const obj: ISuperObject);

begin

  FObj := obj;

  FCount := -;

  if ObjectIsType(FObj, stObject) then

    FObjEnum := FObj.AsObject.GetEnumerator else

    FObjEnum := nil;

end;

destructor TSuperEnumerator.Destroy;

begin

  if FObjEnum <> nil then

    FObjEnum.Free;

end;

function TSuperEnumerator.MoveNext: Boolean;

begin

  case ObjectGetType(FObj) of

    stObject: Result := FObjEnum.MoveNext;

    stArray:

      begin

        inc(FCount);

        if FCount < FObj.AsArray.Length then

          Result := True else

          Result := False;

      end;

  else

    Result := false;

  end;

end;

function TSuperEnumerator.GetCurrent: ISuperObject;

begin

  case ObjectGetType(FObj) of

    stObject: Result := FObjEnum.Current.Value;

    stArray: Result := FObj.AsArray.GetO(FCount);

  else

    Result := FObj;

  end;

end;

{ TSuperObject }

constructor TSuperObject.Create(jt: TSuperType);

begin

  inherited Create;

{$IFDEF DEBUG}

  InterlockedIncrement(debugcount);

{$ENDIF}

  FProcessing := false;

  FDataPtr := nil;

  FDataType := jt;

  case FDataType of

    stObject: FO.c_object := TSuperTableString.Create;

    stArray: FO.c_array := TSuperArray.Create;

    stString: FOString := '';

  else

    FO.c_object := nil;

  end;

end;

constructor TSuperObject.Create(b: boolean);

begin

  Create(stBoolean);

  FO.c_boolean := b;

end;

constructor TSuperObject.Create(i: SuperInt);

begin

  Create(stInt);

  FO.c_int := i;

end;

constructor TSuperObject.Create(d: double);

begin

  Create(stDouble);

  FO.c_double := d;

end;

constructor TSuperObject.CreateCurrency(c: Currency);

begin

  Create(stCurrency);

  FO.c_currency := c;

end;

destructor TSuperObject.Destroy;

begin

{$IFDEF DEBUG}

  InterlockedDecrement(debugcount);

{$ENDIF}

  case FDataType of

    stObject: FO.c_object.Free;

    stArray: FO.c_array.Free;

  end;

  inherited;

end;

function TSuperObject.Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer;

function DoEscape(str: PSOChar; len: Integer): Integer;

var

  pos, start_offset: Integer;

  c: SOChar;

  buf: array[..] of SOChar;

type

  TByteChar = record

  case integer of

    : (a, b: Byte);

    : (c: WideChar);

  end;

  begin

    if str = nil then

    begin

      Result := ;

      exit;

    end;

    pos := ; start_offset := ;

    with writer do

    while pos < len do

    begin

      c := str[pos];

      case c of

        #,#,#,#,#,'"','\','/':

          begin

            if(pos - start_offset > ) then

              Append(str + start_offset, pos - start_offset);

            if(c = #) then Append(ESC_BS, )

            else if (c = #) then Append(ESC_TAB, )

            else if (c = #) then Append(ESC_LF, )

            else if (c = #) then Append(ESC_FF, )

            else if (c = #) then Append(ESC_CR, )

            else if (c = '"') then Append(ESC_QUOT, )

            else if (c = '\') then Append(ESC_SL, )

            else if (c = '/') then Append(ESC_SR, );

            inc(pos);

            start_offset := pos;

          end;

      else

        if (SOIChar(c) > ) then

        begin

          if(pos - start_offset > ) then

            Append(str + start_offset, pos - start_offset);

          buf[] := '\';

          buf[] := 'u';

          buf[] := super_hex_chars[TByteChar(c).b shr ];

          buf[] := super_hex_chars[TByteChar(c).b and $f];

          buf[] := super_hex_chars[TByteChar(c).a shr ];

          buf[] := super_hex_chars[TByteChar(c).a and $f];

          Append(@buf, );

          inc(pos);

          start_offset := pos;

        end else

        if (c < #) or (c > #) then

        begin

          if(pos - start_offset > ) then

            Append(str + start_offset, pos - start_offset);

          buf[] := '\';

          buf[] := 'u';

          buf[] := '';

          buf[] := '';

          buf[] := super_hex_chars[ord(c) shr ];

          buf[] := super_hex_chars[ord(c) and $f];

          Append(buf, );

          inc(pos);

          start_offset := pos;

        end else

          inc(pos);

      end;

    end;

    if(pos - start_offset > ) then

      writer.Append(str + start_offset, pos - start_offset);

    Result := ;

  end;

function DoMinimalEscape(str: PSOChar; len: Integer): Integer;

var

  pos, start_offset: Integer;

  c: SOChar;

type

  TByteChar = record

  case integer of

    : (a, b: Byte);

    : (c: WideChar);

  end;

  begin

    if str = nil then

    begin

      Result := ;

      exit;

    end;

    pos := ; start_offset := ;

    with writer do

    while pos < len do

    begin

      c := str[pos];

      case c of

        #:

          begin

            if(pos - start_offset > ) then

              Append(str + start_offset, pos - start_offset);

            Append(ESC_ZERO, );

            inc(pos);

            start_offset := pos;

          end;

        '"':

          begin

            if(pos - start_offset > ) then

              Append(str + start_offset, pos - start_offset);

            Append(ESC_QUOT, );

            inc(pos);

            start_offset := pos;

          end;

        '\':

          begin

            if(pos - start_offset > ) then

              Append(str + start_offset, pos - start_offset);

            Append(ESC_SL, );

            inc(pos);

            start_offset := pos;

          end;

        '/':

          begin

            if(pos - start_offset > ) then

              Append(str + start_offset, pos - start_offset);

            Append(ESC_SR, );

            inc(pos);

            start_offset := pos;

          end;

      else

        inc(pos);

      end;

    end;

    if(pos - start_offset > ) then

      writer.Append(str + start_offset, pos - start_offset);

    Result := ;

  end;

  procedure _indent(i: shortint; r: boolean);

  begin

    inc(level, i);

    if r then

      with writer do

      begin

{$IFDEF MSWINDOWS}

        Append(TOK_CRLF, );

{$ELSE}

        Append(TOK_LF, );

{$ENDIF}

        for i :=  to level -  do

          Append(TOK_SP, );

      end;

  end;

var

  k,j: Integer;

  iter: TSuperObjectIter;

  st: AnsiString;

  val: ISuperObject;

  fbuffer: array[..] of AnsiChar;

const

  ENDSTR_A: PSOChar = '": ';

  ENDSTR_B: PSOChar = '":';

begin

  if FProcessing then

  begin

    Result := writer.Append(TOK_NULL, );

    Exit;

  end;

  FProcessing := true;

  with writer do

  try

    case FDataType of

      stObject:

        if FO.c_object.FCount >  then

        begin

          k := ;

          Append(TOK_CBL, );

          if indent then _indent(, false);

          if ObjectFindFirst(Self, iter) then

          repeat

  {$IFDEF SUPER_METHOD}

            if (iter.val = nil) or not ObjectIsType(iter.val, stMethod) then

            begin

  {$ENDIF}

              if (iter.val = nil) or (not iter.val.Processing) then

              begin

                if(k <> ) then

                  Append(TOK_COM, );

                if indent then _indent(, true);

                Append(TOK_DQT, );

                if escape then

                  doEscape(PSOChar(iter.key), Length(iter.key)) else

                  DoMinimalEscape(PSOChar(iter.key), Length(iter.key));

                if indent then

                  Append(ENDSTR_A, ) else

                  Append(ENDSTR_B, );

                if(iter.val = nil) then

                  Append(TOK_NULL, ) else

                  iter.val.write(writer, indent, escape, level);

                inc(k);

              end;

  {$IFDEF SUPER_METHOD}

            end;

  {$ENDIF}

          until not ObjectFindNext(iter);

          ObjectFindClose(iter);

          if indent then _indent(-, true);

          Result := Append(TOK_CBR, );

        end else

          Result := Append(TOK_OBJ, );

      stBoolean:

        begin

          if (FO.c_boolean) then

            Result := Append(TOK_TRUE, ) else

            Result := Append(TOK_FALSE, );

        end;

      stInt:

        begin

          str(FO.c_int, st);

          Result := Append(PSOChar(SOString(st)));

        end;

      stDouble:

        Result := Append(PSOChar(SOString(gcvt(FO.c_double, , fbuffer))));

      stCurrency:

        begin

          Result := Append(PSOChar(CurrToStr(FO.c_currency)));

        end;

      stString:

        begin

          Append(TOK_DQT, );

          if escape then

            doEscape(PSOChar(FOString), Length(FOString)) else

            DoMinimalEscape(PSOChar(FOString), Length(FOString));

          Append(TOK_DQT, );

          Result := ;

        end;

      stArray:

        if FO.c_array.FLength >  then

        begin

          Append(TOK_ARL, );

          if indent then _indent(, true);

          k := ;

          j := ;

          while k < FO.c_array.FLength do

          begin

            val :=  FO.c_array.GetO(k);

  {$IFDEF SUPER_METHOD}

            if not ObjectIsType(val, stMethod) then

            begin

  {$ENDIF}

              if (val = nil) or (not val.Processing) then

              begin

                if (j <> ) then

                  Append(TOK_COM, );

                if(val = nil) then

                  Append(TOK_NULL, ) else

                  val.write(writer, indent, escape, level);

                inc(j);

              end;

  {$IFDEF SUPER_METHOD}

            end;

  {$ENDIF}

            inc(k);

          end;

          if indent then _indent(-, false);

          Result := Append(TOK_ARR, );

        end else

          Result := Append(TOK_ARRAY, );

      stNull:

          Result := Append(TOK_NULL, );

    else

      Result := ;

    end;

  finally

    FProcessing := false;

  end;

end;

function TSuperObject.IsType(AType: TSuperType): boolean;

begin

  Result := AType = FDataType;

end;

function TSuperObject.AsBoolean: boolean;

begin

  case FDataType of

    stBoolean: Result := FO.c_boolean;

    stInt: Result := (FO.c_int <> );

    stDouble: Result := (FO.c_double <> );

    stCurrency: Result := (FO.c_currency <> );

    stString: Result := (Length(FOString) <> );

    stNull: Result := False;

  else

    Result := True;

  end;

end;

function TSuperObject.AsInteger: SuperInt;

var

  code: integer;

  cint: SuperInt;

begin

  case FDataType of

    stInt: Result := FO.c_int;

    stDouble: Result := round(FO.c_double);

    stCurrency: Result := round(FO.c_currency);

    stBoolean: Result := ord(FO.c_boolean);

    stString:

      begin

        Val(FOString, cint, code);

        if code =  then

          Result := cint else

          Result := ;

      end;

  else

    Result := ;

  end;

end;

function TSuperObject.AsDouble: Double;

var

  code: integer;

  cdouble: double;

begin

  case FDataType of

    stDouble: Result := FO.c_double;

    stCurrency: Result := FO.c_currency;

    stInt: Result := FO.c_int;

    stBoolean: Result := ord(FO.c_boolean);

    stString:

      begin

        Val(FOString, cdouble, code);

        if code =  then

          Result := cdouble else

          Result := 0.0;

      end;

  else

    Result := 0.0;

  end;

end;

function TSuperObject.AsCurrency: Currency;

var

  code: integer;

  cdouble: double;

begin

  case FDataType of

    stDouble: Result := FO.c_double;

    stCurrency: Result := FO.c_currency;

    stInt: Result := FO.c_int;

    stBoolean: Result := ord(FO.c_boolean);

    stString:

      begin

        Val(FOString, cdouble, code);

        if code =  then

          Result := cdouble else

          Result := 0.0;

      end;

  else

    Result := 0.0;

  end;

end;

function TSuperObject.AsString: SOString;

begin

  if FDataType = stString then

    Result := FOString else

    Result := AsJSon(false, false);

end;

function TSuperObject.GetEnumerator: TSuperEnumerator;

begin

  Result := TSuperEnumerator.Create(Self);

end;

procedure TSuperObject.AfterConstruction;

begin

  InterlockedDecrement(FRefCount);

end;

procedure TSuperObject.BeforeDestruction;

begin

  if RefCount <>  then

    raise Exception.Create('Invalid pointer');

end;

function TSuperObject.AsArray: TSuperArray;

begin

  if FDataType = stArray then

    Result := FO.c_array else

    Result := nil;

end;

function TSuperObject.AsObject: TSuperTableString;

begin

  if FDataType = stObject then

    Result := FO.c_object else

    Result := nil;

end;

function TSuperObject.AsJSon(indent, escape: boolean): SOString;

var

  pb: TSuperWriterString;

begin

  pb := TSuperWriterString.Create;

  try

    if(Write(pb, indent, escape, ) < ) then

    begin

      Result := '';

      Exit;

    end;

    if pb.FBPos >  then

      Result := pb.FBuf else

      Result := '';

  finally

    pb.Free;

  end;

end;

class function TSuperObject.ParseString(s: PSOChar; strict: Boolean; partial: boolean; const this: ISuperObject;

  options: TSuperFindOptions; const put: ISuperObject; dt: TSuperType): ISuperObject;

var

  tok: TSuperTokenizer;

  obj: ISuperObject;

begin

  tok := TSuperTokenizer.Create;

  obj := ParseEx(tok, s, -, strict, this, options, put, dt);

  if(tok.err <> teSuccess) or (not partial and (s[tok.char_offset] <> #)) then

    Result := nil else

    Result := obj;

  tok.Free;

end;

class function TSuperObject.ParseStream(stream: TStream; strict: Boolean;

  partial: boolean; const this: ISuperObject; options: TSuperFindOptions;

   const put: ISuperObject; dt: TSuperType): ISuperObject;

const

  BUFFER_SIZE = ;

var

  tok: TSuperTokenizer;

  buffera: array[..BUFFER_SIZE-] of AnsiChar;

  bufferw: array[..BUFFER_SIZE-] of SOChar;

  bom: array[..] of byte;

  unicode: boolean;

  j, size: Integer;

  st: string;

begin

  st := '';

  tok := TSuperTokenizer.Create;

  if (stream.Read(bom, sizeof(bom)) = ) and (bom[] = $FF) and (bom[] = $FE) then

  begin

    unicode := true;

    size := stream.Read(bufferw, BUFFER_SIZE * SizeOf(SoChar)) div SizeOf(SoChar);

  end else

    begin

      unicode := false;

      stream.Seek(, soFromBeginning);

      size := stream.Read(buffera, BUFFER_SIZE);

    end;

  while size >  do

  begin

    if not unicode then

      for j :=  to size -  do

        bufferw[j] := SOChar(buffera[j]);

    ParseEx(tok, bufferw, size, strict, this, options, put, dt);

    if tok.err = teContinue then

      begin

        if not unicode then

          size := stream.Read(buffera, BUFFER_SIZE) else

          size := stream.Read(bufferw, BUFFER_SIZE * SizeOf(SoChar)) div SizeOf(SoChar);

      end else

      Break;

  end;

  if(tok.err <> teSuccess) or (not partial and (st[tok.char_offset] <> #)) then

    Result := nil else

    Result := tok.stack[tok.depth].current;

  tok.Free;

end;

class function TSuperObject.ParseFile(const FileName: string; strict: Boolean;

  partial: boolean; const this: ISuperObject; options: TSuperFindOptions;

  const put: ISuperObject; dt: TSuperType): ISuperObject;

var

  stream: TFileStream;

begin

  stream := TFileStream.Create(FileName, fmOpenRead, fmShareDenyWrite);

  try

    Result := ParseStream(stream, strict, partial, this, options, put, dt);

  finally

    stream.Free;

  end;

end;

class function TSuperObject.ParseEx(tok: TSuperTokenizer; str: PSOChar; len: integer;

  strict: Boolean; const this: ISuperObject; options: TSuperFindOptions; const put: ISuperObject; dt: TSuperType): ISuperObject;

const

  spaces = [#,#,#,#,#,#];

  delimiters = ['"', '.', '[', ']', '{', '}', '(', ')', ',', ':', #];

  reserved = delimiters + spaces;

  path = ['a'..'z', 'A'..'Z', '.', '_'];

  function hexdigit(x: SOChar): byte;

  begin

    if x <= '' then

      Result := byte(x) - byte('') else

      Result := (byte(x) and ) + ;

  end;

  function min(v1, v2: integer): integer; begin if v1 < v2 then result := v1 else result := v2 end;

var

  obj: ISuperObject;

  v: SOChar;

{$IFDEF SUPER_METHOD}

  sm: TSuperMethod;

{$ENDIF}

  numi: SuperInt;

  numd: Double;

  code: integer;

  TokRec: PSuperTokenerSrec;

  evalstack: integer;

  p: PSOChar;

  function IsEndDelimiter(v: AnsiChar): Boolean;

  begin

    if tok.depth >  then

      case tok.stack[tok.depth - ].state of

        tsArrayAdd: Result := v in [',', ']', #];

        tsObjectValueAdd: Result := v in [',', '}', #];

      else

        Result := v = #;

      end else

        Result := v = #;

  end;

label out, redo_char;

begin

  evalstack := ;

  obj := nil;

  Result := nil;

  TokRec := @tok.stack[tok.depth];

  tok.char_offset := ;

  tok.err := teSuccess;

  repeat

    if (tok.char_offset = len) then

    begin

      if (tok.depth = ) and (TokRec^.state = tsEatws) and

         (TokRec^.saved_state = tsFinish) then

        tok.err := teSuccess else

        tok.err := teContinue;

      goto out;

    end;

    v := str^;

    case v of

    #:

      begin

        inc(tok.line);

        tok.col := ;

      end;

    #: inc(tok.col, );

    else

      inc(tok.col);

    end;

redo_char:

    case TokRec^.state of

    tsEatws:

      begin

        if (SOIChar(v) < ) and (AnsiChar(v) in spaces) then {nop} else

        if (v = '/') then

        begin

          tok.pb.Reset;

          tok.pb.Append(@v, );

          TokRec^.state := tsCommentStart;

        end else begin

          TokRec^.state := TokRec^.saved_state;

          goto redo_char;

        end

      end;

    tsStart:

      case v of

      '"',

      '''':

        begin

          TokRec^.state := tsString;

          tok.pb.Reset;

          tok.quote_char := v;

        end;

      '-':

        begin

          TokRec^.state := tsNumber;

          tok.pb.Reset;

          tok.is_double := ;

          tok.floatcount := -;

          goto redo_char;

        end;

      ''..'':

        begin

          if (tok.depth = ) then

            case ObjectGetType(this) of

            stObject:

              begin

                TokRec^.state := tsIdentifier;

                TokRec^.current := this;

                goto redo_char;

              end;

          end;

          TokRec^.state := tsNumber;

          tok.pb.Reset;

          tok.is_double := ;

          tok.floatcount := -;

          goto redo_char;

        end;

      '{':

        begin

          TokRec^.state := tsEatws;

          TokRec^.saved_state := tsObjectFieldStart;

          TokRec^.current := TSuperObject.Create(stObject);

        end;

      '[':

        begin

          TokRec^.state := tsEatws;

          TokRec^.saved_state := tsArray;

          TokRec^.current := TSuperObject.Create(stArray);

        end;

{$IFDEF SUPER_METHOD}

      '(':

        begin

          if (tok.depth = ) and ObjectIsType(this, stMethod) then

          begin

            TokRec^.current := this;

            TokRec^.state := tsParamValue;

          end;

        end;

{$ENDIF}

      'N',

      'n':

        begin

          TokRec^.state := tsNull;

          tok.pb.Reset;

          tok.st_pos := ;

          goto redo_char;

        end;

      'T',

      't',

      'F',

      'f':

        begin

          TokRec^.state := tsBoolean;

          tok.pb.Reset;

          tok.st_pos := ;

          goto redo_char;

        end;

      else

        TokRec^.state := tsIdentifier;

        tok.pb.Reset;

        goto redo_char;

      end;

    tsFinish:

      begin

        if(tok.depth = ) then goto out;

        obj := TokRec^.current;

        tok.ResetLevel(tok.depth);

        dec(tok.depth);

        TokRec := @tok.stack[tok.depth];

        goto redo_char;

      end;

    tsNull:

      begin

        tok.pb.Append(@v, );

        if (StrLComp(TOK_NULL, PSOChar(tok.pb.FBuf), min(tok.st_pos + , )) = ) then

        begin

          if (tok.st_pos = ) then

          if (((SOIChar(v) < ) and (AnsiChar(v) in path)) or (SOIChar(v) >= )) then

            TokRec^.state := tsIdentifier else

          begin

            TokRec^.current := TSuperObject.Create(stNull);

            TokRec^.saved_state := tsFinish;

            TokRec^.state := tsEatws;

            goto redo_char;

          end;

        end else

        begin

          TokRec^.state := tsIdentifier;

          tok.pb.FBuf[tok.st_pos] := #;

          dec(tok.pb.FBPos);

          goto redo_char;

        end;

        inc(tok.st_pos);

      end;

    tsCommentStart:

      begin

        if(v = '*') then

        begin

          TokRec^.state := tsComment;

        end else

        if (v = '/') then

        begin

          TokRec^.state := tsCommentEol;

        end else

        begin

          tok.err := teParseComment;

          goto out;

        end;

        tok.pb.Append(@v, );

      end;

    tsComment:

      begin

        if(v = '*') then

          TokRec^.state := tsCommentEnd;

        tok.pb.Append(@v, );

      end;

    tsCommentEol:

      begin

        if (v = #) then

          TokRec^.state := tsEatws else

          tok.pb.Append(@v, );

      end;

    tsCommentEnd:

      begin

        tok.pb.Append(@v, );

        if (v = '/') then

          TokRec^.state := tsEatws else

          TokRec^.state := tsComment;

      end;

    tsString:

      begin

        if (v = tok.quote_char) then

        begin

          TokRec^.current := TSuperObject.Create(SOString(tok.pb.GetString));

          TokRec^.saved_state := tsFinish;

          TokRec^.state := tsEatws;

        end else

        if (v = '\') then

        begin

          TokRec^.saved_state := tsString;

          TokRec^.state := tsStringEscape;

        end else

        begin

          tok.pb.Append(@v, );

        end

      end;

    tsEvalProperty:

      begin

        if (TokRec^.current = nil) and (foCreatePath in options) then

        begin

          TokRec^.current := TSuperObject.Create(stObject);

          TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current)

        end else

        if not ObjectIsType(TokRec^.current, stObject) then

        begin

          tok.err := teEvalObject;

          goto out;

        end;

        tok.pb.Reset;

        TokRec^.state := tsIdentifier;

        goto redo_char;

      end;

    tsEvalArray:

      begin

        if (TokRec^.current = nil) and (foCreatePath in options) then

        begin

          TokRec^.current := TSuperObject.Create(stArray);

          TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current)

        end else

        if not ObjectIsType(TokRec^.current, stArray) then

        begin

          tok.err := teEvalArray;

          goto out;

        end;

        tok.pb.Reset;

        TokRec^.state := tsParamValue;

        goto redo_char;

      end;

{$IFDEF SUPER_METHOD}

    tsEvalMethod:

      begin

        if ObjectIsType(TokRec^.current, stMethod) and assigned(TokRec^.current.AsMethod) then

        begin

          tok.pb.Reset;

          TokRec^.obj := TSuperObject.Create(stArray);

          TokRec^.state := tsMethodValue;

          goto redo_char;

        end else

        begin

          tok.err := teEvalMethod;

          goto out;

        end;

      end;

    tsMethodValue:

      begin

        case v of

        ')':

            TokRec^.state := tsIdentifier;

        else

          if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-) then

          begin

            tok.err := teDepth;

            goto out;

          end;

          inc(evalstack);

          TokRec^.state := tsMethodPut;

          inc(tok.depth);

          tok.ResetLevel(tok.depth);

          TokRec := @tok.stack[tok.depth];

          goto redo_char;

        end;

      end;

    tsMethodPut:

      begin

        TokRec^.obj.AsArray.Add(obj);

        case v of

          ',':

            begin

              tok.pb.Reset;

              TokRec^.saved_state := tsMethodValue;

              TokRec^.state := tsEatws;

            end;

          ')':

            begin

              if TokRec^.obj.AsArray.Length =  then

                TokRec^.obj := TokRec^.obj.AsArray.GetO();

              dec(evalstack);

              tok.pb.Reset;

              TokRec^.saved_state := tsIdentifier;

              TokRec^.state := tsEatws;

            end;

        else

          tok.err := teEvalMethod;

          goto out;

        end;

      end;

{$ENDIF}

    tsParamValue:

      begin

        case v of

        ']':

            TokRec^.state := tsIdentifier;

        else

          if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-) then

          begin

            tok.err := teDepth;

            goto out;

          end;

          inc(evalstack);

          TokRec^.state := tsParamPut;

          inc(tok.depth);

          tok.ResetLevel(tok.depth);

          TokRec := @tok.stack[tok.depth];

          goto redo_char;

        end;

      end;

    tsParamPut:

      begin

        dec(evalstack);

        TokRec^.obj := obj;

        tok.pb.Reset;

        TokRec^.saved_state := tsIdentifier;

        TokRec^.state := tsEatws;

        if v <> ']' then

        begin

          tok.err := teEvalArray;

          goto out;

        end;

      end;

    tsIdentifier:

      begin

        if (this = nil) then

        begin

          if (SOIChar(v) < ) and IsEndDelimiter(AnsiChar(v)) then

          begin

            if not strict then

            begin

              tok.pb.TrimRight;

              TokRec^.current := TSuperObject.Create(tok.pb.Fbuf);

              TokRec^.saved_state := tsFinish;

              TokRec^.state := tsEatws;

              goto redo_char;

            end else

            begin

              tok.err := teParseString;

              goto out;

            end;

          end else

          if (v = '\') then

          begin

            TokRec^.saved_state := tsIdentifier;

            TokRec^.state := tsStringEscape;

          end else

            tok.pb.Append(@v, );

        end else

        begin

         if (SOIChar(v) < ) and (AnsiChar(v) in reserved) then

         begin

           TokRec^.gparent := TokRec^.parent;

           if TokRec^.current = nil then

             TokRec^.parent := this else

             TokRec^.parent := TokRec^.current;

             case ObjectGetType(TokRec^.parent) of

               stObject:

                 case v of

                   '.':

                     begin

                       TokRec^.state := tsEvalProperty;

                       if tok.pb.FBPos >  then

                         TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);

                     end;

                   '[':

                     begin

                       TokRec^.state := tsEvalArray;

                       if tok.pb.FBPos >  then

                         TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);

                     end;

                   '(':

                     begin

                       TokRec^.state := tsEvalMethod;

                       if tok.pb.FBPos >  then

                         TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);

                     end;

                 else

                   if tok.pb.FBPos >  then

                     TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);

                   if (foPutValue in options) and (evalstack = ) then

                   begin

                     TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, put);

                     TokRec^.current := put

                   end else

                   if (foDelete in options) and (evalstack = ) then

                   begin

                     TokRec^.current := TokRec^.parent.AsObject.Delete(tok.pb.Fbuf);

                   end else

                   if (TokRec^.current = nil) and (foCreatePath in options) then

                   begin

                     TokRec^.current := TSuperObject.Create(dt);

                     TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current);

                   end;

                   TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);

                   TokRec^.state := tsFinish;

                   goto redo_char;

                 end;

               stArray:

                 begin

                   if TokRec^.obj <> nil then

                   begin

                     if not ObjectIsType(TokRec^.obj, stInt) or (TokRec^.obj.AsInteger < ) then

                     begin

                       tok.err := teEvalInt;

                       TokRec^.obj := nil;

                       goto out;

                     end;

                     numi := TokRec^.obj.AsInteger;

                     TokRec^.obj := nil;

                     TokRec^.current := TokRec^.parent.AsArray.GetO(numi);

                     case v of

                       '.':

                         if (TokRec^.current = nil) and (foCreatePath in options) then

                         begin

                           TokRec^.current := TSuperObject.Create(stObject);

                           TokRec^.parent.AsArray.PutO(numi, TokRec^.current);

                         end else

                         if (TokRec^.current = nil) then

                         begin

                           tok.err := teEvalObject;

                           goto out;

                         end;

                       '[':

                         begin

                           if (TokRec^.current = nil) and (foCreatePath in options) then

                           begin

                             TokRec^.current := TSuperObject.Create(stArray);

                             TokRec^.parent.AsArray.Add(TokRec^.current);

                           end else

                           if (TokRec^.current = nil) then

                           begin

                             tok.err := teEvalArray;

                             goto out;

                           end;

                           TokRec^.state := tsEvalArray;

                         end;

                       '(': TokRec^.state := tsEvalMethod;

                     else

                       if (foPutValue in options) and (evalstack = ) then

                       begin

                         TokRec^.parent.AsArray.PutO(numi, put);

                         TokRec^.current := put;

                       end else

                       if (foDelete in options) and (evalstack = ) then

                       begin

                         TokRec^.current := TokRec^.parent.AsArray.Delete(numi);

                       end else

                         TokRec^.current := TokRec^.parent.AsArray.GetO(numi);

                       TokRec^.state := tsFinish;

                       goto redo_char

                     end;

                   end else

                   begin

                     case v of

                       '.':

                         begin

                           if (foPutValue in options) then

                           begin

                             TokRec^.current := TSuperObject.Create(stObject);

                             TokRec^.parent.AsArray.Add(TokRec^.current);

                           end else

                             TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - );

                         end;

                       '[':

                         begin

                           if (foPutValue in options) then

                           begin

                             TokRec^.current := TSuperObject.Create(stArray);

                             TokRec^.parent.AsArray.Add(TokRec^.current);

                           end else

                             TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - );

                           TokRec^.state := tsEvalArray;

                         end;

                       '(':

                         begin

                           if not (foPutValue in options) then

                             TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - ) else

                             TokRec^.current := nil;

                           TokRec^.state := tsEvalMethod;

                         end;

                     else

                       if (foPutValue in options) and (evalstack = ) then

                       begin

                         TokRec^.parent.AsArray.Add(put);

                         TokRec^.current := put;

                       end else

                         if tok.pb.FBPos =  then

                           TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - );

                       TokRec^.state := tsFinish;

                       goto redo_char

                     end;

                   end;

                 end;

{$IFDEF SUPER_METHOD}

               stMethod:

                 case v of

                   '.':

                     begin

                       TokRec^.current := nil;

                       sm := TokRec^.parent.AsMethod;

                       sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);

                       TokRec^.obj := nil;

                     end;

                   '[':

                     begin

                       TokRec^.current := nil;

                       sm := TokRec^.parent.AsMethod;

                       sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);

                       TokRec^.state := tsEvalArray;

                       TokRec^.obj := nil;

                     end;

                   '(':

                     begin

                       TokRec^.current := nil;

                       sm := TokRec^.parent.AsMethod;

                       sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);

                       TokRec^.state := tsEvalMethod;

                       TokRec^.obj := nil;

                     end;

                 else

                   if not (foPutValue in options) or (evalstack > ) then

                   begin

                     TokRec^.current := nil;

                     sm := TokRec^.parent.AsMethod;

                     sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);

                     TokRec^.obj := nil;

                     TokRec^.state := tsFinish;

                     goto redo_char

                   end else

                   begin

                     tok.err := teEvalMethod;

                     TokRec^.obj := nil;

                     goto out;

                   end;

                 end;

{$ENDIF}

             end;

          end else

            tok.pb.Append(@v, );

        end;

      end;

    tsStringEscape:

      case v of

      'b',

      'n',

      'r',

      't',

      'f':

        begin

          if(v = 'b') then tok.pb.Append(TOK_BS, )

          else if(v = 'n') then tok.pb.Append(TOK_LF, )

          else if(v = 'r') then tok.pb.Append(TOK_CR, )

          else if(v = 't') then tok.pb.Append(TOK_TAB, )

          else if(v = 'f') then tok.pb.Append(TOK_FF, );

          TokRec^.state := TokRec^.saved_state;

        end;

      'u':

        begin

          tok.ucs_char := ;

          tok.st_pos := ;

          TokRec^.state := tsEscapeUnicode;

        end;

      'x':

        begin

          tok.ucs_char := ;

          tok.st_pos := ;

          TokRec^.state := tsEscapeHexadecimal;

        end

      else

        tok.pb.Append(@v, );

        TokRec^.state := TokRec^.saved_state;

      end;

    tsEscapeUnicode:

      begin

        if ((SOIChar(v) < ) and (AnsiChar(v) in super_hex_chars_set)) then

        begin

          inc(tok.ucs_char, (Word(hexdigit(v)) shl ((-tok.st_pos)*)));

          inc(tok.st_pos);

          if (tok.st_pos = ) then

          begin

            tok.pb.Append(@tok.ucs_char, );

            TokRec^.state := TokRec^.saved_state;

          end

        end else

        begin

          tok.err := teParseString;

          goto out;

        end

      end;

    tsEscapeHexadecimal:

      begin

        if ((SOIChar(v) < ) and (AnsiChar(v) in super_hex_chars_set)) then

        begin

          inc(tok.ucs_char, (Word(hexdigit(v)) shl ((-tok.st_pos)*)));

          inc(tok.st_pos);

          if (tok.st_pos = ) then

          begin

            tok.pb.Append(@tok.ucs_char, );

            TokRec^.state := TokRec^.saved_state;

          end

        end else

        begin

          tok.err := teParseString;

          goto out;

        end

      end;

    tsBoolean:

      begin

        tok.pb.Append(@v, );

        if (StrLComp('true', PSOChar(tok.pb.FBuf), min(tok.st_pos + , )) = ) then

        begin

          if (tok.st_pos = ) then

          if (((SOIChar(v) < ) and (AnsiChar(v) in path)) or (SOIChar(v) >= )) then

            TokRec^.state := tsIdentifier else

          begin

            TokRec^.current := TSuperObject.Create(true);

            TokRec^.saved_state := tsFinish;

            TokRec^.state := tsEatws;

            goto redo_char;

          end

        end else

        if (StrLComp('false', PSOChar(tok.pb.FBuf), min(tok.st_pos + , )) = ) then

        begin

          if (tok.st_pos = ) then

          if (((SOIChar(v) < ) and (AnsiChar(v) in path)) or (SOIChar(v) >= )) then

            TokRec^.state := tsIdentifier else

          begin

            TokRec^.current := TSuperObject.Create(false);

            TokRec^.saved_state := tsFinish;

            TokRec^.state := tsEatws;

            goto redo_char;

          end

        end else

        begin

          TokRec^.state := tsIdentifier;

          tok.pb.FBuf[tok.st_pos] := #;

          dec(tok.pb.FBPos);

          goto redo_char;

        end;

        inc(tok.st_pos);

      end;

    tsNumber:

      begin

        if (SOIChar(v) < ) and (AnsiChar(v) in super_number_chars_set) then

        begin

          tok.pb.Append(@v, );

          if (SOIChar(v) < ) then

          case v of

          '.': begin

                 tok.is_double := ;

                 tok.floatcount := ;

               end;

          'e','E':

            begin

              tok.is_double := ;

              tok.floatcount := -;

            end;

          ''..'':

            begin

              if (tok.is_double = ) and (tok.floatcount >= ) then

              begin

                inc(tok.floatcount);

                if tok.floatcount >  then

                  tok.floatcount := -;

              end;

            end;

          end;

        end else

        begin

          if (tok.is_double = ) then

          begin

            val(tok.pb.FBuf, numi, code);

            if ObjectIsType(this, stArray) then

            begin

              if (foPutValue in options) and (evalstack = ) then

              begin

                this.AsArray.PutO(numi, put);

                TokRec^.current := put;

              end else

              if (foDelete in options) and (evalstack = ) then

                TokRec^.current := this.AsArray.Delete(numi) else

                TokRec^.current := this.AsArray.GetO(numi);

            end else

              TokRec^.current := TSuperObject.Create(numi);

          end else

          if (tok.is_double <> ) then

          begin

            if tok.floatcount >=  then

            begin

              p := tok.pb.FBuf;

              while p^ <> '.' do inc(p);

              for code :=  to tok.floatcount -  do

              begin

                p^ := p[];

                inc(p);

              end;

              p^ := #;

              val(tok.pb.FBuf, numi, code);

              case tok.floatcount of

                : numi := numi * ;

                : numi := numi * ;

                : numi := numi * ;

                : numi := numi * ;

              end;

              TokRec^.current := TSuperObject.CreateCurrency(PCurrency(@numi)^);

            end else

            begin

              val(tok.pb.FBuf, numd, code);

              TokRec^.current := TSuperObject.Create(numd);

            end;

          end else

          begin

            tok.err := teParseNumber;

            goto out;

          end;

          TokRec^.saved_state := tsFinish;

          TokRec^.state := tsEatws;

          goto redo_char;

        end

      end;

    tsArray:

      begin

        if (v = ']') then

        begin

          TokRec^.saved_state := tsFinish;

          TokRec^.state := tsEatws;

        end else

        begin

          if(tok.depth >= SUPER_TOKENER_MAX_DEPTH-) then

          begin

            tok.err := teDepth;

            goto out;

          end;

          TokRec^.state := tsArrayAdd;

          inc(tok.depth);

          tok.ResetLevel(tok.depth);

          TokRec := @tok.stack[tok.depth];

          goto redo_char;

        end

      end;

    tsArrayAdd:

      begin

        TokRec^.current.AsArray.Add(obj);

        TokRec^.saved_state := tsArraySep;

        TokRec^.state := tsEatws;

        goto redo_char;

      end;

    tsArraySep:

      begin

        if (v = ']') then

        begin

          TokRec^.saved_state := tsFinish;

          TokRec^.state := tsEatws;

        end else

        if (v = ',') then

        begin

          TokRec^.saved_state := tsArray;

          TokRec^.state := tsEatws;

        end else

        begin

          tok.err := teParseArray;

          goto out;

        end

      end;

    tsObjectFieldStart:

      begin

        if (v = '}') then

        begin

          TokRec^.saved_state := tsFinish;

          TokRec^.state := tsEatws;

        end else

        if (SOIChar(v) < ) and (AnsiChar(v) in ['"', '''']) then

        begin

          tok.quote_char := v;

          tok.pb.Reset;

          TokRec^.state := tsObjectField;

        end else

        if not((SOIChar(v) < ) and ((AnsiChar(v) in reserved) or strict)) then

        begin

          TokRec^.state := tsObjectUnquotedField;

          tok.pb.Reset;

          goto redo_char;

        end else

        begin

          tok.err := teParseObjectKeyName;

          goto out;

        end

      end;

    tsObjectField:

      begin

        if (v = tok.quote_char) then

        begin

          TokRec^.field_name := tok.pb.FBuf;

          TokRec^.saved_state := tsObjectFieldEnd;

          TokRec^.state := tsEatws;

        end else

        if (v = '\') then

        begin

          TokRec^.saved_state := tsObjectField;

          TokRec^.state := tsStringEscape;

        end else

        begin

          tok.pb.Append(@v, );

        end

      end;

    tsObjectUnquotedField:

      begin

        if (SOIChar(v) < ) and (AnsiChar(v) in [':', #]) then

        begin

          TokRec^.field_name := tok.pb.FBuf;

          TokRec^.saved_state := tsObjectFieldEnd;

          TokRec^.state := tsEatws;

          goto redo_char;

        end else

        if (v = '\') then

        begin

          TokRec^.saved_state := tsObjectUnquotedField;

          TokRec^.state := tsStringEscape;

        end else

          tok.pb.Append(@v, );

      end;

    tsObjectFieldEnd:

      begin

        if (v = ':') then

        begin

          TokRec^.saved_state := tsObjectValue;

          TokRec^.state := tsEatws;

        end else

        begin

          tok.err := teParseObjectKeySep;

          goto out;

        end

      end;

    tsObjectValue:

      begin

        if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-) then

        begin

          tok.err := teDepth;

          goto out;

        end;

        TokRec^.state := tsObjectValueAdd;

        inc(tok.depth);

        tok.ResetLevel(tok.depth);

        TokRec := @tok.stack[tok.depth];

        goto redo_char;

      end;

    tsObjectValueAdd:

      begin

        TokRec^.current.AsObject.PutO(TokRec^.field_name, obj);

        TokRec^.field_name := '';

        TokRec^.saved_state := tsObjectSep;

        TokRec^.state := tsEatws;

        goto redo_char;

      end;

    tsObjectSep:

      begin

        if (v = '}') then

        begin

          TokRec^.saved_state := tsFinish;

          TokRec^.state := tsEatws;

        end else

        if (v = ',') then

        begin

          TokRec^.saved_state := tsObjectFieldStart;

          TokRec^.state := tsEatws;

        end else

        begin

          tok.err := teParseObjectValueSep;

          goto out;

        end

      end;

    end;

    inc(str);

    inc(tok.char_offset);

  until v = #;

  if(TokRec^.state <> tsFinish) and

     (TokRec^.saved_state <> tsFinish) then

    tok.err := teParseEof;

 out:

  if(tok.err in [teSuccess]) then

  begin

{$IFDEF SUPER_METHOD}

    if (foCallMethod in options) and ObjectIsType(TokRec^.current, stMethod) and assigned(TokRec^.current.AsMethod) then

    begin

      sm := TokRec^.current.AsMethod;

      sm(TokRec^.parent, put, Result);

    end else

{$ENDIF}

    Result := TokRec^.current;

  end else

    Result := nil;

end;

procedure TSuperObject.PutO(const path: SOString; const Value: ISuperObject);

begin

  ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], Value);

end;

procedure TSuperObject.PutB(const path: SOString; Value: Boolean);

begin

  ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));

end;

procedure TSuperObject.PutD(const path: SOString; Value: Double);

begin

  ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));

end;

procedure TSuperObject.PutC(const path: SOString; Value: Currency);

begin

  ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.CreateCurrency(Value));

end;

procedure TSuperObject.PutI(const path: SOString; Value: SuperInt);

begin

  ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));

end;

procedure TSuperObject.PutS(const path: SOString; const Value: SOString);

begin

  ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));

end;

function TSuperObject.QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;

begin

  if GetInterface(IID, Obj) then

    Result :=

  else

    Result := E_NOINTERFACE;

end;

function TSuperObject.SaveTo(stream: TStream; indent, escape: boolean): integer;

var

  pb: TSuperWriterStream;

begin

  if escape then

    pb := TSuperAnsiWriterStream.Create(stream) else

    pb := TSuperUnicodeWriterStream.Create(stream);

  if(Write(pb, indent, escape, ) < ) then

  begin

    pb.Reset;

    pb.Free;

    Result := ;

    Exit;

  end;

  Result := stream.Size;

  pb.Free;

end;

function TSuperObject.CalcSize(indent, escape: boolean): integer;

var

  pb: TSuperWriterFake;

begin

  pb := TSuperWriterFake.Create;

  if(Write(pb, indent, escape, ) < ) then

  begin

    pb.Free;

    Result := ;

    Exit;

  end;

  Result := pb.FSize;

  pb.Free;

end;

function TSuperObject.SaveTo(socket: Integer; indent, escape: boolean): integer;

var

  pb: TSuperWriterSock;

begin

  pb := TSuperWriterSock.Create(socket);

  if(Write(pb, indent, escape, ) < ) then

  begin

    pb.Free;

    Result := ;

    Exit;

  end;

  Result := pb.FSize;

  pb.Free;

end;

constructor TSuperObject.Create(const s: SOString);

begin

  Create(stString);

  FOString := s;

end;

procedure TSuperObject.Clear(all: boolean);

begin

  if FProcessing then exit;

  FProcessing := true;

  try

    case FDataType of

      stBoolean: FO.c_boolean := false;

      stDouble: FO.c_double := 0.0;

      stCurrency: FO.c_currency := 0.0;

      stInt: FO.c_int := ;

      stObject: FO.c_object.Clear(all);

      stArray: FO.c_array.Clear(all);

      stString: FOString := '';

{$IFDEF SUPER_METHOD}

      stMethod: FO.c_method := nil;

{$ENDIF}

    end;

  finally

    FProcessing := false;

  end;

end;

procedure TSuperObject.Pack(all: boolean = false);

begin

  if FProcessing then exit;

  FProcessing := true;

  try

    case FDataType of

      stObject: FO.c_object.Pack(all);

      stArray: FO.c_array.Pack(all);

    end;

  finally

    FProcessing := false;

  end;

end;

function TSuperObject.GetN(const path: SOString): ISuperObject;

begin

  Result := ParseString(PSOChar(path), False, true, self);

  if Result = nil then

    Result := TSuperObject.Create(stNull);

end;

procedure TSuperObject.PutN(const path: SOString; const Value: ISuperObject);

begin

  if Value = nil then

    ParseString(PSOChar(path), False, True, self, [foCreatePath, foPutValue], TSuperObject.Create(stNull)) else

    ParseString(PSOChar(path), False, True, self, [foCreatePath, foPutValue], Value);

end;

function TSuperObject.Delete(const path: SOString): ISuperObject;

begin

  Result := ParseString(PSOChar(path), False, true, self, [foDelete]);

end;

function TSuperObject.Clone: ISuperObject;

var

  ite: TSuperObjectIter;

  arr: TSuperArray;

  j: integer;

begin

  case FDataType of

    stBoolean: Result := TSuperObject.Create(FO.c_boolean);

    stDouble: Result := TSuperObject.Create(FO.c_double);

    stCurrency: Result := TSuperObject.CreateCurrency(FO.c_currency);

    stInt: Result := TSuperObject.Create(FO.c_int);

    stString: Result := TSuperObject.Create(FOString);

{$IFDEF SUPER_METHOD}

    stMethod: Result := TSuperObject.Create(FO.c_method);

{$ENDIF}

    stObject:

      begin

        Result := TSuperObject.Create(stObject);

        if ObjectFindFirst(self, ite) then

        with Result.AsObject do

        repeat

          PutO(ite.key, ite.val.Clone);

        until not ObjectFindNext(ite);

        ObjectFindClose(ite);

      end;

    stArray:

      begin

        Result := TSuperObject.Create(stArray);

        arr := AsArray;

        with Result.AsArray do

        for j :=  to arr.Length -  do

          Add(arr.GetO(j).Clone);

      end;

  else

    Result := nil;

  end;

end;

procedure TSuperObject.Merge(const obj: ISuperObject; reference: boolean);

var

  prop1, prop2: ISuperObject;

  ite: TSuperObjectIter;

  arr: TSuperArray;

  j: integer;

begin

  if ObjectIsType(obj, FDataType) then

  case FDataType of

    stBoolean: FO.c_boolean := obj.AsBoolean;

    stDouble: FO.c_double := obj.AsDouble;

    stCurrency: FO.c_currency := obj.AsCurrency;

    stInt: FO.c_int := obj.AsInteger;

    stString: FOString := obj.AsString;

{$IFDEF SUPER_METHOD}

    stMethod: FO.c_method := obj.AsMethod;

{$ENDIF}

    stObject:

      begin

        if ObjectFindFirst(obj, ite) then

        with FO.c_object do

        repeat

          prop1 := FO.c_object.GetO(ite.key);

          if (prop1 <> nil) and (ite.val <> nil) and (prop1.DataType = ite.val.DataType) then

            prop1.Merge(ite.val) else

            if reference then

              PutO(ite.key, ite.val) else

              PutO(ite.key, ite.val.Clone);

        until not ObjectFindNext(ite);

        ObjectFindClose(ite);

      end;

    stArray:

      begin

        arr := obj.AsArray;

        with FO.c_array do

        for j :=  to arr.Length -  do

        begin

          prop1 := GetO(j);

          prop2 := arr.GetO(j);

          if (prop1 <> nil) and (prop2 <> nil) and (prop1.DataType = prop2.DataType) then

            prop1.Merge(prop2) else

            if reference then

              PutO(j, prop2) else

              PutO(j, prop2.Clone);

        end;

      end;

  end;

end;

procedure TSuperObject.Merge(const str: SOString);

begin

  Merge(TSuperObject.ParseString(PSOChar(str), False), true);

end;

class function TSuperObject.NewInstance: TObject;

begin

  Result := inherited NewInstance;

  TSuperObject(Result).FRefCount := ;

end;

function TSuperObject.ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject;

begin

  Result := ParseString(PSOChar(path), False, True, Self, [foCreatePath], nil, dataType);

end;

function TSuperObject.Format(const str: SOString; BeginSep: SOChar; EndSep: SOChar): SOString;

var

  p1, p2: PSOChar;

begin

  Result := '';

  p2 := PSOChar(str);

  p1 := p2;

  while true do

    if p2^ = BeginSep then

      begin

        if p2 > p1 then

          Result := Result + Copy(p1, , p2-p1);

        inc(p2);

        p1 := p2;

        while true do

          if p2^ = EndSep then Break else

          if p2^ = #     then Exit else

            inc(p2);

        Result := Result + GetS(copy(p1, , p2-p1));

        inc(p2);

        p1 := p2;

      end

    else if p2^ = # then

      begin

        if p2 > p1 then

          Result := Result + Copy(p1, , p2-p1);

        Break;

      end else

        inc(p2);

end;

function TSuperObject.GetO(const path: SOString): ISuperObject;

begin

  Result := ParseString(PSOChar(path), False, True, Self);

end;

function TSuperObject.GetA(const path: SOString): TSuperArray;

var

  obj: ISuperObject;

begin

  obj := ParseString(PSOChar(path), False, True, Self);

  if obj <> nil then

    Result := obj.AsArray else

    Result := nil;

end;

function TSuperObject.GetB(const path: SOString): Boolean;

var

  obj: ISuperObject;

begin

  obj := GetO(path);

  if obj <> nil then

    Result := obj.AsBoolean else

    Result := false;

end;

function TSuperObject.GetD(const path: SOString): Double;

var

  obj: ISuperObject;

begin

  obj := GetO(path);

  if obj <> nil then

    Result := obj.AsDouble else

    Result := 0.0;

end;

function TSuperObject.GetC(const path: SOString): Currency;

var

  obj: ISuperObject;

begin

  obj := GetO(path);

  if obj <> nil then

    Result := obj.AsCurrency else

    Result := 0.0;

end;

function TSuperObject.GetI(const path: SOString): SuperInt;

var

  obj: ISuperObject;

begin

  obj := GetO(path);

  if obj <> nil then

    Result := obj.AsInteger else

    Result := ;

end;

function TSuperObject.GetDataPtr: Pointer;

begin

  Result := FDataPtr;

end;

function TSuperObject.GetDataType: TSuperType;

begin

  Result := FDataType

end;

function TSuperObject.GetS(const path: SOString): SOString;

var

  obj: ISuperObject;

begin

  obj := GetO(path);

  if obj <> nil then

    Result := obj.AsString else

    Result := '';

end;

function TSuperObject.SaveTo(const FileName: string; indent, escape: boolean): integer;

var

  stream: TFileStream;

begin

  stream := TFileStream.Create(FileName, fmCreate);

  try

    Result := SaveTo(stream, indent, escape);

  finally

    stream.Free;

  end;

end;

function TSuperObject.Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean;

begin

  Result := Validate(TSuperObject.ParseString(PSOChar(rules), False), TSuperObject.ParseString(PSOChar(defs), False), callback, sender);

end;

function TSuperObject.Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean;

type

  TDataType = (dtUnknown, dtStr, dtInt, dtFloat, dtNumber, dtText, dtBool,

               dtMap, dtSeq, dtScalar, dtAny);

var

  datatypes: ISuperObject;

  names: ISuperObject;

  function FindInheritedProperty(const prop: PSOChar; p: ISuperObject): ISuperObject;

  var

    o: ISuperObject;

    e: TSuperAvlEntry;

  begin

    o := p[prop];

    if o <> nil then

      result := o else

      begin

        o := p['inherit'];

        if (o <> nil) and ObjectIsType(o, stString) then

          begin

            e := names.AsObject.Search(o.AsString);

            if (e <> nil) then

              Result := FindInheritedProperty(prop, e.Value) else

              Result := nil;

          end else

            Result := nil;

      end;

  end;

  function FindDataType(o: ISuperObject): TDataType;

  var

    e: TSuperAvlEntry;

    obj: ISuperObject;

  begin

    obj := FindInheritedProperty('type', o);

    if obj <> nil then

    begin

      e := datatypes.AsObject.Search(obj.AsString);

      if  e <> nil then

        Result := TDataType(e.Value.AsInteger) else

        Result := dtUnknown;

    end else

      Result := dtUnknown;

  end;

  procedure GetNames(o: ISuperObject);

  var

    obj: ISuperObject;

    f: TSuperObjectIter;

  begin

    obj := o['name'];

    if ObjectIsType(obj, stString) then

      names[obj.AsString] := o;

    case FindDataType(o) of

      dtMap:

        begin

          obj := o['mapping'];

          if ObjectIsType(obj, stObject) then

          begin

            if ObjectFindFirst(obj, f) then

            repeat

              if ObjectIsType(f.val, stObject) then

                GetNames(f.val);

            until not ObjectFindNext(f);

            ObjectFindClose(f);

          end;

        end;

      dtSeq:

        begin

          obj := o['sequence'];

          if ObjectIsType(obj, stObject) then

            GetNames(obj);

        end;

    end;

  end;

  function FindInheritedField(const prop: SOString; p: ISuperObject): ISuperObject;

  var

    o: ISuperObject;

    e: TSuperAvlEntry;

  begin

    o := p['mapping'];

    if ObjectIsType(o, stObject) then

    begin

      o := o.AsObject.GetO(prop);

      if o <> nil then

      begin

        Result := o;

        Exit;

      end;

    end;

    o := p['inherit'];

    if ObjectIsType(o, stString) then

    begin

      e := names.AsObject.Search(o.AsString);

      if (e <> nil) then

        Result := FindInheritedField(prop, e.Value) else

        Result := nil;

    end else

      Result := nil;

  end;

  function InheritedFieldExist(const obj: ISuperObject; p: ISuperObject; const name: SOString = ''): boolean;

  var

   o: ISuperObject;

   e: TSuperAvlEntry;

   j: TSuperAvlIterator;

  begin

    Result := true;

    o := p['mapping'];

    if ObjectIsType(o, stObject) then

    begin

      j := TSuperAvlIterator.Create(o.AsObject);

      try

        j.First;

        e := j.GetIter;

        while e <> nil do

        begin

          if obj.AsObject.Search(e.Name) = nil then

          begin

            Result := False;

            if assigned(callback) then

              callback(sender, veFieldNotFound, name + '.' + e.Name);

          end;

          j.Next;

          e := j.GetIter;

        end;

      finally

        j.Free;

      end;

    end;

    o := p['inherit'];

    if ObjectIsType(o, stString) then

    begin

      e := names.AsObject.Search(o.AsString);

      if (e <> nil) then

        Result := InheritedFieldExist(obj, e.Value, name) and Result;

    end;

  end;

  function getInheritedBool(f: PSOChar; p: ISuperObject; default: boolean = false): boolean;

  var

    o: ISuperObject;

  begin

    o := FindInheritedProperty(f, p);

    case ObjectGetType(o) of

      stBoolean: Result := o.AsBoolean;

      stNull: Result := Default;

    else

      Result := default;

      if assigned(callback) then

        callback(sender, veRuleMalformated, f);

    end;

  end;

  procedure GetInheritedFieldList(list: ISuperObject; p: ISuperObject);

  var

   o: ISuperObject;

   e: TSuperAvlEntry;

   i: TSuperAvlIterator;

  begin

    Result := true;

    o := p['mapping'];

    if ObjectIsType(o, stObject) then

    begin

      i := TSuperAvlIterator.Create(o.AsObject);

      try

        i.First;

        e := i.GetIter;

        while e <> nil do

        begin

          if list.AsObject.Search(e.Name) = nil then

            list[e.Name] := e.Value;

          i.Next;

          e := i.GetIter;

        end;

      finally

        i.Free;

      end;

    end;

    o := p['inherit'];

    if ObjectIsType(o, stString) then

    begin

      e := names.AsObject.Search(o.AsString);

      if (e <> nil) then

        GetInheritedFieldList(list, e.Value);

    end;

  end;

  function CheckEnum(o: ISuperObject; p: ISuperObject; name: SOString = ''): boolean;

  var

    enum: ISuperObject;

    i: integer;

  begin

    Result := false;

    enum := FindInheritedProperty('enum', p);

    case ObjectGetType(enum) of

      stArray:

        for i :=  to enum.AsArray.Length -  do

          if (o.AsString = enum.AsArray[i].AsString) then

          begin

            Result := true;

            exit;

          end;

      stNull: Result := true;

    else

      Result := false;

      if assigned(callback) then

        callback(sender, veRuleMalformated, '');

      Exit;

    end;

    if (not Result) and assigned(callback) then

      callback(sender, veValueNotInEnum, name);

  end;

  function CheckLength(len: integer; p: ISuperObject; const objpath: SOString): boolean;

  var

    length, o: ISuperObject;

  begin

    result := true;

    length := FindInheritedProperty('length', p);

    case ObjectGetType(length) of

      stObject:

        begin

          o := length.AsObject.GetO('min');

          if (o <> nil) and (o.AsInteger > len) then

          begin

            Result := false;

            if assigned(callback) then

              callback(sender, veInvalidLength, objpath);

          end;

          o := length.AsObject.GetO('max');

          if (o <> nil) and (o.AsInteger < len) then

          begin

            Result := false;

            if assigned(callback) then

              callback(sender, veInvalidLength, objpath);

          end;

          o := length.AsObject.GetO('minex');

          if (o <> nil) and (o.AsInteger >= len) then

          begin

            Result := false;

            if assigned(callback) then

              callback(sender, veInvalidLength, objpath);

          end;

          o := length.AsObject.GetO('maxex');

          if (o <> nil) and (o.AsInteger <= len) then

          begin

            Result := false;

            if assigned(callback) then

              callback(sender, veInvalidLength, objpath);

          end;

        end;

      stNull: ;

    else

      Result := false;

      if assigned(callback) then

        callback(sender, veRuleMalformated, '');

    end;

  end;

  function CheckRange(obj: ISuperObject; p: ISuperObject; const objpath: SOString): boolean;

  var

    length, o: ISuperObject;

  begin

    result := true;

    length := FindInheritedProperty('range', p);

    case ObjectGetType(length) of

      stObject:

        begin

          o := length.AsObject.GetO('min');

          if (o <> nil) and (o.Compare(obj) = cpGreat) then

          begin

            Result := false;

            if assigned(callback) then

              callback(sender, veInvalidRange, objpath);

          end;

          o := length.AsObject.GetO('max');

          if (o <> nil) and (o.Compare(obj) = cpLess) then

          begin

            Result := false;

            if assigned(callback) then

              callback(sender, veInvalidRange, objpath);

          end;

          o := length.AsObject.GetO('minex');

          if (o <> nil) and (o.Compare(obj) in [cpGreat, cpEqu]) then

          begin

            Result := false;

            if assigned(callback) then

              callback(sender, veInvalidRange, objpath);

          end;

          o := length.AsObject.GetO('maxex');

          if (o <> nil) and (o.Compare(obj) in [cpLess, cpEqu]) then

          begin

            Result := false;

            if assigned(callback) then

              callback(sender, veInvalidRange, objpath);

          end;

        end;

      stNull: ;

    else

      Result := false;

      if assigned(callback) then

        callback(sender, veRuleMalformated, '');

    end;

  end;

  function process(o: ISuperObject; p: ISuperObject; objpath: SOString = ''): boolean;

  var

    ite: TSuperAvlIterator;

    ent: TSuperAvlEntry;

    p2, o2, sequence: ISuperObject;

    s: SOString;

    i: integer;

    uniquelist, fieldlist: ISuperObject;

  begin

    Result := true;

    if (o = nil) then

    begin

      if getInheritedBool('required', p) then

      begin

        if assigned(callback) then

          callback(sender, veFieldIsRequired, objpath);

        result := false;

      end;

    end else

      case FindDataType(p) of

        dtStr:

          case ObjectGetType(o) of

            stString:

              begin

                Result := Result and CheckLength(Length(o.AsString), p, objpath);

                Result := Result and CheckRange(o, p, objpath);

              end;

          else

            if assigned(callback) then

              callback(sender, veInvalidDataType, objpath);

            result := false;

          end;

        dtBool:

          case ObjectGetType(o) of

            stBoolean:

              begin

                Result := Result and CheckRange(o, p, objpath);

              end;

          else

            if assigned(callback) then

              callback(sender, veInvalidDataType, objpath);

            result := false;

          end;

        dtInt:

          case ObjectGetType(o) of

            stInt:

              begin

                Result := Result and CheckRange(o, p, objpath);

              end;

          else

            if assigned(callback) then

              callback(sender, veInvalidDataType, objpath);

            result := false;

          end;

        dtFloat:

          case ObjectGetType(o) of

            stDouble, stCurrency:

              begin

                Result := Result and CheckRange(o, p, objpath);

              end;

          else

            if assigned(callback) then

              callback(sender, veInvalidDataType, objpath);

            result := false;

          end;

        dtMap:

          case ObjectGetType(o) of

            stObject:

              begin

                // all objects have and match a rule ?

                ite := TSuperAvlIterator.Create(o.AsObject);

                try

                  ite.First;

                  ent := ite.GetIter;

                  while ent <> nil do

                  begin

                    p2 :=  FindInheritedField(ent.Name, p);

                    if ObjectIsType(p2, stObject) then

                      result := process(ent.Value, p2, objpath + '.' + ent.Name) and result else

                    begin

                      if assigned(callback) then

                        callback(sender, veUnexpectedField, objpath + '.' + ent.Name);

                      result := false; // field have no rule

                    end;

                    ite.Next;

                    ent := ite.GetIter;

                  end;

                finally

                  ite.Free;

                end;

                // all expected field exists ?

                Result :=  InheritedFieldExist(o, p, objpath) and Result;

              end;

            stNull: {nop};

          else

            result := false;

            if assigned(callback) then

              callback(sender, veRuleMalformated, objpath);

          end;

        dtSeq:

          case ObjectGetType(o) of

            stArray:

              begin

                sequence := FindInheritedProperty('sequence', p);

                if sequence <> nil then

                case ObjectGetType(sequence) of

                  stObject:

                    begin

                      for i :=  to o.AsArray.Length -  do

                        result := process(o.AsArray.GetO(i), sequence, objpath + '[' + IntToStr(i) + ']') and result;

                      if getInheritedBool('unique', sequence) then

                      begin

                        // type is unique ?

                        uniquelist := TSuperObject.Create(stObject);

                        try

                          for i :=  to o.AsArray.Length -  do

                          begin

                            s := o.AsArray.GetO(i).AsString;

                            if (s <> '') then

                            begin

                              if uniquelist.AsObject.Search(s) = nil then

                                uniquelist[s] := nil else

                                begin

                                  Result := False;

                                  if Assigned(callback) then

                                    callback(sender, veDuplicateEntry, objpath + '[' + IntToStr(i) + ']');

                                end;

                            end;

                          end;

                        finally

                          uniquelist := nil;

                        end;

                      end;

                      // field is unique ?

                      if (FindDataType(sequence) = dtMap) then

                      begin

                        fieldlist := TSuperObject.Create(stObject);

                        try

                          GetInheritedFieldList(fieldlist, sequence);

                          ite := TSuperAvlIterator.Create(fieldlist.AsObject);

                          try

                            ite.First;

                            ent := ite.GetIter;

                            while ent <> nil do

                            begin

                              if getInheritedBool('unique', ent.Value) then

                              begin

                                uniquelist := TSuperObject.Create(stObject);

                                try

                                  for i :=  to o.AsArray.Length -  do

                                  begin

                                    o2 := o.AsArray.GetO(i);

                                    if o2 <> nil then

                                    begin

                                      s := o2.AsObject.GetO(ent.Name).AsString;

                                      if (s <> '') then

                                      if uniquelist.AsObject.Search(s) = nil then

                                        uniquelist[s] := nil else

                                        begin

                                          Result := False;

                                          if Assigned(callback) then

                                            callback(sender, veDuplicateEntry, objpath + '[' + IntToStr(i) + '].' + ent.name);

                                        end;

                                    end;

                                  end;

                                finally

                                  uniquelist := nil;

                                end;

                              end;

                              ite.Next;

                              ent := ite.GetIter;

                            end;

                          finally

                            ite.Free;

                          end;

                        finally

                          fieldlist := nil;

                        end;

                      end;

                    end;

                  stNull: {nop};

                else

                  result := false;

                  if assigned(callback) then

                    callback(sender, veRuleMalformated, objpath);

                end;

                Result := Result and CheckLength(o.AsArray.Length, p, objpath);

              end;

          else

            result := false;

            if assigned(callback) then

              callback(sender, veRuleMalformated, objpath);

          end;

        dtNumber:

          case ObjectGetType(o) of

            stInt,

            stDouble, stCurrency:

              begin

                Result := Result and CheckRange(o, p, objpath);

              end;

          else

            if assigned(callback) then

              callback(sender, veInvalidDataType, objpath);

            result := false;

          end;

        dtText:

          case ObjectGetType(o) of

            stInt,

            stDouble,

            stCurrency,

            stString:

              begin

                result := result and CheckLength(Length(o.AsString), p, objpath);

                Result := Result and CheckRange(o, p, objpath);

              end;

          else

            if assigned(callback) then

              callback(sender, veInvalidDataType, objpath);

            result := false;

          end;

        dtScalar:

          case ObjectGetType(o) of

            stBoolean,

            stDouble,

            stCurrency,

            stInt,

            stString:

              begin

                result := result and CheckLength(Length(o.AsString), p, objpath);

                Result := Result and CheckRange(o, p, objpath);

              end;

          else

            if assigned(callback) then

              callback(sender, veInvalidDataType, objpath);

            result := false;

          end;

        dtAny:;

      else

        if assigned(callback) then

          callback(sender, veRuleMalformated, objpath);

        result := false;

      end;

      Result := Result and CheckEnum(o, p, objpath)

  end;

var

  j: integer;

begin

  Result := False;

  datatypes := TSuperObject.Create(stObject);

  names := TSuperObject.Create;

  try

    datatypes.I['str'] := ord(dtStr);

    datatypes.I['int'] := ord(dtInt);

    datatypes.I['float'] := ord(dtFloat);

    datatypes.I['number'] := ord(dtNumber);

    datatypes.I['text'] := ord(dtText);

    datatypes.I['bool'] := ord(dtBool);

    datatypes.I['map'] := ord(dtMap);

    datatypes.I['seq'] := ord(dtSeq);

    datatypes.I['scalar'] := ord(dtScalar);

    datatypes.I['any'] := ord(dtAny);

    if ObjectIsType(defs, stArray) then

      for j :=  to defs.AsArray.Length -  do

        if ObjectIsType(defs.AsArray[j], stObject) then

          GetNames(defs.AsArray[j]) else

          begin

            if assigned(callback) then

              callback(sender, veRuleMalformated, '');

            Exit;

          end;

    if ObjectIsType(rules, stObject) then

      GetNames(rules) else

      begin

        if assigned(callback) then

          callback(sender, veRuleMalformated, '');

        Exit;

      end;

    Result := process(self, rules);

  finally

    datatypes := nil;

    names := nil;

  end;

end;

function TSuperObject._AddRef: Integer; stdcall;

begin

  Result := InterlockedIncrement(FRefCount);

end;

function TSuperObject._Release: Integer; stdcall;

begin

  Result := InterlockedDecrement(FRefCount);

  if Result =  then

    Destroy;

end;

function TSuperObject.Compare(const str: SOString): TSuperCompareResult;

begin

  Result := Compare(TSuperObject.ParseString(PSOChar(str), False));

end;

function TSuperObject.Compare(const obj: ISuperObject): TSuperCompareResult;

  function GetIntCompResult(const i: int64): TSuperCompareResult;

  begin

    if i <  then result := cpLess else

    if i =  then result := cpEqu else

      Result := cpGreat;

  end;

  function GetDblCompResult(const d: double): TSuperCompareResult;

  begin

    if d <  then result := cpLess else

    if d =  then result := cpEqu else

      Result := cpGreat;

  end;

begin

  case DataType of

    stBoolean:

      case ObjectGetType(obj) of

        stBoolean: Result := GetIntCompResult(ord(FO.c_boolean) - ord(obj.AsBoolean));

        stDouble:  Result := GetDblCompResult(ord(FO.c_boolean) - obj.AsDouble);

        stCurrency:Result := GetDblCompResult(ord(FO.c_boolean) - obj.AsCurrency);

        stInt:     Result := GetIntCompResult(ord(FO.c_boolean) - obj.AsInteger);

        stString:  Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));

      else

        Result := cpError;

      end;

    stDouble:

      case ObjectGetType(obj) of

        stBoolean: Result := GetDblCompResult(FO.c_double - ord(obj.AsBoolean));

        stDouble:  Result := GetDblCompResult(FO.c_double - obj.AsDouble);

        stCurrency:Result := GetDblCompResult(FO.c_double - obj.AsCurrency);

        stInt:     Result := GetDblCompResult(FO.c_double - obj.AsInteger);

        stString:  Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));

      else

        Result := cpError;

      end;

    stCurrency:

      case ObjectGetType(obj) of

        stBoolean: Result := GetDblCompResult(FO.c_currency - ord(obj.AsBoolean));

        stDouble:  Result := GetDblCompResult(FO.c_currency - obj.AsDouble);

        stCurrency:Result := GetDblCompResult(FO.c_currency - obj.AsCurrency);

        stInt:     Result := GetDblCompResult(FO.c_currency - obj.AsInteger);

        stString:  Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));

      else

        Result := cpError;

      end;

    stInt:

      case ObjectGetType(obj) of

        stBoolean: Result := GetIntCompResult(FO.c_int - ord(obj.AsBoolean));

        stDouble:  Result := GetDblCompResult(FO.c_int - obj.AsDouble);

        stCurrency:Result := GetDblCompResult(FO.c_int - obj.AsCurrency);

        stInt:     Result := GetIntCompResult(FO.c_int - obj.AsInteger);

        stString:  Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));

      else

        Result := cpError;

      end;

    stString:

      case ObjectGetType(obj) of

        stBoolean,

        stDouble,

        stCurrency,

        stInt,

        stString:  Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));

      else

        Result := cpError;

      end;

  else

    Result := cpError;

  end;

end;

{$IFDEF SUPER_METHOD}

function TSuperObject.AsMethod: TSuperMethod;

begin

  if FDataType = stMethod then

    Result := FO.c_method else

    Result := nil;

end;

{$ENDIF}

{$IFDEF SUPER_METHOD}

constructor TSuperObject.Create(m: TSuperMethod);

begin

  Create(stMethod);

  FO.c_method := m;

end;

{$ENDIF}

{$IFDEF SUPER_METHOD}

function TSuperObject.GetM(const path: SOString): TSuperMethod;

var

  v: ISuperObject;

begin

  v := ParseString(PSOChar(path), False, True, Self);

  if (v <> nil) and (ObjectGetType(v) = stMethod) then

    Result := v.AsMethod else

    Result := nil;

end;

{$ENDIF}

{$IFDEF SUPER_METHOD}

procedure TSuperObject.PutM(const path: SOString; Value: TSuperMethod);

begin

  ParseString(PSOChar(path), False, True, Self, [foCreatePath, foPutValue], TSuperObject.Create(Value));

end;

{$ENDIF}

{$IFDEF SUPER_METHOD}

function TSuperObject.call(const path: SOString; const param: ISuperObject): ISuperObject;

begin

  Result := ParseString(PSOChar(path), False, True, Self, [foCallMethod], param);

end;

{$ENDIF}

{$IFDEF SUPER_METHOD}

function TSuperObject.call(const path, param: SOString): ISuperObject;

begin

  Result := ParseString(PSOChar(path), False, True, Self, [foCallMethod], TSuperObject.ParseString(PSOChar(param), False));

end;

{$ENDIF}

function TSuperObject.GetProcessing: boolean;

begin

  Result := FProcessing;

end;

procedure TSuperObject.SetDataPtr(const Value: Pointer);

begin

  FDataPtr := Value;

end;

procedure TSuperObject.SetProcessing(value: boolean);

begin

  FProcessing := value;

end;

{ TSuperArray }

function TSuperArray.Add(const Data: ISuperObject): Integer;

begin

  Result := FLength;

  PutO(Result, data);

end;

function TSuperArray.Delete(index: Integer): ISuperObject;

begin

  if (Index >= ) and (Index < FLength) then

  begin

    Result := FArray^[index];

    FArray^[index] := nil;

    Dec(FLength);

    if Index < FLength then

    begin

      Move(FArray^[index + ], FArray^[index],

        (FLength - index) * SizeOf(Pointer));

      Pointer(FArray^[FLength]) := nil;

    end;

  end;

end;

procedure TSuperArray.Insert(index: Integer; const value: ISuperObject);

begin

  if (Index >= ) then

  if (index < FLength) then

  begin

    if FLength = FSize then

      Expand(index);

    if Index < FLength then

      Move(FArray^[index], FArray^[index + ],

        (FLength - index) * SizeOf(Pointer));

    Pointer(FArray^[index]) := nil;

    FArray^[index] := value;

    Inc(FLength);

  end else

    PutO(index, value);

end;

procedure TSuperArray.Clear(all: boolean);

var

  j: Integer;

begin

  for j :=  to FLength -  do

    if FArray^[j] <> nil then

    begin

      if all then

        FArray^[j].Clear(all);

      FArray^[j] := nil;

    end;

  FLength := ;

end;

procedure TSuperArray.Pack(all: boolean);

var

  PackedCount, StartIndex, EndIndex, j: Integer;

begin

  if FLength >  then

  begin

    PackedCount := ;

    StartIndex := ;

    repeat

      while (StartIndex < FLength) and (FArray^[StartIndex] = nil) do

        Inc(StartIndex);

      if StartIndex < FLength then

        begin

          EndIndex := StartIndex;

          while (EndIndex < FLength) and  (FArray^[EndIndex] <> nil) do

            Inc(EndIndex);

          Dec(EndIndex);

          if StartIndex > PackedCount then

            Move(FArray^[StartIndex], FArray^[PackedCount], (EndIndex - StartIndex + ) * SizeOf(Pointer));

          Inc(PackedCount, EndIndex - StartIndex + );

          StartIndex := EndIndex + ;

        end;

    until StartIndex >= FLength;

    FillChar(FArray^[PackedCount], (FLength - PackedCount) * sizeof(Pointer), );

    FLength := PackedCount;

    if all then

      for j :=  to FLength -  do

        FArray^[j].Pack(all);

  end;

end;

constructor TSuperArray.Create;

begin

  inherited Create;

  FSize := SUPER_ARRAY_LIST_DEFAULT_SIZE;

  FLength := ;

  GetMem(FArray, sizeof(Pointer) * FSize);

  FillChar(FArray^, sizeof(Pointer) * FSize, );

end;

destructor TSuperArray.Destroy;

begin

  Clear;

  FreeMem(FArray);

  inherited;

end;

procedure TSuperArray.Expand(max: Integer);

var

  new_size: Integer;

begin

  if (max < FSize) then

    Exit;

  if max < (FSize shl ) then

    new_size := (FSize shl ) else

    new_size := max + ;

  ReallocMem(FArray, new_size * sizeof(Pointer));

  FillChar(FArray^[FSize], (new_size - FSize) * sizeof(Pointer), );

  FSize := new_size;

end;

function TSuperArray.GetO(const index: Integer): ISuperObject;

begin

  if(index >= FLength) then

    Result := nil else

    Result := FArray^[index];

end;

function TSuperArray.GetB(const index: integer): Boolean;

var

  obj: ISuperObject;

begin

  obj := GetO(index);

  if obj <> nil then

    Result := obj.AsBoolean else

    Result := false;

end;

function TSuperArray.GetD(const index: integer): Double;

var

  obj: ISuperObject;

begin

  obj := GetO(index);

  if obj <> nil then

    Result := obj.AsDouble else

    Result := 0.0;

end;

function TSuperArray.GetI(const index: integer): SuperInt;

var

  obj: ISuperObject;

begin

  obj := GetO(index);

  if obj <> nil then

    Result := obj.AsInteger else

    Result := ;

end;

function TSuperArray.GetS(const index: integer): SOString;

var

  obj: ISuperObject;

begin

  obj := GetO(index);

  if obj <> nil then

    Result := obj.AsString else

    Result := '';

end;

procedure TSuperArray.PutO(const index: Integer; const Value: ISuperObject);

begin

  Expand(index);

  FArray^[index] := value;

  if(FLength <= index) then FLength := index + ;

end;

function TSuperArray.GetN(const index: integer): ISuperObject;

begin

  Result := GetO(index);

  if Result = nil then

    Result := TSuperObject.Create(stNull);

end;

procedure TSuperArray.PutN(const index: integer; const Value: ISuperObject);

begin

  if Value <> nil then

    PutO(index, Value) else

    PutO(index, TSuperObject.Create(stNull));

end;

procedure TSuperArray.PutB(const index: integer; Value: Boolean);

begin

  PutO(index, TSuperObject.Create(Value));

end;

procedure TSuperArray.PutD(const index: integer; Value: Double);

begin

  PutO(index, TSuperObject.Create(Value));

end;

function TSuperArray.GetC(const index: integer): Currency;

var

  obj: ISuperObject;

begin

  obj := GetO(index);

  if obj <> nil then

    Result := obj.AsCurrency else

    Result := 0.0;

end;

procedure TSuperArray.PutC(const index: integer; Value: Currency);

begin

  PutO(index, TSuperObject.CreateCurrency(Value));

end;

procedure TSuperArray.PutI(const index: integer; Value: SuperInt);

begin

  PutO(index, TSuperObject.Create(Value));

end;

procedure TSuperArray.PutS(const index: integer; const Value: SOString);

begin

  PutO(index, TSuperObject.Create(Value));

end;

{$IFDEF SUPER_METHOD}

function TSuperArray.GetM(const index: integer): TSuperMethod;

var

  v: ISuperObject;

begin

  v := GetO(index);

  if (ObjectGetType(v) = stMethod) then

    Result := v.AsMethod else

    Result := nil;

end;

{$ENDIF}

{$IFDEF SUPER_METHOD}

procedure TSuperArray.PutM(const index: integer; Value: TSuperMethod);

begin

  PutO(index, TSuperObject.Create(Value));

end;

{$ENDIF}

{ TSuperWriterString }

function TSuperWriterString.Append(buf: PSOChar; Size: Integer): Integer;

  function max(a, b: Integer): integer; begin if a > b then  Result := a else Result := b end;

begin

  Result := size;

  if Size >  then

  begin

    if (FSize - FBPos <= size) then

    begin

      FSize := max(FSize * , FBPos + size + );

      ReallocMem(FBuf, FSize * SizeOf(SOChar));

    end;

    // fast move

    case size of

    : FBuf[FBPos] := buf^;

    : PInteger(@FBuf[FBPos])^ := PInteger(buf)^;

    : PInt64(@FBuf[FBPos])^ := PInt64(buf)^;

    else

      move(buf^, FBuf[FBPos], size * SizeOf(SOChar));

    end;

    inc(FBPos, size);

    FBuf[FBPos] := #;

  end;

end;

function TSuperWriterString.Append(buf: PSOChar): Integer;

begin

  Result := Append(buf, strlen(buf));

end;

constructor TSuperWriterString.Create;

begin

  inherited;

  FSize := ;

  FBPos := ;

  GetMem(FBuf, FSize * SizeOf(SOChar));

end;

destructor TSuperWriterString.Destroy;

begin

  inherited;

  if FBuf <> nil then

    FreeMem(FBuf)

end;

function TSuperWriterString.GetString: SOString;

begin

  SetString(Result, FBuf, FBPos);

end;

procedure TSuperWriterString.Reset;

begin

  FBuf[] := #;

  FBPos := ;

end;

procedure TSuperWriterString.TrimRight;

begin

  while (FBPos > ) and (FBuf[FBPos-] < #) and (AnsiChar(FBuf[FBPos-]) in [#, #, #]) do

  begin

    dec(FBPos);

    FBuf[FBPos] := #;

  end;

end;

{ TSuperWriterStream }

function TSuperWriterStream.Append(buf: PSOChar): Integer;

begin

  Result := Append(buf, StrLen(buf));

end;

constructor TSuperWriterStream.Create(AStream: TStream);

begin

  inherited Create;

  FStream := AStream;

end;

procedure TSuperWriterStream.Reset;

begin

  FStream.Size := ;

end;

{ TSuperWriterStream }

function TSuperAnsiWriterStream.Append(buf: PSOChar; Size: Integer): Integer;

var

  Buffer: array[..] of AnsiChar;

  pBuffer: PAnsiChar;

  i: Integer;

begin

  if Size =  then

    Result := FStream.Write(buf^, Size) else

  begin

    if Size > SizeOf(Buffer) then

      GetMem(pBuffer, Size) else

      pBuffer := @Buffer;

    try

      for i :=   to Size -  do

        pBuffer[i] := AnsiChar(buf[i]);

      Result := FStream.Write(pBuffer^, Size);

    finally

      if pBuffer <> @Buffer then

        FreeMem(pBuffer);

    end;

  end;

end;

{ TSuperUnicodeWriterStream }

function TSuperUnicodeWriterStream.Append(buf: PSOChar; Size: Integer): Integer;

begin

  Result := FStream.Write(buf^, Size * );

end;

{ TSuperWriterFake }

function TSuperWriterFake.Append(buf: PSOChar; Size: Integer): Integer;

begin

  inc(FSize, Size);

  Result := FSize;

end;

function TSuperWriterFake.Append(buf: PSOChar): Integer;

begin

  inc(FSize, Strlen(buf));

  Result := FSize;

end;

constructor TSuperWriterFake.Create;

begin

  inherited Create;

  FSize := ;

end;

procedure TSuperWriterFake.Reset;

begin

  FSize := ;

end;

{ TSuperWriterSock }

function TSuperWriterSock.Append(buf: PSOChar; Size: Integer): Integer;

var

  Buffer: array[..] of AnsiChar;

  pBuffer: PAnsiChar;

  i: Integer;

begin

  if Size =  then

{$IFDEF FPC}

    Result := fpsend(FSocket, buf, size, ) else

{$ELSE}

    Result := send(FSocket, buf^, size, ) else

{$ENDIF}

  begin

    if Size > SizeOf(Buffer) then

      GetMem(pBuffer, Size) else

      pBuffer := @Buffer;

    try

      for i :=   to Size -  do

        pBuffer[i] := AnsiChar(buf[i]);

{$IFDEF FPC}

      Result := fpsend(FSocket, pBuffer, size, );

{$ELSE}

      Result := send(FSocket, pBuffer^, size, );

{$ENDIF}

    finally

      if pBuffer <> @Buffer then

        FreeMem(pBuffer);

    end;

  end;

  inc(FSize, Result);

end;

function TSuperWriterSock.Append(buf: PSOChar): Integer;

begin

  Result := Append(buf, StrLen(buf));

end;

constructor TSuperWriterSock.Create(ASocket: Integer);

begin

  inherited Create;

  FSocket := ASocket;

  FSize := ;

end;

procedure TSuperWriterSock.Reset;

begin

  FSize := ;

end;

{ TSuperTokenizer }

constructor TSuperTokenizer.Create;

begin

  pb := TSuperWriterString.Create;

  line := ;

  col := ;

  Reset;

end;

destructor TSuperTokenizer.Destroy;

begin

  Reset;

  pb.Free;

  inherited;

end;

procedure TSuperTokenizer.Reset;

var

  i: integer;

begin

  for i := depth downto  do

    ResetLevel(i);

  depth := ;

  err := teSuccess;

end;

procedure TSuperTokenizer.ResetLevel(adepth: integer);

begin

  stack[adepth].state := tsEatws;

  stack[adepth].saved_state := tsStart;

  stack[adepth].current := nil;

  stack[adepth].field_name := '';

  stack[adepth].obj := nil;

  stack[adepth].parent := nil;

  stack[adepth].gparent := nil;

end;

{ TSuperAvlTree }

constructor TSuperAvlTree.Create;

begin

  FRoot := nil;

  FCount := ;

end;

destructor TSuperAvlTree.Destroy;

begin

  Clear;

  inherited;

end;

function TSuperAvlTree.IsEmpty: boolean;

begin

  result := FRoot = nil;

end;

function TSuperAvlTree.balance(bal: TSuperAvlEntry): TSuperAvlEntry;

var

  deep, old: TSuperAvlEntry;

  bf: integer;

begin

  if (bal.FBf > ) then

  begin

    deep := bal.FGt;

    if (deep.FBf < ) then

    begin

      old := bal;

      bal := deep.FLt;

      old.FGt := bal.FLt;

      deep.FLt := bal.FGt;

      bal.FLt := old;

      bal.FGt := deep;

      bf := bal.FBf;

      if (bf <> ) then

      begin

        if (bf > ) then

        begin

          old.FBf := -;

          deep.FBf := ;

        end else

        begin

          deep.FBf := ;

          old.FBf := ;

        end;

        bal.FBf := ;

      end else

      begin

        old.FBf := ;

        deep.FBf := ;

      end;

    end else

    begin

      bal.FGt := deep.FLt;

      deep.FLt := bal;

      if (deep.FBf = ) then

      begin

        deep.FBf := -;

        bal.FBf := ;

      end else

      begin

        deep.FBf := ;

        bal.FBf := ;

      end;

      bal := deep;

    end;

  end else

  begin

    (* "Less than" subtree is deeper. *)

    deep := bal.FLt;

    if (deep.FBf > ) then

    begin

      old := bal;

      bal := deep.FGt;

      old.FLt := bal.FGt;

      deep.FGt := bal.FLt;

      bal.FGt := old;

      bal.FLt := deep;

      bf := bal.FBf;

      if (bf <> ) then

      begin

        if (bf < ) then

        begin

          old.FBf := ;

          deep.FBf := ;

        end else

        begin

          deep.FBf := -;

          old.FBf := ;

        end;

        bal.FBf := ;

      end else

      begin

        old.FBf := ;

        deep.FBf := ;

      end;

    end else

    begin

      bal.FLt := deep.FGt;

      deep.FGt := bal;

      if (deep.FBf = ) then

      begin

        deep.FBf := ;

        bal.FBf := -;

      end else

      begin

        deep.FBf := ;

        bal.FBf := ;

      end;

      bal := deep;

    end;

  end;

  Result := bal;

end;

function TSuperAvlTree.Insert(h: TSuperAvlEntry): TSuperAvlEntry;

var

  unbal, parentunbal, hh, parent: TSuperAvlEntry;

  depth, unbaldepth: longint;

  cmp: integer;

  unbalbf: integer;

  branch: TSuperAvlBitArray;

  p: Pointer;

begin

  inc(FCount);

  h.FLt := nil;

  h.FGt := nil;

  h.FBf := ;

  branch := [];

  if (FRoot = nil) then

    FRoot := h

  else

  begin

    unbal := nil;

    parentunbal := nil;

    depth := ;

    unbaldepth := ;

    hh := FRoot;

    parent := nil;

    repeat

      if (hh.FBf <> ) then

      begin

        unbal := hh;

        parentunbal := parent;

        unbaldepth := depth;

      end;

      if hh.FHash <> h.FHash then

      begin

        if nowSortMode = sosmDefault then

        begin

          //original code

          if hh.FHash < h.FHash then cmp := - else

            if hh.FHash > h.FHash then cmp :=  else

              cmp := ;

        end else

        begin

          // modify by mofen

          cmp := CompareForSortModeString(h.Name, hh.Name);

        end;

      end else

        cmp := CompareNodeNode(h, hh);

      if (cmp = ) then

      begin

        Result := hh;

        //exchange data

        p := hh.Ptr;

        hh.FPtr := h.Ptr;

        h.FPtr := p;

        doDeleteEntry(h, false);

        dec(FCount);

        exit;

      end;

      parent := hh;

      if (cmp > ) then

      begin

        hh := hh.FGt;

        include(branch, depth);

      end else

      begin

        hh := hh.FLt;

        exclude(branch, depth);

      end;

      inc(depth);

    until (hh = nil);

    if (cmp < ) then

      parent.FLt := h else

      parent.FGt := h;

    depth := unbaldepth;

    if (unbal = nil) then

      hh := FRoot

    else

    begin

      if depth in branch then

        cmp :=  else

        cmp := -;

      inc(depth);

      unbalbf := unbal.FBf;

      if (cmp < ) then

        dec(unbalbf) else

        inc(unbalbf);

      if cmp <  then

        hh := unbal.FLt else

        hh := unbal.FGt;

      if ((unbalbf <> -) and (unbalbf <> )) then

      begin

        unbal.FBf := unbalbf;

        unbal := nil;

      end;

    end;

    if (hh <> nil) then

      while (h <> hh) do

      begin

        if depth in branch then

          cmp :=  else

          cmp := -;

        inc(depth);

        if (cmp < ) then

        begin

          hh.FBf := -;

          hh := hh.FLt;

        end else (* cmp > 0 *)

        begin

          hh.FBf := ;

          hh := hh.FGt;

        end;

      end;

    //  original code

    //    if (unbal <> nil) then

    if (unbal <> nil) and (nowSortMode <> sosmAdd) then    //modify by mofen

    begin

      unbal := balance(unbal);

      if (parentunbal = nil) then

        FRoot := unbal

      else

      begin

        depth := unbaldepth - ;

        if depth in branch then

          cmp :=  else

          cmp := -;

        if (cmp < ) then

          parentunbal.FLt := unbal else

          parentunbal.FGt := unbal;

      end;

    end;

  end;

  result := h;

end;

function TSuperAvlTree.Search(const k: SOString; st: TSuperAvlSearchTypes): TSuperAvlEntry;

var

  cmp, target_cmp: integer;

  match_h, h: TSuperAvlEntry;

  ha: Cardinal;

begin

  ha := TSuperAvlEntry.Hash(k);

  match_h := nil;

  h := FRoot;

  if (stLess in st) then

    target_cmp :=  else

    if (stGreater in st) then

      target_cmp := - else

      target_cmp := ;

  while (h <> nil) do

  begin

            // modify by mofen

    if nowSortMode = sosmDefault then

    begin

      //original code

      if h.FHash < ha then cmp := - else

        if h.FHash > ha then cmp :=  else

          cmp := ;

    end else

    begin

      // modify by mofen

      cmp := CompareForSortModeString(k, h.Name);

    end;

//    if h.FHash < ha then cmp := -1 else

//    if h.FHash > ha then cmp := 1 else

//      cmp := 0;

    if cmp =  then

      cmp := CompareKeyNode(PSOChar(k), h);

    if (cmp = ) then

    begin

      if (stEqual in st) then

      begin

        match_h := h;

        break;

      end;

      cmp := -target_cmp;

    end

    else

    if (target_cmp <> ) then

      if ((cmp xor target_cmp) and SUPER_AVL_MASK_HIGH_BIT) =  then

        match_h := h;

    if cmp <  then

      h := h.FLt else

      h := h.FGt;

  end;

  result := match_h;

end;

function TSuperAvlTree.Delete(const k: SOString): ISuperObject;

var

  depth, rm_depth: longint;

  branch: TSuperAvlBitArray;

  h, parent, child, path, rm, parent_rm: TSuperAvlEntry;

  cmp, cmp_shortened_sub_with_path, reduced_depth, bf: integer;

  ha: Cardinal;

begin

  ha := TSuperAvlEntry.Hash(k);

  cmp_shortened_sub_with_path := ;

  branch := [];

  depth := ;

  h := FRoot;

  parent := nil;

  while true do

  begin

    if (h = nil) then

      exit;

//    if h.FHash < ha then cmp := -1 else

//    if h.FHash > ha then cmp := 1 else

//      cmp := 0;

            // modify by mofen

    if nowSortMode = sosmDefault then

    begin

      //original code

      if h.FHash < ha then cmp := - else

        if h.FHash > ha then cmp :=  else

          cmp := ;

    end else

    begin

      // modify by mofen

      cmp := CompareForSortModeString(k, h.Name);

    end;

    if cmp =  then

      cmp := CompareKeyNode(k, h);

    if (cmp = ) then

      break;

    parent := h;

    if (cmp > ) then

    begin

      h := h.FGt;

      include(branch, depth)

    end else

    begin

      h := h.FLt;

      exclude(branch, depth)

    end;

    inc(depth);

    cmp_shortened_sub_with_path := cmp;

  end;

  rm := h;

  parent_rm := parent;

  rm_depth := depth;

  if (h.FBf < ) then

  begin

    child := h.FLt;

    exclude(branch, depth);

    cmp := -;

  end else

  begin

    child := h.FGt;

    include(branch, depth);

    cmp := ;

  end;

  inc(depth);

  if (child <> nil) then

  begin

    cmp := -cmp;

    repeat

      parent := h;

      h := child;

      if (cmp < ) then

      begin

        child := h.FLt;

        exclude(branch, depth);

      end else

      begin

        child := h.FGt;

        include(branch, depth);

      end;

      inc(depth);

    until (child = nil);

    if (parent = rm) then

      cmp_shortened_sub_with_path := -cmp else

      cmp_shortened_sub_with_path := cmp;

    if cmp >  then

      child := h.FLt else

      child := h.FGt;

  end;

  if (parent = nil) then

    FRoot := child else

    if (cmp_shortened_sub_with_path < ) then

      parent.FLt := child else

      parent.FGt := child;

  if parent = rm then

    path := h else

    path := parent;

  if (h <> rm) then

  begin

    h.FLt := rm.FLt;

    h.FGt := rm.FGt;

    h.FBf := rm.FBf;

    if (parent_rm = nil) then

      FRoot := h

    else

    begin

      depth := rm_depth - ;

      if (depth in branch) then

        parent_rm.FGt := h else

        parent_rm.FLt := h;

    end;

  end;

  if (path <> nil) then

  begin

    h := FRoot;

    parent := nil;

    depth := ;

    while (h <> path) do

    begin

      if (depth in branch) then

      begin

        child := h.FGt;

        h.FGt := parent;

      end else

      begin

        child := h.FLt;

        h.FLt := parent;

      end;

      inc(depth);

      parent := h;

      h := child;

    end;

    reduced_depth := ;

    cmp := cmp_shortened_sub_with_path;

    while true do

    begin

      if (reduced_depth <> ) then

      begin

        bf := h.FBf;

        if (cmp < ) then

          inc(bf) else

          dec(bf);

        if ((bf = -) or (bf = )) then

        begin

          h := balance(h);

          bf := h.FBf;

        end else

          h.FBf := bf;

        reduced_depth := integer(bf = );

      end;

      if (parent = nil) then

        break;

      child := h;

      h := parent;

      dec(depth);

      if depth in branch then

        cmp :=  else

        cmp := -;

      if (cmp < ) then

      begin

        parent := h.FLt;

        h.FLt := child;

      end else

      begin

        parent := h.FGt;

        h.FGt := child;

      end;

    end;

    FRoot := h;

  end;

  if rm <> nil then

  begin

    Result := rm.GetValue;

    doDeleteEntry(rm, false);

    dec(FCount);

  end;

end;

procedure TSuperAvlTree.Pack(all: boolean);

var

  node1, node2: TSuperAvlEntry;

  list: TList;

  i: Integer;

begin

  node1 := FRoot;

  list := TList.Create;

  while node1 <> nil do

  begin

    if (node1.FLt = nil) then

    begin

      node2 := node1.FGt;

      if (node1.FPtr = nil) then

        list.Add(node1) else

        if all then

          node1.Value.Pack(all);

    end

    else

    begin

      node2 := node1.FLt;

      node1.FLt := node2.FGt;

      node2.FGt := node1;

    end;

    node1 := node2;

  end;

  for i :=  to list.Count -  do

    Delete(TSuperAvlEntry(list[i]).FName);

  list.Free;

end;

procedure TSuperAvlTree.Clear(all: boolean);

var

  node1, node2: TSuperAvlEntry;

begin

  node1 := FRoot;

  while node1 <> nil do

  begin

    if (node1.FLt = nil) then

    begin

      node2 := node1.FGt;

      doDeleteEntry(node1, all);

    end

    else

    begin

      node2 := node1.FLt;

      node1.FLt := node2.FGt;

      node2.FGt := node1;

    end;

    node1 := node2;

  end;

  FRoot := nil;

  FCount := ;

end;

function TSuperAvlTree.CompareKeyNode(const k: SOString; h: TSuperAvlEntry): integer;

begin

  Result := StrComp(PSOChar(k), PSOChar(h.FName));

end;

function TSuperAvlTree.CompareNodeNode(node1, node2: TSuperAvlEntry): integer;

begin

  Result := StrComp(PSOChar(node1.FName), PSOChar(node2.FName));

end;

{ TSuperAvlIterator }

(* Initialize depth to invalid value, to indicate iterator is

** invalid.   (Depth is zero-base.)  It's not necessary to initialize

** iterators prior to passing them to the "start" function.

*)

constructor TSuperAvlIterator.Create(tree: TSuperAvlTree);

begin

  FDepth := not ;

  FTree := tree;

end;

procedure TSuperAvlIterator.Search(const k: SOString; st: TSuperAvlSearchTypes);

var

  h: TSuperAvlEntry;

  d: longint;

  cmp, target_cmp: integer;

  ha: Cardinal;

begin

  ha := TSuperAvlEntry.Hash(k);

  h := FTree.FRoot;

  d := ;

  FDepth := not ;

  if (h = nil) then

    exit;

  if (stLess in st) then

    target_cmp :=  else

      if (stGreater in st) then

        target_cmp := - else

          target_cmp := ;

  while true do

  begin

    if h.FHash < ha then cmp := - else

    if h.FHash > ha then cmp :=  else

      cmp := ;

    if cmp =  then

      cmp := FTree.CompareKeyNode(k, h);

    if (cmp = ) then

    begin

      if (stEqual in st) then

      begin

        FDepth := d;

        break;

      end;

      cmp := -target_cmp;

    end

    else

    if (target_cmp <> ) then

      if ((cmp xor target_cmp) and SUPER_AVL_MASK_HIGH_BIT) =  then

        FDepth := d;

    if cmp <  then

      h := h.FLt else

      h := h.FGt;

    if (h = nil) then

      break;

    if (cmp > ) then

      include(FBranch, d) else

      exclude(FBranch, d);

    FPath[d] := h;

    inc(d);

  end;

end;

procedure TSuperAvlIterator.First;

var

  h: TSuperAvlEntry;

begin

  h := FTree.FRoot;

  FDepth := not ;

  FBranch := [];

  while (h <> nil) do

  begin

    if (FDepth <> not ) then

      FPath[FDepth] := h;

    inc(FDepth);

    h := h.FLt;

  end;

end;

procedure TSuperAvlIterator.Last;

var

  h: TSuperAvlEntry;

begin

  h := FTree.FRoot;

  FDepth := not ;

  FBranch := [..SUPER_AVL_MAX_DEPTH - ];

  while (h <> nil) do

  begin

    if (FDepth <> not ) then

      FPath[FDepth] := h;

    inc(FDepth);

    h := h.FGt;

  end;

end;

function TSuperAvlIterator.MoveNext: boolean;

begin

  if FDepth = not  then

    First else

    Next;

  Result := GetIter <> nil;

end;

function TSuperAvlIterator.GetIter: TSuperAvlEntry;

begin

  if (FDepth = not ) then

  begin

    result := nil;

    exit;

  end;

  if FDepth =  then

    Result := FTree.FRoot else

    Result := FPath[FDepth - ];

end;

procedure TSuperAvlIterator.Next;

var

  h: TSuperAvlEntry;

begin

  if (FDepth <> not ) then

  begin

    if FDepth =  then

      h := FTree.FRoot.FGt else

      h := FPath[FDepth - ].FGt;

    if (h = nil) then

      repeat

        if (FDepth = ) then

        begin

          FDepth := not ;

          break;

        end;

        dec(FDepth);

      until (not (FDepth in FBranch))

    else

    begin

      include(FBranch, FDepth);

      FPath[FDepth] := h;

      inc(FDepth);

      while true do

      begin

        h := h.FLt;

        if (h = nil) then

          break;

        exclude(FBranch, FDepth);

        FPath[FDepth] := h;

        inc(FDepth);

      end;

    end;

  end;

end;

procedure TSuperAvlIterator.Prior;

var

  h: TSuperAvlEntry;

begin

  if (FDepth <> not ) then

  begin

    if FDepth =  then

      h := FTree.FRoot.FLt else

      h := FPath[FDepth - ].FLt;

    if (h = nil) then

      repeat

        if (FDepth = ) then

        begin

          FDepth := not ;

          break;

        end;

        dec(FDepth);

      until (FDepth in FBranch)

    else

    begin

      exclude(FBranch, FDepth);

      FPath[FDepth] := h;

      inc(FDepth);

      while true do

      begin

        h := h.FGt;

        if (h = nil) then

          break;

        include(FBranch, FDepth);

        FPath[FDepth] := h;

        inc(FDepth);

      end;

    end;

  end;

end;

procedure TSuperAvlTree.doDeleteEntry(Entry: TSuperAvlEntry; all: boolean);

begin

  Entry.Free;

end;

function TSuperAvlTree.GetEnumerator: TSuperAvlIterator;

begin

  Result := TSuperAvlIterator.Create(Self);

end;

function TSuperAvlTree.CompareForSortModeString(pvKey1, pvKey2: SOString):Integer;

  var

    cmp: integer;

    lvKey1, lvKey2: SOString;

  begin

    lvKey1 := LowerCase(pvKey1);

    lvKey2 := LowerCase(pvKey2);

    if lvKey1 <> lvKey2 then

   begin

    case nowSortMode of

       sosmAdd: cmp := ;

       sosmASC: if lvKey2 < lvKey1 then cmp :=  else if lvKey2 > lvKey1 then cmp := -;

      sosmDesc: if lvKey2 < lvKey1 then cmp := - else if lvKey2 > lvKey1 then cmp := ;

     else

       raise Exception.Create('默认排序不采用compareForSortModeString');

     end;

   end else

     cmp := ;

   Result := cmp;

  end;

{ TSuperAvlEntry }

constructor TSuperAvlEntry.Create(const AName: SOString; Obj: Pointer);

begin

  FName := AName;

  FPtr := Obj;

  FHash := Hash(FName);

end;

function TSuperAvlEntry.GetValue: ISuperObject;

begin

  Result := ISuperObject(FPtr)

end;

//class function TSuperAvlEntry.Hash(const k: SOString): Cardinal;

//var

//  h: cardinal;

//  i: Integer;

//begin

//  h := 0;

//{$Q-}

//  for i := 1 to Length(k) do

//    h := h*129 + ord(k[i]) + $9e370001;

//{$Q+}

//  Result := h;

//end;

//修改为：

{$OVERFLOWCHECKS OFF}

class function TSuperAvlEntry.Hash(const k: SOString): Cardinal;

var

  h: cardinal;

  i: Integer;

begin

  h := ;

  for i :=  to Length(k) do

    h := h* + ord(k[i]) + $9e370001;

  Result := h;

end;

{$OVERFLOWCHECKS ON}

procedure TSuperAvlEntry.SetValue(const val: ISuperObject);

begin

  ISuperObject(FPtr) := val;

end;

{ TSuperTableString }

function TSuperTableString.GetValues: ISuperObject;

var

  ite: TSuperAvlIterator;

  obj: TSuperAvlEntry;

begin

  Result := TSuperObject.Create(stArray);

  ite := TSuperAvlIterator.Create(Self);

  try

    ite.First;

    obj := ite.GetIter;

    while obj <> nil do

    begin

      Result.AsArray.Add(obj.Value);

      ite.Next;

      obj := ite.GetIter;

    end;

  finally

    ite.Free;

  end;

end;

function TSuperTableString.GetNames: ISuperObject;

var

  ite: TSuperAvlIterator;

  obj: TSuperAvlEntry;

begin

  Result := TSuperObject.Create(stArray);

  ite := TSuperAvlIterator.Create(Self);

  try

    ite.First;

    obj := ite.GetIter;

    while obj <> nil do

    begin

      Result.AsArray.Add(TSuperObject.Create(obj.FName));

      ite.Next;

      obj := ite.GetIter;

    end;

  finally

    ite.Free;

  end;

end;

procedure TSuperTableString.doDeleteEntry(Entry: TSuperAvlEntry; all: boolean);

begin

  if Entry.Ptr <> nil then

  begin

    if all then Entry.Value.Clear(true);

    Entry.Value := nil;

  end;

  inherited;

end;

function TSuperTableString.GetO(const k: SOString): ISuperObject;

var

  e: TSuperAvlEntry;

begin

  e := Search(k);

  if e <> nil then

    Result := e.Value else

    Result := nil

end;

procedure TSuperTableString.PutO(const k: SOString; const value: ISuperObject);

var

  entry: TSuperAvlEntry;

begin

  entry := Insert(TSuperAvlEntry.Create(k, Pointer(value)));

  if entry.FPtr <> nil then

    ISuperObject(entry.FPtr)._AddRef;

end;

procedure TSuperTableString.PutS(const k: SOString; const value: SOString);

begin

  PutO(k, TSuperObject.Create(Value));

end;

function TSuperTableString.GetS(const k: SOString): SOString;

var

  obj: ISuperObject;

begin

 obj := GetO(k);

 if obj <> nil then

   Result := obj.AsString else

   Result := '';

end;

procedure TSuperTableString.PutI(const k: SOString; value: SuperInt);

begin

  PutO(k, TSuperObject.Create(Value));

end;

function TSuperTableString.GetI(const k: SOString): SuperInt;

var

  obj: ISuperObject;

begin

 obj := GetO(k);

 if obj <> nil then

   Result := obj.AsInteger else

   Result := ;

end;

procedure TSuperTableString.PutD(const k: SOString; value: Double);

begin

  PutO(k, TSuperObject.Create(Value));

end;

procedure TSuperTableString.PutC(const k: SOString; value: Currency);

begin

  PutO(k, TSuperObject.CreateCurrency(Value));

end;

function TSuperTableString.GetC(const k: SOString): Currency;

var

  obj: ISuperObject;

begin

 obj := GetO(k);

 if obj <> nil then

   Result := obj.AsCurrency else

   Result := 0.0;

end;

function TSuperTableString.GetD(const k: SOString): Double;

var

  obj: ISuperObject;

begin

 obj := GetO(k);

 if obj <> nil then

   Result := obj.AsDouble else

   Result := 0.0;

end;

procedure TSuperTableString.PutB(const k: SOString; value: Boolean);

begin

  PutO(k, TSuperObject.Create(Value));

end;

function TSuperTableString.GetB(const k: SOString): Boolean;

var

  obj: ISuperObject;

begin

 obj := GetO(k);

 if obj <> nil then

   Result := obj.AsBoolean else

   Result := False;

end;

{$IFDEF SUPER_METHOD}

procedure TSuperTableString.PutM(const k: SOString; value: TSuperMethod);

begin

  PutO(k, TSuperObject.Create(Value));

end;

{$ENDIF}

{$IFDEF SUPER_METHOD}

function TSuperTableString.GetM(const k: SOString): TSuperMethod;

var

  obj: ISuperObject;

begin

 obj := GetO(k);

 if obj <> nil then

   Result := obj.AsMethod else

   Result := nil;

end;

{$ENDIF}

procedure TSuperTableString.PutN(const k: SOString; const value: ISuperObject);

begin

  if value <> nil then

    PutO(k, TSuperObject.Create(stNull)) else

    PutO(k, value);

end;

function TSuperTableString.GetN(const k: SOString): ISuperObject;

var

  obj: ISuperObject;

begin

 obj := GetO(k);

 if obj <> nil then

   Result := obj else

   Result := TSuperObject.Create(stNull);

end;

{$IFDEF VER210}

{ TSuperAttribute }

constructor TSuperAttribute.Create(const AName: string);

begin

  FName := AName;

end;

{ TSuperRttiContext }

constructor TSuperRttiContext.Create;

begin

  Context := TRttiContext.Create;

  SerialFromJson := TDictionary<PTypeInfo, TSerialFromJson>.Create;

  SerialToJson := TDictionary<PTypeInfo, TSerialToJson>.Create;

  SerialFromJson.Add(TypeInfo(Boolean), serialfromboolean);

  SerialFromJson.Add(TypeInfo(TDateTime), serialfromdatetime);

  SerialFromJson.Add(TypeInfo(TGUID), serialfromguid);

  SerialToJson.Add(TypeInfo(Boolean), serialtoboolean);

  SerialToJson.Add(TypeInfo(TDateTime), serialtodatetime);

  SerialToJson.Add(TypeInfo(TGUID), serialtoguid);

end;

destructor TSuperRttiContext.Destroy;

begin

  SerialFromJson.Free;

  SerialToJson.Free;

  Context.Free;

end;

class function TSuperRttiContext.GetFieldName(r: TRttiField): string;

var

  o: TCustomAttribute;

begin

  for o in r.GetAttributes do

    if o is SOName then

      Exit(SOName(o).Name);

  Result := r.Name;

end;

class function TSuperRttiContext.GetFieldDefault(r: TRttiField; const obj: ISuperObject): ISuperObject;

var

  o: TCustomAttribute;

begin

  if not ObjectIsType(obj, stNull) then Exit(obj);

  for o in r.GetAttributes do

    if o is SODefault then

      Exit(SO(SODefault(o).Name));

  Result := obj;

end;

function TSuperRttiContext.AsType<T>(const obj: ISuperObject): T;

var

  ret: TValue;

begin

  if FromJson(TypeInfo(T), obj, ret) then

    Result := ret.AsType<T> else

    raise exception.Create('Marshalling error');

end;

function TSuperRttiContext.AsJson<T>(const obj: T; const index: ISuperObject = nil): ISuperObject;

var

  v: TValue;

begin

  TValue.MakeWithoutCopy(@obj, TypeInfo(T), v);

  if index <> nil then

    Result := ToJson(v, index) else

    Result := ToJson(v, so);

end;

function TSuperRttiContext.FromJson(TypeInfo: PTypeInfo; const obj: ISuperObject;

  var Value: TValue): Boolean;

  procedure FromChar;

  begin

    if ObjectIsType(obj, stString) and (Length(obj.AsString) = ) then

      begin

        Value := string(AnsiString(obj.AsString)[]);

        Result := True;

      end else

        Result := False;

  end;

  procedure FromWideChar;

  begin

    if ObjectIsType(obj, stString) and (Length(obj.AsString) = ) then

    begin

      Value := obj.AsString[];

      Result := True;

    end else

      Result := False;

  end;

  procedure FromInt64;

  var

    i: Int64;

  begin

    case ObjectGetType(obj) of

    stInt:

      begin

        TValue.Make(nil, TypeInfo, Value);

        TValueData(Value).FAsSInt64 := obj.AsInteger;

        Result := True;

      end;

    stString:

      begin

        if TryStrToInt64(obj.AsString, i) then

        begin

          TValue.Make(nil, TypeInfo, Value);

          TValueData(Value).FAsSInt64 := i;

          Result := True;

        end else

          Result := False;

      end;

    else

      Result := False;

    end;

  end;

  procedure FromInt(const obj: ISuperObject);

  var

    TypeData: PTypeData;

    i: Integer;

    o: ISuperObject;

  begin

    case ObjectGetType(obj) of

    stInt, stBoolean:

      begin

        i := obj.AsInteger;

        TypeData := GetTypeData(TypeInfo);

        Result := (i >= TypeData.MinValue) and (i <= TypeData.MaxValue);

        if Result then

          TValue.Make(@i, TypeInfo, Value);

      end;

    stString:

      begin

        o := SO(obj.AsString);

        if not ObjectIsType(o, stString) then

          FromInt(o) else

          Result := False;

      end;

    else

      Result := False;

    end;

  end;

  procedure fromSet;

  begin

    if ObjectIsType(obj, stInt) then

    begin

      TValue.Make(nil, TypeInfo, Value);

      TValueData(Value).FAsSLong := obj.AsInteger;

      Result := True;

    end else

      Result := False;

  end;

  procedure FromFloat(const obj: ISuperObject);

  var

    o: ISuperObject;

  begin

    case ObjectGetType(obj) of

    stInt, stDouble, stCurrency:

      begin

        TValue.Make(nil, TypeInfo, Value);

        case GetTypeData(TypeInfo).FloatType of

          ftSingle: TValueData(Value).FAsSingle := obj.AsDouble;

          ftDouble: TValueData(Value).FAsDouble := obj.AsDouble;

          ftExtended: TValueData(Value).FAsExtended := obj.AsDouble;

          ftComp: TValueData(Value).FAsSInt64 := obj.AsInteger;

          ftCurr: TValueData(Value).FAsCurr := obj.AsCurrency;

        end;

        Result := True;

      end;

    stString:

      begin

        o := SO(obj.AsString);

        if not ObjectIsType(o, stString) then

          FromFloat(o) else

          Result := False;

      end

    else

       Result := False;

    end;

  end;

  procedure FromString;

  begin

    case ObjectGetType(obj) of

    stObject, stArray:

      Result := False;

    stnull:

      begin

        Value := '';

        Result := True;

      end;

    else

      Value := obj.AsString;

      Result := True;

    end;

  end;

  procedure FromClass;

  var

    f: TRttiField;

    v: TValue;

  begin

    case ObjectGetType(obj) of

      stObject:

        begin

          Result := True;

          if Value.Kind <> tkClass then

            Value := GetTypeData(TypeInfo).ClassType.Create;

          for f in Context.GetType(Value.AsObject.ClassType).GetFields do

            if f.FieldType <> nil then

            begin

              Result := FromJson(f.FieldType.Handle, GetFieldDefault(f, obj.AsObject[GetFieldName(f)]), v);

              if Result then

                f.SetValue(Value.AsObject, v) else

                Exit;

            end;

        end;

      stNull:

        begin

          Value := nil;

          Result := True;

        end

    else

      // error

      Value := nil;

      Result := False;

    end;

  end;

  procedure FromRecord;

  var

    f: TRttiField;

    p: Pointer;

    v: TValue;

  begin

    Result := True;

    TValue.Make(nil, TypeInfo, Value);

    for f in Context.GetType(TypeInfo).GetFields do

    begin

      if ObjectIsType(obj, stObject) and (f.FieldType <> nil) then

      begin

        p := IValueData(TValueData(Value).FHeapData).GetReferenceToRawData;

        Result := FromJson(f.FieldType.Handle, GetFieldDefault(f, obj.AsObject[GetFieldName(f)]), v);

        if Result then

          f.SetValue(p, v) else

          Exit;

      end else

      begin

        Result := False;

        Exit;

      end;

    end;

  end;

  procedure FromDynArray;

  var

    i: Integer;

    p: Pointer;

    pb: PByte;

    val: TValue;

    typ: PTypeData;

    el: PTypeInfo;

  begin

    case ObjectGetType(obj) of

    stArray:

      begin

        i := obj.AsArray.Length;

        p := nil;

        DynArraySetLength(p, TypeInfo, , @i);

        pb := p;

        typ := GetTypeData(TypeInfo);

        if typ.elType <> nil then

          el := typ.elType^ else

          el := typ.elType2^;

        Result := True;

        for i :=  to i -  do

        begin

          Result := FromJson(el, obj.AsArray[i], val);

          if not Result then

            Break;

          val.ExtractRawData(pb);

          val := TValue.Empty;

          Inc(pb, typ.elSize);

        end;

        if Result then

          TValue.MakeWithoutCopy(@p, TypeInfo, Value) else

          DynArrayClear(p, TypeInfo);

      end;

    stNull:

      begin

        TValue.MakeWithoutCopy(nil, TypeInfo, Value);

        Result := True;

      end;

    else

      i := ;

      p := nil;

      DynArraySetLength(p, TypeInfo, , @i);

      pb := p;

      typ := GetTypeData(TypeInfo);

      if typ.elType <> nil then

        el := typ.elType^ else

        el := typ.elType2^;

      Result := FromJson(el, obj, val);

      val.ExtractRawData(pb);

      val := TValue.Empty;

      if Result then

        TValue.MakeWithoutCopy(@p, TypeInfo, Value) else

        DynArrayClear(p, TypeInfo);

    end;

  end;

  procedure FromArray;

  var

    ArrayData: PArrayTypeData;

    idx: Integer;

    function ProcessDim(dim: Byte; const o: ISuperobject): Boolean;

    var

      i: Integer;

      v: TValue;

      a: PTypeData;

    begin

      if ObjectIsType(o, stArray) and (ArrayData.Dims[dim-] <> nil) then

      begin

        a := @GetTypeData(ArrayData.Dims[dim-]^).ArrayData;

        if (a.MaxValue - a.MinValue + ) <> o.AsArray.Length then

        begin

          Result := False;

          Exit;

        end;

        Result := True;

        if dim = ArrayData.DimCount then

          for i := a.MinValue to a.MaxValue do

          begin

            Result := FromJson(ArrayData.ElType^, o.AsArray[i], v);

            if not Result then

              Exit;

            Value.SetArrayElement(idx, v);

            inc(idx);

          end

        else

          for i := a.MinValue to a.MaxValue do

          begin

            Result := ProcessDim(dim + , o.AsArray[i]);

            if not Result then

              Exit;

          end;

      end else

        Result := False;

    end;

  var

    i: Integer;

    v: TValue;

  begin

    TValue.Make(nil, TypeInfo, Value);

    ArrayData := @GetTypeData(TypeInfo).ArrayData;

    idx := ;

    if ArrayData.DimCount =  then

    begin

      if ObjectIsType(obj, stArray) and (obj.AsArray.Length = ArrayData.ElCount) then

      begin

        Result := True;

        for i :=  to ArrayData.ElCount -  do

        begin

          Result := FromJson(ArrayData.ElType^, obj.AsArray[i], v);

          if not Result then

            Exit;

          Value.SetArrayElement(idx, v);

          v := TValue.Empty;

          inc(idx);

        end;

      end else

        Result := False;

    end else

      Result := ProcessDim(, obj);

  end;

  procedure FromClassRef;

  var

    r: TRttiType;

  begin

    if ObjectIsType(obj, stString) then

    begin

      r := Context.FindType(obj.AsString);

      if r <> nil then

      begin

        Value := TRttiInstanceType(r).MetaclassType;

        Result := True;

      end else

        Result := False;

    end else

      Result := False;

  end;

  procedure FromUnknown;

  begin

    case ObjectGetType(obj) of

      stBoolean:

        begin

          Value := obj.AsBoolean;

          Result := True;

        end;

      stDouble:

        begin

          Value := obj.AsDouble;

          Result := True;

        end;

      stCurrency:

        begin

          Value := obj.AsCurrency;

          Result := True;

        end;

      stInt:

        begin

          Value := obj.AsInteger;

          Result := True;

        end;

      stString:

        begin

          Value := obj.AsString;

          Result := True;

        end

    else

      Value := nil;

      Result := False;

    end;

  end;

  procedure FromInterface;

  const soguid: TGuid = '{4B86A9E3-E094-4E5A-954A-69048B7B6327}';

  var

    o: ISuperObject;

  begin

    if CompareMem(@GetTypeData(TypeInfo).Guid, @soguid, SizeOf(TGUID)) then

    begin

      if obj <> nil then

        TValue.Make(@obj, TypeInfo, Value) else

        begin

          o := TSuperObject.Create(stNull);

          TValue.Make(@o, TypeInfo, Value);

        end;

      Result := True;

    end else

      Result := False;

  end;

var

  Serial: TSerialFromJson;

begin

  if TypeInfo <> nil then

  begin

    if not SerialFromJson.TryGetValue(TypeInfo, Serial) then

      case TypeInfo.Kind of

        tkChar: FromChar;

        tkInt64: FromInt64;

        tkEnumeration, tkInteger: FromInt(obj);

        tkSet: fromSet;

        tkFloat: FromFloat(obj);

        tkString, tkLString, tkUString, tkWString: FromString;

        tkClass: FromClass;

        tkMethod: ;

        tkWChar: FromWideChar;

        tkRecord: FromRecord;

        tkPointer: ;

        tkInterface: FromInterface;

        tkArray: FromArray;

        tkDynArray: FromDynArray;

        tkClassRef: FromClassRef;

      else

        FromUnknown

      end else

      begin

        TValue.Make(nil, TypeInfo, Value);

        Result := Serial(Self, obj, Value);

      end;

  end else

    Result := False;

end;

function TSuperRttiContext.ToJson(var value: TValue; const index: ISuperObject): ISuperObject;

  procedure ToInt64;

  begin

    Result := TSuperObject.Create(SuperInt(Value.AsInt64));

  end;

  procedure ToChar;

  begin

    Result := TSuperObject.Create(string(Value.AsType<AnsiChar>));

  end;

  procedure ToInteger;

  begin

    Result := TSuperObject.Create(TValueData(Value).FAsSLong);

  end;

  procedure ToFloat;

  begin

    case Value.TypeData.FloatType of

      ftSingle: Result := TSuperObject.Create(TValueData(Value).FAsSingle);

      ftDouble: Result := TSuperObject.Create(TValueData(Value).FAsDouble);

      ftExtended: Result := TSuperObject.Create(TValueData(Value).FAsExtended);

      ftComp: Result := TSuperObject.Create(TValueData(Value).FAsSInt64);

      ftCurr: Result := TSuperObject.CreateCurrency(TValueData(Value).FAsCurr);

    end;

  end;

  procedure ToString;

  begin

    Result := TSuperObject.Create(string(Value.AsType<string>));

  end;

  procedure ToClass;

  var

    o: ISuperObject;

    f: TRttiField;

    v: TValue;

  begin

    if TValueData(Value).FAsObject <> nil then

    begin

      o := index[IntToStr(Integer(Value.AsObject))];

      if o = nil then

      begin

        Result := TSuperObject.Create(stObject);

        index[IntToStr(Integer(Value.AsObject))] := Result;

        for f in Context.GetType(Value.AsObject.ClassType).GetFields do

          if f.FieldType <> nil then

          begin

            v := f.GetValue(Value.AsObject);

            Result.AsObject[GetFieldName(f)] := ToJson(v, index);

          end

      end else

        Result := o;

    end else

      Result := nil;

  end;

  procedure ToWChar;

  begin

    Result :=  TSuperObject.Create(string(Value.AsType<WideChar>));

  end;

  procedure ToVariant;

  begin

    Result := SO(Value.AsVariant);

  end;

  procedure ToRecord;

  var

    f: TRttiField;

    v: TValue;

  begin

    Result := TSuperObject.Create(stObject);

    for f in Context.GetType(Value.TypeInfo).GetFields do

    begin

      v := f.GetValue(IValueData(TValueData(Value).FHeapData).GetReferenceToRawData);

      Result.AsObject[GetFieldName(f)] := ToJson(v, index);

    end;

  end;

  procedure ToArray;

  var

    idx: Integer;

    ArrayData: PArrayTypeData;

    procedure ProcessDim(dim: Byte; const o: ISuperObject);

    var

      dt: PTypeData;

      i: Integer;

      o2: ISuperObject;

      v: TValue;

    begin

      if ArrayData.Dims[dim-] = nil then Exit;

      dt := GetTypeData(ArrayData.Dims[dim-]^);

      if Dim = ArrayData.DimCount then

        for i := dt.MinValue to dt.MaxValue do

        begin

          v := Value.GetArrayElement(idx);

          o.AsArray.Add(toJSon(v, index));

          inc(idx);

        end

      else

        for i := dt.MinValue to dt.MaxValue do

        begin

          o2 := TSuperObject.Create(stArray);

          o.AsArray.Add(o2);

          ProcessDim(dim + , o2);

        end;

    end;

  var

    i: Integer;

    v: TValue;

  begin

    Result := TSuperObject.Create(stArray);

    ArrayData := @Value.TypeData.ArrayData;

    idx := ;

    if ArrayData.DimCount =  then

      for i :=  to ArrayData.ElCount -  do

      begin

        v := Value.GetArrayElement(i);

        Result.AsArray.Add(toJSon(v, index))

      end

    else

      ProcessDim(, Result);

  end;

  procedure ToDynArray;

  var

    i: Integer;

    v: TValue;

  begin

    Result := TSuperObject.Create(stArray);

    for i :=  to Value.GetArrayLength -  do

    begin

      v := Value.GetArrayElement(i);

      Result.AsArray.Add(toJSon(v, index));

    end;

  end;

  procedure ToClassRef;

  begin

    if TValueData(Value).FAsClass <> nil then

      Result :=  TSuperObject.Create(string(

        TValueData(Value).FAsClass.UnitName + '.' +

        TValueData(Value).FAsClass.ClassName)) else

      Result := nil;

  end;

  procedure ToInterface;

  begin

    if TValueData(Value).FHeapData <> nil then

      TValueData(Value).FHeapData.QueryInterface(ISuperObject, Result) else

      Result := nil;

  end;

var

  Serial: TSerialToJson;

begin

  if not SerialToJson.TryGetValue(value.TypeInfo, Serial) then

    case Value.Kind of

      tkInt64: ToInt64;

      tkChar: ToChar;

      tkSet, tkInteger, tkEnumeration: ToInteger;

      tkFloat: ToFloat;

      tkString, tkLString, tkUString, tkWString: ToString;

      tkClass: ToClass;

      tkWChar: ToWChar;

      tkVariant: ToVariant;

      tkRecord: ToRecord;

      tkArray: ToArray;

      tkDynArray: ToDynArray;

      tkClassRef: ToClassRef;

      tkInterface: ToInterface;

    else

      result := nil;

    end else

      Result := Serial(Self, value, index);

end;

{ TSuperObjectHelper }

constructor TSuperObjectHelper.FromJson(const obj: ISuperObject; ctx: TSuperRttiContext = nil);

var

  v: TValue;

  ctxowned: Boolean;

begin

  if ctx = nil then

  begin

    ctx := TSuperRttiContext.Create;

    ctxowned := True;

  end else

    ctxowned := False;

  try

    v := Self;

    if not ctx.FromJson(v.TypeInfo, obj, v) then

      raise Exception.Create('Invalid object');

  finally

    if ctxowned then

      ctx.Free;

  end;

end;

constructor TSuperObjectHelper.FromJson(const str: string; ctx: TSuperRttiContext = nil);

begin

  FromJson(SO(str), ctx);

end;

function TSuperObjectHelper.ToJson(ctx: TSuperRttiContext = nil): ISuperObject;

var

  v: TValue;

  ctxowned: boolean;

begin

  if ctx = nil then

  begin

    ctx := TSuperRttiContext.Create;

    ctxowned := True;

  end else

    ctxowned := False;

  try

    v := Self;

    Result := ctx.ToJson(v, SO);

  finally

    if ctxowned then

      ctx.Free;

  end;

end;

{$ENDIF}

{$IFDEF DEBUG}

initialization

finalization

  Assert(debugcount = , 'Memory leak');

{$ENDIF}

end.