我叫常冰川10319618
delphi 的 isuperobject 属性顺序为随机。但是很多时候，是需要按加入顺序进行读取。我也看了网上很多人有类似需求。也有人问过原作者，作者答复为：json协议规定为无序。看了我真是无语。
也看过网上一些人自己的修改，但是修改后有两个问题（网上的方法都不好，只能自己动手了）：
1. 性能急剧下降。原作者是用二叉树对性能做了极大的优化。但是网上修改的方法性能不行。
2. 属性数大于 32 时会出错。（原来用的是二叉树，修改后部分算法未修改，导致此问题）。
我采用的是重写遍历器的方法，和原版性能接近。
* 执行 500*500 数据的节点变更后，性能和原版差别不太大。
*
* 原始性能 0.280 秒
* 旧的稳定改版性能 15.774 秒
* 新的稳定改版性能 0.535 秒
*
* 性能是原版的 1.9 倍左右。而之前将二叉树变为链表的方法，导致性能变为 56 分之一。
* 温涛，于 2018-10-26。邮箱 delphi2006@163.com
把源码顺便贴上吧。
(*
* super object toolkit
*
* usage allowed under the restrictions of the lesser gnu general public license
* or alternatively the restrictions of the mozilla public license 1.1
*
* software distributed under the license is distributed on an "as is" basis,
* without warranty of any kind, either express or implied. see the license for
* the specific language governing rights and limitations under the license.
*
* unit owner : henri gourvest <hgourvest@gmail.com>
* web site : http://www.progdigy.com
*
* this unit is inspired from the json c lib:
* michael clark <michael@metaparadigm.com>
* http://oss.metaparadigm.com/json-c/
*
* changes:
* 终极改版来了，现在的改版增加了存储节点名称的功能。并且重写了遍历器，和原版性能接近。
* 执行 500*500 数据的节点变更后，性能和原版差别不太大。
*
* 原始性能 0.280 秒
* 旧的稳定改版性能 15.774 秒
* 新的稳定改版性能 0.535 秒
*
* 性能是原版的 1.9 倍左右。而之前将二叉树变为链表的方法，导致性能变为 56 分之一。
* 温涛，于 2018-10-26。邮箱 delphi2006@163.com
*
* v1.2
* + support of currency data type
* + right trim unquoted string
* + read unicode files and streams (litle endian with bom)
* + fix bug on javadate functions + windows nt compatibility
* + now you can force to parse only the canonical syntax of json using the stric parameter
* + delphi 2010 rtti marshalling
* v1.1
* + double licence mpl or lgpl.
* + delphi 2009 compatibility & unicode support.
* + asstring return a string instead of pchar.
* + escaped and unascaped json serialiser.
* + missed formfeed added \f
* - removed @ trick, uses forcepath() method instead.
* + fixed parse error with uppercase e symbol in numbers.
* + fixed possible buffer overflow when enlarging array.
* + added "delete", "pack", "insert" methods for arrays and/or objects
* + multi parametters when calling methods
* + delphi enumerator (for obj1 in obj2 do ...)
* + format method ex: obj.format('<%name%>%tab[1]%</%name%>')
* + parsefile and parsestream methods
* + parser now understand hexdecimal c syntax ex: \xff
* + null object design patern (ex: for obj in values.n['path'] do ...)
* v1.0
* + renamed class
* + interfaced object
* + added a new data type: the method
* + parser can now evaluate properties and call methods
* - removed obselet rpc class
* - removed "find" method, now you can use "parse" method instead
* v0.6
* + refactoring
* v0.5
* + new find method to get or set value using a path syntax
* ex: obj.s['obj.prop[1]'] := 'string value';
* obj.a['@obj.array'].b[n] := true; // @ -> create property if necessary
* v0.4
* + bug corrected: avl tree badly balanced.
* v0.3
* + new validator partially based on the kwalify syntax.
* + extended syntax to parse unquoted fields.
* + freepascal compatibility win32/64 linux32/64.
* + javatodelphidatetime and delphitojavadatetime improved for utc.
* + new tjsonobject.compare function.
* v0.2
* + hashed string list replaced with a faster avl tree
* + jsonint data type can be changed to int64
* + javatodelphidatetime and delphitojavadatetime helper fonctions
* + from json-c v0.7
* + add escaping of backslash to json output
* + add escaping of foward slash on tokenizing and output
* + changes to internal tokenizer from using recursion to
* using a depth state structure to allow incremental parsing
* v0.1
* + first release
*)
{$ifdef fpc}
{$mode objfpc}{$h+}
{$endif}
{$define super_method}
{$define windowsnt_compatibility}
{.$define debug} // track memory leack
{$if defined(fpc) or defined(ver170) or defined(ver180) or defined(ver190) or defined(ver200) or defined(ver210)}
{$define have_inline}
{$ifend}
{$if defined(ver210) or defined(ver220) or defined(ver230)}
{$define have_rtti}
{$ifend}
{$overflowchecks off}
{$rangechecks off}
{.$define tostringex}
unit superobjecttoolkit;
interface
uses
classes, sysutils
{$ifdef have_rtti}
,generics.collections, rtti, typinfo
{$endif}
, math, generics.defaults, variants;
type
{$ifndef fpc}
{$ifdef cpux64}
ptrint = int64;
ptruint = uint64;
{$else}
ptrint = longint;
ptruint = longword;
{$endif}
{$endif}
superint = int64;
{$if (sizeof(char) = 1)}
sochar = widechar;
soichar = word;
psochar = pwidechar;
{$ifdef fpc}
sostring = unicodestring;
{$else}
sostring = widestring;
{$endif}
{$else}
sochar = char;
soichar = word;
psochar = pchar;
sostring = string;
{$ifend}
const
super_array_list_default_size = 32;
super_tokener_max_depth = 32;
super_avl_max_depth = sizeof(longint) * 8;
super_avl_mask_high_bit = not ((not longword(0)) shr 1);
type
// forward declarations
tsuperobject = class;
isuperobject = interface;
tsuperarray = class;
(* avl tree
* this is a "special" autobalanced avl tree
* it use a hash value for fast compare
*)
{$ifdef super_method}
tsupermethod = procedure(const this, params: isuperobject; var result: isuperobject);
{$endif}
tsuperavlbitarray = set of 0..super_avl_max_depth - 1;
tsuperavlsearchtype = (stequal, stless, stgreater);
tsuperavlsearchtypes = set of tsuperavlsearchtype;
tsuperavliterator = class;
tsuperavlentry = class
private
fgt, flt: tsuperavlentry;
fbf: integer;
fhash: cardinal;
fname: sostring;
fptr: pointer;
function getvalue: isuperobject;
procedure setvalue(const val: isuperobject);
public
class function hash(const k: sostring): cardinal; virtual;
constructor create(const aname: sostring; obj: pointer); virtual;
property name: sostring read fname;
property ptr: pointer read fptr;
property value: isuperobject read getvalue write setvalue;
end;
tsuperavltree = class
private
froot: tsuperavlentry;
fcount: integer;
// wentao 添加了用于节点顺序的功能。
fnodenames: tstringlist;
function balance(bal: tsuperavlentry): tsuperavlentry;
protected
// wentao 添加了用于节点顺序的功能。
procedure addnodename(nodename: sostring);
procedure removenode(nodename: sostring);
procedure dodeleteentry(entry: tsuperavlentry; all: boolean); virtual;
function comparenodenode(node1, node2: tsuperavlentry): integer; virtual;
function comparekeynode(const k: sostring; h: tsuperavlentry): integer; virtual;
function insert(h: tsuperavlentry): tsuperavlentry; virtual;
function search(const k: sostring; st: tsuperavlsearchtypes = [stequal]): tsuperavlentry; virtual;
public
constructor create; virtual;
destructor destroy; override;
function isempty: boolean;
procedure clear(all: boolean = false); virtual;
procedure pack(all: boolean);
function delete(const k: sostring): isuperobject;
function getenumerator: tsuperavliterator;
property count: integer read fcount;
end;
tsupertablestring = class(tsuperavltree)
protected
procedure dodeleteentry(entry: tsuperavlentry; all: boolean); override;
procedure puto(const k: sostring; const value: isuperobject);
function geto(const k: sostring): isuperobject;
procedure puts(const k: sostring; const value: sostring);
function gets(const k: sostring): sostring;
procedure puti(const k: sostring; value: superint);
function geti(const k: sostring): superint;
procedure putd(const k: sostring; value: double);
function getd(const k: sostring): double;
procedure putb(const k: sostring; value: boolean);
function getb(const k: sostring): boolean;
{$ifdef super_method}
procedure putm(const k: sostring; value: tsupermethod);
function getm(const k: sostring): tsupermethod;
{$endif}
procedure putn(const k: sostring; const value: isuperobject);
function getn(const k: sostring): isuperobject;
procedure putc(const k: sostring; value: currency);
function getc(const k: sostring): currency;
public
property o[const k: sostring]: isuperobject read geto write puto; default;
property s[const k: sostring]: sostring read gets write puts;
property i[const k: sostring]: superint read geti write puti;
property d[const k: sostring]: double read getd write putd;
property b[const k: sostring]: boolean read getb write putb;
{$ifdef super_method}
property m[const k: sostring]: tsupermethod read getm write putm;
{$endif}
property n[const k: sostring]: isuperobject read getn write putn;
property c[const k: sostring]: currency read getc write putc;
function getvalues: isuperobject;
function getnames: isuperobject;
function find(const k: sostring; var value: isuperobject): boolean;
end;
tsuperavliterator = class
private
ftree: tsuperavltree;
// wentao 新的遍历方法只需要一个索引即可。
fcurnameindex: integer;
(* 旧的代码。
fbranch: tsuperavlbitarray;
fdepth: longint;
fpath: array[0..super_avl_max_depth - 2] of tsuperavlentry;
*)
public
constructor create(tree: tsuperavltree); virtual;
// wentao 新的 search 只支持等于的查找，不过原库中也没有用过非等于的查找。
procedure search(const k: sostring);
// 旧的代码：
// procedure search(const k: sostring; st: tsuperavlsearchtypes = [stequal]);
procedure first;
procedure last;
function getiter: tsuperavlentry;
procedure next;
procedure prior;
// delphi enumerator
function movenext: boolean;
property current: tsuperavlentry read getiter;
end;
tsuperobjectarray = array[0..(high(integer) div sizeof(tsuperobject))-1] of isuperobject;
psuperobjectarray = ^tsuperobjectarray;
tsuperarray = class
private
farray: psuperobjectarray;
flength: integer;
fsize: integer;
procedure expand(max: integer);
protected
function geto(const index: integer): isuperobject;
procedure puto(const index: integer; const value: isuperobject);
function getb(const index: integer): boolean;
procedure putb(const index: integer; value: boolean);
function geti(const index: integer): superint;
procedure puti(const index: integer; value: superint);
function getd(const index: integer): double;
procedure putd(const index: integer; value: double);
function getc(const index: integer): currency;
procedure putc(const index: integer; value: currency);
function gets(const index: integer): sostring;
procedure puts(const index: integer; const value: sostring);
{$ifdef super_method}
function getm(const index: integer): tsupermethod;
procedure putm(const index: integer; value: tsupermethod);
{$endif}
function getn(const index: integer): isuperobject;
procedure putn(const index: integer; const value: isuperobject);
public
constructor create; virtual;
destructor destroy; override;
function add(const data: isuperobject): integer;
function delete(index: integer): isuperobject;
procedure insert(index: integer; const value: isuperobject);
procedure clear(all: boolean = false);
procedure pack(all: boolean);
property length: integer read flength;
property n[const index: integer]: isuperobject read getn write putn;
property o[const index: integer]: isuperobject read geto write puto; default;
property b[const index: integer]: boolean read getb write putb;
property i[const index: integer]: superint read geti write puti;
property d[const index: integer]: double read getd write putd;
property c[const index: integer]: currency read getc write putc;
property s[const index: integer]: sostring read gets write puts;
{$ifdef super_method}
property m[const index: integer]: tsupermethod read getm write putm;
{$endif}
end;
tsuperwriter = class
public
// abstact methods to overide
function append(buf: psochar; size: integer): integer; overload; virtual; abstract;
function append(buf: psochar): integer; overload; virtual; abstract;
procedure reset; virtual; abstract;
end;
tsuperwriterstring = class(tsuperwriter)
private
fbuf: psochar;
fbpos: integer;
fsize: integer;
public
function append(buf: psochar; size: integer): integer; overload; override;
function append(buf: psochar): integer; overload; override;
procedure reset; override;
procedure trimright;
constructor create; virtual;
destructor destroy; override;
function getstring: sostring;
property data: psochar read fbuf;
property size: integer read fsize;
property position: integer read fbpos;
end;
tsuperwriterstream = class(tsuperwriter)
private
fstream: tstream;
public
function append(buf: psochar): integer; override;
procedure reset; override;
constructor create(astream: tstream); reintroduce; virtual;
end;
tsuperansiwriterstream = class(tsuperwriterstream)
public
function append(buf: psochar; size: integer): integer; override;
end;
tsuperunicodewriterstream = class(tsuperwriterstream)
public
function append(buf: psochar; size: integer): integer; override;
end;
tsuperwriterfake = class(tsuperwriter)
private
fsize: integer;
public
function append(buf: psochar; size: integer): integer; override;
function append(buf: psochar): integer; override;
procedure reset; override;
constructor create; reintroduce; virtual;
property size: integer read fsize;
end;
tsuperwritersock = class(tsuperwriter)
private
fsocket: longint;
fsize: integer;
public
function append(buf: psochar; size: integer): integer; override;
function append(buf: psochar): integer; override;
procedure reset; override;
constructor create(asocket: longint); reintroduce; virtual;
property socket: longint read fsocket;
property size: integer read fsize;
end;
tsupertokenizererror = (
tesuccess,
tecontinue,
tedepth,
teparseeof,
teparseunexpected,
teparsenull,
teparseboolean,
teparsenumber,
teparsearray,
teparseobjectkeyname,
teparseobjectkeysep,
teparseobjectvaluesep,
teparsestring,
teparsecomment,
teevalobject,
teevalarray,
teevalmethod,
teevalint
);
tsupertokenerstate = (
tseatws,
tsstart,
tsfinish,
tsnull,
tscommentstart,
tscomment,
tscommenteol,
tscommentend,
tsstring,
tsstringescape,
tsidentifier,
tsescapeunicode,
tsescapehexadecimal,
tsboolean,
tsnumber,
tsarray,
tsarrayadd,
tsarraysep,
tsobjectfieldstart,
tsobjectfield,
tsobjectunquotedfield,
tsobjectfieldend,
tsobjectvalue,
tsobjectvalueadd,
tsobjectsep,
tsevalproperty,
tsevalarray,
tsevalmethod,
tsparamvalue,
tsparamput,
tsmethodvalue,
tsmethodput
);
psupertokenersrec = ^tsupertokenersrec;
tsupertokenersrec = record
state, saved_state: tsupertokenerstate;
obj: isuperobject;
current: isuperobject;
field_name: sostring;
parent: isuperobject;
gparent: isuperobject;
end;
tsupertokenizer = class
public
str: psochar;
pb: tsuperwriterstring;
depth, is_double, floatcount, st_pos, char_offset: integer;
err: tsupertokenizererror;
ucs_char: word;
quote_char: sochar;
stack: array[0..super_tokener_max_depth-1] of tsupertokenersrec;
line, col: integer;
public
constructor create; virtual;
destructor destroy; override;
procedure resetlevel(adepth: integer);
procedure reset;
end;
// supported object types
tsupertype = (
stnull,
stboolean,
stdouble,
stcurrency,
stint,
stobject,
starray,
ststring
{$ifdef super_method}
,stmethod
{$endif}
);
tsupervalidateerror = (
verulemalformated,
vefieldisrequired,
veinvaliddatatype,
vefieldnotfound,
veunexpectedfield,
veduplicateentry,
vevaluenotinenum,
veinvalidlength,
veinvalidrange
);
tsuperfindoption = (
focreatepath,
foputvalue,
fodelete
{$ifdef super_method}
,focallmethod
{$endif}
);
tsuperfindoptions = set of tsuperfindoption;
tsupercompareresult = (cpless, cpequ, cpgreat, cperror);
tsuperonvalidateerror = procedure(sender: pointer; error: tsupervalidateerror; const objpath: sostring);
tsuperenumerator = class
private
fobj: isuperobject;
fobjenum: tsuperavliterator;
fcount: integer;
public
constructor create(const obj: isuperobject); virtual;
destructor destroy; override;
function movenext: boolean;
function getcurrent: isuperobject;
property current: isuperobject read getcurrent;
end;
tjsonformattype = (ftoneline, ftmultiline, ftarray, ftobjectarray);
isuperobject = interface
['{4b86a9e3-e094-4e5a-954a-69048b7b6327}']
function getenumerator: tsuperenumerator;
function getdatatype: tsupertype;
function getprocessing: boolean;
procedure setprocessing(value: boolean);
function forcepath(const path: sostring; datatype: tsupertype = stobject): isuperobject;
function format(const str: sostring; beginsep: sochar = '%'; endsep: sochar = '%'): sostring;
function geto(const path: sostring): isuperobject;
procedure puto(const path: sostring; const value: isuperobject);
function getb(const path: sostring): boolean;
procedure putb(const path: sostring; value: boolean);
function geti(const path: sostring): superint;
procedure puti(const path: sostring; value: superint);
function getd(const path: sostring): double;
procedure putc(const path: sostring; value: currency);
function getc(const path: sostring): currency;
procedure putd(const path: sostring; value: double);
function gets(const path: sostring): sostring;
procedure puts(const path: sostring; const value: sostring);
{$ifdef super_method}
function getm(const path: sostring): tsupermethod;
procedure putm(const path: sostring; value: tsupermethod);
{$endif}
function geta(const path: sostring): tsuperarray;
// null object design patern
function getn(const path: sostring): isuperobject;
procedure putn(const path: sostring; const value: isuperobject);
// writers
function write(writer: tsuperwriter; indent: boolean; escape: boolean; level: integer): integer;
function saveto(stream: tstream; indent: boolean = false; escape: boolean = true): integer; overload;
function saveto(const filename: string; indent: boolean = false; escape: boolean = true): integer; overload;
function saveto(socket: longint; indent: boolean = false; escape: boolean = true): integer; overload;
function calcsize(indent: boolean = false; escape: boolean = true): integer;
// convert
function asboolean: boolean;
function asinteger: superint;
function asdouble: double;
function ascurrency: currency;
function asstring: sostring;
function asarray: tsuperarray;
function asobject: tsupertablestring;
{$ifdef super_method}
function asmethod: tsupermethod;
{$endif}
function asjson(indent: boolean = false; escape: boolean = true): sostring;
procedure clear(all: boolean = false);
procedure pack(all: boolean = false);
property n[const path: sostring]: isuperobject read getn write putn;
property o[const path: sostring]: isuperobject read geto write puto; default;
property b[const path: sostring]: boolean read getb write putb;
property i[const path: sostring]: superint read geti write puti;
property d[const path: sostring]: double read getd write putd;
property c[const path: sostring]: currency read getc write putc;
property s[const path: sostring]: sostring read gets write puts;
{$ifdef super_method}
property m[const path: sostring]: tsupermethod read getm write putm;
{$endif}
property a[const path: sostring]: tsuperarray read geta;
{$ifdef super_method}
function call(const path: sostring; const param: isuperobject = nil): isuperobject; overload;
function call(const path, param: sostring): isuperobject; overload;
{$endif}
// clone a node
function clone: isuperobject;
function delete(const path: sostring): isuperobject;
// merges tow objects of same type, if reference is true then nodes are not cloned
procedure merge(const obj: isuperobject; reference: boolean = false); overload;
procedure merge(const str: sostring); overload;
// validate methods
function validate(const rules: sostring; const defs: sostring = ''; callback: tsuperonvalidateerror = nil; sender: pointer = nil): boolean; overload;
function validate(const rules: isuperobject; const defs: isuperobject = nil; callback: tsuperonvalidateerror = nil; sender: pointer = nil): boolean; overload;
// compare
function compare(const obj: isuperobject): tsupercompareresult; overload;
function compare(const str: sostring): tsupercompareresult; overload;
// the data type
function istype(atype: tsupertype): boolean;
property datatype: tsupertype read getdatatype;
property processing: boolean read getprocessing write setprocessing;
function getdataptr: pointer;
procedure setdataptr(const value: pointer);
property dataptr: pointer read getdataptr write setdataptr;
// wentao 新增加的排序、过滤接口。
// eachprop: 遍历每一个值的属性
// eachobj: 遍历每一个对象类型的属性
procedure foreachforproperty(eachprop: tproc<{key}string, {islast: }boolean>; eachobj: tproc<{key}string, {islast: }boolean>);
// 当 superobject 是 array 时，统计每一个列的最大宽度。
procedure calcmaxlen(lendict: tdictionary<string, integer>);
// 按特写字段排序
function sortbyfield(afieldname: string; adatatype: tsupertype = ststring): isuperobject;
function sort(oncompare: tfunc<isuperobject, isuperobject, integer>): isuperobject;
function filterbyfield(afieldname: string; avalue: variant; adatatype: tsupertype = ststring): isuperobject;
function filter(oncompare: tfunc<isuperobject, boolean>): isuperobject;
function foreachforarray(callback: tproc<{index: }integer, {item: }isuperobject, {islast: }boolean>): isuperobject;
function findbyfield(afieldname: string; avalue: variant; adatatype: tsupertype = ststring): isuperobject;
function find(oncompare: tfunc<isuperobject, boolean>): isuperobject;
function reverse: isuperobject;
{$ifdef tostringex}
function tostringex(ajsontype: tjsonformattype): string;
{$endif}
end;
tsuperobject = class(tobject, isuperobject)
private
frefcount: integer;
fprocessing: boolean;
fdatatype: tsupertype;
fdataptr: pointer;
{.$if true}
fo: record
case tsupertype of
stboolean: (c_boolean: boolean);
stdouble: (c_double: double);
stcurrency: (c_currency: currency);
stint: (c_int: superint);
stobject: (c_object: tsupertablestring);
starray: (c_array: tsuperarray);
{$ifdef super_method}
stmethod: (c_method: tsupermethod);
{$endif}
end;
{.$ifend}
fostring: sostring;
function getdatatype: tsupertype;
function getdataptr: pointer;
procedure setdataptr(const value: pointer);
procedure needarray;
protected
function queryinterface(const iid: tguid; out obj): hresult; virtual; stdcall;
function _addref: integer; virtual; stdcall;
function _release: integer; virtual; stdcall;
function geto(const path: sostring): isuperobject;
procedure puto(const path: sostring; const value: isuperobject);
function getb(const path: sostring): boolean;
procedure putb(const path: sostring; value: boolean);
function geti(const path: sostring): superint;
procedure puti(const path: sostring; value: superint);
function getd(const path: sostring): double;
procedure putd(const path: sostring; value: double);
procedure putc(const path: sostring; value: currency);
function getc(const path: sostring): currency;
function gets(const path: sostring): sostring;
procedure puts(const path: sostring; const value: sostring);
{$ifdef super_method}
function getm(const path: sostring): tsupermethod;
procedure putm(const path: sostring; value: tsupermethod);
{$endif}
function geta(const path: sostring): tsuperarray;
function write(writer: tsuperwriter; indent: boolean; escape: boolean; level: integer): integer; virtual;
public
function getenumerator: tsuperenumerator;
procedure afterconstruction; override;
procedure beforedestruction; override;
class function newinstance: tobject; override;
property refcount: integer read frefcount;
function getprocessing: boolean;
procedure setprocessing(value: boolean);
// writers
function saveto(stream: tstream; indent: boolean = false; escape: boolean = true): integer; overload;
function saveto(const filename: string; indent: boolean = false; escape: boolean = true): integer; overload;
function saveto(socket: longint; indent: boolean = false; escape: boolean = true): integer; overload;
function calcsize(indent: boolean = false; escape: boolean = true): integer;
function asjson(indent: boolean = false; escape: boolean = true): sostring;
// parser ... owned!
class function parsestring(s: psochar; strict: boolean; partial: boolean = true; const this: isuperobject = nil; options: tsuperfindoptions = [];
const put: isuperobject = nil; dt: tsupertype = stnull): isuperobject;
class function parsestream(stream: tstream; strict: boolean; partial: boolean = true; const this: isuperobject = nil; options: tsuperfindoptions = [];
const put: isuperobject = nil; dt: tsupertype = stnull): isuperobject;
class function parsefile(const filename: string; strict: boolean; partial: boolean = true; const this: isuperobject = nil; options: tsuperfindoptions = [];
const put: isuperobject = nil; dt: tsupertype = stnull): isuperobject;
class function parseex(tok: tsupertokenizer; str: psochar; len: integer; strict: boolean; const this: isuperobject = nil;
options: tsuperfindoptions = []; const put: isuperobject = nil; dt: tsupertype = stnull): isuperobject;
// constructors / destructor
constructor create(jt: tsupertype = stobject); overload; virtual;
constructor create(b: boolean); overload; virtual;
constructor create(i: superint); overload; virtual;
constructor create(d: double); overload; virtual;
constructor createcurrency(c: currency); overload; virtual;
constructor create(const s: sostring); overload; virtual;
{$ifdef super_method}
constructor create(m: tsupermethod); overload; virtual;
{$endif}
destructor destroy; override;
// convert
function asboolean: boolean; virtual;
function asinteger: superint; virtual;
function asdouble: double; virtual;
function ascurrency: currency; virtual;
function asstring: sostring; virtual;
function asarray: tsuperarray; virtual;
function asobject: tsupertablestring; virtual;
{$ifdef super_method}
function asmethod: tsupermethod; virtual;
{$endif}
procedure clear(all: boolean = false); virtual;
procedure pack(all: boolean = false); virtual;
function getn(const path: sostring): isuperobject;
procedure putn(const path: sostring; const value: isuperobject);
function forcepath(const path: sostring; datatype: tsupertype = stobject): isuperobject;
function format(const str: sostring; beginsep: sochar = '%'; endsep: sochar = '%'): sostring;
property n[const path: sostring]: isuperobject read getn write putn;
property o[const path: sostring]: isuperobject read geto write puto; default;
property b[const path: sostring]: boolean read getb write putb;
property i[const path: sostring]: superint read geti write puti;
property d[const path: sostring]: double read getd write putd;
property c[const path: sostring]: currency read getc write putc;
property s[const path: sostring]: sostring read gets write puts;
{$ifdef super_method}
property m[const path: sostring]: tsupermethod read getm write putm;
{$endif}
property a[const path: sostring]: tsuperarray read geta;
{$ifdef super_method}
function call(const path: sostring; const param: isuperobject = nil): isuperobject; overload; virtual;
function call(const path, param: sostring): isuperobject; overload; virtual;
{$endif}
// clone a node
function clone: isuperobject; virtual;
function delete(const path: sostring): isuperobject;
// merges tow objects of same type, if reference is true then nodes are not cloned
procedure merge(const obj: isuperobject; reference: boolean = false); overload;
procedure merge(const str: sostring); overload;
// validate methods
function validate(const rules: sostring; const defs: sostring = ''; callback: tsuperonvalidateerror = nil; sender: pointer = nil): boolean; overload;
function validate(const rules: isuperobject; const defs: isuperobject = nil; callback: tsuperonvalidateerror = nil; sender: pointer = nil): boolean; overload;
// compare
function compare(const obj: isuperobject): tsupercompareresult; overload;
function compare(const str: sostring): tsupercompareresult; overload;
// the data type
function istype(atype: tsupertype): boolean;
property datatype: tsupertype read getdatatype;
// a data pointer to link to something ele, a treeview for example
property dataptr: pointer read getdataptr write setdataptr;
property processing: boolean read getprocessing;
// wentao 新增加的排序、过滤接口。
procedure foreachforproperty(eachprop: tproc<{key}string, {islast: }boolean>; eachobj: tproc<{key}string, {islast: }boolean>);
procedure calcmaxlen(lendict: tdictionary<string, integer>);
function sortbyfield(afieldname: string; adatatype: tsupertype = ststring): isuperobject;
function sort(oncompare: tfunc<isuperobject, isuperobject, integer>): isuperobject;
function filterbyfield(afieldname: string; avalue: variant; adatatype: tsupertype = ststring): isuperobject;
function filter(oncompare: tfunc<isuperobject, boolean>): isuperobject;
function foreachforarray(callback: tproc<{index: }integer, {item: }isuperobject, {islast: }boolean>): isuperobject;
function findbyfield(afieldname: string; avalue: variant; adatatype: tsupertype = ststring): isuperobject;
function find(oncompare: tfunc<isuperobject, boolean>): isuperobject;
function reverse: isuperobject;
{$ifdef tostringex}
class function escapevalue(valuestr: sostring): sostring;
function tostringex(ajsontype: tjsonformattype): string;
{$endif}
end;
{$ifdef have_rtti}
tsuperrtticontext = class;
tserialfromjson = function(ctx: tsuperrtticontext; const obj: isuperobject; var value: tvalue): boolean;
tserialtojson = function(ctx: tsuperrtticontext; var value: tvalue; const index: isuperobject): isuperobject;
tsuperattribute = class(tcustomattribute)
private
fname: string;
public
constructor create(const aname: string);
property name: string read fname;
end;
soname = class(tsuperattribute);
sodefault = class(tsuperattribute);
tsuperrtticontext = class
private
class function getfieldname(r: trttifield): string;
class function getfielddefault(r: trttifield; const obj: isuperobject): isuperobject;
public
context: trtticontext;
serialfromjson: tdictionary<ptypeinfo, tserialfromjson>;
serialtojson: tdictionary<ptypeinfo, tserialtojson>;
constructor create; virtual;
destructor destroy; override;
function fromjson(typeinfo: ptypeinfo; const obj: isuperobject; var value: tvalue): boolean; virtual;
function tojson(var value: tvalue; const index: isuperobject): isuperobject; virtual;
function astype<t>(const obj: isuperobject): t;
function asjson<t>(const obj: t; const index: isuperobject = nil): isuperobject;
end;
tsuperobjecthelper = class helper for tobject
public
function tojson(ctx: tsuperrtticontext = nil): isuperobject;
constructor fromjson(const obj: isuperobject; ctx: tsuperrtticontext = nil); overload;
constructor fromjson(const str: string; ctx: tsuperrtticontext = nil); overload;
end;
{$endif}
tsuperobjectiter = record
key: sostring;
val: isuperobject;
ite: tsuperavliterator;
end;
function objectiserror(obj: tsuperobject): boolean;
function objectistype(const obj: isuperobject; typ: tsupertype): boolean;
function objectgettype(const obj: isuperobject): tsupertype;
function objectfindfirst(const obj: isuperobject; var f: tsuperobjectiter): boolean;
function objectfindnext(var f: tsuperobjectiter): boolean;
procedure objectfindclose(var f: tsuperobjectiter);
function so(const s: sostring = '{}'): isuperobject; overload;
function so(const value: variant): isuperobject; overload;
function so(const args: array of const): isuperobject; overload;
function sa(const args: array of const): isuperobject; overload;
function javatodelphidatetime(const dt: int64): tdatetime;
function delphitojavadatetime(const dt: tdatetime): int64;
function tryobjecttodate(const obj: isuperobject; var dt: tdatetime): boolean;
function iso8601datetojavadatetime(const str: sostring; var ms: int64): boolean;
function iso8601datetodelphidatetime(const str: sostring; var dt: tdatetime): boolean;
function delphidatetimetoiso8601date(dt: tdatetime): sostring;
{$ifdef have_rtti}
function uuidtostring(const g: tguid): string;
function stringtouuid(const str: string; var g: tguid): boolean;
type
tsuperinvokeresult = (
irsuccess,
irmethothoderror, // method don't exist
irparamerror, // invalid parametters
irerror // other error
);
function trysoinvoke(var ctx: tsuperrtticontext; const obj: tvalue; const method: string; const params: isuperobject; var return: isuperobject): tsuperinvokeresult; overload;
function soinvoke(const obj: tvalue; const method: string; const params: isuperobject; ctx: tsuperrtticontext = nil): isuperobject; overload;
function soinvoke(const obj: tvalue; const method: string; const params: string; ctx: tsuperrtticontext = nil): isuperobject; overload;
{$endif}
implementation
uses
{$ifdef tostringex} wtstrutility, {$endif}
{$ifdef unix}
baseunix, unix, dateutils
{$else}
windows
{$endif}
{$ifdef fpc}
,sockets
{$else}
,winsock
{$endif};
{$ifdef debug}
var
debugcount: integer = 0;
{$endif}
const
super_number_chars_set = ['0'..'9','.','+','-','e','e'];
super_hex_chars: psochar = '0123456789abcdef';
super_hex_chars_set = ['0'..'9','a'..'f','a'..'f'];
esc_bs: psochar = '\b';
esc_lf: psochar = '\n';
esc_cr: psochar = '\r';
esc_tab: psochar = '\t';
esc_ff: psochar = '\f';
esc_quot: psochar = '"';
esc_sl: psochar = '\\';
esc_sr: psochar = '/';
esc_zero: psochar = '0000';
tok_crlf: psochar = #13#10;
tok_sp: psochar = #32;
tok_bs: psochar = #8;
tok_tab: psochar = #9;
tok_lf: psochar = #10;
tok_ff: psochar = #12;
tok_cr: psochar = #13;
// tok_sl: psochar = '\';
// tok_sr: psochar = '/';
tok_null: psochar = 'null';
tok_cbl: psochar = '{'; // curly bracket left
tok_cbr: psochar = '}'; // curly bracket right
tok_arl: psochar = '[';
tok_arr: psochar = ']';
tok_array: psochar = '[]';
tok_obj: psochar = '{}'; // empty object
tok_com: psochar = ','; // comma
tok_dqt: psochar = '"'; // double quote
tok_true: psochar = 'true';
tok_false: psochar = 'false';
{$if (sizeof(char) = 1)}
function strlcomp(const str1, str2: psochar; maxlen: cardinal): integer;
var
p1, p2: pwidechar;
i: cardinal;
c1, c2: widechar;
begin
p1 := str1;
p2 := str2;
i := 0;
while i < maxlen do
begin
c1 := p1^;
c2 := p2^;
if (c1 <> c2) or (c1 = #0) then
begin
result := ord(c1) - ord(c2);
exit;
end;
inc(p1);
inc(p2);
inc(i);
end;
result := 0;
end;
function strcomp(const str1, str2: psochar): integer;
var
p1, p2: pwidechar;
c1, c2: widechar;
begin
p1 := str1;
p2 := str2;
while true do
begin
c1 := p1^;
c2 := p2^;
if (c1 <> c2) or (c1 = #0) then
begin
result := ord(c1) - ord(c2);
exit;
end;
inc(p1);
inc(p2);
end;
end;
function strlen(const str: psochar): cardinal;
var
p: psochar;
begin
result := 0;
if str <> nil then
begin
p := str;
while p^ <> #0 do inc(p);
result := (p - str);
end;
end;
{$ifend}
function floattojson(const value: double): sostring;
var
p: psochar;
begin
result := floattostr(value);
if decimalseparator <> '.' then
begin
p := psochar(result);
while p^ <> #0 do
if p^ <> sochar(decimalseparator) then
inc(p) else
begin
p^ := '.';
exit;
end;
end;
end;
function currtojson(const value: currency): sostring;
var
p: psochar;
begin
result := currtostr(value);
if decimalseparator <> '.' then
begin
p := psochar(result);
while p^ <> #0 do
if p^ <> sochar(decimalseparator) then
inc(p) else
begin
p^ := '.';
exit;
end;
end;
end;
{$ifdef unix}
function gettimebias: integer;
var
timeval: ttimeval;
timezone: ttimezone;
begin
fpgettimeofday(@timeval, @timezone);
result := timezone.tz_minuteswest;
end;
{$else}
function gettimebias: integer;
var
tzi : ttimezoneinformation;
begin
case gettimezoneinformation(tzi) of
time_zone_id_unknown : result := tzi.bias;
time_zone_id_standard: result := tzi.bias + tzi.standardbias;
time_zone_id_daylight: result := tzi.bias + tzi.daylightbias;
else
result := 0;
end;
end;
{$endif}
{$ifdef unix}
type
ptm = ^tm;
tm = record
tm_sec: integer; (* seconds: 0-59 (k&r says 0-61?) *)
tm_min: integer; (* minutes: 0-59 *)
tm_hour: integer; (* hours since midnight: 0-23 *)
tm_mday: integer; (* day of the month: 1-31 *)
tm_mon: integer; (* months *since* january: 0-11 *)
tm_year: integer; (* years since 1900 *)
tm_wday: integer; (* days since sunday (0-6) *)
tm_yday: integer; (* days since jan. 1: 0-365 *)
tm_isdst: integer; (* +1 daylight savings time, 0 no dst, -1 don't know *)
end;
function mktime(p: ptm): longint; cdecl; external;
function gmtime(const t: plongint): ptm; cdecl; external;
function localtime (const t: plongint): ptm; cdecl; external;
function delphitojavadatetime(const dt: tdatetime): int64;
var
p: ptm;
l, ms: integer;
v: int64;
begin
v := round((dt - 25569) * 86400000);
ms := v mod 1000;
l := v div 1000;
p := localtime(@l);
result := int64(mktime(p)) * 1000 + ms;
end;
function javatodelphidatetime(const dt: int64): tdatetime;
var
p: ptm;
l, ms: integer;
begin
l := dt div 1000;
ms := dt mod 1000;
p := gmtime(@l);
result := encodedatetime(p^.tm_year+1900, p^.tm_mon+1, p^.tm_mday, p^.tm_hour, p^.tm_min, p^.tm_sec, ms);
end;
{$else}
{$ifdef windowsnt_compatibility}
function daylightcomparedate(const date: psystemtime;
const comparedate: psystemtime): integer;
var
limit_day, dayinsecs, weekofmonth: integer;
first: word;
begin
if (date^.wmonth < comparedate^.wmonth) then
begin
result := -1; (* we are in a month before the date limit. *)
exit;
end;
if (date^.wmonth > comparedate^.wmonth) then
begin
result := 1; (* we are in a month after the date limit. *)
exit;
end;
(* if year is 0 then date is in day-of-week format, otherwise
* it's absolute date.
*)
if (comparedate^.wyear = 0) then
begin
(* comparedate.wday is interpreted as number of the week in the month
* 5 means: the last week in the month *)
weekofmonth := comparedate^.wday;
(* calculate the day of the first dayofweek in the month *)
first := (6 + comparedate^.wdayofweek - date^.wdayofweek + date^.wday) mod 7 + 1;
limit_day := first + 7 * (weekofmonth - 1);
(* check needed for the 5th weekday of the month *)
if (limit_day > monthdays[(date^.wmonth=2) and isleapyear(date^.wyear)][date^.wmonth]) then
dec(limit_day, 7);
end
else
limit_day := comparedate^.wday;
(* convert to seconds *)
limit_day := ((limit_day * 24 + comparedate^.whour) * 60 + comparedate^.wminute ) * 60;
dayinsecs := ((date^.wday * 24 + date^.whour) * 60 + date^.wminute ) * 60 + date^.wsecond;
(* and compare *)
if dayinsecs < limit_day then
result := -1 else
if dayinsecs > limit_day then
result := 1 else
result := 0; (* date is equal to the date limit. *)
end;
function comptimezoneid(const ptzinfo: ptimezoneinformation;
lpfiletime: pfiletime; islocal: boolean): longword;
var
ret: integer;
beforestandarddate, afterdaylightdate: boolean;
lltime: int64;
systime: tsystemtime;
fttemp: tfiletime;
begin
lltime := 0;
if (ptzinfo^.daylightdate.wmonth <> 0) then
begin
(* if year is 0 then date is in day-of-week format, otherwise
* it's absolute date.
*)
if ((ptzinfo^.standarddate.wmonth = 0) or
((ptzinfo^.standarddate.wyear = 0) and
((ptzinfo^.standarddate.wday < 1) or
(ptzinfo^.standarddate.wday > 5) or
(ptzinfo^.daylightdate.wday < 1) or
(ptzinfo^.daylightdate.wday > 5)))) then
begin
setlasterror(error_invalid_parameter);
result := time_zone_id_invalid;
exit;
end;
if (not islocal) then
begin
lltime := pint64(lpfiletime)^;
dec(lltime, int64(ptzinfo^.bias + ptzinfo^.daylightbias) * 600000000);
pint64(@fttemp)^ := lltime;
lpfiletime := @fttemp;
end;
filetimetosystemtime(lpfiletime^, systime);
(* check for daylight savings *)
ret := daylightcomparedate(@systime, @ptzinfo^.standarddate);
if (ret = -2) then
begin
result := time_zone_id_invalid;
exit;
end;
beforestandarddate := ret < 0;
if (not islocal) then
begin
dec(lltime, int64(ptzinfo^.standardbias - ptzinfo^.daylightbias) * 600000000);
pint64(@fttemp)^ := lltime;
filetimetosystemtime(lpfiletime^, systime);
end;
ret := daylightcomparedate(@systime, @ptzinfo^.daylightdate);
if (ret = -2) then
begin
result := time_zone_id_invalid;
exit;
end;
afterdaylightdate := ret >= 0;
result := time_zone_id_standard;
if( ptzinfo^.daylightdate.wmonth < ptzinfo^.standarddate.wmonth ) then
begin
(* northern hemisphere *)
if( beforestandarddate and afterdaylightdate) then
result := time_zone_id_daylight;
end else (* down south *)
if( beforestandarddate or afterdaylightdate) then
result := time_zone_id_daylight;
end else
(* no transition date *)
result := time_zone_id_unknown;
end;
function gettimezonebias(const ptzinfo: ptimezoneinformation;
lpfiletime: pfiletime; islocal: boolean; pbias: plongint): boolean;
var
bias: longint;
tzid: longword;
begin
bias := ptzinfo^.bias;
tzid := comptimezoneid(ptzinfo, lpfiletime, islocal);
if( tzid = time_zone_id_invalid) then
begin
result := false;
exit;
end;
if (tzid = time_zone_id_daylight) then
inc(bias, ptzinfo^.daylightbias)
else if (tzid = time_zone_id_standard) then
inc(bias, ptzinfo^.standardbias);
pbias^ := bias;
result := true;
end;
function systemtimetotzspecificlocaltime(
lptimezoneinformation: ptimezoneinformation;
lpuniversaltime, lplocaltime: psystemtime): bool;
var
ft: tfiletime;
lbias: longint;
lltime: int64;
tzinfo: ttimezoneinformation;
begin
if (lptimezoneinformation <> nil) then
tzinfo := lptimezoneinformation^ else
if (gettimezoneinformation(tzinfo) = time_zone_id_invalid) then
begin
result := false;
exit;
end;
if (not systemtimetofiletime(lpuniversaltime^, ft)) then
begin
result := false;
exit;
end;
lltime := pint64(@ft)^;
if (not gettimezonebias(@tzinfo, @ft, false, @lbias)) then
begin
result := false;
exit;
end;
(* convert minutes to 100-nanoseconds-ticks *)
dec(lltime, int64(lbias) * 600000000);
pint64(@ft)^ := lltime;
result := filetimetosystemtime(ft, lplocaltime^);
end;
function tzspecificlocaltimetosystemtime(
const lptimezoneinformation: ptimezoneinformation;
const lplocaltime: psystemtime; lpuniversaltime: psystemtime): bool;
var
ft: tfiletime;
lbias: longint;
t: int64;
tzinfo: ttimezoneinformation;
begin
if (lptimezoneinformation <> nil) then
tzinfo := lptimezoneinformation^
else
if (gettimezoneinformation(tzinfo) = time_zone_id_invalid) then
begin
result := false;
exit;
end;
if (not systemtimetofiletime(lplocaltime^, ft)) then
begin
result := false;
exit;
end;
t := pint64(@ft)^;
if (not gettimezonebias(@tzinfo, @ft, true, @lbias)) then
begin
result := false;
exit;
end;
(* convert minutes to 100-nanoseconds-ticks *)
inc(t, int64(lbias) * 600000000);
pint64(@ft)^ := t;
result := filetimetosystemtime(ft, lpuniversaltime^);
end;
{$else}
function tzspecificlocaltimetosystemtime(
lptimezoneinformation: ptimezoneinformation;
lplocaltime, lpuniversaltime: psystemtime): bool; stdcall; external 'kernel32.dll';
function systemtimetotzspecificlocaltime(
lptimezoneinformation: ptimezoneinformation;
lpuniversaltime, lplocaltime: psystemtime): bool; stdcall; external 'kernel32.dll';
{$endif}
function javatodelphidatetime(const dt: int64): tdatetime;
var
t: tsystemtime;
begin
datetimetosystemtime(25569 + (dt / 86400000), t);
systemtimetotzspecificlocaltime(nil, @t, @t);
result := systemtimetodatetime(t);
end;
function delphitojavadatetime(const dt: tdatetime): int64;
var
t: tsystemtime;
begin
datetimetosystemtime(dt, t);
tzspecificlocaltimetosystemtime(nil, @t, @t);
result := round((systemtimetodatetime(t) - 25569) * 86400000)
end;
{$endif}
function iso8601datetojavadatetime(const str: sostring; var ms: int64): boolean;
type
tstate = (
ststart, styear, stmonth, stweek, stweekday, stday, stdayofyear,
sthour, stmin, stsec, stms, stutc, stgmth, stgmtm,
stgmtend, stend);
tperhaps = (yes, no, perhaps);
tdatetimeinfo = record
year: word;
month: word;
week: word;
weekday: word;
day: word;
dayofyear: integer;
hour: word;
minute: word;
second: word;
ms: word;
bias: integer;
end;
var
p: psochar;
state: tstate;
pos, v: word;
sep: tperhaps;
inctz, havetz, havedate: boolean;
st: tdatetimeinfo;
daytable: pdaytable;
function get(var v: word; c: sochar): boolean; {$ifdef have_inline} inline;{$endif}
begin
if (c < #256) and (ansichar(c) in ['0'..'9']) then
begin
result := true;
v := v * 10 + ord(c) - ord('0');
end else
result := false;
end;
label
error;
begin
p := psochar(str);
sep := perhaps;
state := ststart;
pos := 0;
fillchar(st, sizeof(st), 0);
havedate := true;
inctz := false;
havetz := false;
while true do
case state of
ststart:
case p^ of
'0'..'9': state := styear;
't', 't':
begin
state := sthour;
pos := 0;
inc(p);
havedate := false;
end;
else
goto error;
end;
styear:
case pos of
0..1,3:
if get(st.year, p^) then
begin
inc(pos);
inc(p);
end else
goto error;
2: case p^ of
'0'..'9':
begin
st.year := st.year * 10 + ord(p^) - ord('0');
inc(pos);
inc(p);
end;
':':
begin
havedate := false;
st.hour := st.year;
st.year := 0;
inc(p);
pos := 0;
state := stmin;
sep := yes;
end;
else
goto error;
end;
4: case p^ of
'-': begin
pos := 0;
inc(p);
sep := yes;
state := stmonth;
end;
'0'..'9':
begin
sep := no;
pos := 0;
state := stmonth;
end;
'w', 'w' :
begin
pos := 0;
inc(p);
state := stweek;
end;
't', 't', ' ':
begin
state := sthour;
pos := 0;
inc(p);
st.month := 1;
st.day := 1;
end;
#0:
begin
st.month := 1;
st.day := 1;
state := stend;
end;
else
goto error;
end;
end;
stmonth:
case pos of
0: case p^ of
'0'..'9':
begin
st.month := ord(p^) - ord('0');
inc(pos);
inc(p);
end;
'w', 'w':
begin
pos := 0;
inc(p);
state := stweek;
end;
else
goto error;
end;
1: if get(st.month, p^) then
begin
inc(pos);
inc(p);
end else
goto error;
2: case p^ of
'-':
if (sep in [yes, perhaps]) then
begin
pos := 0;
inc(p);
state := stday;
sep := yes;
end else
goto error;
'0'..'9':
if sep in [no, perhaps] then
begin
pos := 0;
state := stday;
sep := no;
end else
begin
st.dayofyear := st.month * 10 + ord(p^) - ord('0');
st.month := 0;
inc(p);
pos := 3;
state := stdayofyear;
end;
't', 't', ' ':
begin
state := sthour;
pos := 0;
inc(p);
st.day := 1;
end;
#0:
begin
st.day := 1;
state := stend;
end;
else
goto error;
end;
end;
stday:
case pos of
0: if get(st.day, p^) then
begin
inc(pos);
inc(p);
end else
goto error;
1: if get(st.day, p^) then
begin
inc(pos);
inc(p);
end else
if sep in [no, perhaps] then
begin
st.dayofyear := st.month * 10 + st.day;
st.day := 0;
st.month := 0;
state := stdayofyear;
end else
goto error;
2: case p^ of
't', 't', ' ':
begin
pos := 0;
inc(p);
state := sthour;
end;
#0: state := stend;
else
goto error;
end;
end;
stdayofyear:
begin
if (st.dayofyear <= 0) then goto error;
case p^ of
't', 't', ' ':
begin
pos := 0;
inc(p);
state := sthour;
end;
#0: state := stend;
else
goto error;
end;
end;
stweek:
begin
case pos of
0..1: if get(st.week, p^) then
begin
inc(pos);
inc(p);
end else
goto error;
2: case p^ of
'-': if (sep in [yes, perhaps]) then
begin
inc(p);
state := stweekday;
sep := yes;
end else
goto error;
'1'..'7':
if sep in [no, perhaps] then
begin
state := stweekday;
sep := no;
end else
goto error;
else
goto error;
end;
end;
end;
stweekday:
begin
if (st.week > 0) and get(st.weekday, p^) then
begin
inc(p);
v := st.year - 1;
v := ((v * 365) + (v div 4) - (v div 100) + (v div 400)) mod 7 + 1;
st.dayofyear := (st.weekday - v) + ((st.week) * 7) + 1;
if v <= 4 then dec(st.dayofyear, 7);
case p^ of
't', 't', ' ':
begin
pos := 0;
inc(p);
state := sthour;
end;
#0: state := stend;
else
goto error;
end;
end else
goto error;
end;
sthour:
case pos of
0: case p^ of
'0'..'9':
if get(st.hour, p^) then
begin
inc(pos);
inc(p);
end else
goto error;
'-':
begin
inc(p);
state := stmin;
end;
else
goto error;
end;
1: if get(st.hour, p^) then
begin
inc(pos);
inc(p);
end else
goto error;
2: case p^ of
':': if sep in [yes, perhaps] then
begin
sep := yes;
pos := 0;
inc(p);
state := stmin;
end else
goto error;
',':
begin
inc(p);
state := stms;
end;
'+':
if havedate then
begin
state := stgmth;
pos := 0;
v := 0;
inc(p);
end else
goto error;
'-':
if havedate then
begin
state := stgmth;
pos := 0;
v := 0;
inc(p);
inctz := true;
end else
goto error;
'z', 'z':
if havedate then
state := stutc else
goto error;
'0'..'9':
if sep in [no, perhaps] then
begin
pos := 0;
state := stmin;
sep := no;
end else
goto error;
#0: state := stend;
else
goto error;
end;
end;
stmin:
case pos of
0: case p^ of
'0'..'9':
if get(st.minute, p^) then
begin
inc(pos);
inc(p);
end else
goto error;
'-':
begin
inc(p);
state := stsec;
end;
else
goto error;
end;
1: if get(st.minute, p^) then
begin
inc(pos);
inc(p);
end else
goto error;
2: case p^ of
':': if sep in [yes, perhaps] then
begin
pos := 0;
inc(p);
state := stsec;
sep := yes;
end else
goto error;
',':
begin
inc(p);
state := stms;
end;
'+':
if havedate then
begin
state := stgmth;
pos := 0;
v := 0;
inc(p);
end else
goto error;
'-':
if havedate then
begin
state := stgmth;
pos := 0;
v := 0;
inc(p);
inctz := true;
end else
goto error;
'z', 'z':
if havedate then
state := stutc else
goto error;
'0'..'9':
if sep in [no, perhaps] then
begin
pos := 0;
state := stsec;
end else
goto error;
#0: state := stend;
else
goto error;
end;
end;
stsec:
case pos of
0..1: if get(st.second, p^) then
begin
inc(pos);
inc(p);
end else
goto error;
2: case p^ of
',':
begin
inc(p);
state := stms;
end;
'+':
if havedate then
begin
state := stgmth;
pos := 0;
v := 0;
inc(p);
end else
goto error;
'-':
if havedate then
begin
state := stgmth;
pos := 0;
v := 0;
inc(p);
inctz := true;
end else
goto error;
'z', 'z':
if havedate then
state := stutc else
goto error;
#0: state := stend;
else
goto error;
end;
end;
stms:
case p^ of
'0'..'9':
begin
st.ms := st.ms * 10 + ord(p^) - ord('0');
inc(p);
end;
'+':
if havedate then
begin
state := stgmth;
pos := 0;
v := 0;
inc(p);
end else
goto error;
'-':
if havedate then
begin
state := stgmth;
pos := 0;
v := 0;
inc(p);
inctz := true;
end else
goto error;
'z', 'z':
if havedate then
state := stutc else
goto error;
#0: state := stend;
else
goto error;
end;
stutc: // = gmt 0
begin
havetz := true;
inc(p);
if p^ = #0 then
break else
goto error;
end;
stgmth:
begin
havetz := true;
case pos of
0..1: if get(v, p^) then
begin
inc(p);
inc(pos);
end else
goto error;
2:
begin
st.bias := v * 60;
case p^ of
':': if sep in [yes, perhaps] then
begin
state := stgmtm;
inc(p);
pos := 0;
v := 0;
sep := yes;
end else
goto error;
'0'..'9':
if sep in [no, perhaps] then
begin
state := stgmtm;
pos := 1;
sep := no;
inc(p);
v := ord(p^) - ord('0');
end else
goto error;
#0: state := stgmtend;
else
goto error;
end;
end;
end;
end;
stgmtm:
case pos of
0..1: if get(v, p^) then
begin
inc(p);
inc(pos);
end else
goto error;
2: case p^ of
#0:
begin
state := stgmtend;
inc(st.bias, v);
end;
else
goto error;
end;
end;
stgmtend:
begin
if not inctz then
st.bias := -st.bias;
break;
end;
stend:
begin
break;
end;
end;
if (st.hour >= 24) or (st.minute >= 60) or (st.second >= 60) or (st.ms >= 1000) or (st.week > 53)
then goto error;
if not havetz then
st.bias := gettimebias;
ms := st.ms + st.second * 1000 + (st.minute + st.bias) * 60000 + st.hour * 3600000;
if havedate then
begin
daytable := @monthdays[isleapyear(st.year)];
if st.month <> 0 then
begin
if not (st.month in [1..12]) or (daytable^[st.month] < st.day) then
goto error;
for v := 1 to st.month - 1 do
inc(ms, daytable^[v] * 86400000);
end;
dec(st.year);
ms := ms + (int64((st.year * 365) + (st.year div 4) - (st.year div 100) +
(st.year div 400) + st.day + st.dayofyear - 719163) * 86400000);
end;
result := true;
exit;
error:
result := false;
end;
function iso8601datetodelphidatetime(const str: sostring; var dt: tdatetime): boolean;
var
ms: int64;
begin
result := iso8601datetojavadatetime(str, ms);
if result then
dt := javatodelphidatetime(ms)
end;
function delphidatetimetoiso8601date(dt: tdatetime): sostring;
var
year, month, day, hour, min, sec, msec: word;
tzh: smallint;
tzm: word;
sign: sochar;
bias: integer;
begin
decodedate(dt, year, month, day);
decodetime(dt, hour, min, sec, msec);
bias := gettimebias;
tzh := abs(bias) div 60;
tzm := abs(bias) - tzh * 60;
if bias > 0 then
sign := '-' else
sign := '+';
result := format('%.4d-%.2d-%.2dt%.2d:%.2d:%.2d,%d%s%.2d:%.2d',
[year, month, day, hour, min, sec, msec, sign, tzh, tzm]);
end;
function tryobjecttodate(const obj: isuperobject; var dt: tdatetime): boolean;
var
i: int64;
begin
case objectgettype(obj) of
stint:
begin
dt := javatodelphidatetime(obj.asinteger);
result := true;
end;
ststring:
begin
if iso8601datetojavadatetime(obj.asstring, i) then
begin
dt := javatodelphidatetime(i);
result := true;
end else
result := trystrtodatetime(obj.asstring, dt);
end;
else
result := false;
end;
end;
function so(const s: sostring): isuperobject; overload;
begin
result := tsuperobject.parsestring(psochar(s), false);
end;
function sa(const args: array of const): isuperobject; overload;
type
tbytearray = array[0..sizeof(integer) - 1] of byte;
pbytearray = ^tbytearray;
var
j: integer;
intf: iinterface;
begin
result := tsuperobject.create(starray);
for j := 0 to length(args) - 1 do
with result.asarray do
case tvarrec(args[j]).vtype of
vtinteger : add(tsuperobject.create(tvarrec(args[j]).vinteger));
vtint64 : add(tsuperobject.create(tvarrec(args[j]).vint64^));
