用户登录
用户注册

SuperObject Delphi 的 JSON 属性乱序 - 操作类改造 - 关于属性顺序的问题

delphi 的 isuperobject 属性顺序为随机。但是很多时候,是需要按加入顺序进行读取。我也看了网上很多人有类似需求。也有人问过原作者,作者答复为:json协议规定为无序。看了我真是无语。

也看过网上一些人自己的修改,但是修改后有两个问题(网上的方法都不好,只能自己动手了):
1. 性能急剧下降。原作者是用二叉树对性能做了极大的优化。但是网上修改的方法性能不行。
2. 属性数大于 32 时会出错。(原来用的是二叉树,修改后部分算法未修改,导致此问题)。

我采用的是重写遍历器的方法,和原版性能接近。

* 执行 500*500 数据的节点变更后,性能和原版差别不太大。
*
* 原始性能 0.280 秒
* 旧的稳定改版性能 15.774 秒
* 新的稳定改版性能 0.535 秒
*
* 性能是原版的 1.9 倍左右。而之前将二叉树变为链表的方法,导致性能变为 56 分之一。
* 温涛,于 2018-10-26。邮箱 delphi2006@163.com

 

把源码顺便贴上吧。

 

(*
 *                         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:
 *    终极改版来了,现在的改版增加了存储节点名称的功能。并且重写了遍历器,和原版性能接近。
 *  执行 500*500 数据的节点变更后,性能和原版差别不太大。
 *
 *        原始性能           0.280 秒
 *        旧的稳定改版性能  15.774 秒
 *        新的稳定改版性能   0.535 秒
 *
 *    性能是原版的 1.9 倍左右。而之前将二叉树变为链表的方法,导致性能变为 56 分之一。
 *    温涛,于 2018-10-26。邮箱 delphi2006@163.com
 *
 *  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}

{$overflowchecks off}
{$rangechecks off}
{.$define tostringex}

unit superobjecttoolkit;

interface
uses
  classes, sysutils
{$ifdef have_rtti}
  ,generics.collections, rtti, typinfo
{$endif}
  , math, generics.defaults, variants;

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;
    // wentao 添加了用于节点顺序的功能。
    fnodenames: tstringlist;
    function balance(bal: tsuperavlentry): tsuperavlentry;
  protected
    // wentao 添加了用于节点顺序的功能。
    procedure addnodename(nodename: sostring);
    procedure removenode(nodename: sostring);

    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;

    // wentao 新的遍历方法只需要一个索引即可。
    fcurnameindex: integer;

    (* 旧的代码。
    fbranch: tsuperavlbitarray;
    fdepth: longint;
    fpath: array[0..super_avl_max_depth - 2] of tsuperavlentry;
    *)

  public
    constructor create(tree: tsuperavltree); virtual;

    // wentao 新的 search 只支持等于的查找,不过原库中也没有用过非等于的查找。
    procedure search(const k: sostring);

    // 旧的代码:
    // 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;
    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;

  tjsonformattype = (ftoneline, ftmultiline, ftarray, ftobjectarray);

  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;

    // wentao 新增加的排序、过滤接口。

    // eachprop: 遍历每一个值的属性
    // eachobj:  遍历每一个对象类型的属性
    procedure foreachforproperty(eachprop: tproc<{key}string, {islast: }boolean>; eachobj: tproc<{key}string, {islast: }boolean>);

    // 当 superobject 是 array 时,统计每一个列的最大宽度。
    procedure calcmaxlen(lendict: tdictionary<string, integer>);

    // 按特写字段排序
    function sortbyfield(afieldname: string; adatatype: tsupertype = ststring): isuperobject;
    function sort(oncompare: tfunc<isuperobject, isuperobject, integer>): isuperobject;
    function filterbyfield(afieldname: string; avalue: variant; adatatype: tsupertype = ststring): isuperobject;
    function filter(oncompare: tfunc<isuperobject, boolean>): isuperobject;
    function foreachforarray(callback: tproc<{index: }integer, {item: }isuperobject, {islast: }boolean>): isuperobject;
    function findbyfield(afieldname: string; avalue: variant; adatatype: tsupertype = ststring): isuperobject;
    function find(oncompare: tfunc<isuperobject, boolean>): isuperobject;
    function reverse: isuperobject;

    {$ifdef tostringex}
    function tostringex(ajsontype: tjsonformattype): string;
    {$endif}
  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);
    procedure needarray;
  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;

    // wentao 新增加的排序、过滤接口。
    procedure foreachforproperty(eachprop: tproc<{key}string, {islast: }boolean>; eachobj: tproc<{key}string, {islast: }boolean>);

    procedure calcmaxlen(lendict: tdictionary<string, integer>);

    function sortbyfield(afieldname: string; adatatype: tsupertype = ststring): isuperobject;
    function sort(oncompare: tfunc<isuperobject, isuperobject, integer>): isuperobject;
    function filterbyfield(afieldname: string; avalue: variant; adatatype: tsupertype = ststring): isuperobject;
    function filter(oncompare: tfunc<isuperobject, boolean>): isuperobject;
    function foreachforarray(callback: tproc<{index: }integer, {item: }isuperobject, {islast: }boolean>): isuperobject;
    function findbyfield(afieldname: string; avalue: variant; adatatype: tsupertype = ststring): isuperobject;
    function find(oncompare: tfunc<isuperobject, boolean>): isuperobject;
    function reverse: isuperobject;

    {$ifdef tostringex}
    class function escapevalue(valuestr: sostring): sostring;
    function tostringex(ajsontype: tjsonformattype): string;
    {$endif}
  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;
{$ifdef have_rtti}
function uuidtostring(const g: tguid): string;
function stringtouuid(const str: string; var g: tguid): boolean;


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
{$ifdef tostringex} wtstrutility, {$endif}
{$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 = '0000';

  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 decimalseparator <> '.' then
  begin
    p := psochar(result);
    while p^ <> #0 do
      if p^ <> sochar(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 decimalseparator <> '.' then
  begin
    p := psochar(result);
    while p^ <> #0 do
      if p^ <> sochar(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:  if get(st.day, p^) then
            begin
              inc(pos);
              inc(p);
            end else
            if sep in [no, perhaps] then
            begin
              st.dayofyear := st.month * 10 + st.day;
              st.day := 0;
              st.month := 0;
              state := stdayofyear;
            end else
              goto error;

        2: case p^ of
             't', 't', ' ':
                  begin
                    pos := 0;
                    inc(p);
                    state := sthour;
                  end;
             #0:  state := stend;
           else
             goto error;
           end;
      end;
    stdayofyear:
      begin
        if (st.dayofyear <= 0) then goto error;
        case p^ of
          't', 't', ' ':
               begin
                 pos := 0;
                 inc(p);
                 state := sthour;
               end;
          #0:  state := stend;
        else
          goto error;
        end;
      end;
    stweek:
      begin
        case pos of
          0..1: if get(st.week, p^) then
                begin
                  inc(pos);
                  inc(p);
                end else
                  goto error;
          2: case p^ of
               '-': if (sep in [yes, perhaps]) then
                    begin
                      inc(p);
                      state := stweekday;
                      sep := yes;
                    end else
                      goto error;
               '1'..'7':
                    if sep in [no, perhaps] then
                    begin
                      state := stweekday;
                      sep := no;
                    end else
                      goto error;
             else
               goto error;
             end;
        end;
      end;
    stweekday:
      begin
        if (st.week > 0) and get(st.weekday, p^) then
        begin
          inc(p);
          v := st.year - 1;
          v := ((v * 365) + (v div 4) - (v div 100) + (v div 400)) mod 7 + 1;
          st.dayofyear := (st.weekday - v) + ((st.week) * 7) + 1;
          if v <= 4 then dec(st.dayofyear, 7);
          case p^ of
            't', 't', ' ':
                 begin
                   pos := 0;
                   inc(p);
                   state := sthour;
                 end;
            #0:  state := stend;
          else
            goto error;
          end;
        end else
          goto error;
      end;
    sthour:
      case pos of
        0:    case p^ of
                '0'..'9':
                    if get(st.hour, p^) then
                    begin
                      inc(pos);
                      inc(p);
                      end else
                        goto error;
                '-':
                  begin
                    inc(p);
                    state := stmin;
                  end;
              else
                goto error;
              end;
        1:    if get(st.hour, p^) then
              begin
                inc(pos);
                inc(p);
              end else
                goto error;
        2: case p^ of
             ':': if sep in [yes, perhaps] then
                  begin
                    sep := yes;
                    pos := 0;
                    inc(p);
                    state := stmin;
                  end else
                    goto error;
             ',':
                begin
                  inc(p);
                  state := stms;
                end;
             '+':
               if havedate then
               begin
                 state := stgmth;
                 pos := 0;
                 v := 0;
                 inc(p);
               end else
                 goto error;
             '-':
               if havedate then
               begin
                 state := stgmth;
                 pos := 0;
                 v := 0;
                 inc(p);
                 inctz := true;
               end else
                 goto error;
             'z', 'z':
                  if havedate then
                    state := stutc else
                    goto error;
             '0'..'9':
                  if sep in [no, perhaps] then
                  begin
                    pos := 0;
                    state := stmin;
                    sep := no;
                  end else
                    goto error;
             #0:  state := stend;
           else
             goto error;
           end;
      end;
    stmin:
      case pos of
        0: case p^ of
             '0'..'9':
                if get(st.minute, p^) then
                begin
                  inc(pos);
                  inc(p);
                end else
                  goto error;
             '-':
                begin
                  inc(p);
                  state := stsec;
                end;
           else
             goto error;
           end;
        1: if get(st.minute, 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 := stsec;
                    sep := yes;
                  end else
                    goto error;
             ',':
                begin
                  inc(p);
                  state := stms;
                end;
             '+':
               if havedate then
               begin
                 state := stgmth;
                 pos := 0;
                 v := 0;
                 inc(p);
               end else
                 goto error;
             '-':
               if havedate then
               begin
                 state := stgmth;
                 pos := 0;
                 v := 0;
                 inc(p);
                 inctz := true;
               end else
                 goto error;
             'z', 'z':
                  if havedate then
                    state := stutc else
                    goto error;
             '0'..'9':
                  if sep in [no, perhaps] then
                  begin
                    pos := 0;
                    state := stsec;
                  end else
                    goto error;
             #0:  state := stend;
           else
             goto error;
           end;
      end;
    stsec:
      case pos of
        0..1: if get(st.second, p^) then
              begin
                inc(pos);
                inc(p);
              end else
                goto error;
        2:    case p^ of
               ',':
                  begin
                    inc(p);
                    state := stms;
                  end;
               '+':
                 if havedate then
                 begin
                   state := stgmth;
                   pos := 0;
                   v := 0;
                   inc(p);
                 end else
                   goto error;
               '-':
                 if havedate then
                 begin
                   state := stgmth;
                   pos := 0;
                   v := 0;
                   inc(p);
                   inctz := true;
                 end else
                   goto error;
               'z', 'z':
                    if havedate then
                      state := stutc else
                      goto error;
               #0: state := stend;
              else
               goto error;
              end;
      end;
    stms:
      case p^ of
        '0'..'9':
        begin
          st.ms := st.ms * 10 + ord(p^) - ord('0');
          inc(p);
        end;
        '+':
          if havedate then
          begin
            state := stgmth;
            pos := 0;
            v := 0;
            inc(p);
          end else
            goto error;
        '-':
          if havedate then
          begin
            state := stgmth;
            pos := 0;
            v := 0;
            inc(p);
            inctz := true;
          end else
            goto error;
        'z', 'z':
             if havedate then
               state := stutc else
               goto error;
        #0: state := stend;
      else
        goto error;
      end;
    stutc: // = gmt 0
      begin
        havetz := true;
        inc(p);
        if p^ = #0 then
          break else
          goto error;
      end;
    stgmth:
      begin
        havetz := true;
        case pos of
          0..1: if get(v, p^) then
                begin
                  inc(p);
                  inc(pos);
                end else
                  goto error;
          2:
            begin
              st.bias := v * 60;
              case p^ of
                ':': if sep in [yes, perhaps] then
                     begin
                       state := stgmtm;
                       inc(p);
                       pos := 0;
                       v := 0;
                       sep := yes;
                     end else
                       goto error;
                '0'..'9':
                     if sep in [no, perhaps] then
                     begin
                       state := stgmtm;
                       pos := 1;
                       sep := no;
                       inc(p);
                       v := ord(p^) - ord('0');
                     end else
                       goto error;
                #0: state := stgmtend;
              else
                goto error;
              end;

            end;
        end;
      end;
    stgmtm:
      case pos of
        0..1:  if get(v, p^) then
               begin
                 inc(p);
                 inc(pos);
               end else
                 goto error;
        2:  case p^ of
              #0:
                begin
                  state := stgmtend;
                  inc(st.bias, v);
                end;
            else
              goto error;
            end;
      end;
    stgmtend:
      begin
        if not inctz then
          st.bias := -st.bias;
        break;
      end;
    stend:
    begin

      break;
    end;
  end;

  if (st.hour >= 24) or (st.minute >= 60) or (st.second >= 60) or (st.ms >= 1000) or (st.week > 53)
    then goto error;

  if not havetz then
    st.bias := gettimebias;

  ms := st.ms + st.second * 1000 + (st.minute + st.bias) * 60000 + st.hour * 3600000;
  if havedate then
  begin
    daytable := @monthdays[isleapyear(st.year)];
    if st.month <> 0 then
    begin
      if not (st.month in [1..12]) or (daytable^[st.month] < st.day) then
        goto error;

      for v := 1 to  st.month - 1 do
        inc(ms, daytable^[v] * 86400000);
    end;
    dec(st.year);
    ms := ms + (int64((st.year * 365) + (st.year div 4) - (st.year div 100) +
      (st.year div 400) + st.day + st.dayofyear - 719163) * 86400000);
  end;

 result := true;
 exit;
error:
  result := false;
end;

function iso8601datetodelphidatetime(const str: sostring; var dt: tdatetime): boolean;
var
  ms: int64;
begin
  result := iso8601datetojavadatetime(str, ms);
  if result then
    dt := javatodelphidatetime(ms)
end;

function delphidatetimetoiso8601date(dt: tdatetime): sostring;
var
  year, month, day, hour, min, sec, msec: word;
  tzh: smallint;
  tzm: word;
  sign: sochar;
  bias: integer;
begin
  decodedate(dt, year, month, day);
  decodetime(dt, hour, min, sec, msec);
  bias := gettimebias;
  tzh := abs(bias) div 60;
  tzm := abs(bias) - tzh * 60;
  if bias > 0 then
    sign := '-' else
    sign := '+';
  result := format('%.4d-%.2d-%.2dt%.2d:%.2d:%.2d,%d%s%.2d:%.2d',
    [year, month, day, hour, min, sec, msec, sign, tzh, tzm]);
end;

function tryobjecttodate(const obj: isuperobject; var dt: tdatetime): boolean;
var
  i: int64;
begin
  case objectgettype(obj) of
  stint:
    begin
      dt := javatodelphidatetime(obj.asinteger);
      result := true;
    end;
  ststring:
    begin
      if iso8601datetojavadatetime(obj.asstring, i) then
      begin
        dt := javatodelphidatetime(i);
        result := true;
      end else
        result := trystrtodatetime(obj.asstring, dt);
    end;
  else
    result := false;
  end;
end;

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[0..sizeof(integer) - 1] of byte;
  pbytearray = ^tbytearray;
var
  j: integer;
  intf: iinterface;
begin
  result := tsuperobject.create(starray);
  for j := 0 to length(args) - 1 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^));


                    
热门评论
暂无评论,快去抢占沙发吧~

分享至

长按复制下方链接,去粘贴给好友吧:
请使用当前手机浏览器底部中间的“添加书签”功能进行收藏。
我知道了
软件
前端设计
程序设计
Java相关