欢迎您访问程序员文章站本站旨在为大家提供分享程序员计算机编程知识!
您现在的位置是: 首页  >  IT编程

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

程序员文章站 2022-03-10 11:38:25
Delphi 的 ISuperObject 属性顺序为随机。但是很多时候,是需要按加入顺序进行读取。我也看了网上很多人有类似需求。也有人问过原作者,作者答复为:JSON协议规定为无序。看了我真是无语。 也看过网上一些人自己的修改,但是修改后有两个问题(网上的方法都不好,只能自己动手了): 1. 性能 ......

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 = '\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 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^));


                    
                
(0)
打赏 SuperObject Delphi 的 JSON 属性乱序 - 操作类改造 - 关于属性顺序的问题 微信扫一扫

相关文章:

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

    【C++并发实战】(一)并发基本概念

    什么是并发 什么是并发 并发,最简单的理解就是,两个或者以上的活动同时进行。举个比较实际的例子,你可以手脚并用,两只手做不同的动作等等。 在计算机中... [阅读全文]
  • SuperObject Delphi 的 JSON 属性乱序 - 操作类改造 - 关于属性顺序的问题

    第二十一天- 基本模块

    1 from collections import Counter 2 3 s = "狗咬我一口,难道我还要去咬狗?" 4 # ... [阅读全文]
  • SuperObject Delphi 的 JSON 属性乱序 - 操作类改造 - 关于属性顺序的问题

    计算机基础

    1.什么是语言 语言是一个事物与另外一个事物沟通的介质 Python则是人与计算机沟通的介质2.什么是编程 编程就是程序员将自己想要让计算机做的事情... [阅读全文]
  • SuperObject Delphi 的 JSON 属性乱序 - 操作类改造 - 关于属性顺序的问题

    常用模块-01

    本节主要内容: 1.模块的简单认识 2.collections模块 3.time时间模块 4.random模块 5.os模块 6.sys模块 一.模... [阅读全文]
  • SuperObject Delphi 的 JSON 属性乱序 - 操作类改造 - 关于属性顺序的问题

    05替换空格

    题目描述: 请实现一个函数,将一个字符串中的每个空格替换成“%20”。例如,当字符串为We Are Happy.则经过替换之后的字符串为We%20A... [阅读全文]

版权声明:本文内容由互联网用户贡献,该文观点仅代表作者本人。本站仅提供信息存储服务,不拥有所有权,不承担相关法律责任。 如发现本站有涉嫌抄袭侵权/违法违规的内容, 请发送邮件至 2386932994@qq.com 举报,一经查实将立刻删除。

发表评论

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