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

把源码顺便贴上吧。

(* * 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> * web site : www.progdigy * * this unit is inspired from the json c lib: * michael clark <michael@metaparadigm> * oss.metaparadigm/json-c/ * * changes: * 终极改版来了，现在的改版增加了存储节点名称的功能。并且重写了遍历器，和原版性能接近。 * 执行 500*500 数据的节点变更后，性能和原版差别不太大。 * * 原始性能 0.280 秒 * 旧的稳定改版性能 15.774 秒 * 新的稳定改版性能 0.535 秒 * * 性能是原版的 1.9 倍左右。而之前将二叉树变为链表的方法，导致性能变为 56 分之一。 * 温涛，于 2018-10-26。邮箱 delphi2006@163 * * 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 tjsonobjectpare 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;interfaceuses 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}implementationuses{$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^));

• 0
• 0
• 0
• 0
• 0