SuperObject Delphi 的 JSON 屬性亂序 - 操作類改造 - 關於屬性順序的問題
阿新 • • 發佈：2018-11-15
Delphi 的 ISuperObject 屬性順序為隨機。但是很多時候，是需要按加入順序進行讀取。我也看了網上很多人有類似需求。也有人問過原作者，作者答覆為：JSON協議規定為無序。看了我真是無語。
也看過網上一些人自己的修改，但是修改後有兩個問題（網上的方法都不好，只能自己動手了）：
1. 效能急劇下降。原作者是用二叉樹對效能做了極大的優化。但是網上修改的方法效能不行。
2. 屬性數大於 32 時會出錯。（原來用的是二叉樹，修改後部分演算法未修改，導致此問題）。
我採用的是重寫遍歷器的方法，和原版效能接近。
* 執行 500*500 資料的節點變更後，效能和原版差別不太大。
*
* 原始效能 0.280 秒
* 舊的穩定改版效能 15.774 秒
* 新的穩定改版效能 0.535 秒
*
* 效能是原版的 1.9 倍左右。而之前將二叉樹變為連結串列的方法，導致效能變為 56 分之一。
* 溫濤，於 2018-10-26。郵箱 [email protected]
把原始碼順便貼上吧。
(* * 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 <[email protected]> * Web site : http://www.progdigy.com * * This unit is inspired from the json c lib: * Michael Clark <[email protected]> * http://oss.metaparadigm.com/json-c/ * * CHANGES: * 終極改版來了，現在的改版增加了儲存節點名稱的功能。並且重寫了遍歷器，和原版效能接近。 * 執行 500*500 資料的節點變更後，效能和原版差別不太大。 * * 原始效能 0.280 秒 * 舊的穩定改版效能 15.774 秒 * 新的穩定改版效能 0.535 秒 * * 效能是原版的 1.9 倍左右。而之前將二叉樹變為連結串列的方法，導致效能變為 56 分之一。 * 溫濤，於 2018-10-26。郵箱[email protected] * * v1.2 * + support of currency data type * + right trim unquoted string * + read Unicode Files and streams (Litle Endian with BOM) * + Fix bug on javadate functions + windows nt compatibility * + Now you can force to parse only the canonical syntax of JSON using the stric parameter * + Delphi 2010 RTTI marshalling * v1.1 * + Double licence MPL or LGPL. * + Delphi 2009 compatibility & Unicode support. * + AsString return a string instead of PChar. * + Escaped and Unascaped JSON serialiser. * + Missed FormFeed added \f * - Removed @ trick, uses forcepath() method instead. * + Fixed parse error with uppercase E symbol in numbers. * + Fixed possible buffer overflow when enlarging array. * + Added "delete", "pack", "insert" methods for arrays and/or objects * + Multi parametters when calling methods * + Delphi Enumerator (for obj1 in obj2 do ...) * + Format method ex: obj.format('<%name%>%tab[1]%</%name%>') * + ParseFile and ParseStream methods * + Parser now understand hexdecimal c syntax ex: \xFF * + Null Object Design Patern (ex: for obj in values.N['path'] do ...) * v1.0 * + renamed class * + interfaced object * + added a new data type: the method * + parser can now evaluate properties and call methods * - removed obselet rpc class * - removed "find" method, now you can use "parse" method instead * v0.6 * + refactoring * v0.5 * + new find method to get or set value using a path syntax * ex: obj.s['obj.prop[1]'] := 'string value'; * obj.a['@obj.array'].b[n] := true; // @ -> create property if necessary * v0.4 * + bug corrected: AVL tree badly balanced. * v0.3 * + New validator partially based on the Kwalify syntax. * + extended syntax to parse unquoted fields. * + Freepascal compatibility win32/64 Linux32/64. * + JavaToDelphiDateTime and DelphiToJavaDateTime improved for UTC. * + new TJsonObject.Compare function. * v0.2 * + Hashed string list replaced with a faster AVL tree * + JsonInt data type can be changed to int64 * + JavaToDelphiDateTime and DelphiToJavaDateTime helper fonctions * + from json-c v0.7 * + Add escaping of backslash to json output * + Add escaping of foward slash on tokenizing and output * + Changes to internal tokenizer from using recursion to * using a depth state structure to allow incremental parsing * v0.1 * + first release *) {$IFDEF FPC} {$MODE OBJFPC}{$H+} {$ENDIF} {$DEFINE SUPER_METHOD} {$DEFINE WINDOWSNT_COMPATIBILITY} {.$DEFINE DEBUG} // track memory leack {$if defined(FPC) or defined(VER170) or defined(VER180) or defined(VER190) or defined(VER200) or defined(VER210)} {$DEFINE HAVE_INLINE} {$ifend} {$if defined(VER210) or defined(VER220) or defined(VER230)} {$define HAVE_RTTI} {$ifend} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} {.$DEFINE ToStringEx} unit SuperObjectToolkit; interface uses Classes, SysUtils {$IFDEF HAVE_RTTI} ,Generics.Collections, RTTI, TypInfo {$ENDIF} , Math, Generics.Defaults, Variants; type {$IFNDEF FPC} {$IFDEF CPUX64} PtrInt = Int64; PtrUInt = UInt64; {$ELSE} PtrInt = longint; PtrUInt = Longword; {$ENDIF} {$ENDIF} SuperInt = Int64; {$if (sizeof(Char) = 1)} SOChar = WideChar; SOIChar = Word; PSOChar = PWideChar; {$IFDEF FPC} SOString = UnicodeString; {$ELSE} SOString = WideString; {$ENDIF} {$else} SOChar = Char; SOIChar = Word; PSOChar = PChar; SOString = string; {$ifend} const SUPER_ARRAY_LIST_DEFAULT_SIZE = 32; SUPER_TOKENER_MAX_DEPTH = 32; SUPER_AVL_MAX_DEPTH = sizeof(longint) * 8; SUPER_AVL_MASK_HIGH_BIT = not ((not longword(0)) shr 1); type // forward declarations TSuperObject = class; ISuperObject = interface; TSuperArray = class; (* AVL Tree * This is a "special" autobalanced AVL tree * It use a hash value for fast compare *) {$IFDEF SUPER_METHOD} TSuperMethod = procedure(const This, Params: ISuperObject; var Result: ISuperObject); {$ENDIF} TSuperAvlBitArray = set of 0..SUPER_AVL_MAX_DEPTH - 1; TSuperAvlSearchType = (stEQual, stLess, stGreater); TSuperAvlSearchTypes = set of TSuperAvlSearchType; TSuperAvlIterator = class; TSuperAvlEntry = class private FGt, FLt: TSuperAvlEntry; FBf: integer; FHash: Cardinal; FName: SOString; FPtr: Pointer; function GetValue: ISuperObject; procedure SetValue(const val: ISuperObject); public class function Hash(const k: SOString): Cardinal; virtual; constructor Create(const AName: SOString; Obj: Pointer); virtual; property Name: SOString read FName; property Ptr: Pointer read FPtr; property Value: ISuperObject read GetValue write SetValue; end; TSuperAvlTree = class private FRoot: TSuperAvlEntry; FCount: Integer; // WenTao 添加了用於節點順序的功能。 FNodeNames: TStringList; function balance(bal: TSuperAvlEntry): TSuperAvlEntry; protected // WenTao 添加了用於節點順序的功能。 procedure AddNodeName(nodeName: SOString); procedure RemoveNode(nodeName: SOString); procedure doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); virtual; function CompareNodeNode(node1, node2: TSuperAvlEntry): integer; virtual; function CompareKeyNode(const k: SOString; h: TSuperAvlEntry): integer; virtual; function Insert(h: TSuperAvlEntry): TSuperAvlEntry; virtual; function Search(const k: SOString; st: TSuperAvlSearchTypes = [stEqual]): TSuperAvlEntry; virtual; public constructor Create; virtual; destructor Destroy; override; function IsEmpty: boolean; procedure Clear(all: boolean = false); virtual; procedure Pack(all: boolean); function Delete(const k: SOString): ISuperObject; function GetEnumerator: TSuperAvlIterator; property count: Integer read FCount; end; TSuperTableString = class(TSuperAvlTree) protected procedure doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); override; procedure PutO(const k: SOString; const value: ISuperObject); function GetO(const k: SOString): ISuperObject; procedure PutS(const k: SOString; const value: SOString); function GetS(const k: SOString): SOString; procedure PutI(const k: SOString; value: SuperInt); function GetI(const k: SOString): SuperInt; procedure PutD(const k: SOString; value: Double); function GetD(const k: SOString): Double; procedure PutB(const k: SOString; value: Boolean); function GetB(const k: SOString): Boolean; {$IFDEF SUPER_METHOD} procedure PutM(const k: SOString; value: TSuperMethod); function GetM(const k: SOString): TSuperMethod; {$ENDIF} procedure PutN(const k: SOString; const value: ISuperObject); function GetN(const k: SOString): ISuperObject; procedure PutC(const k: SOString; value: Currency); function GetC(const k: SOString): Currency; public property O[const k: SOString]: ISuperObject read GetO write PutO; default; property S[const k: SOString]: SOString read GetS write PutS; property I[const k: SOString]: SuperInt read GetI write PutI; property D[const k: SOString]: Double read GetD write PutD; property B[const k: SOString]: Boolean read GetB write PutB; {$IFDEF SUPER_METHOD} property M[const k: SOString]: TSuperMethod read GetM write PutM; {$ENDIF} property N[const k: SOString]: ISuperObject read GetN write PutN; property C[const k: SOString]: Currency read GetC write PutC; function GetValues: ISuperObject; function GetNames: ISuperObject; function Find(const k: SOString; var value: ISuperObject): Boolean; end; TSuperAvlIterator = class private FTree: TSuperAvlTree; // WenTao 新的遍歷方法只需要一個索引即可。 FCurNameIndex: Integer; (* 舊的程式碼。 FBranch: TSuperAvlBitArray; FDepth: LongInt; FPath: array[0..SUPER_AVL_MAX_DEPTH - 2] of TSuperAvlEntry; *) public constructor Create(tree: TSuperAvlTree); virtual; // WenTao 新的 Search 只支援等於的查詢，不過原庫中也沒有用過非等於的查詢。 procedure Search(const k: SOString); // 舊的程式碼： // procedure Search(const k: SOString; st: TSuperAvlSearchTypes = [stEQual]); procedure First; procedure Last; function GetIter: TSuperAvlEntry; procedure Next; procedure Prior; // delphi enumerator function MoveNext: Boolean; property Current: TSuperAvlEntry read GetIter; end; TSuperObjectArray = array[0..(high(Integer) div sizeof(TSuperObject))-1] of ISuperObject; PSuperObjectArray = ^TSuperObjectArray; TSuperArray = class private FArray: PSuperObjectArray; FLength: Integer; FSize: Integer; procedure Expand(max: Integer); protected function GetO(const index: integer): ISuperObject; procedure PutO(const index: integer; const Value: ISuperObject); function GetB(const index: integer): Boolean; procedure PutB(const index: integer; Value: Boolean); function GetI(const index: integer): SuperInt; procedure PutI(const index: integer; Value: SuperInt); function GetD(const index: integer): Double; procedure PutD(const index: integer; Value: Double); function GetC(const index: integer): Currency; procedure PutC(const index: integer; Value: Currency); function GetS(const index: integer): SOString; procedure PutS(const index: integer; const Value: SOString); {$IFDEF SUPER_METHOD} function GetM(const index: integer): TSuperMethod; procedure PutM(const index: integer; Value: TSuperMethod); {$ENDIF} function GetN(const index: integer): ISuperObject; procedure PutN(const index: integer; const Value: ISuperObject); public constructor Create; virtual; destructor Destroy; override; function Add(const Data: ISuperObject): Integer; function Delete(index: Integer): ISuperObject; procedure Insert(index: Integer; const value: ISuperObject); procedure Clear(all: boolean = false); procedure Pack(all: boolean); property Length: Integer read FLength; property N[const index: integer]: ISuperObject read GetN write PutN; property O[const index: integer]: ISuperObject read GetO write PutO; default; property B[const index: integer]: boolean read GetB write PutB; property I[const index: integer]: SuperInt read GetI write PutI; property D[const index: integer]: Double read GetD write PutD; property C[const index: integer]: Currency read GetC write PutC; property S[const index: integer]: SOString read GetS write PutS; {$IFDEF SUPER_METHOD} property M[const index: integer]: TSuperMethod read GetM write PutM; {$ENDIF} end; TSuperWriter = class public // abstact methods to overide function Append(buf: PSOChar; Size: Integer): Integer; overload; virtual; abstract; function Append(buf: PSOChar): Integer; overload; virtual; abstract; procedure Reset; virtual; abstract; end; TSuperWriterString = class(TSuperWriter) private FBuf: PSOChar; FBPos: integer; FSize: integer; public function Append(buf: PSOChar; Size: Integer): Integer; overload; override; function Append(buf: PSOChar): Integer; overload; override; procedure Reset; override; procedure TrimRight; constructor Create; virtual; destructor Destroy; override; function GetString: SOString; property Data: PSOChar read FBuf; property Size: Integer read FSize; property Position: integer read FBPos; end; TSuperWriterStream = class(TSuperWriter) private FStream: TStream; public function Append(buf: PSOChar): Integer; override; procedure Reset; override; constructor Create(AStream: TStream); reintroduce; virtual; end; TSuperAnsiWriterStream = class(TSuperWriterStream) public function Append(buf: PSOChar; Size: Integer): Integer; override; end; TSuperUnicodeWriterStream = class(TSuperWriterStream) public function Append(buf: PSOChar; Size: Integer): Integer; override; end; TSuperWriterFake = class(TSuperWriter) private FSize: Integer; public function Append(buf: PSOChar; Size: Integer): Integer; override; function Append(buf: PSOChar): Integer; override; procedure Reset; override; constructor Create; reintroduce; virtual; property size: integer read FSize; end; TSuperWriterSock = class(TSuperWriter) private FSocket: longint; FSize: Integer; public function Append(buf: PSOChar; Size: Integer): Integer; override; function Append(buf: PSOChar): Integer; override; procedure Reset; override; constructor Create(ASocket: longint); reintroduce; virtual; property Socket: longint read FSocket; property Size: Integer read FSize; end; TSuperTokenizerError = ( teSuccess, teContinue, teDepth, teParseEof, teParseUnexpected, teParseNull, teParseBoolean, teParseNumber, teParseArray, teParseObjectKeyName, teParseObjectKeySep, teParseObjectValueSep, teParseString, teParseComment, teEvalObject, teEvalArray, teEvalMethod, teEvalInt ); TSuperTokenerState = ( tsEatws, tsStart, tsFinish, tsNull, tsCommentStart, tsComment, tsCommentEol, tsCommentEnd, tsString, tsStringEscape, tsIdentifier, tsEscapeUnicode, tsEscapeHexadecimal, tsBoolean, tsNumber, tsArray, tsArrayAdd, tsArraySep, tsObjectFieldStart, tsObjectField, tsObjectUnquotedField, tsObjectFieldEnd, tsObjectValue, tsObjectValueAdd, tsObjectSep, tsEvalProperty, tsEvalArray, tsEvalMethod, tsParamValue, tsParamPut, tsMethodValue, tsMethodPut ); PSuperTokenerSrec = ^TSuperTokenerSrec; TSuperTokenerSrec = record state, saved_state: TSuperTokenerState; obj: ISuperObject; current: ISuperObject; field_name: SOString; parent: ISuperObject; gparent: ISuperObject; end; TSuperTokenizer = class public str: PSOChar; pb: TSuperWriterString; depth, is_double, floatcount, st_pos, char_offset: Integer; err: TSuperTokenizerError; ucs_char: Word; quote_char: SOChar; stack: array[0..SUPER_TOKENER_MAX_DEPTH-1] of TSuperTokenerSrec; line, col: Integer; public constructor Create; virtual; destructor Destroy; override; procedure ResetLevel(adepth: integer); procedure Reset; end; // supported object types TSuperType = ( stNull, stBoolean, stDouble, stCurrency, stInt, stObject, stArray, stString {$IFDEF SUPER_METHOD} ,stMethod {$ENDIF} ); TSuperValidateError = ( veRuleMalformated, veFieldIsRequired, veInvalidDataType, veFieldNotFound, veUnexpectedField, veDuplicateEntry, veValueNotInEnum, veInvalidLength, veInvalidRange ); TSuperFindOption = ( foCreatePath, foPutValue, foDelete {$IFDEF SUPER_METHOD} ,foCallMethod {$ENDIF} ); TSuperFindOptions = set of TSuperFindOption; TSuperCompareResult = (cpLess, cpEqu, cpGreat, cpError); TSuperOnValidateError = procedure(sender: Pointer; error: TSuperValidateError; const objpath: SOString); TSuperEnumerator = class private FObj: ISuperObject; FObjEnum: TSuperAvlIterator; FCount: Integer; public constructor Create(const obj: ISuperObject); virtual; destructor Destroy; override; function MoveNext: Boolean; function GetCurrent: ISuperObject; property Current: ISuperObject read GetCurrent; end; TJsonFormatType = (ftOneLine, ftMultiLine, ftArray, ftObjectArray); ISuperObject = interface ['{4B86A9E3-E094-4E5A-954A-69048B7B6327}'] function GetEnumerator: TSuperEnumerator; function GetDataType: TSuperType; function GetProcessing: boolean; procedure SetProcessing(value: boolean); function ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject; function Format(const str: SOString; BeginSep: SOChar = '%'; EndSep: SOChar = '%'): SOString; function GetO(const path: SOString): ISuperObject; procedure PutO(const path: SOString; const Value: ISuperObject); function GetB(const path: SOString): Boolean; procedure PutB(const path: SOString; Value: Boolean); function GetI(const path: SOString): SuperInt; procedure PutI(const path: SOString; Value: SuperInt); function GetD(const path: SOString): Double; procedure PutC(const path: SOString; Value: Currency); function GetC(const path: SOString): Currency; procedure PutD(const path: SOString; Value: Double); function GetS(const path: SOString): SOString; procedure PutS(const path: SOString; const Value: SOString); {$IFDEF SUPER_METHOD} function GetM(const path: SOString): TSuperMethod; procedure PutM(const path: SOString; Value: TSuperMethod); {$ENDIF} function GetA(const path: SOString): TSuperArray; // Null Object Design patern function GetN(const path: SOString): ISuperObject; procedure PutN(const path: SOString; const Value: ISuperObject); // Writers function Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer; function SaveTo(stream: TStream; indent: boolean = false; escape: boolean = true): integer; overload; function SaveTo(const FileName: string; indent: boolean = false; escape: boolean = true): integer; overload; function SaveTo(socket: longint; indent: boolean = false; escape: boolean = true): integer; overload; function CalcSize(indent: boolean = false; escape: boolean = true): integer; // convert function AsBoolean: Boolean; function AsInteger: SuperInt; function AsDouble: Double; function AsCurrency: Currency; function AsString: SOString; function AsArray: TSuperArray; function AsObject: TSuperTableString; {$IFDEF SUPER_METHOD} function AsMethod: TSuperMethod; {$ENDIF} function AsJSon(indent: boolean = false; escape: boolean = true): SOString; procedure Clear(all: boolean = false); procedure Pack(all: boolean = false); property N[const path: SOString]: ISuperObject read GetN write PutN; property O[const path: SOString]: ISuperObject read GetO write PutO; default; property B[const path: SOString]: boolean read GetB write PutB; property I[const path: SOString]: SuperInt read GetI write PutI; property D[const path: SOString]: Double read GetD write PutD; property C[const path: SOString]: Currency read GetC write PutC; property S[const path: SOString]: SOString read GetS write PutS; {$IFDEF SUPER_METHOD} property M[const path: SOString]: TSuperMethod read GetM write PutM; {$ENDIF} property A[const path: SOString]: TSuperArray read GetA; {$IFDEF SUPER_METHOD} function call(const path: SOString; const param: ISuperObject = nil): ISuperObject; overload; function call(const path, param: SOString): ISuperObject; overload; {$ENDIF} // clone a node function Clone: ISuperObject; function Delete(const path: SOString): ISuperObject; // merges tow objects of same type, if reference is true then nodes are not cloned procedure Merge(const obj: ISuperObject; reference: boolean = false); overload; procedure Merge(const str: SOString); overload; // validate methods function Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload; function Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload; // compare function Compare(const obj: ISuperObject): TSuperCompareResult; overload; function Compare(const str: SOString): TSuperCompareResult; overload; // the data type function IsType(AType: TSuperType): boolean; property DataType: TSuperType read GetDataType; property Processing: boolean read GetProcessing write SetProcessing; function GetDataPtr: Pointer; procedure SetDataPtr(const Value: Pointer); property DataPtr: Pointer read GetDataPtr write SetDataPtr; // WenTao 新增加的排序、過濾介面。 // eachProp: 遍歷每一個值的屬性 // eachObj: 遍歷每一個物件型別的屬性 procedure forEachForProperty(eachProp: TProc<{Key}String, {isLast: }Boolean>; eachObj: TProc<{Key}String, {isLast: }Boolean>); // 當 SuperObject 是 Array 時，統計每一個列的最大寬度。 procedure calcMaxLen(lenDict: TDictionary<String, Integer>); // 按特寫欄位排序 function sortByField(AFieldName: String; ADataType: TSuperType = stString): ISuperObject; function sort(onCompare: TFunc<ISuperObject, ISuperObject, Integer>): ISuperObject; function filterByField(AFieldName: String; AValue: Variant; ADataType: TSuperType = stString): ISuperObject; function filter(onCompare: TFunc<ISuperObject, Boolean>): ISuperObject; function forEachForArray(callback: TProc<{Index: }Integer, {item: }ISuperObject, {isLast: }Boolean>): ISuperObject; function findByField(AFieldName: String; AValue: Variant; ADataType: TSuperType = stString): ISuperObject; function find(onCompare: TFunc<ISuperObject, Boolean>): ISuperObject; function reverse: ISuperObject; {$IFDEF ToStringEx} function toStringEx(AJsonType: TJsonFormatType): String; {$ENDIF} end; TSuperObject = class(TObject, ISuperObject) private FRefCount: Integer; FProcessing: boolean; FDataType: TSuperType; FDataPtr: Pointer; {.$if true} FO: record case TSuperType of stBoolean: (c_boolean: boolean); stDouble: (c_double: double); stCurrency: (c_currency: Currency); stInt: (c_int: SuperInt); stObject: (c_object: TSuperTableString); stArray: (c_array: TSuperArray); {$IFDEF SUPER_METHOD} stMethod: (c_method: TSuperMethod); {$ENDIF} end; {.$ifend} FOString: SOString; function GetDataType: TSuperType; function GetDataPtr: Pointer; procedure SetDataPtr(const Value: Pointer); procedure needArray; protected function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall; function _AddRef: Integer; virtual; stdcall; function _Release: Integer; virtual; stdcall; function GetO(const path: SOString): ISuperObject; procedure PutO(const path: SOString; const Value: ISuperObject); function GetB(const path: SOString): Boolean; procedure PutB(const path: SOString; Value: Boolean); function GetI(const path: SOString): SuperInt; procedure PutI(const path: SOString; Value: SuperInt); function GetD(const path: SOString): Double; procedure PutD(const path: SOString; Value: Double); procedure PutC(const path: SOString; Value: Currency); function GetC(const path: SOString): Currency; function GetS(const path: SOString): SOString; procedure PutS(const path: SOString; const Value: SOString); {$IFDEF SUPER_METHOD} function GetM(const path: SOString): TSuperMethod; procedure PutM(const path: SOString; Value: TSuperMethod); {$ENDIF} function GetA(const path: SOString): TSuperArray; function Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer; virtual; public function GetEnumerator: TSuperEnumerator; procedure AfterConstruction; override; procedure BeforeDestruction; override; class function NewInstance: TObject; override; property RefCount: Integer read FRefCount; function GetProcessing: boolean; procedure SetProcessing(value: boolean); // Writers function SaveTo(stream: TStream; indent: boolean = false; escape: boolean = true): integer; overload; function SaveTo(const FileName: string; indent: boolean = false; escape: boolean = true): integer; overload; function SaveTo(socket: longint; indent: boolean = false; escape: boolean = true): integer; overload; function CalcSize(indent: boolean = false; escape: boolean = true): integer; function AsJSon(indent: boolean = false; escape: boolean = true): SOString; // parser ... owned! class function ParseString(s: PSOChar; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = []; const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject; class function ParseStream(stream: TStream; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = []; const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject; class function ParseFile(const FileName: string; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = []; const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject; class function ParseEx(tok: TSuperTokenizer; str: PSOChar; len: integer; strict: Boolean; const this: ISuperObject = nil; options: TSuperFindOptions = []; const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject; // constructors / destructor constructor Create(jt: TSuperType = stObject); overload; virtual; constructor Create(b: boolean); overload; virtual; constructor Create(i: SuperInt); overload; virtual; constructor Create(d: double); overload; virtual; constructor CreateCurrency(c: Currency); overload; virtual; constructor Create(const s: SOString); overload; virtual; {$IFDEF SUPER_METHOD} constructor Create(m: TSuperMethod); overload; virtual; {$ENDIF} destructor Destroy; override; // convert function AsBoolean: Boolean; virtual; function AsInteger: SuperInt; virtual; function AsDouble: Double; virtual; function AsCurrency: Currency; virtual; function AsString: SOString; virtual; function AsArray: TSuperArray; virtual; function AsObject: TSuperTableString; virtual; {$IFDEF SUPER_METHOD} function AsMethod: TSuperMethod; virtual; {$ENDIF} procedure Clear(all: boolean = false); virtual; procedure Pack(all: boolean = false); virtual; function GetN(const path: SOString): ISuperObject; procedure PutN(const path: SOString; const Value: ISuperObject); function ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject; function Format(const str: SOString; BeginSep: SOChar = '%'; EndSep: SOChar = '%'): SOString; property N[const path: SOString]: ISuperObject read GetN write PutN; property O[const path: SOString]: ISuperObject read GetO write PutO; default; property B[const path: SOString]: boolean read GetB write PutB; property I[const path: SOString]: SuperInt read GetI write PutI; property D[const path: SOString]: Double read GetD write PutD; property C[const path: SOString]: Currency read GetC write PutC; property S[const path: SOString]: SOString read GetS write PutS; {$IFDEF SUPER_METHOD} property M[const path: SOString]: TSuperMethod read GetM write PutM; {$ENDIF} property A[const path: SOString]: TSuperArray read GetA; {$IFDEF SUPER_METHOD} function call(const path: SOString; const param: ISuperObject = nil): ISuperObject; overload; virtual; function call(const path, param: SOString): ISuperObject; overload; virtual; {$ENDIF} // clone a node function Clone: ISuperObject; virtual; function Delete(const path: SOString): ISuperObject; // merges tow objects of same type, if reference is true then nodes are not cloned procedure Merge(const obj: ISuperObject; reference: boolean = false); overload; procedure Merge(const str: SOString); overload; // validate methods function Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload; function Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload; // compare function Compare(const obj: ISuperObject): TSuperCompareResult; overload; function Compare(const str: SOString): TSuperCompareResult; overload; // the data type function IsType(AType: TSuperType): boolean; property DataType: TSuperType read GetDataType; // a data pointer to link to something ele, a treeview for example property DataPtr: Pointer read GetDataPtr write SetDataPtr; property Processing: boolean read GetProcessing; // WenTao 新增加的排序、過濾介面。 procedure forEachForProperty(eachProp: TProc<{Key}String, {isLast: }Boolean>; eachObj: TProc<{Key}String, {isLast: }Boolean>); procedure calcMaxLen(lenDict: TDictionary<String, Integer>); function sortByField(AFieldName: String; ADataType: TSuperType = stString): ISuperObject; function sort(onCompare: TFunc<ISuperObject, ISuperObject, Integer>): ISuperObject; function filterByField(AFieldName: String; AValue: Variant; ADataType: TSuperType = stString): ISuperObject; function filter(onCompare: TFunc<ISuperObject, Boolean>): ISuperObject; function forEachForArray(callback: TProc<{Index: }Integer, {item: }ISuperObject, {isLast: }Boolean>): ISuperObject; function findByField(AFieldName: String; AValue: Variant; ADataType: TSuperType = stString): ISuperObject; function find(onCompare: TFunc<ISuperObject, Boolean>): ISuperObject; function reverse: ISuperObject; {$IFDEF ToStringEx} class function escapeValue(valueStr: SOString): SOString; function toStringEx(AJsonType: TJsonFormatType): String; {$ENDIF} end; {$IFDEF HAVE_RTTI} TSuperRttiContext = class; TSerialFromJson = function(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean; TSerialToJson = function(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject; TSuperAttribute = class(TCustomAttribute) private FName: string; public constructor Create(const AName: string); property Name: string read FName; end; SOName = class(TSuperAttribute); SODefault = class(TSuperAttribute); TSuperRttiContext = class private class function GetFieldName(r: TRttiField): string; class function GetFieldDefault(r: TRttiField; const obj: ISuperObject): ISuperObject; public Context: TRttiContext; SerialFromJson: TDictionary<PTypeInfo, TSerialFromJson>; SerialToJson: TDictionary<PTypeInfo, TSerialToJson>; constructor Create; virtual; destructor Destroy; override; function FromJson(TypeInfo: PTypeInfo; const obj: ISuperObject; var Value: TValue): Boolean; virtual; function ToJson(var value: TValue; const index: ISuperObject): ISuperObject; virtual; function AsType<T>(const obj: ISuperObject): T; function AsJson<T>(const obj: T; const index: ISuperObject = nil): ISuperObject; end; TSuperObjectHelper = class helper for TObject public function ToJson(ctx: TSuperRttiContext = nil): ISuperObject; constructor FromJson(const obj: ISuperObject; ctx: TSuperRttiContext = nil); overload; constructor FromJson(const str: string; ctx: TSuperRttiContext = nil); overload; end; {$ENDIF} TSuperObjectIter = record key: SOString; val: ISuperObject; Ite: TSuperAvlIterator; end; function ObjectIsError(obj: TSuperObject): boolean; function ObjectIsType(const obj: ISuperObject; typ: TSuperType): boolean; function ObjectGetType(const obj: ISuperObject): TSuperType; function ObjectFindFirst(const obj: ISuperObject; var F: TSuperObjectIter): boolean; function ObjectFindNext(var F: TSuperObjectIter): boolean; procedure ObjectFindClose(var F: TSuperObjectIter); function SO(const s: SOString = '{}'): ISuperObject; overload; function SO(const value: Variant): ISuperObject; overload; function SO(const Args: array of const): ISuperObject; overload; function SA(const Args: array of const): ISuperObject; overload; function JavaToDelphiDateTime(const dt: int64): TDateTime; function DelphiToJavaDateTime(const dt: TDateTime): int64; function TryObjectToDate(const obj: ISuperObject; var dt: TDateTime): Boolean; function ISO8601DateToJavaDateTime(const str: SOString; var ms: Int64): Boolean; function ISO8601DateToDelphiDateTime(const str: SOString; var dt: TDateTime): Boolean; function DelphiDateTimeToISO8601Date(dt: TDateTime): SOString; {$IFDEF HAVE_RTTI} function UUIDToString(const g: TGUID): string; function StringToUUID(const str: string; var g: TGUID): Boolean; type TSuperInvokeResult = ( irSuccess, irMethothodError, // method don't exist irParamError, // invalid parametters irError // other error ); function TrySOInvoke(var ctx: TSuperRttiContext; const obj: TValue; const method: string; const params: ISuperObject; var Return: ISuperObject): TSuperInvokeResult; overload; function SOInvoke(const obj: TValue; const method: string; const params: ISuperObject; ctx: TSuperRttiContext = nil): ISuperObject; overload; function SOInvoke(const obj: TValue; const method: string; const params: string; ctx: TSuperRttiContext = nil): ISuperObject; overload; {$ENDIF} implementation uses {$IFDEF ToStringEx} wtStrUtility, {$ENDIF} {$IFDEF UNIX} baseunix, unix, DateUtils {$ELSE} Windows {$ENDIF} {$IFDEF FPC} ,sockets {$ELSE} ,WinSock {$ENDIF}; {$IFDEF DEBUG} var debugcount: integer = 0; {$ENDIF} const super_number_chars_set = ['0'..'9','.','+','-','e','E']; super_hex_chars: PSOChar = '0123456789abcdef'; super_hex_chars_set = ['0'..'9','a'..'f','A'..'F']; ESC_BS: PSOChar = '\b'; ESC_LF: PSOChar = '\n'; ESC_CR: PSOChar = '\r'; ESC_TAB: PSOChar = '\t'; ESC_FF: PSOChar = '\f'; ESC_QUOT: PSOChar = '\"'; ESC_SL: PSOChar = '\\'; ESC_SR: PSOChar = '\/'; ESC_ZERO: PSOChar = '\u0000'; TOK_CRLF: PSOChar = #13#10; TOK_SP: PSOChar = #32; TOK_BS: PSOChar = #8; TOK_TAB: PSOChar = #9; TOK_LF: PSOChar = #10; TOK_FF: PSOChar = #12; TOK_CR: PSOChar = #13; // TOK_SL: PSOChar = '\'; // TOK_SR: PSOChar = '/'; TOK_NULL: PSOChar = 'null'; TOK_CBL: PSOChar = '{'; // curly bracket left TOK_CBR: PSOChar = '}'; // curly bracket right TOK_ARL: PSOChar = '['; TOK_ARR: PSOChar = ']'; TOK_ARRAY: PSOChar = '[]'; TOK_OBJ: PSOChar = '{}'; // empty object TOK_COM: PSOChar = ','; // Comma TOK_DQT: PSOChar = '"'; // Double Quote TOK_TRUE: PSOChar = 'true'; TOK_FALSE: PSOChar = 'false'; {$if (sizeof(Char) = 1)} function StrLComp(const Str1, Str2: PSOChar; MaxLen: Cardinal): Integer; var P1, P2: PWideChar; I: Cardinal; C1, C2: WideChar; begin P1 := Str1; P2 := Str2; I := 0; while I < MaxLen do begin C1 := P1^; C2 := P2^; if (C1 <> C2) or (C1 = #0) then begin Result := Ord(C1) - Ord(C2); Exit; end; Inc(P1); Inc(P2); Inc(I); end; Result := 0; end; function StrComp(const Str1, Str2: PSOChar): Integer; var P1, P2: PWideChar; C1, C2: WideChar; begin P1 := Str1; P2 := Str2; while True do begin C1 := P1^; C2 := P2^; if (C1 <> C2) or (C1 = #0) then begin Result := Ord(C1) - Ord(C2); Exit; end; Inc(P1); Inc(P2); end; end; function StrLen(const Str: PSOChar): Cardinal; var p: PSOChar; begin Result := 0; if Str <> nil then begin p := Str; while p^ <> #0 do inc(p); Result := (p - Str); end; end; {$ifend} function FloatToJson(const value: Double): SOString; var p: PSOChar; begin Result := FloatToStr(value); if DecimalSeparator <> '.' then begin p := PSOChar(Result); while p^ <> #0 do if p^ <> SOChar(DecimalSeparator) then inc(p) else begin p^ := '.'; Exit; end; end; end; function CurrToJson(const value: Currency): SOString; var p: PSOChar; begin Result := CurrToStr(value); if DecimalSeparator <> '.' then begin p := PSOChar(Result); while p^ <> #0 do if p^ <> SOChar(DecimalSeparator) then inc(p) else begin p^ := '.'; Exit; end; end; end; {$IFDEF UNIX} function GetTimeBias: integer; var TimeVal: TTimeVal; TimeZone: TTimeZone; begin fpGetTimeOfDay(@TimeVal, @TimeZone); Result := TimeZone.tz_minuteswest; end; {$ELSE} function GetTimeBias: integer; var tzi : TTimeZoneInformation; begin case GetTimeZoneInformation(tzi) of TIME_ZONE_ID_UNKNOWN : Result := tzi.Bias; TIME_ZONE_ID_STANDARD: Result := tzi.Bias + tzi.StandardBias; TIME_ZONE_ID_DAYLIGHT: Result := tzi.Bias + tzi.DaylightBias; else Result := 0; end; end; {$ENDIF} {$IFDEF UNIX} type ptm = ^tm; tm = record tm_sec: Integer; (* Seconds: 0-59 (K&R says 0-61?) *) tm_min: Integer; (* Minutes: 0-59 *) tm_hour: Integer; (* Hours since midnight: 0-23 *) tm_mday: Integer; (* Day of the month: 1-31 *) tm_mon: Integer; (* Months *since* january: 0-11 *) tm_year: Integer; (* Years since 1900 *) tm_wday: Integer; (* Days since Sunday (0-6) *) tm_yday: Integer; (* Days since Jan. 1: 0-365 *) tm_isdst: Integer; (* +1 Daylight Savings Time, 0 No DST, -1 don't know *) end; function mktime(p: ptm): LongInt; cdecl; external; function gmtime(const t: PLongint): ptm; cdecl; external; function localtime (const t: PLongint): ptm; cdecl; external; function DelphiToJavaDateTime(const dt: TDateTime): Int64; var p: ptm; l, ms: Integer; v: Int64; begin v := Round((dt - 25569) * 86400000); ms := v mod 1000; l := v div 1000; p := localtime(@l); Result := Int64(mktime(p)) * 1000 + ms; end; function JavaToDelphiDateTime(const dt: int64): TDateTime; var p: ptm; l, ms: Integer; begin l := dt div 1000; ms := dt mod 1000; p := gmtime(@l); Result := EncodeDateTime(p^.tm_year+1900, p^.tm_mon+1, p^.tm_mday, p^.tm_hour, p^.tm_min, p^.tm_sec, ms); end; {$ELSE} {$IFDEF WINDOWSNT_COMPATIBILITY} function DayLightCompareDate(const date: PSystemTime; const compareDate: PSystemTime): Integer; var limit_day, dayinsecs, weekofmonth: Integer; First: Word; begin if (date^.wMonth < compareDate^.wMonth) then begin Result := -1; (* We are in a month before the date limit. *) Exit; end; if (date^.wMonth > compareDate^.wMonth) then begin Result := 1; (* We are in a month after the date limit. *) Exit; end; (* if year is 0 then date is in day-of-week format, otherwise * it's absolute date. *) if (compareDate^.wYear = 0) then begin (* compareDate.wDay is interpreted as number of the week in the month * 5 means: the last week in the month *) weekofmonth := compareDate^.wDay; (* calculate the day of the first DayOfWeek in the month *) First := (6 + compareDate^.wDayOfWeek - date^.wDayOfWeek + date^.wDay) mod 7 + 1; limit_day := First + 7 * (weekofmonth - 1); (* check needed for the 5th weekday of the month *) if (limit_day > MonthDays[(date^.wMonth=2) and IsLeapYear(date^.wYear)][date^.wMonth]) then dec(limit_day, 7); end else limit_day := compareDate^.wDay; (* convert to seconds *) limit_day := ((limit_day * 24 + compareDate^.wHour) * 60 + compareDate^.wMinute ) * 60; dayinsecs := ((date^.wDay * 24 + date^.wHour) * 60 + date^.wMinute ) * 60 + date^.wSecond; (* and compare *) if dayinsecs < limit_day then Result := -1 else if dayinsecs > limit_day then Result := 1 else Result := 0; (* date is equal to the date limit. *) end; function CompTimeZoneID(const pTZinfo: PTimeZoneInformation; lpFileTime: PFileTime; islocal: Boolean): LongWord; var ret: Integer; beforeStandardDate, afterDaylightDate: Boolean; llTime: Int64; SysTime: TSystemTime; ftTemp: TFileTime; begin llTime := 0; if (pTZinfo^.DaylightDate.wMonth <> 0) then begin (* if year is 0 then date is in day-of-week format, otherwise * it's absolute date. *) if ((pTZinfo^.StandardDate.wMonth = 0) or ((pTZinfo^.StandardDate.wYear = 0) and ((pTZinfo^.StandardDate.wDay < 1) or (pTZinfo^.StandardDate.wDay > 5) or (pTZinfo^.DaylightDate.wDay < 1) or (pTZinfo^.DaylightDate.wDay > 5)))) then begin SetLastError(ERROR_INVALID_PARAMETER); Result := TIME_ZONE_ID_INVALID; Exit; end; if (not islocal) then begin llTime := PInt64(lpFileTime)^; dec(llTime, Int64(pTZinfo^.Bias + pTZinfo^.DaylightBias) * 600000000); PInt64(@ftTemp)^ := llTime; lpFileTime := @ftTemp; end; FileTimeToSystemTime(lpFileTime^, SysTime); (* check for daylight savings *) ret := DayLightCompareDate(@SysTime, @pTZinfo^.StandardDate); if (ret = -2) then begin Result := TIME_ZONE_ID_INVALID; Exit; end; beforeStandardDate := ret < 0; if (not islocal) then begin dec(llTime, Int64(pTZinfo^.StandardBias - pTZinfo^.DaylightBias) * 600000000); PInt64(@ftTemp)^ := llTime; FileTimeToSystemTime(lpFileTime^, SysTime); end; ret := DayLightCompareDate(@SysTime, @pTZinfo^.DaylightDate); if (ret = -2) then begin Result := TIME_ZONE_ID_INVALID; Exit; end; afterDaylightDate := ret >= 0; Result := TIME_ZONE_ID_STANDARD; if( pTZinfo^.DaylightDate.wMonth < pTZinfo^.StandardDate.wMonth ) then begin (* Northern hemisphere *) if( beforeStandardDate and afterDaylightDate) then Result := TIME_ZONE_ID_DAYLIGHT; end else (* Down south *) if( beforeStandardDate or afterDaylightDate) then Result := TIME_ZONE_ID_DAYLIGHT; end else (* No transition date *) Result := TIME_ZONE_ID_UNKNOWN; end; function GetTimezoneBias(const pTZinfo: PTimeZoneInformation; lpFileTime: PFileTime; islocal: Boolean; pBias: PLongint): Boolean; var bias: LongInt; tzid: LongWord; begin bias := pTZinfo^.Bias; tzid := CompTimeZoneID(pTZinfo, lpFileTime, islocal); if( tzid = TIME_ZONE_ID_INVALID) then begin Result := False; Exit; end; if (tzid = TIME_ZONE_ID_DAYLIGHT) then inc(bias, pTZinfo^.DaylightBias) else if (tzid = TIME_ZONE_ID_STANDARD) then inc(bias, pTZinfo^.StandardBias); pBias^ := bias; Result := True; end; function SystemTimeToTzSpecificLocalTime( lpTimeZoneInformation: PTimeZoneInformation; lpUniversalTime, lpLocalTime: PSystemTime): BOOL; var ft: TFileTime; lBias: LongInt; llTime: Int64; tzinfo: TTimeZoneInformation; begin if (lpTimeZoneInformation <> nil) then tzinfo := lpTimeZoneInformation^ else if (GetTimeZoneInformation(tzinfo) = TIME_ZONE_ID_INVALID) then begin Result := False; Exit; end; if (not SystemTimeToFileTime(lpUniversalTime^, ft)) then begin Result := False; Exit; end; llTime := PInt64(@ft)^; if (not GetTimezoneBias(@tzinfo, @ft, False, @lBias)) then begin Result := False; Exit; end; (* convert minutes to 100-nanoseconds-ticks *) dec(llTime, Int64(lBias) * 600000000); PInt64(@ft)^ := llTime; Result := FileTimeToSystemTime(ft, lpLocalTime^); end; function TzSpecificLocalTimeToSystemTime( const lpTimeZoneInformation: PTimeZoneInformation; const lpLocalTime: PSystemTime; lpUniversalTime: PSystemTime): BOOL; var ft: TFileTime; lBias: LongInt; t: Int64; tzinfo: TTimeZoneInformation; begin if (lpTimeZoneInformation <> nil) then tzinfo := lpTimeZoneInformation^ else if (GetTimeZoneInformation(tzinfo) = TIME_ZONE_ID_INVALID) then begin Result := False; Exit; end; if (not SystemTimeToFileTime(lpLocalTime^, ft)) then begin Result := False; Exit; end; t := PInt64(@ft)^; if (not GetTimezoneBias(@tzinfo, @ft, True, @lBias)) then begin Result := False; Exit; end; (* convert minutes to 100-nanoseconds-ticks *) inc(t, Int64(lBias) * 600000000); PInt64(@ft)^ := t; Result := FileTimeToSystemTime(ft, lpUniversalTime^); end; {$ELSE} function TzSpecificLocalTimeToSystemTime( lpTimeZoneInformation: PTimeZoneInformation; lpLocalTime, lpUniversalTime: PSystemTime): BOOL; stdcall; external 'kernel32.dll'; function SystemTimeToTzSpecificLocalTime( lpTimeZoneInformation: PTimeZoneInformation; lpUniversalTime, lpLocalTime: PSystemTime): BOOL; stdcall; external 'kernel32.dll'; {$ENDIF} function JavaToDelphiDateTime(const dt: int64): TDateTime; var t: TSystemTime; begin DateTimeToSystemTime(25569 + (dt / 86400000), t); SystemTimeToTzSpecificLocalTime(nil, @t, @t); Result := SystemTimeToDateTime(t); end; function DelphiToJavaDateTime(const dt: TDateTime): int64; var t: TSystemTime; begin DateTimeToSystemTime(dt, t); TzSpecificLocalTimeToSystemTime(nil, @t, @t); Result := Round((SystemTimeToDateTime(t) - 25569) * 86400000) end; {$ENDIF} function ISO8601DateToJavaDateTime(const str: SOString; var ms: Int64): Boolean; type TState = ( stStart, stYear, stMonth, stWeek, stWeekDay, stDay, stDayOfYear, stHour, stMin, stSec, stMs, stUTC, stGMTH, stGMTM, stGMTend, stEnd); TPerhaps = (yes, no, perhaps); TDateTimeInfo = record year: Word; month: Word; week: Word; weekday: Word; day: Word; dayofyear: Integer; hour: Word; minute: Word; second: Word; ms: Word; bias: Integer; end; var p: PSOChar; state: TState; pos, v: Word; sep: TPerhaps; inctz, havetz, havedate: Boolean; st: TDateTimeInfo; DayTable: PDayTable; function get(var v: Word; c: SOChar): Boolean; {$IFDEF HAVE_INLINE} inline;{$ENDIF} begin if (c < #256) and (AnsiChar(c) in ['0'..'9']) then begin Result := True; v := v * 10 + Ord(c) - Ord('0'); end else Result := False; end; label error; begin p := PSOChar(str); sep := perhaps; state := stStart; pos := 0; FillChar(st, SizeOf(st), 0); havedate := True; inctz := False; havetz := False; while true do case state of stStart: case p^ of '0'..'9': state := stYear; 'T', 't': begin state := stHour; pos := 0; inc(p); havedate := False; end; else goto error; end; stYear: case pos of 0..1,3: if get(st.year, p^) then begin Inc(pos); Inc(p); end else goto error; 2: case p^ of '0'..'9': begin st.year := st.year * 10 + ord(p^) - ord('0'); Inc(pos); Inc(p); end; ':': begin havedate := false; st.hour := st.year; st.year := 0; inc(p); pos := 0; state := stMin; sep := yes; end; else goto error; end; 4: case p^ of '-': begin pos := 0; Inc(p); sep := yes; state := stMonth; end; '0'..'9': begin sep := no; pos := 0; state := stMonth; end; 'W', 'w' : begin pos := 0; Inc(p); state := stWeek; end; 'T', 't', ' ': begin state := stHour; pos := 0; inc(p); st.month := 1; st.day := 1; end; #0: begin st.month := 1; st.day := 1; state := stEnd; end; else goto error; end; end; stMonth: case pos of 0: case p^ of '0'..'9': begin st.month := ord(p^) - ord('0'); Inc(pos); Inc(p); end; 'W', 'w': begin pos := 0; Inc(p); state := stWeek; end; else goto error; end; 1: if get(st.month, p^) then begin Inc(pos); Inc(p); end else goto error; 2: case p^ of '-': if (sep in [yes, perhaps]) then begin pos := 0; Inc(p); state := stDay; sep := yes; end else goto error; '0'..'9': if sep in [no, perhaps] then begin pos := 0; state := stDay; sep := no; end else begin st.dayofyear := st.month * 10 + Ord(p^) - Ord('0'); st.month := 0; inc(p); pos := 3; state := stDayOfYear; end; 'T', 't', ' ': begin state := stHour; pos := 0; inc(p); st.day := 1; end; #0: begin st.day := 1; state := stEnd; end; else goto error; end; end; stDay: case pos of 0: if get(st.day, p^) then begin Inc(pos); Inc(p); end else goto error; 1: if get(st.day, p^) then begin Inc(pos); Inc(p); end else if sep in [no, perhaps] then begin st.dayofyear := st.month * 10 + st.day; st.day := 0; st.month := 0; state := stDayOfYear; end else goto error; 2: case p^ of 'T', 't', ' ': begin pos := 0; Inc(p); state := stHour; end; #0: state := stEnd; else goto error; end; end; stDayOfYear: begin if (st.dayofyear <= 0) then goto error; case p^ of 'T', 't', ' ': begin pos := 0; Inc(p); state := stHour; end; #0: state := stEnd; else goto error; end; end; stWeek: begin case pos of 0..1: if get(st.week, p^) then begin inc(pos); inc(p); end else goto error; 2: case p^ of '-': if (sep in [yes, perhaps]) then begin Inc(p); state := stWeekDay; sep := yes; end else goto error; '1'..'7': if sep in [no, perhaps] then begin state := stWeekDay; sep := no; end else goto error; else goto error; end; end; end; stWeekDay: begin if (st.week > 0) and get(st.weekday, p^) then begin inc(p); v := st.year - 1; v := ((v * 365) + (v div 4) - (v div 100) + (v div 400)) mod 7 + 1; st.dayofyear := (st.weekday - v) + ((st.week) * 7) + 1; if v <= 4 then dec(st.dayofyear, 7); case p^ of 'T', 't', ' ': begin pos := 0; Inc(p); state := stHour; end; #0: state := stEnd; else goto error; end; end else goto error; end; stHour: case pos of 0: case p^ of '0'..'9': if get(st.hour, p^) then begin inc(pos); inc(p); end else goto error; '-': begin inc(p); state := stMin; end; else goto error; end; 1: if get(st.hour, p^) then begin inc(pos); inc(p); end else goto error; 2: case p^ of ':': if sep in [yes, perhaps] then begin sep := yes; pos := 0; Inc(p); state := stMin; end else goto error; ',': begin Inc(p); state := stMs; end; '+': if havedate then begin state := stGMTH; pos := 0; v := 0; inc(p); end else goto error; '-': if havedate then begin state := stGMTH; pos := 0; v := 0; inc(p); inctz := True; end else goto error; 'Z', 'z': if havedate then state := stUTC else goto error; '0'..'9': if sep in [no, perhaps] then begin pos := 0; state := stMin; sep := no; end else goto error; #0: state := stEnd; else goto error; end; end; stMin: case pos of 0: case p^ of '0'..'9': if get(st.minute, p^) then begin inc(pos); inc(p); end else goto error; '-': begin inc(p); state := stSec; end; else goto error; end; 1: if get(st.minute, p^) then begin inc(pos); inc(p); end else goto error; 2: case p^ of ':': if sep in [yes, perhaps] then begin pos := 0; Inc(p); state := stSec; sep := yes; end else goto error; ',': begin Inc(p); state := stMs; end; '+': if havedate then begin state := stGMTH; pos := 0; v := 0; inc(p); end else goto error; '-': if havedate then begin state := stGMTH; pos := 0; v := 0; inc(p); inctz := True; end else goto error; 'Z', 'z': if havedate then state := stUTC else goto error; '0'..'9': if sep in [no, perhaps] then begin pos := 0; state := stSec; end else goto error; #0: state := stEnd; else goto error; end; end; stSec: case pos of 0..1: if get(st.second, p^) then begin inc(pos); inc(p); end else goto error; 2: case p^ of ',': begin Inc(p); state := stMs; end; '+': if havedate then begin state := stGMTH; pos := 0; v := 0; inc(p); end else goto error; '-': if havedate then begin state := stGMTH; pos := 0; v := 0; inc(p); inctz := True; end else goto error; 'Z', 'z': if havedate then state := stUTC else goto error; #0: state := stEnd; else goto error; end; end; stMs: case p^ of '0'..'9': begin st.ms := st.ms * 10 + ord(p^) - ord('0'); inc(p); end; '+': if havedate then begin state := stGMTH; pos := 0; v := 0; inc(p); end else goto error; '-': if havedate then begin state := stGMTH; pos := 0; v := 0; inc(p); inctz := True; end else goto error; 'Z', 'z': if havedate then state := stUTC else goto error; #0: state := stEnd; else goto error; end; stUTC: // = GMT 0 begin havetz := True; inc(p); if p^ = #0 then Break else goto error; end; stGMTH: begin havetz := True; case pos of 0..1: if get(v, p^) then begin inc(p); inc(pos); end else goto error; 2: begin st.bias := v * 60; case p^ of ':': if sep in [yes, perhaps] then begin state := stGMTM; inc(p); pos := 0; v := 0; sep := yes; end else goto error; '0'..'9': if sep in [no, perhaps] then begin state := stGMTM; pos := 1; sep := no; inc(p); v := ord(p^) - ord('0'); end else goto error; #0: state := stGMTend; else goto error; end; end; end; end; stGMTM: case pos of 0..1: if get(v, p^) then begin inc(p); inc(pos); end else goto error; 2: case p^ of #0: begin state := stGMTend; inc(st.Bias, v); end; else goto error; end; end; stGMTend: begin if not inctz then st.Bias := -st.bias; Break; end; stEnd: begin Break; end; end; if (st.hour >= 24) or (st.minute >= 60) or (st.second >= 60) or (st.ms >= 1000) or (st.week > 53) then goto error; if not havetz then st.bias := GetTimeBias; ms := st.ms + st.second * 1000 + (st.minute + st.bias) * 60000 + st.hour * 3600000; if havedate then begin DayTable := @MonthDays[IsLeapYear(st.year)]; if st.month <> 0 then begin if not (st.month in [1..12]) or (DayTable^[st.month] < st.day) then goto error; for v := 1 to st.month - 1 do Inc(ms, DayTable^[v] * 86400000); end; dec(st.year); ms := ms + (int64((st.year * 365) + (st.year div 4) - (st.year div 100) + (st.year div 400) + st.day + st.dayofyear - 719163) * 86400000); end; Result := True; Exit; error: Result := False; end; function ISO8601DateToDelphiDateTime(const str: SOString; var dt: TDateTime): Boolean; var ms: Int64; begin Result := ISO8601DateToJavaDateTime(str, ms); if Result then dt := JavaToDelphiDateTime(ms) end; function DelphiDateTimeToISO8601Date(dt: TDateTime): SOString; var year, month, day, hour, min, sec, msec: Word; tzh: SmallInt; tzm: Word; sign: SOChar; bias: Integer; begin DecodeDate(dt, year, month, day); DecodeTime(dt, hour, min, sec, msec); bias := GetTimeBias; tzh := Abs(bias) div 60; tzm := Abs(bias) - tzh * 60; if Bias > 0 then sign := '-' else sign := '+'; Result := Format('%.4d-%.2d-%.2dT%.2d:%.2d:%.2d,%d%s%.2d:%.2d', [year, month, day, hour, min, sec, msec, sign, tzh, tzm]); end; function TryObjectToDate(const obj: ISuperObject; var dt: TDateTime): Boolean; var i: Int64; begin case ObjectGetType(obj) of stInt: begin dt := JavaToDelphiDateTime(obj.AsInteger); Result := True; end; stString: begin if ISO8601DateToJavaDateTime(obj.AsString, i) then begin dt := JavaToDelphiDateTime(i); Result := True; end else Result := TryStrToDateTime(obj.AsString, dt); end; else Result := False; end; end; function SO(const s: SOString): ISuperObject; overload; begin Result := TSuperObject.ParseString(PSOChar(s), False); end;