Delphi 的 ISuperObject JSON属性按加入顺序进行读取
时间:2018-11-15
本文章向大家介绍SuperObject Delphi 的 JSON 属性乱序 - 操作类改造 - 关于属性顺序的问题，需要的朋友可以参考一下
Delphi 的 ISuperObject 属性顺序为随机。但是很多时候，是需要按加入顺序进行读取。我也看了网上很多人有类似需求。也有人问过原作者，作者答复为：JSON协议规定为无序。看了我真是无语。
也看过网上一些人自己的修改，但是修改后有两个问题（网上的方法都不好，只能自己动手了）：
1. 性能急剧下降。原作者是用二叉树对性能做了极大的优化。但是网上修改的方法性能不行。
2. 属性数大于 32 时会出错。（原来用的是二叉树，修改后部分算法未修改，导致此问题）。
我采用的是重写遍历器的方法，和原版性能接近。
* 执行 500*500 数据的节点变更后，性能和原版差别不太大。
*
* 原始性能 0.280 秒
* 旧的稳定改版性能 15.774 秒
* 新的稳定改版性能 0.535 秒
*
* 性能是原版的 1.9 倍左右。而之前将二叉树变为链表的方法，导致性能变为 56 分之一。
* 温涛，于 2018-10-26。邮箱 delphi2006@163.com
把源码顺便贴上吧。
(*
* Super Object Toolkit
*
* Usage allowed under the restrictions of the Lesser GNU General Public License
* or alternatively the restrictions of the Mozilla Public License 1.1
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
* the specific language governing rights and limitations under the License.
*
* Unit owner : Henri Gourvest <hgourvest@gmail.com>
* Web site : http://www.progdigy.com
*
* This unit is inspired from the json c lib:
* Michael Clark <michael@metaparadigm.com>
* http://oss.metaparadigm.com/json-c/
*
* CHANGES:
* 终极改版来了，现在的改版增加了存储节点名称的功能。并且重写了遍历器，和原版性能接近。
* 执行 500*500 数据的节点变更后，性能和原版差别不太大。
*
* 原始性能 0.280 秒
* 旧的稳定改版性能 15.774 秒
* 新的稳定改版性能 0.535 秒
*
* 性能是原版的 1.9 倍左右。而之前将二叉树变为链表的方法，导致性能变为 56 分之一。
* 温涛，于 2018-10-26。邮箱 delphi2006@163.com
*
* v1.2
* + support of currency data type
* + right trim unquoted string
* + read Unicode Files and streams (Litle Endian with BOM)
* + Fix bug on javadate functions + windows nt compatibility
* + Now you can force to parse only the canonical syntax of JSON using the stric parameter
* + Delphi 2010 RTTI marshalling
* v1.1
* + Double licence MPL or LGPL.
* + Delphi 2009 compatibility & Unicode support.
* + AsString return a string instead of PChar.
* + Escaped and Unascaped JSON serialiser.
* + Missed FormFeed added \f
* - Removed @ trick, uses forcepath() method instead.
* + Fixed parse error with uppercase E symbol in numbers.
* + Fixed possible buffer overflow when enlarging array.
* + Added "delete", "pack", "insert" methods for arrays and/or objects
* + Multi parametters when calling methods
* + Delphi Enumerator (for obj1 in obj2 do ...)
* + Format method ex: obj.format('<%name%>%tab[1]%</%name%>')
* + ParseFile and ParseStream methods
* + Parser now understand hexdecimal c syntax ex: \xFF
* + Null Object Design Patern (ex: for obj in values.N['path'] do ...)
* v1.0
* + renamed class
* + interfaced object
* + added a new data type: the method
* + parser can now evaluate properties and call methods
* - removed obselet rpc class
* - removed "find" method, now you can use "parse" method instead
* v0.6
* + refactoring
* v0.5
* + new find method to get or set value using a path syntax
* ex: obj.s['obj.prop[1]'] := 'string value';
* obj.a['@obj.array'].b[n] := true; // @ -> create property if necessary
* v0.4
* + bug corrected: AVL tree badly balanced.
* v0.3
* + New validator partially based on the Kwalify syntax.
* + extended syntax to parse unquoted fields.
* + Freepascal compatibility win32/64 Linux32/64.
* + JavaToDelphiDateTime and DelphiToJavaDateTime improved for UTC.
* + new TJsonObject.Compare function.
* v0.2
* + Hashed string list replaced with a faster AVL tree
* + JsonInt data type can be changed to int64
* + JavaToDelphiDateTime and DelphiToJavaDateTime helper fonctions
* + from json-c v0.7
* + Add escaping of backslash to json output
* + Add escaping of foward slash on tokenizing and output
* + Changes to internal tokenizer from using recursion to
* using a depth state structure to allow incremental parsing
* v0.1
* + first release
*)
{$IFDEF FPC}
{$MODE OBJFPC}{$H+}
{$ENDIF}
{$DEFINE SUPER_METHOD}
{$DEFINE WINDOWSNT_COMPATIBILITY}
{.$DEFINE DEBUG} // track memory leack
{$if defined(FPC) or defined(VER170) or defined(VER180) or defined(VER190) or defined(VER200) or defined(VER210)}
{$DEFINE HAVE_INLINE}
{$ifend}
{$if defined(VER210) or defined(VER220) or defined(VER230)}
{$define HAVE_RTTI}
{$ifend}
{$OVERFLOWCHECKS OFF}
{$RANGECHECKS OFF}
{.$DEFINE ToStringEx}
unit SuperObjectToolkit;
interface
uses
Classes, SysUtils
{$IFDEF HAVE_RTTI}
,Generics.Collections, RTTI, TypInfo
{$ENDIF}
, Math, Generics.Defaults, Variants;
type
{$IFNDEF FPC}
{$IFDEF CPUX64}
PtrInt = Int64;
PtrUInt = UInt64;
{$ELSE}
PtrInt = longint;
PtrUInt = Longword;
{$ENDIF}
{$ENDIF}
SuperInt = Int64;
{$if (sizeof(Char) = 1)}
SOChar = WideChar;
SOIChar = Word;
PSOChar = PWideChar;
{$IFDEF FPC}
SOString = UnicodeString;
{$ELSE}
SOString = WideString;
{$ENDIF}
{$else}
SOChar = Char;
SOIChar = Word;
PSOChar = PChar;
SOString = string;
{$ifend}
const
SUPER_ARRAY_LIST_DEFAULT_SIZE = 32;
SUPER_TOKENER_MAX_DEPTH = 32;
SUPER_AVL_MAX_DEPTH = sizeof(longint) * 8;
SUPER_AVL_MASK_HIGH_BIT = not ((not longword(0)) shr 1);
type
// forward declarations
TSuperObject = class;
ISuperObject = interface;
TSuperArray = class;
(* AVL Tree
* This is a "special" autobalanced AVL tree
* It use a hash value for fast compare
*)
{$IFDEF SUPER_METHOD}
TSuperMethod = procedure(const This, Params: ISuperObject; var Result: ISuperObject);
{$ENDIF}
TSuperAvlBitArray = set of 0..SUPER_AVL_MAX_DEPTH - 1;
TSuperAvlSearchType = (stEQual, stLess, stGreater);
TSuperAvlSearchTypes = set of TSuperAvlSearchType;
TSuperAvlIterator = class;
TSuperAvlEntry = class
private
FGt, FLt: TSuperAvlEntry;
FBf: integer;
FHash: Cardinal;
FName: SOString;
FPtr: Pointer;
function GetValue: ISuperObject;
procedure SetValue(const val: ISuperObject);
public
class function Hash(const k: SOString): Cardinal; virtual;
constructor Create(const AName: SOString; Obj: Pointer); virtual;
property Name: SOString read FName;
property Ptr: Pointer read FPtr;
property Value: ISuperObject read GetValue write SetValue;
end;
TSuperAvlTree = class
private
FRoot: TSuperAvlEntry;
FCount: Integer;
// WenTao 添加了用于节点顺序的功能。
FNodeNames: TStringList;
function balance(bal: TSuperAvlEntry): TSuperAvlEntry;
protected
// WenTao 添加了用于节点顺序的功能。
procedure AddNodeName(nodeName: SOString);
procedure RemoveNode(nodeName: SOString);
procedure doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); virtual;
function CompareNodeNode(node1, node2: TSuperAvlEntry): integer; virtual;
function CompareKeyNode(const k: SOString; h: TSuperAvlEntry): integer; virtual;
function Insert(h: TSuperAvlEntry): TSuperAvlEntry; virtual;
function Search(const k: SOString; st: TSuperAvlSearchTypes = [stEqual]): TSuperAvlEntry; virtual;
public
constructor Create; virtual;
destructor Destroy; override;
function IsEmpty: boolean;
procedure Clear(all: boolean = false); virtual;
procedure Pack(all: boolean);
function Delete(const k: SOString): ISuperObject;
function GetEnumerator: TSuperAvlIterator;
property count: Integer read FCount;
end;
TSuperTableString = class(TSuperAvlTree)
protected
procedure doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); override;
procedure PutO(const k: SOString; const value: ISuperObject);
function GetO(const k: SOString): ISuperObject;
procedure PutS(const k: SOString; const value: SOString);
function GetS(const k: SOString): SOString;
procedure PutI(const k: SOString; value: SuperInt);
function GetI(const k: SOString): SuperInt;
procedure PutD(const k: SOString; value: Double);
function GetD(const k: SOString): Double;
procedure PutB(const k: SOString; value: Boolean);
function GetB(const k: SOString): Boolean;
{$IFDEF SUPER_METHOD}
procedure PutM(const k: SOString; value: TSuperMethod);
function GetM(const k: SOString): TSuperMethod;
{$ENDIF}
procedure PutN(const k: SOString; const value: ISuperObject);
function GetN(const k: SOString): ISuperObject;
procedure PutC(const k: SOString; value: Currency);
function GetC(const k: SOString): Currency;
public
property O[const k: SOString]: ISuperObject read GetO write PutO; default;
property S[const k: SOString]: SOString read GetS write PutS;
property I[const k: SOString]: SuperInt read GetI write PutI;
property D[const k: SOString]: Double read GetD write PutD;
property B[const k: SOString]: Boolean read GetB write PutB;
{$IFDEF SUPER_METHOD}
property M[const k: SOString]: TSuperMethod read GetM write PutM;
{$ENDIF}
property N[const k: SOString]: ISuperObject read GetN write PutN;
property C[const k: SOString]: Currency read GetC write PutC;
function GetValues: ISuperObject;
function GetNames: ISuperObject;
function Find(const k: SOString; var value: ISuperObject): Boolean;
end;
TSuperAvlIterator = class
private
FTree: TSuperAvlTree;
// WenTao 新的遍历方法只需要一个索引即可。
FCurNameIndex: Integer;
(* 旧的代码。
FBranch: TSuperAvlBitArray;
FDepth: LongInt;
FPath: array[0..SUPER_AVL_MAX_DEPTH - 2] of TSuperAvlEntry;
*)
public
constructor Create(tree: TSuperAvlTree); virtual;
// WenTao 新的 Search 只支持等于的查找，不过原库中也没有用过非等于的查找。
procedure Search(const k: SOString);
// 旧的代码：
// procedure Search(const k: SOString; st: TSuperAvlSearchTypes = [stEQual]);
procedure First;
procedure Last;
function GetIter: TSuperAvlEntry;
procedure Next;
procedure Prior;
// delphi enumerator
function MoveNext: Boolean;
property Current: TSuperAvlEntry read GetIter;
end;
TSuperObjectArray = array[0..(high(Integer) div sizeof(TSuperObject))-1] of ISuperObject;
PSuperObjectArray = ^TSuperObjectArray;
TSuperArray = class
private
FArray: PSuperObjectArray;
FLength: Integer;
FSize: Integer;
procedure Expand(max: Integer);
protected
function GetO(const index: integer): ISuperObject;
procedure PutO(const index: integer; const Value: ISuperObject);
function GetB(const index: integer): Boolean;
procedure PutB(const index: integer; Value: Boolean);
function GetI(const index: integer): SuperInt;
procedure PutI(const index: integer; Value: SuperInt);
function GetD(const index: integer): Double;
procedure PutD(const index: integer; Value: Double);
function GetC(const index: integer): Currency;
procedure PutC(const index: integer; Value: Currency);
function GetS(const index: integer): SOString;
procedure PutS(const index: integer; const Value: SOString);
{$IFDEF SUPER_METHOD}
function GetM(const index: integer): TSuperMethod;
procedure PutM(const index: integer; Value: TSuperMethod);
{$ENDIF}
function GetN(const index: integer): ISuperObject;
procedure PutN(const index: integer; const Value: ISuperObject);
public
constructor Create; virtual;
destructor Destroy; override;
function Add(const Data: ISuperObject): Integer;
function Delete(index: Integer): ISuperObject;
procedure Insert(index: Integer; const value: ISuperObject);
procedure Clear(all: boolean = false);
procedure Pack(all: boolean);
property Length: Integer read FLength;
property N[const index: integer]: ISuperObject read GetN write PutN;
property O[const index: integer]: ISuperObject read GetO write PutO; default;
property B[const index: integer]: boolean read GetB write PutB;
property I[const index: integer]: SuperInt read GetI write PutI;
property D[const index: integer]: Double read GetD write PutD;
property C[const index: integer]: Currency read GetC write PutC;
property S[const index: integer]: SOString read GetS write PutS;
{$IFDEF SUPER_METHOD}
property M[const index: integer]: TSuperMethod read GetM write PutM;
{$ENDIF}
end;
TSuperWriter = class
public
// abstact methods to overide
function Append(buf: PSOChar; Size: Integer): Integer; overload; virtual; abstract;
function Append(buf: PSOChar): Integer; overload; virtual; abstract;
procedure Reset; virtual; abstract;
end;
TSuperWriterString = class(TSuperWriter)
private
FBuf: PSOChar;
FBPos: integer;
FSize: integer;
public
function Append(buf: PSOChar; Size: Integer): Integer; overload; override;
function Append(buf: PSOChar): Integer; overload; override;
procedure Reset; override;
procedure TrimRight;
constructor Create; virtual;
destructor Destroy; override;
function GetString: SOString;
property Data: PSOChar read FBuf;
property Size: Integer read FSize;
property Position: integer read FBPos;
end;
TSuperWriterStream = class(TSuperWriter)
private
FStream: TStream;
public
function Append(buf: PSOChar): Integer; override;
procedure Reset; override;
constructor Create(AStream: TStream); reintroduce; virtual;
end;
TSuperAnsiWriterStream = class(TSuperWriterStream)
public
function Append(buf: PSOChar; Size: Integer): Integer; override;
end;
TSuperUnicodeWriterStream = class(TSuperWriterStream)
public
function Append(buf: PSOChar; Size: Integer): Integer; override;
end;
TSuperWriterFake = class(TSuperWriter)
private
FSize: Integer;
public
function Append(buf: PSOChar; Size: Integer): Integer; override;
function Append(buf: PSOChar): Integer; override;
procedure Reset; override;
constructor Create; reintroduce; virtual;
property size: integer read FSize;
end;
TSuperWriterSock = class(TSuperWriter)
private
FSocket: longint;
FSize: Integer;
public
function Append(buf: PSOChar; Size: Integer): Integer; override;
function Append(buf: PSOChar): Integer; override;
procedure Reset; override;
constructor Create(ASocket: longint); reintroduce; virtual;
property Socket: longint read FSocket;
property Size: Integer read FSize;
end;
TSuperTokenizerError = (
teSuccess,
teContinue,
teDepth,
teParseEof,
teParseUnexpected,
teParseNull,
teParseBoolean,
teParseNumber,
teParseArray,
teParseObjectKeyName,
teParseObjectKeySep,
teParseObjectValueSep,
teParseString,
teParseComment,
teEvalObject,
teEvalArray,
teEvalMethod,
teEvalInt
);
TSuperTokenerState = (
tsEatws,
tsStart,
tsFinish,
tsNull,
tsCommentStart,
tsComment,
tsCommentEol,
tsCommentEnd,
tsString,
tsStringEscape,
tsIdentifier,
tsEscapeUnicode,
tsEscapeHexadecimal,
tsBoolean,
tsNumber,
tsArray,
tsArrayAdd,
tsArraySep,
tsObjectFieldStart,
tsObjectField,
tsObjectUnquotedField,
tsObjectFieldEnd,
tsObjectValue,
tsObjectValueAdd,
tsObjectSep,
tsEvalProperty,
tsEvalArray,
tsEvalMethod,
tsParamValue,
tsParamPut,
tsMethodValue,
tsMethodPut
);
PSuperTokenerSrec = ^TSuperTokenerSrec;
TSuperTokenerSrec = record
state, saved_state: TSuperTokenerState;
obj: ISuperObject;
current: ISuperObject;
field_name: SOString;
parent: ISuperObject;
gparent: ISuperObject;
end;
TSuperTokenizer = class
public
str: PSOChar;
pb: TSuperWriterString;
depth, is_double, floatcount, st_pos, char_offset: Integer;
err: TSuperTokenizerError;
ucs_char: Word;
quote_char: SOChar;
stack: array[0..SUPER_TOKENER_MAX_DEPTH-1] of TSuperTokenerSrec;
line, col: Integer;
public
constructor Create; virtual;
destructor Destroy; override;
procedure ResetLevel(adepth: integer);
procedure Reset;
end;
// supported object types
TSuperType = (
stNull,
stBoolean,
stDouble,
stCurrency,
stInt,
stObject,
stArray,
stString
{$IFDEF SUPER_METHOD}
,stMethod
{$ENDIF}
);
TSuperValidateError = (
veRuleMalformated,
veFieldIsRequired,
veInvalidDataType,
veFieldNotFound,
veUnexpectedField,
veDuplicateEntry,
veValueNotInEnum,
veInvalidLength,
veInvalidRange
);
TSuperFindOption = (
foCreatePath,
foPutValue,
foDelete
{$IFDEF SUPER_METHOD}
,foCallMethod
{$ENDIF}
);
TSuperFindOptions = set of TSuperFindOption;
TSuperCompareResult = (cpLess, cpEqu, cpGreat, cpError);
TSuperOnValidateError = procedure(sender: Pointer; error: TSuperValidateError; const objpath: SOString);
TSuperEnumerator = class
private
FObj: ISuperObject;
FObjEnum: TSuperAvlIterator;
FCount: Integer;
public
constructor Create(const obj: ISuperObject); virtual;
destructor Destroy; override;
function MoveNext: Boolean;
function GetCurrent: ISuperObject;
property Current: ISuperObject read GetCurrent;
end;
TJsonFormatType = (ftOneLine, ftMultiLine, ftArray, ftObjectArray);
ISuperObject = interface
['{4B86A9E3-E094-4E5A-954A-69048B7B6327}']
function GetEnumerator: TSuperEnumerator;
function GetDataType: TSuperType;
function GetProcessing: boolean;
procedure SetProcessing(value: boolean);
function ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject;
function Format(const str: SOString; BeginSep: SOChar = '%'; EndSep: SOChar = '%'): SOString;
function GetO(const path: SOString): ISuperObject;
procedure PutO(const path: SOString; const Value: ISuperObject);
function GetB(const path: SOString): Boolean;
procedure PutB(const path: SOString; Value: Boolean);
function GetI(const path: SOString): SuperInt;
procedure PutI(const path: SOString; Value: SuperInt);
function GetD(const path: SOString): Double;
procedure PutC(const path: SOString; Value: Currency);
function GetC(const path: SOString): Currency;
procedure PutD(const path: SOString; Value: Double);
function GetS(const path: SOString): SOString;
procedure PutS(const path: SOString; const Value: SOString);
{$IFDEF SUPER_METHOD}
function GetM(const path: SOString): TSuperMethod;
procedure PutM(const path: SOString; Value: TSuperMethod);
{$ENDIF}
function GetA(const path: SOString): TSuperArray;
// Null Object Design patern
function GetN(const path: SOString): ISuperObject;
procedure PutN(const path: SOString; const Value: ISuperObject);
// Writers
function Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer;
function SaveTo(stream: TStream; indent: boolean = false; escape: boolean = true): integer; overload;
function SaveTo(const FileName: string; indent: boolean = false; escape: boolean = true): integer; overload;
function SaveTo(socket: longint; indent: boolean = false; escape: boolean = true): integer; overload;
function CalcSize(indent: boolean = false; escape: boolean = true): integer;
// convert
function AsBoolean: Boolean;
function AsInteger: SuperInt;
function AsDouble: Double;
function AsCurrency: Currency;
function AsString: SOString;
function AsArray: TSuperArray;
function AsObject: TSuperTableString;
{$IFDEF SUPER_METHOD}
function AsMethod: TSuperMethod;
{$ENDIF}
function AsJSon(indent: boolean = false; escape: boolean = true): SOString;
procedure Clear(all: boolean = false);
procedure Pack(all: boolean = false);
property N[const path: SOString]: ISuperObject read GetN write PutN;
property O[const path: SOString]: ISuperObject read GetO write PutO; default;
property B[const path: SOString]: boolean read GetB write PutB;
property I[const path: SOString]: SuperInt read GetI write PutI;
property D[const path: SOString]: Double read GetD write PutD;
property C[const path: SOString]: Currency read GetC write PutC;
property S[const path: SOString]: SOString read GetS write PutS;
{$IFDEF SUPER_METHOD}
property M[const path: SOString]: TSuperMethod read GetM write PutM;
{$ENDIF}
property A[const path: SOString]: TSuperArray read GetA;
{$IFDEF SUPER_METHOD}
function call(const path: SOString; const param: ISuperObject = nil): ISuperObject; overload;
function call(const path, param: SOString): ISuperObject; overload;
{$ENDIF}
// clone a node
function Clone: ISuperObject;
function Delete(const path: SOString): ISuperObject;
// merges tow objects of same type, if reference is true then nodes are not cloned
procedure Merge(const obj: ISuperObject; reference: boolean = false); overload;
procedure Merge(const str: SOString); overload;
// validate methods
function Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload;
function Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload;
// compare
function Compare(const obj: ISuperObject): TSuperCompareResult; overload;
function Compare(const str: SOString): TSuperCompareResult; overload;
// the data type
function IsType(AType: TSuperType): boolean;
property DataType: TSuperType read GetDataType;
property Processing: boolean read GetProcessing write SetProcessing;
function GetDataPtr: Pointer;
procedure SetDataPtr(const Value: Pointer);
property DataPtr: Pointer read GetDataPtr write SetDataPtr;
// WenTao 新增加的排序、过滤接口。
// eachProp: 遍历每一个值的属性
// eachObj: 遍历每一个对象类型的属性
procedure forEachForProperty(eachProp: TProc<{Key}String, {isLast: }Boolean>; eachObj: TProc<{Key}String, {isLast: }Boolean>);
// 当 SuperObject 是 Array 时，统计每一个列的最大宽度。
procedure calcMaxLen(lenDict: TDictionary<String, Integer>);
// 按特写字段排序
function sortByField(AFieldName: String; ADataType: TSuperType = stString): ISuperObject;
function sort(onCompare: TFunc<ISuperObject, ISuperObject, Integer>): ISuperObject;
function filterByField(AFieldName: String; AValue: Variant; ADataType: TSuperType = stString): ISuperObject;
function filter(onCompare: TFunc<ISuperObject, Boolean>): ISuperObject;
function forEachForArray(callback: TProc<{Index: }Integer, {item: }ISuperObject, {isLast: }Boolean>): ISuperObject;
function findByField(AFieldName: String; AValue: Variant; ADataType: TSuperType = stString): ISuperObject;
function find(onCompare: TFunc<ISuperObject, Boolean>): ISuperObject;
function reverse: ISuperObject;
{$IFDEF ToStringEx}
function toStringEx(AJsonType: TJsonFormatType): String;
{$ENDIF}
end;
TSuperObject = class(TObject, ISuperObject)
private
FRefCount: Integer;
FProcessing: boolean;
FDataType: TSuperType;
FDataPtr: Pointer;
{.$if true}
FO: record
case TSuperType of
stBoolean: (c_boolean: boolean);
stDouble: (c_double: double);
stCurrency: (c_currency: Currency);
stInt: (c_int: SuperInt);
stObject: (c_object: TSuperTableString);
stArray: (c_array: TSuperArray);
{$IFDEF SUPER_METHOD}
stMethod: (c_method: TSuperMethod);
{$ENDIF}
end;
{.$ifend}
FOString: SOString;
function GetDataType: TSuperType;
function GetDataPtr: Pointer;
procedure SetDataPtr(const Value: Pointer);
procedure needArray;
protected
function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
function _AddRef: Integer; virtual; stdcall;
function _Release: Integer; virtual; stdcall;
function GetO(const path: SOString): ISuperObject;
procedure PutO(const path: SOString; const Value: ISuperObject);
function GetB(const path: SOString): Boolean;
procedure PutB(const path: SOString; Value: Boolean);
function GetI(const path: SOString): SuperInt;
procedure PutI(const path: SOString; Value: SuperInt);
function GetD(const path: SOString): Double;
procedure PutD(const path: SOString; Value: Double);
procedure PutC(const path: SOString; Value: Currency);
function GetC(const path: SOString): Currency;
function GetS(const path: SOString): SOString;
procedure PutS(const path: SOString; const Value: SOString);
{$IFDEF SUPER_METHOD}
function GetM(const path: SOString): TSuperMethod;
procedure PutM(const path: SOString; Value: TSuperMethod);
{$ENDIF}
function GetA(const path: SOString): TSuperArray;
function Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer; virtual;
public
function GetEnumerator: TSuperEnumerator;
procedure AfterConstruction; override;
procedure BeforeDestruction; override;
class function NewInstance: TObject; override;
property RefCount: Integer read FRefCount;
function GetProcessing: boolean;
procedure SetProcessing(value: boolean);
// Writers
function SaveTo(stream: TStream; indent: boolean = false; escape: boolean = true): integer; overload;
function SaveTo(const FileName: string; indent: boolean = false; escape: boolean = true): integer; overload;
function SaveTo(socket: longint; indent: boolean = false; escape: boolean = true): integer; overload;
function CalcSize(indent: boolean = false; escape: boolean = true): integer;
function AsJSon(indent: boolean = false; escape: boolean = true): SOString;
// parser ... owned!
class function ParseString(s: PSOChar; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = [];
const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject;
class function ParseStream(stream: TStream; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = [];
const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject;
class function ParseFile(const FileName: string; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = [];
const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject;
class function ParseEx(tok: TSuperTokenizer; str: PSOChar; len: integer; strict: Boolean; const this: ISuperObject = nil;
options: TSuperFindOptions = []; const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject;
// constructors / destructor
constructor Create(jt: TSuperType = stObject); overload; virtual;
constructor Create(b: boolean); overload; virtual;
constructor Create(i: SuperInt); overload; virtual;
constructor Create(d: double); overload; virtual;
constructor CreateCurrency(c: Currency); overload; virtual;
constructor Create(const s: SOString); overload; virtual;
{$IFDEF SUPER_METHOD}
constructor Create(m: TSuperMethod); overload; virtual;
{$ENDIF}
destructor Destroy; override;
// convert
function AsBoolean: Boolean; virtual;
function AsInteger: SuperInt; virtual;
function AsDouble: Double; virtual;
function AsCurrency: Currency; virtual;
function AsString: SOString; virtual;
function AsArray: TSuperArray; virtual;
function AsObject: TSuperTableString; virtual;
{$IFDEF SUPER_METHOD}
function AsMethod: TSuperMethod; virtual;
{$ENDIF}
procedure Clear(all: boolean = false); virtual;
procedure Pack(all: boolean = false); virtual;
function GetN(const path: SOString): ISuperObject;
procedure PutN(const path: SOString; const Value: ISuperObject);
function ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject;
function Format(const str: SOString; BeginSep: SOChar = '%'; EndSep: SOChar = '%'): SOString;
property N[const path: SOString]: ISuperObject read GetN write PutN;
property O[const path: SOString]: ISuperObject read GetO write PutO; default;
property B[const path: SOString]: boolean read GetB write PutB;
property I[const path: SOString]: SuperInt read GetI write PutI;
property D[const path: SOString]: Double read GetD write PutD;
property C[const path: SOString]: Currency read GetC write PutC;
property S[const path: SOString]: SOString read GetS write PutS;
{$IFDEF SUPER_METHOD}
property M[const path: SOString]: TSuperMethod read GetM write PutM;
{$ENDIF}
property A[const path: SOString]: TSuperArray read GetA;
{$IFDEF SUPER_METHOD}
function call(const path: SOString; const param: ISuperObject = nil): ISuperObject; overload; virtual;
function call(const path, param: SOString): ISuperObject; overload; virtual;
{$ENDIF}
// clone a node
function Clone: ISuperObject; virtual;
function Delete(const path: SOString): ISuperObject;
// merges tow objects of same type, if reference is true then nodes are not cloned
procedure Merge(const obj: ISuperObject; reference: boolean = false); overload;
procedure Merge(const str: SOString); overload;
// validate methods
function Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload;
function Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload;
// compare
function Compare(const obj: ISuperObject): TSuperCompareResult; overload;
function Compare(const str: SOString): TSuperCompareResult; overload;
// the data type
function IsType(AType: TSuperType): boolean;
property DataType: TSuperType read GetDataType;
// a data pointer to link to something ele, a treeview for example
property DataPtr: Pointer read GetDataPtr write SetDataPtr;
property Processing: boolean read GetProcessing;
// WenTao 新增加的排序、过滤接口。
procedure forEachForProperty(eachProp: TProc<{Key}String, {isLast: }Boolean>; eachObj: TProc<{Key}String, {isLast: }Boolean>);
procedure calcMaxLen(lenDict: TDictionary<String, Integer>);
function sortByField(AFieldName: String; ADataType: TSuperType = stString): ISuperObject;
function sort(onCompare: TFunc<ISuperObject, ISuperObject, Integer>): ISuperObject;
function filterByField(AFieldName: String; AValue: Variant; ADataType: TSuperType = stString): ISuperObject;
function filter(onCompare: TFunc<ISuperObject, Boolean>): ISuperObject;
function forEachForArray(callback: TProc<{Index: }Integer, {item: }ISuperObject, {isLast: }Boolean>): ISuperObject;
function findByField(AFieldName: String; AValue: Variant; ADataType: TSuperType = stString): ISuperObject;
function find(onCompare: TFunc<ISuperObject, Boolean>): ISuperObject;
function reverse: ISuperObject;
{$IFDEF ToStringEx}
class function escapeValue(valueStr: SOString): SOString;
function toStringEx(AJsonType: TJsonFormatType): String;
{$ENDIF}
end;
{$IFDEF HAVE_RTTI}
TSuperRttiContext = class;
TSerialFromJson = function(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;
TSerialToJson = function(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject;
TSuperAttribute = class(TCustomAttribute)
private
FName: string;
public
constructor Create(const AName: string);
property Name: string read FName;
end;
SOName = class(TSuperAttribute);
SODefault = class(TSuperAttribute);
TSuperRttiContext = class
private
class function GetFieldName(r: TRttiField): string;
class function GetFieldDefault(r: TRttiField; const obj: ISuperObject): ISuperObject;
public
Context: TRttiContext;
SerialFromJson: TDictionary<PTypeInfo, TSerialFromJson>;
SerialToJson: TDictionary<PTypeInfo, TSerialToJson>;
constructor Create; virtual;
destructor Destroy; override;
function FromJson(TypeInfo: PTypeInfo; const obj: ISuperObject; var Value: TValue): Boolean; virtual;
function ToJson(var value: TValue; const index: ISuperObject): ISuperObject; virtual;
function AsType<T>(const obj: ISuperObject): T;
function AsJson<T>(const obj: T; const index: ISuperObject = nil): ISuperObject;
end;
TSuperObjectHelper = class helper for TObject
public
function ToJson(ctx: TSuperRttiContext = nil): ISuperObject;
constructor FromJson(const obj: ISuperObject; ctx: TSuperRttiContext = nil); overload;
constructor FromJson(const str: string; ctx: TSuperRttiContext = nil); overload;
end;
{$ENDIF}
TSuperObjectIter = record
key: SOString;
val: ISuperObject;
Ite: TSuperAvlIterator;
end;
function ObjectIsError(obj: TSuperObject): boolean;
function ObjectIsType(const obj: ISuperObject; typ: TSuperType): boolean;
function ObjectGetType(const obj: ISuperObject): TSuperType;
function ObjectFindFirst(const obj: ISuperObject; var F: TSuperObjectIter): boolean;
function ObjectFindNext(var F: TSuperObjectIter): boolean;
procedure ObjectFindClose(var F: TSuperObjectIter);
function SO(const s: SOString = '{}'): ISuperObject; overload;
function SO(const value: Variant): ISuperObject; overload;
function SO(const Args: array of const): ISuperObject; overload;
function SA(const Args: array of const): ISuperObject; overload;
function JavaToDelphiDateTime(const dt: int64): TDateTime;
function DelphiToJavaDateTime(const dt: TDateTime): int64;
function TryObjectToDate(const obj: ISuperObject; var dt: TDateTime): Boolean;
function ISO8601DateToJavaDateTime(const str: SOString; var ms: Int64): Boolean;
function ISO8601DateToDelphiDateTime(const str: SOString; var dt: TDateTime): Boolean;
function DelphiDateTimeToISO8601Date(dt: TDateTime): SOString;
{$IFDEF HAVE_RTTI}
function UUIDToString(const g: TGUID): string;
function StringToUUID(const str: string; var g: TGUID): Boolean;
type
TSuperInvokeResult = (
irSuccess,
irMethothodError, // method don't exist
irParamError, // invalid parametters
irError // other error
);
function TrySOInvoke(var ctx: TSuperRttiContext; const obj: TValue; const method: string; const params: ISuperObject; var Return: ISuperObject): TSuperInvokeResult; overload;
function SOInvoke(const obj: TValue; const method: string; const params: ISuperObject; ctx: TSuperRttiContext = nil): ISuperObject; overload;
function SOInvoke(const obj: TValue; const method: string; const params: string; ctx: TSuperRttiContext = nil): ISuperObject; overload;
{$ENDIF}
implementation
uses
{$IFDEF ToStringEx} wtStrUtility, {$ENDIF}
{$IFDEF UNIX}
baseunix, unix, DateUtils
{$ELSE}
Windows
{$ENDIF}
{$IFDEF FPC}
,sockets
{$ELSE}
,WinSock
{$ENDIF};
{$IFDEF DEBUG}
var
debugcount: integer = 0;
{$ENDIF}
const
super_number_chars_set = ['0'..'9','.','+','-','e','E'];
super_hex_chars: PSOChar = '0123456789abcdef';
super_hex_chars_set = ['0'..'9','a'..'f','A'..'F'];
ESC_BS: PSOChar = '\b';
ESC_LF: PSOChar = '\n';
ESC_CR: PSOChar = '\r';
ESC_TAB: PSOChar = '\t';
ESC_FF: PSOChar = '\f';
ESC_QUOT: PSOChar = '\"';
ESC_SL: PSOChar = '\\';
ESC_SR: PSOChar = '\/';
ESC_ZERO: PSOChar = '\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);
- Selenium2+python自动化8-SeleniumBuilder辅助定位元素
- HDU 1250 Hat's Fibonacci
- Scrapy在Ubuntu下的安装与配置
- Selenium2+python自动化20-引入unittest框架
- HDU 1002 A + B Problem II(高精度加法(C++/Java))
- POJ 1018 Communication System
- POJ 1017 Packets
- Codeforces 725B Food on the Plane
- Codefoces 723B Text Document Analysis
- Codefoces 723A The New Year: Meeting Friends
- ECJTUACM16 Winter vacation training #1 题解&源码
- 信息学奥赛一本通算法（C++版）基础算法：高精度计算
- 看破欧拉函数的奥秘
- 线段树入门总结
- JavaScript 教程
- JavaScript 编辑工具
- JavaScript 与HTML
- JavaScript 与Java
- JavaScript 数据结构
- JavaScript 基本数据类型
- JavaScript 特殊数据类型
- JavaScript 运算符
- JavaScript typeof 运算符
- JavaScript 表达式
- JavaScript 类型转换
- JavaScript 基本语法
- JavaScript 注释
- Javascript 基本处理流程
- Javascript 选择结构
- Javascript if 语句
- Javascript if 语句的嵌套
- Javascript switch 语句
- Javascript 循环结构
- Javascript 循环结构实例
- Javascript 跳转语句
- Javascript 控制语句总结
- Javascript 函数介绍
- Javascript 函数的定义
- Javascript 函数调用
- Javascript 几种特殊的函数
- JavaScript 内置函数简介
- Javascript eval() 函数
- Javascript isFinite() 函数
- Javascript isNaN() 函数
- parseInt() 与 parseFloat()
- escape() 与 unescape()
- Javascript 字符串介绍
- Javascript length属性
- javascript 字符串函数
- Javascript 日期对象简介
- Javascript 日期对象用途
- Date 对象属性和方法
- Javascript 数组是什么
- Javascript 创建数组
- Javascript 数组赋值与取值
- Javascript 数组属性和方法
- yii2 url重写并隐藏index.php方法
- PHP设计模式之模板方法模式实例浅析
- keras 自定义loss model.add_loss的使用详解
- keras做CNN的训练误差loss的下降操作
- Python基于yaml文件配置logging日志过程解析
- Python ckeditor富文本编辑器代码实例解析
- PHP自定义错误处理的方法分析
- PHP聊天室简单实现方法详解
- phpStorm+XDebug+chrome 配置详解
- PHP面向对象程序设计之多态性的应用示例
- PHP设计模式之单例模式定义与用法分析
- PHP面向对象程序设计之接口的继承定义与用法详解
- PHP简单验证码功能机制实例详解
- php高清晰度无损图片压缩功能的实现代码
- Python自省及反射原理实例详解