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

于 2018-11-15 13:11:00 发布
阅读量1.4k 收藏 8
点赞数 3
文章标签： json runtime 操作系统
原文链接：http://www.cnblogs.com/delphi2006/p/9962928.html
版权
针对Delphi的ISuperObject JSON属性随机顺序的问题，本文提出了一个重写遍历器的解决方案，以保持属性加入顺序。该方法解决了网上其他修改方案存在的性能下降和属性数限制问题，性能接近原版，且避免了将二叉树改为链表导致的性能大幅下降。文章附带源码分享。

摘要生成于 C知道 ，由 DeepSeek-R1 满血版支持， 前往体验 >

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;
最低0.47元/天 解锁文章
aibi9565
关注
评论
添加红包

请填写红包祝福语或标题

个

红包个数最小为10个

元

红包金额最低5元

当前余额3.43元 前往充值 >
需支付：10.00元
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付元
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明：

1.余额是钱包充值的虚拟货币，按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载，可以购买VIP、付费专栏及课程。

余额充值