/src/superobject/superobject.pas

Large files files are truncated, but you can click here to view the full file

(*

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

 *

 * Embarcadero Technologies Inc is not permitted to use or redistribute

 * this source code without explicit permission.

 *

 * 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





{$if defined(FPC) or defined(VER170) or defined(VER180) or defined(VER190) or defined(VER200) or defined(VER210)}

  {$DEFINE HAVE_INLINE}

{$ifend}



{$if defined(VER210) or defined(VER220) or defined(VER230)}

  {$define HAVE_RTTI}

{$ifend}



{$if defined(VER230)}

  {$define NEED_FORMATSETTINGS}

{$ifend}



{$if defined(FPC) and defined(VER2_6)}

  {$define NEED_FORMATSETTINGS}

{$ifend}



{$OVERFLOWCHECKS OFF}

{$RANGECHECKS OFF}



unit superobject;



interface

uses

  Classes

{$IFDEF HAVE_RTTI}

  ,Generics.Collections, RTTI, TypInfo

{$ENDIF}

  ;



type

{$IFNDEF FPC}

{$IFDEF CPUX64}

  PtrInt = Int64;

  PtrUInt = UInt64;

{$ELSE}

  PtrInt = longint;

  PtrUInt = Longword;

{$ENDIF}

{$ENDIF}

  SuperInt = Int64;



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

  SOChar = WideChar;

  SOIChar = Word;

  PSOChar = PWideChar;

{$IFDEF FPC}

  SOString = UnicodeString;

{$ELSE}

  SOString = WideString;

{$ENDIF}

{$else}

  SOChar = Char;

  SOIChar = Word;

  PSOChar = PChar;

  SOString = string;

{$ifend}



const

  SUPER_ARRAY_LIST_DEFAULT_SIZE = 32;

  SUPER_TOKENER_MAX_DEPTH = 32;



  SUPER_AVL_MAX_DEPTH = sizeof(longint) * 8;

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



type

  // forward declarations

  TSuperObject = class;

  ISuperObject = interface;

  TSuperArray = class;



(* 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 0..SUPER_AVL_MAX_DEPTH - 1;



  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;

    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;

    function Find(const k: SOString; var value: ISuperObject): Boolean;

  end;



  TSuperAvlIterator = class

  private

    FTree: TSuperAvlTree;

    FBranch: TSuperAvlBitArray;

    FDepth: LongInt;

    FPath: array[0..SUPER_AVL_MAX_DEPTH - 2] 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[0..(high(Integer) div sizeof(TSuperObject))-1] 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; overload;

    function Add(Data: SuperInt): Integer; overload;

    function Add(const Data: SOString): Integer; overload;

    function Add(Data: Boolean): Integer; overload;

    function Add(Data: Double): Integer; overload;

    function AddC(const Data: Currency): 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}

  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[0..SUPER_TOKENER_MAX_DEPTH-1] 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

{$IFDEF FPC}

    function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid: tguid; out obj): longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};

{$ELSE}

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

{$ENDIF}

    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 HAVE_RTTI}

  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;

function TryObjectToDate(const obj: ISuperObject; var dt: TDateTime): Boolean;

function ISO8601DateToJavaDateTime(const str: SOString; var ms: Int64): Boolean;

function ISO8601DateToDelphiDateTime(const str: SOString; var dt: TDateTime): Boolean;

function DelphiDateTimeToISO8601Date(dt: TDateTime): SOString;

function UUIDToString(const g: TGUID): SOString;

function StringToUUID(const str: SOString; var g: TGUID): Boolean;



{$IFDEF HAVE_RTTI}



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}



implementation

uses sysutils,

{$IFDEF UNIX}

  baseunix, unix, DateUtils

{$ELSE}

  Windows

{$ENDIF}

{$IFDEF FPC}

  ,sockets

{$ELSE}

  ,WinSock

{$ENDIF};



{$IFDEF DEBUG}

var

  debugcount: integer = 0;

{$ENDIF}



const

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

  super_hex_chars: PSOChar = '0123456789abcdef';

  super_hex_chars_set = ['0'..'9','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 = #13#10;

  TOK_SP: PSOChar = #32;

  TOK_BS: PSOChar = #8;

  TOK_TAB: PSOChar = #9;

  TOK_LF: PSOChar = #10;

  TOK_FF: PSOChar = #12;

  TOK_CR: PSOChar = #13;

//  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';



{$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 := 0;

  while I < MaxLen do

  begin

    C1 := P1^;

    C2 := P2^;



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

    begin

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

      Exit;

    end;



    Inc(P1);

    Inc(P2);

    Inc(I);

  end;

  Result := 0;

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 = #0) 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 := 0;

  if Str <> nil then

  begin

    p := Str;

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

    Result := (p - Str);

  end;

end;

{$ifend}



function FloatToJson(const value: Double): SOString;

var

  p: PSOChar;

begin

  Result := FloatToStr(value);

  if {$if defined(NEED_FORMATSETTINGS)}FormatSettings.{$ifend}DecimalSeparator <> '.' then

  begin

    p := PSOChar(Result);

    while p^ <> #0 do

      if p^ <> SOChar({$if defined(NEED_FORMATSETTINGS)}FormatSettings.{$ifend}DecimalSeparator) then

      inc(p) else

      begin

        p^ := '.';

        Exit;

      end;

  end;

end;



function CurrToJson(const value: Currency): SOString;

var

  p: PSOChar;

begin

  Result := CurrToStr(value);

  if {$if defined(NEED_FORMATSETTINGS)}FormatSettings.{$ifend}DecimalSeparator <> '.' then

  begin

    p := PSOChar(Result);

    while p^ <> #0 do

      if p^ <> SOChar({$if defined(NEED_FORMATSETTINGS)}FormatSettings.{$ifend}DecimalSeparator) then

      inc(p) else

      begin

        p^ := '.';

        Exit;

      end;

  end;

end;



{$IFDEF UNIX}

function GetTimeBias: integer;

var

  TimeVal: TTimeVal;

  TimeZone: TTimeZone;

begin

  fpGetTimeOfDay(@TimeVal, @TimeZone);

  Result := TimeZone.tz_minuteswest;

end;

{$ELSE}

function GetTimeBias: integer;

var

  tzi : TTimeZoneInformation;

begin

  case GetTimeZoneInformation(tzi) of

    TIME_ZONE_ID_UNKNOWN : Result := tzi.Bias;

    TIME_ZONE_ID_STANDARD: Result := tzi.Bias + tzi.StandardBias;

    TIME_ZONE_ID_DAYLIGHT: Result := tzi.Bias + tzi.DaylightBias;

  else

    Result := 0;

  end;

end;

{$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 - 25569) * 86400000);

  ms := v mod 1000;

  l := v div 1000;

  p := localtime(@l);

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

end;



function JavaToDelphiDateTime(const dt: int64): TDateTime;

var

  p: ptm;

  l, ms: Integer;

begin

  l := dt div 1000;

  ms := dt mod 1000;

  p := gmtime(@l);

  Result := EncodeDateTime(p^.tm_year+1900, p^.tm_mon+1, 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 := -1; (* We are in a month before the date limit. *)

    Exit;

  end;



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

  begin

    Result := 1; (* 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 = 0) 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 := (6 + compareDate^.wDayOfWeek - date^.wDayOfWeek + date^.wDay) mod 7 + 1;

    limit_day := First + 7 * (weekofmonth - 1);

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

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

      dec(limit_day, 7);

  end

  else

    limit_day := compareDate^.wDay;



  (* convert to seconds *)

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

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

  (* and compare *)



  if dayinsecs < limit_day then

    Result :=  -1 else

    if dayinsecs > limit_day then

      Result :=  1 else

      Result :=  0; (* 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 := 0;



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

  begin

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

     * it's absolute date.

     *)

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

        ((pTZinfo^.StandardDate.wYear = 0) and

        ((pTZinfo^.StandardDate.wDay < 1) or

        (pTZinfo^.StandardDate.wDay > 5) or

        (pTZinfo^.DaylightDate.wDay < 1) or

        (pTZinfo^.DaylightDate.wDay > 5)))) 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) * 600000000);

      PInt64(@ftTemp)^ := llTime;

      lpFileTime := @ftTemp;

    end;



    FileTimeToSystemTime(lpFileTime^, SysTime);



    (* check for daylight savings *)

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

    if (ret = -2) then

    begin

      Result := TIME_ZONE_ID_INVALID;

      Exit;

    end;



    beforeStandardDate := ret < 0;



    if (not islocal) then

    begin

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

      PInt64(@ftTemp)^ := llTime;

      FileTimeToSystemTime(lpFileTime^, SysTime);

    end;



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

    if (ret = -2) then

    begin

      Result := TIME_ZONE_ID_INVALID;

      Exit;

    end;



    afterDaylightDate := ret >= 0;



    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) * 600000000);

  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) * 600000000);

  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(25569 + (dt / 86400000), 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) - 25569) * 86400000)

end;

{$ENDIF}



function ISO8601DateToJavaDateTime(const str: SOString; var ms: Int64): Boolean;

type

  TState = (

    stStart, stYear, stMonth, stWeek, stWeekDay, stDay, stDayOfYear,

    stHour, stMin, stSec, stMs, stUTC, stGMTH, stGMTM,

    stGMTend, stEnd);



  TPerhaps = (yes, no, perhaps);

  TDateTimeInfo = record

    year: Word;

    month: Word;

    week: Word;

    weekday: Word;

    day: Word;

    dayofyear: Integer;

    hour: Word;

    minute: Word;

    second: Word;

    ms: Word;

    bias: Integer;

  end;



var

  p: PSOChar;

  state: TState;

  pos, v: Word;

  sep: TPerhaps;

  inctz, havetz, havedate: Boolean;

  st: TDateTimeInfo;

  DayTable: PDayTable;



  function get(var v: Word; c: SOChar): Boolean; {$IFDEF HAVE_INLINE} inline;{$ENDIF}

  begin

    if (c < #256) and (AnsiChar(c) in ['0'..'9']) then

    begin

      Result := True;

      v := v * 10 + Ord(c) - Ord('0');

    end else

      Result := False;

  end;



label

  error;

begin

  p := PSOChar(str);

  sep := perhaps;

  state := stStart;

  pos := 0;

  FillChar(st, SizeOf(st), 0);

  havedate := True;

  inctz := False;

  havetz := False;



  while true do

  case state of

    stStart:

      case p^ of

        '0'..'9': state := stYear;

        'T', 't':

          begin

            state := stHour;

            pos := 0;

            inc(p);

            havedate := False;

          end;

      else

        goto error;

      end;

    stYear:

      case pos of

        0..1,3:

              if get(st.year, p^) then

              begin

                Inc(pos);

                Inc(p);

              end else

                goto error;

        2:    case p^ of

                '0'..'9':

                  begin

                    st.year := st.year * 10 + ord(p^) - ord('0');

                    Inc(pos);

                    Inc(p);

                  end;

                ':':

                  begin

                    havedate := false;

                    st.hour := st.year;

                    st.year := 0;

                    inc(p);

                    pos := 0;

                    state := stMin;

                    sep := yes;

                  end;

              else

                goto error;

              end;

        4: case p^ of

             '-': begin

                    pos := 0;

                    Inc(p);

                    sep := yes;

                    state := stMonth;

                  end;

             '0'..'9':

                  begin

                    sep := no;

                    pos := 0;

                    state := stMonth;

                  end;

             'W', 'w' :

                  begin

                    pos := 0;

                    Inc(p);

                    state := stWeek;

                  end;

             'T', 't', ' ':

                  begin

                    state := stHour;

                    pos := 0;

                    inc(p);

                    st.month := 1;

                    st.day := 1;

                  end;

             #0:

                  begin

                    st.month := 1;

                    st.day := 1;

                    state := stEnd;

                  end;

           else

             goto error;

           end;

      end;

    stMonth:

      case pos of

        0:  case p^ of

              '0'..'9':

                begin

                  st.month := ord(p^) - ord('0');

                  Inc(pos);

                  Inc(p);

                end;

              'W', 'w':

                begin

                  pos := 0;

                  Inc(p);

                  state := stWeek;

                end;

            else

              goto error;

            end;

        1:  if get(st.month, p^) then

            begin

              Inc(pos);

              Inc(p);

            end else

              goto error;

        2: case p^ of

             '-':

                  if (sep in [yes, perhaps])  then

                  begin

                    pos := 0;

                    Inc(p);

                    state := stDay;

                    sep := yes;

                  end else

                    goto error;

             '0'..'9':

                  if sep in [no, perhaps] then

                  begin

                    pos := 0;

                    state := stDay;

                    sep := no;

                  end else

                  begin

                    st.dayofyear := st.month * 10 + Ord(p^) - Ord('0');

                    st.month := 0;

                    inc(p);

                    pos := 3;

                    state := stDayOfYear;

                  end;

             'T', 't', ' ':

                  begin

                    state := stHour;

                    pos := 0;

                    inc(p);

                    st.day := 1;

                 end;

             #0:

               begin

                 st.day := 1;

                 state := stEnd;

               end;

           else

             goto error;

           end;

      end;

    stDay:

      case pos of

        0:  if get(st.day, p^) then

            begin

              Inc(pos);

              Inc(p);

            end else

              goto error;

        1:…