SuperObject Delphi 的 JSON 属性乱序 - 操作类…
2018-11-20 03:14:23来源：博客园 阅读 ()
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);
inc(pos);
end else
goto error;
2: case p^ of
#0:
begin
state := stGMTend;
inc(st.Bias, v);
end;
else
goto error;
end;
end;
stGMTend:
begin
if not inctz then
st.Bias := -st.bias;
Break;
end;
stEnd:
begin
Break;
end;
end;
if (st.hour >= 24) or (st.minute >= 60) or (st.second >= 60) or (st.ms >= 1000) or (st.week > 53)
then goto error;
if not havetz then
st.bias := GetTimeBias;
ms := st.ms + st.second * 1000 + (st.minute + st.bias) * 60000 + st.hour * 3600000;
if havedate then
begin
DayTable := @MonthDays[IsLeapYear(st.year)];
if st.month <> 0 then
begin
if not (st.month in [1..12]) or (DayTable^[st.month] < st.day) then
goto error;
for v := 1 to st.month - 1 do
Inc(ms, DayTable^[v] * 86400000);
end;
dec(st.year);
ms := ms + (int64((st.year * 365) + (st.year div 4) - (st.year div 100) +
(st.year div 400) + st.day + st.dayofyear - 719163) * 86400000);
end;
Result := True;
Exit;
error:
Result := False;
end;
function ISO8601DateToDelphiDateTime(const str: SOString; var dt: TDateTime): Boolean;
var
ms: Int64;
begin
Result := ISO8601DateToJavaDateTime(str, ms);
if Result then
dt := JavaToDelphiDateTime(ms)
end;
function DelphiDateTimeToISO8601Date(dt: TDateTime): SOString;
var
year, month, day, hour, min, sec, msec: Word;
tzh: SmallInt;
tzm: Word;
sign: SOChar;
bias: Integer;
begin
DecodeDate(dt, year, month, day);
DecodeTime(dt, hour, min, sec, msec);
bias := GetTimeBias;
tzh := Abs(bias) div 60;
tzm := Abs(bias) - tzh * 60;
if Bias > 0 then
sign := '-' else
sign := '+';
Result := Format('%.4d-%.2d-%.2dT%.2d:%.2d:%.2d,%d%s%.2d:%.2d',
[year, month, day, hour, min, sec, msec, sign, tzh, tzm]);
end;
function TryObjectToDate(const obj: ISuperObject; var dt: TDateTime): Boolean;
var
i: Int64;
begin
case ObjectGetType(obj) of
stInt:
begin
dt := JavaToDelphiDateTime(obj.AsInteger);
Result := True;
end;
stString:
begin
if ISO8601DateToJavaDateTime(obj.AsString, i) then
begin
dt := JavaToDelphiDateTime(i);
Result := True;
end else
Result := TryStrToDateTime(obj.AsString, dt);
end;
else
Result := False;
end;
end;
function SO(const s: SOString): ISuperObject; overload;
begin
Result := TSuperObject.ParseString(PSOChar(s), False);
end;
function SA(const Args: array of const): ISuperObject; overload;
type
TByteArray = array[0..sizeof(integer) - 1] of byte;
PByteArray = ^TByteArray;
var
j: Integer;
intf: IInterface;
begin
Result := TSuperObject.Create(stArray);
for j := 0 to length(Args) - 1 do
with Result.AsArray do
case TVarRec(Args[j]).VType of
vtInteger : Add(TSuperObject.Create(TVarRec(Args[j]).VInteger));
vtInt64 : Add(TSuperObject.Create(TVarRec(Args[j]).VInt64^));
vtBoolean : Add(TSuperObject.Create(TVarRec(Args[j]).VBoolean));
vtChar : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VChar)));
vtWideChar: Add(TSuperObject.Create(SOChar(TVarRec(Args[j]).VWideChar)));
vtExtended: Add(TSuperObject.Create(TVarRec(Args[j]).VExtended^));
vtCurrency: Add(TSuperObject.CreateCurrency(TVarRec(Args[j]).VCurrency^));
vtString : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VString^)));
vtPChar : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VPChar^)));
vtAnsiString: Add(TSuperObject.Create(SOString(AnsiString(TVarRec(Args[j]).VAnsiString))));
vtWideString: Add(TSuperObject.Create(SOString(PWideChar(TVarRec(Args[j]).VWideString))));
vtInterface:
if TVarRec(Args[j]).VInterface = nil then
Add(nil) else
if IInterface(TVarRec(Args[j]).VInterface).QueryInterface(ISuperObject, intf) = 0 then
Add(ISuperObject(intf)) else
Add(nil);
vtPointer :
if TVarRec(Args[j]).VPointer = nil then
Add(nil) else
Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer)));
vtVariant:
Add(SO(TVarRec(Args[j]).VVariant^));
vtObject:
if TVarRec(Args[j]).VPointer = nil then
Add(nil) else
Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer)));
vtClass:
if TVarRec(Args[j]).VPointer = nil then
Add(nil) else
Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer)));
{$if declared(vtUnicodeString)}
vtUnicodeString:
Add(TSuperObject.Create(SOString(string(TVarRec(Args[j]).VUnicodeString))));
{$ifend}
else
assert(false);
end;
end;
function SO(const Args: array of const): ISuperObject; overload;
var
j: Integer;
arr: ISuperObject;
begin
Result := TSuperObject.Create(stObject);
arr := SA(Args);
with arr.AsArray do
for j := 0 to (Length div 2) - 1 do
Result.AsObject.PutO(O[j*2].AsString, O[(j*2) + 1]);
end;
function SO(const value: Variant): ISuperObject; overload;
begin
with TVarData(value) do
case VType of
varNull: Result := nil;
varEmpty: Result := nil;
varSmallInt: Result := TSuperObject.Create(VSmallInt);
varInteger: Result := TSuperObject.Create(VInteger);
varSingle: Result := TSuperObject.Create(VSingle);
varDouble: Result := TSuperObject.Create(VDouble);
varCurrency: Result := TSuperObject.CreateCurrency(VCurrency);
varDate: Result := TSuperObject.Create(DelphiToJavaDateTime(vDate));
varOleStr: Result := TSuperObject.Create(SOString(VOleStr));
varBoolean: Result := TSuperObject.Create(VBoolean);
varShortInt: Result := TSuperObject.Create(VShortInt);
varByte: Result := TSuperObject.Create(VByte);
varWord: Result := TSuperObject.Create(VWord);
varLongWord: Result := TSuperObject.Create(VLongWord);
varInt64: Result := TSuperObject.Create(VInt64);
varString: Result := TSuperObject.Create(SOString(AnsiString(VString)));
{$if declared(varUString)}
varUString: Result := TSuperObject.Create(SOString(string(VUString)));
{$ifend}
else
raise Exception.CreateFmt('Unsuported variant data type: %d', [VType]);
end;
end;
function ObjectIsError(obj: TSuperObject): boolean;
begin
Result := PtrUInt(obj) > PtrUInt(-4000);
end;
function ObjectIsType(const obj: ISuperObject; typ: TSuperType): boolean;
begin
if obj <> nil then
Result := typ = obj.DataType else
Result := typ = stNull;
end;
function ObjectGetType(const obj: ISuperObject): TSuperType;
begin
if obj <> nil then
Result := obj.DataType else
Result := stNull;
end;
function ObjectFindFirst(const obj: ISuperObject; var F: TSuperObjectIter): boolean;
var
i: TSuperAvlEntry;
begin
if ObjectIsType(obj, stObject) then
begin
F.Ite := TSuperAvlIterator.Create(obj.AsObject);
F.Ite.First;
i := F.Ite.GetIter;
if i <> nil then
begin
f.key := i.Name;
f.val := i.Value;
Result := true;
end else
Result := False;
end else
Result := False;
end;
function ObjectFindNext(var F: TSuperObjectIter): boolean;
var
i: TSuperAvlEntry;
begin
F.Ite.Next;
i := F.Ite.GetIter;
if i <> nil then
begin
f.key := i.FName;
f.val := i.Value;
Result := true;
end else
Result := False;
end;
procedure ObjectFindClose(var F: TSuperObjectIter);
begin
F.Ite.Free;
F.val := nil;
end;
{$IFDEF HAVE_RTTI}
function serialtoboolean(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject;
begin
Result := TSuperObject.Create(TValueData(value).FAsSLong <> 0);
end;
function serialtodatetime(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject;
begin
Result := TSuperObject.Create(DelphiToJavaDateTime(TValueData(value).FAsDouble));
end;
function serialtoguid(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject;
var
g: TGUID;
begin
value.ExtractRawData(@g);
Result := TSuperObject.Create(
format('%.8x-%.4x-%.4x-%.2x%.2x-%.2x%.2x%.2x%.2x%.2x%.2x',
[g.D1, g.D2, g.D3,
g.D4[0], g.D4[1], g.D4[2],
g.D4[3], g.D4[4], g.D4[5],
g.D4[6], g.D4[7]])
);
end;
function serialfromboolean(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;
var
o: ISuperObject;
begin
case ObjectGetType(obj) of
stBoolean:
begin
TValueData(Value).FAsSLong := obj.AsInteger;
Result := True;
end;
stInt:
begin
TValueData(Value).FAsSLong := ord(obj.AsInteger <> 0);
Result := True;
end;
stString:
begin
o := SO(obj.AsString);
if not ObjectIsType(o, stString) then
Result := serialfromboolean(ctx, SO(obj.AsString), Value) else
Result := False;
end;
else
Result := False;
end;
end;
function serialfromdatetime(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;
var
dt: TDateTime;
i: Int64;
begin
case ObjectGetType(obj) of
stInt:
begin
TValueData(Value).FAsDouble := JavaToDelphiDateTime(obj.AsInteger);
Result := True;
end;
stString:
begin
if ISO8601DateToJavaDateTime(obj.AsString, i) then
begin
TValueData(Value).FAsDouble := JavaToDelphiDateTime(i);
Result := True;
end else
if TryStrToDateTime(obj.AsString, dt) then
begin
TValueData(Value).FAsDouble := dt;
Result := True;
end else
Result := False;
end;
else
Result := False;
end;
end;
function UuidFromString(p: PSOChar; Uuid: PGUID): Boolean;
const
hex2bin: array[#48..#102] of Byte = (
0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0,
0,10,11,12,13,14,15, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0,10,11,12,13,14,15);
type
TState = (stEatSpaces, stStart, stHEX, stBracket, stEnd);
TUUID = record
case byte of
0: (guid: TGUID);
1: (bytes: array[0..15] of Byte);
2: (words: array[0..7] of Word);
3: (ints: array[0..3] of Cardinal);
4: (i64s: array[0..1] of UInt64);
end;
function ishex(const c: Char): Boolean; {$IFDEF HAVE_INLINE} inline;{$ENDIF}
begin
result := (c < #256) and (AnsiChar(c) in ['0'..'9', 'a'..'z', 'A'..'Z'])
end;
var
pos: Byte;
state, saved: TState;
bracket, separator: Boolean;
label
redo;
begin
FillChar(Uuid^, SizeOf(TGUID), 0);
saved := stStart;
state := stEatSpaces;
bracket := false;
separator := false;
pos := 0;
while true do
redo:
case state of
stEatSpaces:
begin
while true do
case p^ of
' ', #13, #10, #9: inc(p);
else
state := saved;
goto redo;
end;
end;
stStart:
case p^ of
'{':
begin
bracket := true;
inc(p);
state := stEatSpaces;
saved := stHEX;
pos := 0;
end;
else
state := stHEX;
end;
stHEX:
case pos of
0..7:
if ishex(p^) then
begin
Uuid.D1 := (Uuid.D1 * 16) + hex2bin[p^];
inc(p);
inc(pos);
end else
Exit(False);
8:
if (p^ = '-') then
begin
separator := true;
inc(p);
inc(pos)
end else
inc(pos);
13,18,23:
if separator then
begin
if p^ <> '-' then
Exit(False);
inc(p);
inc(pos);
end else
inc(pos);
9..12:
if ishex(p^) then
begin
TUUID(Uuid^).words[2] := (TUUID(Uuid^).words[2] * 16) + hex2bin[p^];
inc(p);
inc(pos);
end else
Exit(False);
14..17:
if ishex(p^) then
begin
TUUID(Uuid^).words[3] := (TUUID(Uuid^).words[3] * 16) + hex2bin[p^];
inc(p);
inc(pos);
end else
Exit(False);
19..20:
if ishex(p^) then
begin
TUUID(Uuid^).bytes[8] := (TUUID(Uuid^).bytes[8] * 16) + hex2bin[p^];
inc(p);
inc(pos);
end else
Exit(False);
21..22:
if ishex(p^) then
begin
TUUID(Uuid^).bytes[9] := (TUUID(Uuid^).bytes[9] * 16) + hex2bin[p^];
inc(p);
inc(pos);
end else
Exit(False);
24..25:
if ishex(p^) then
begin
TUUID(Uuid^).bytes[10] := (TUUID(Uuid^).bytes[10] * 16) + hex2bin[p^];
inc(p);
inc(pos);
end else
Exit(False);
26..27:
if ishex(p^) then
begin
TUUID(Uuid^).bytes[11] := (TUUID(Uuid^).bytes[11] * 16) + hex2bin[p^];
inc(p);
inc(pos);
end else
Exit(False);
28..29:
if ishex(p^) then
begin
TUUID(Uuid^).bytes[12] := (TUUID(Uuid^).bytes[12] * 16) + hex2bin[p^];
inc(p);
inc(pos);
end else
Exit(False);
30..31:
if ishex(p^) then
begin
TUUID(Uuid^).bytes[13] := (TUUID(Uuid^).bytes[13] * 16) + hex2bin[p^];
inc(p);
inc(pos);
end else
Exit(False);
32..33:
if ishex(p^) then
begin
TUUID(Uuid^).bytes[14] := (TUUID(Uuid^).bytes[14] * 16) + hex2bin[p^];
inc(p);
inc(pos);
end else
Exit(False);
34..35:
if ishex(p^) then
begin
TUUID(Uuid^).bytes[15] := (TUUID(Uuid^).bytes[15] * 16) + hex2bin[p^];
inc(p);
inc(pos);
end else
Exit(False);
36: if bracket then
begin
state := stEatSpaces;
saved := stBracket;
end else
begin
state := stEatSpaces;
saved := stEnd;
end;
end;
stBracket:
begin
if p^ <> '}' then
Exit(False);
inc(p);
state := stEatSpaces;
saved := stEnd;
end;
stEnd:
begin
if p^ <> #0 then
Exit(False);
Break;
end;
end;
Result := True;
end;
function UUIDToString(const g: TGUID): string;
begin
Result := format('%.8x%.4x%.4x%.2x%.2x%.2x%.2x%.2x%.2x%.2x%.2x',
[g.D1, g.D2, g.D3,
g.D4[0], g.D4[1], g.D4[2],
g.D4[3], g.D4[4], g.D4[5],
g.D4[6], g.D4[7]]);
end;
function StringToUUID(const str: string; var g: TGUID): Boolean;
begin
Result := UuidFromString(PSOChar(str), @g);
end;
function serialfromguid(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;
begin
case ObjectGetType(obj) of
stNull:
begin
FillChar(Value.GetReferenceToRawData^, SizeOf(TGUID), 0);
Result := True;
end;
stString: Result := UuidFromString(PSOChar(obj.AsString), Value.GetReferenceToRawData);
else
Result := False;
end;
end;
function SOInvoke(const obj: TValue; const method: string; const params: ISuperObject; ctx: TSuperRttiContext): ISuperObject; overload;
var
owned: Boolean;
begin
if ctx = nil then
begin
ctx := TSuperRttiContext.Create;
owned := True;
end else
owned := False;
try
if TrySOInvoke(ctx, obj, method, params, Result) <> irSuccess then
raise Exception.Create('Invalid method call');
finally
if owned then
ctx.Free;
end;
end;
function SOInvoke(const obj: TValue; const method: string; const params: string; ctx: TSuperRttiContext): ISuperObject; overload;
begin
Result := SOInvoke(obj, method, so(params), ctx)
end;
function TrySOInvoke(var ctx: TSuperRttiContext; const obj: TValue;
const method: string; const params: ISuperObject;
var Return: ISuperObject): TSuperInvokeResult;
var
t: TRttiInstanceType;
m: TRttiMethod;
a: TArray<TValue>;
ps: TArray<TRttiParameter>;
v: TValue;
index: ISuperObject;
function GetParams: Boolean;
var
i: Integer;
begin
case ObjectGetType(params) of
stArray:
for i := 0 to Length(ps) - 1 do
if (pfOut in ps[i].Flags) then
TValue.Make(nil, ps[i].ParamType.Handle, a[i]) else
if not ctx.FromJson(ps[i].ParamType.Handle, params.AsArray[i], a[i]) then
Exit(False);
stObject:
for i := 0 to Length(ps) - 1 do
if (pfOut in ps[i].Flags) then
TValue.Make(nil, ps[i].ParamType.Handle, a[i]) else
if not ctx.FromJson(ps[i].ParamType.Handle, params.AsObject[ps[i].Name], a[i]) then
Exit(False);
stNull: ;
else
Exit(False);
end;
Result := True;
end;
procedure SetParams;
var
i: Integer;
begin
case ObjectGetType(params) of
stArray:
for i := 0 to Length(ps) - 1 do
if (ps[i].Flags * [pfVar, pfOut]) <> [] then
params.AsArray[i] := ctx.ToJson(a[i], index);
stObject:
for i := 0 to Length(ps) - 1 do
if (ps[i].Flags * [pfVar, pfOut]) <> [] then
params.AsObject[ps[i].Name] := ctx.ToJson(a[i], index);
end;
end;
begin
Result := irSuccess;
index := SO;
case obj.Kind of
tkClass:
begin
t := TRttiInstanceType(ctx.Context.GetType(obj.AsObject.ClassType));
m := t.GetMethod(method);
if m = nil then Exit(irMethothodError);
ps := m.GetParameters;
SetLength(a, Length(ps));
if not GetParams then Exit(irParamError);
if m.IsClassMethod then
begin
v := m.Invoke(obj.AsObject.ClassType, a);
Return := ctx.ToJson(v, index);
SetParams;
end else
begin
v := m.Invoke(obj, a);
Return := ctx.ToJson(v, index);
SetParams;
end;
end;
tkClassRef:
begin
t := TRttiInstanceType(ctx.Context.GetType(obj.AsClass));
m := t.GetMethod(method);
if m = nil then Exit(irMethothodError);
ps := m.GetParameters;
SetLength(a, Length(ps));
if not GetParams then Exit(irParamError);
if m.IsClassMethod then
begin
v := m.Invoke(obj, a);
Return := ctx.ToJson(v, index);
SetParams;
end else
Exit(irError);
end;
else
Exit(irError);
end;
end;
{$ENDIF}
{ TSuperEnumerator }
constructor TSuperEnumerator.Create(const obj: ISuperObject);
begin
FObj := obj;
FCount := -1;
if ObjectIsType(FObj, stObject) then
FObjEnum := FObj.AsObject.GetEnumerator else
FObjEnum := nil;
end;
destructor TSuperEnumerator.Destroy;
begin
if FObjEnum <> nil then
FObjEnum.Free;
end;
function TSuperEnumerator.MoveNext: Boolean;
begin
case ObjectGetType(FObj) of
stObject: Result := FObjEnum.MoveNext;
stArray:
begin
inc(FCount);
if FCount < FObj.AsArray.Length then
Result := True else
Result := False;
end;
else
Result := false;
end;
end;
function TSuperEnumerator.GetCurrent: ISuperObject;
begin
case ObjectGetType(FObj) of
stObject: Result := FObjEnum.Current.Value;
stArray: Result := FObj.AsArray.GetO(FCount);
else
Result := FObj;
end;
end;
{ TSuperObject }
constructor TSuperObject.Create(jt: TSuperType);
begin
inherited Create;
{$IFDEF DEBUG}
InterlockedIncrement(debugcount);
{$ENDIF}
FProcessing := false;
FDataPtr := nil;
FDataType := jt;
case FDataType of
stObject: FO.c_object := TSuperTableString.Create;
stArray: FO.c_array := TSuperArray.Create;
stString: FOString := '';
else
FO.c_object := nil;
end;
end;
constructor TSuperObject.Create(b: boolean);
begin
Create(stBoolean);
FO.c_boolean := b;
end;
constructor TSuperObject.Create(i: SuperInt);
begin
Create(stInt);
FO.c_int := i;
end;
constructor TSuperObject.Create(d: double);
begin
Create(stDouble);
FO.c_double := d;
end;
constructor TSuperObject.CreateCurrency(c: Currency);
begin
Create(stCurrency);
FO.c_currency := c;
end;
destructor TSuperObject.Destroy;
begin
{$IFDEF DEBUG}
InterlockedDecrement(debugcount);
{$ENDIF}
case FDataType of
stObject: FO.c_object.Free;
stArray: FO.c_array.Free;
end;
inherited;
end;
function TSuperObject.Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer;
function DoEscape(str: PSOChar; len: Integer): Integer;
var
pos, start_offset: Integer;
c: SOChar;
buf: array[0..5] of SOChar;
type
TByteChar = record
case integer of
0: (a, b: Byte);
1: (c: WideChar);
end;
begin
if str = nil then
begin
Result := 0;
exit;
end;
pos := 0; start_offset := 0;
with writer do
while pos < len do
begin
c := str[pos];
case c of
#8,#9,#10,#12,#13,'"','\','/':
begin
if(pos - start_offset > 0) then
Append(str + start_offset, pos - start_offset);
if(c = #8) then Append(ESC_BS, 2)
else if (c = #9) then Append(ESC_TAB, 2)
else if (c = #10) then Append(ESC_LF, 2)
else if (c = #12) then Append(ESC_FF, 2)
else if (c = #13) then Append(ESC_CR, 2)
else if (c = '"') then Append(ESC_QUOT, 2)
else if (c = '\') then Append(ESC_SL, 2)
else if (c = '/') then Append(ESC_SR, 2);
inc(pos);
start_offset := pos;
end;
else
if (SOIChar(c) > 255) then
begin
if(pos - start_offset > 0) then
Append(str + start_offset, pos - start_offset);
buf[0] := '\';
buf[1] := 'u';
buf[2] := super_hex_chars[TByteChar(c).b shr 4];
buf[3] := super_hex_chars[TByteChar(c).b and $f];
buf[4] := super_hex_chars[TByteChar(c).a shr 4];
buf[5] := super_hex_chars[TByteChar(c).a and $f];
Append(@buf, 6);
inc(pos);
start_offset := pos;
end else
if (c < #32) or (c > #127) then
begin
if(pos - start_offset > 0) then
Append(str + start_offset, pos - start_offset);
buf[0] := '\';
buf[1] := 'u';
buf[2] := '0';
buf[3] := '0';
buf[4] := super_hex_chars[ord(c) shr 4];
buf[5] := super_hex_chars[ord(c) and $f];
Append(buf, 6);
inc(pos);
start_offset := pos;
end else
inc(pos);
end;
end;
if(pos - start_offset > 0) then
writer.Append(str + start_offset, pos - start_offset);
Result := 0;
end;
function DoMinimalEscape(str: PSOChar; len: Integer): Integer;
var
pos, start_offset: Integer;
c: SOChar;
type
TByteChar = record
case integer of
0: (a, b: Byte);
1: (c: WideChar);
end;
begin
if str = nil then
begin
Result := 0;
exit;
end;
pos := 0; start_offset := 0;
with writer do
while pos < len do
begin
c := str[pos];
case c of
#0:
begin
if(pos - start_offset > 0) then
Append(str + start_offset, pos - start_offset);
Append(ESC_ZERO, 6);
inc(pos);
start_offset := pos;
end;
'"':
begin
if(pos - start_offset > 0) then
Append(str + start_offset, pos - start_offset);
Append(ESC_QUOT, 2);
inc(pos);
start_offset := pos;
end;
'\':
begin
if(pos - start_offset > 0) then
Append(str + start_offset, pos - start_offset);
Append(ESC_SL, 2);
inc(pos);
start_offset := pos;
end;
else
inc(pos);
end;
end;
if(pos - start_offset > 0) then
writer.Append(str + start_offset, pos - start_offset);
Result := 0;
end;
procedure _indent(i: shortint; r: boolean);
begin
inc(level, i);
if r then
with writer do
begin
{$IFDEF MSWINDOWS}
Append(TOK_CRLF, 2);
{$ELSE}
Append(TOK_LF, 1);
{$ENDIF}
for i := 0 to level - 1 do
Append(TOK_SP, 1);
end;
end;
var
k,j: Integer;
iter: TSuperObjectIter;
st: AnsiString;
val: ISuperObject;
const
ENDSTR_A: PSOChar = '": ';
ENDSTR_B: PSOChar = '":';
begin
if FProcessing then
begin
Result := writer.Append(TOK_NULL, 4);
Exit;
end;
FProcessing := true;
with writer do
try
case FDataType of
stObject:
if FO.c_object.FCount > 0 then
begin
k := 0;
Append(TOK_CBL, 1);
if indent then _indent(1, false);
if ObjectFindFirst(Self, iter) then
repeat
{$IFDEF SUPER_METHOD}
if (iter.val = nil) or not ObjectIsType(iter.val, stMethod) then
begin
{$ENDIF}
if (iter.val = nil) or (not iter.val.Processing) then
begin
if(k <> 0) then
Append(TOK_COM, 1);
if indent then _indent(0, true);
Append(TOK_DQT, 1);
if escape then
doEscape(PSOChar(iter.key), Length(iter.key)) else
DoMinimalEscape(PSOChar(iter.key), Length(iter.key));
if indent then
Append(ENDSTR_A, 3) else
Append(ENDSTR_B, 2);
if(iter.val = nil) then
Append(TOK_NULL, 4) else
iter.val.write(writer, indent, escape, level);
inc(k);
end;
{$IFDEF SUPER_METHOD}
end;
{$ENDIF}
until not ObjectFindNext(iter);
ObjectFindClose(iter);
if indent then _indent(-1, true);
Result := Append(TOK_CBR, 1);
end else
Result := Append(TOK_OBJ, 2);
stBoolean:
begin
if (FO.c_boolean) then
Result := Append(TOK_TRUE, 4) else
Result := Append(TOK_FALSE, 5);
end;
stInt:
begin
str(FO.c_int, st);
Result := Append(PSOChar(SOString(st)));
end;
stDouble:
Result := Append(PSOChar(FloatToJson(FO.c_double)));
stCurrency:
begin
Result := Append(PSOChar(CurrToJson(FO.c_currency)));
end;
stString:
begin
Append(TOK_DQT, 1);
if escape then
doEscape(PSOChar(FOString), Length(FOString)) else
DoMinimalEscape(PSOChar(FOString), Length(FOString));
Append(TOK_DQT, 1);
Result := 0;
end;
stArray:
if FO.c_array.FLength > 0 then
begin
Append(TOK_ARL, 1);
if indent then _indent(1, true);
k := 0;
j := 0;
while k < FO.c_array.FLength do
begin
val := FO.c_array.GetO(k);
{$IFDEF SUPER_METHOD}
if not ObjectIsType(val, stMethod) then
begin
{$ENDIF}
if (val = nil) or (not val.Processing) then
begin
if (j <> 0) then
Append(TOK_COM, 1);
if(val = nil) then
Append(TOK_NULL, 4) else
val.write(writer, indent, escape, level);
inc(j);
end;
{$IFDEF SUPER_METHOD}
end;
{$ENDIF}
inc(k);
end;
if indent then _indent(-1, false);
Result := Append(TOK_ARR, 1);
end else
Result := Append(TOK_ARRAY, 2);
stNull:
Result := Append(TOK_NULL, 4);
else
Result := 0;
end;
finally
FProcessing := false;
end;
end;
function TSuperObject.IsType(AType: TSuperType): boolean;
begin
Result := AType = FDataType;
end;
function TSuperObject.AsBoolean: boolean;
begin
case FDataType of
stBoolean: Result := FO.c_boolean;
stInt: Result := (FO.c_int <> 0);
stDouble: Result := (FO.c_double <> 0);
stCurrency: Result := (FO.c_currency <> 0);
stString: Result := (Length(FOString) <> 0);
stNull: Result := False;
else
Result := True;
end;
end;
function TSuperObject.AsInteger: SuperInt;
var
code: integer;
cint: SuperInt;
begin
case FDataType of
stInt: Result := FO.c_int;
stDouble: Result := round(FO.c_double);
stCurrency: Result := round(FO.c_currency);
stBoolean: Result := ord(FO.c_boolean);
stString:
begin
Val(FOString, cint, code);
if code = 0 then
Result := cint else
Result := 0;
end;
else
Result := 0;
end;
end;
function TSuperObject.AsDouble: Double;
var
code: integer;
cdouble: double;
begin
case FDataType of
stDouble: Result := FO.c_double;
stCurrency: Result := FO.c_currency;
stInt: Result := FO.c_int;
stBoolean: Result := ord(FO.c_boolean);
stString:
begin
Val(FOString, cdouble, code);
if code = 0 then
Result := cdouble else
Result := 0.0;
end;
else
Result := 0.0;
end;
end;
function TSuperObject.AsCurrency: Currency;
var
code: integer;
cdouble: double;
begin
case FDataType of
stDouble: Result := FO.c_double;
stCurrency: Result := FO.c_currency;
stInt: Result := FO.c_int;
stBoolean: Result := ord(FO.c_boolean);
stString:
begin
Val(FOString, cdouble, code);
if code = 0 then
Result := cdouble else
Result := 0.0;
end;
else
Result := 0.0;
end;
end;
function TSuperObject.AsString: SOString;
begin
if FDataType = stString then
Result := FOString else
Result := AsJSon(false, false);
end;
function TSuperObject.GetEnumerator: TSuperEnumerator;
begin
Result := TSuperEnumerator.Create(Self);
end;
procedure TSuperObject.AfterConstruction;
begin
InterlockedDecrement(FRefCount);
end;
procedure TSuperObject.BeforeDestruction;
begin
if RefCount <> 0 then
raise Exception.Create('Invalid pointer');
end;
function TSuperObject.AsArray: TSuperArray;
begin
if FDataType = stArray then
Result := FO.c_array else
Result := nil;
end;
function TSuperObject.AsObject: TSuperTableString;
begin
if FDataType = stObject then
Result := FO.c_object else
Result := nil;
end;
function TSuperObject.AsJSon(indent, escape: boolean): SOString;
var
pb: TSuperWriterString;
begin
pb := TSuperWriterString.Create;
try
if(Write(pb, indent, escape, 0) < 0) then
begin
Result := '';
Exit;
end;
if pb.FBPos > 0 then
Result := pb.FBuf else
Result := '';
finally
pb.Free;
end;
end;
class function TSuperObject.ParseString(s: PSOChar; strict: Boolean; partial: boolean; const this: ISuperObject;
options: TSuperFindOptions; const put: ISuperObject; dt: TSuperType): ISuperObject;
var
tok: TSuperTokenizer;
obj: ISuperObject;
begin
tok := TSuperTokenizer.Create;
obj := ParseEx(tok, s, -1, strict, this, options, put, dt);
if(tok.err <> teSuccess) or (not partial and (s[tok.char_offset] <> #0)) then
Result := nil else
Result := obj;
tok.Free;
end;
class function TSuperObject.ParseStream(stream: TStream; strict: Boolean;
partial: boolean; const this: ISuperObject; options: TSuperFindOptions;
const put: ISuperObject; dt: TSuperType): ISuperObject;
const
BUFFER_SIZE = 1024;
var
tok: TSuperTokenizer;
buffera: array[0..BUFFER_SIZE-1] of AnsiChar;
bufferw: array[0..BUFFER_SIZE-1] of SOChar;
bom: array[0..1] of byte;
unicode: boolean;
j, size: Integer;
st: string;
begin
st := '';
tok := TSuperTokenizer.Create;
if (stream.Read(bom, sizeof(bom)) = 2) and (bom[0] = $FF) and (bom[1] = $FE) then
begin
unicode := true;
size := stream.Read(bufferw, BUFFER_SIZE * SizeOf(SoChar)) div SizeOf(SoChar);
end else
begin
unicode := false;
stream.Seek(0, soFromBeginning);
size := stream.Read(buffera, BUFFER_SIZE);
end;
while size > 0 do
begin
if not unicode then
for j := 0 to size - 1 do
bufferw[j] := SOChar(buffera[j]);
ParseEx(tok, bufferw, size, strict, this, options, put, dt);
if tok.err = teContinue then
begin
if not unicode then
size := stream.Read(buffera, BUFFER_SIZE) else
size := stream.Read(bufferw, BUFFER_SIZE * SizeOf(SoChar)) div SizeOf(SoChar);
end else
Break;
end;
if(tok.err <> teSuccess) or (not partial and (st[tok.char_offset] <> #0)) then
Result := nil else
Result := tok.stack[tok.depth].current;
tok.Free;
end;
class function TSuperObject.ParseFile(const FileName: string; strict: Boolean;
partial: boolean; const this: ISuperObject; options: TSuperFindOptions;
const put: ISuperObject; dt: TSuperType): ISuperObject;
var
stream: TFileStream;
begin
stream := TFileStream.Create(FileName, fmOpenRead, fmShareDenyWrite);
try
Result := ParseStream(stream, strict, partial, this, options, put, dt);
finally
stream.Free;
end;
end;
class function TSuperObject.ParseEx(tok: TSuperTokenizer; str: PSOChar; len: integer;
strict: Boolean; const this: ISuperObject; options: TSuperFindOptions; const put: ISuperObject; dt: TSuperType): ISuperObject;
const
spaces = [#32,#8,#9,#10,#12,#13];
delimiters = ['"', '.', '[', ']', '{', '}', '(', ')', ',', ':', #0];
reserved = delimiters + spaces;
path = ['a'..'z', 'A'..'Z', '.', '_'];
function hexdigit(x: SOChar): byte; {$IFDEF HAVE_INLINE} inline;{$ENDIF}
begin
if x <= '9' then
Result := byte(x) - byte('0') else
Result := (byte(x) and 7) + 9;
end;
function min(v1, v2: integer): integer;{$IFDEF HAVE_INLINE} inline;{$ENDIF}
begin if v1 < v2 then result := v1 else result := v2 end;
var
obj: ISuperObject;
v: SOChar;
{$IFDEF SUPER_METHOD}
sm: TSuperMethod;
{$ENDIF}
numi: SuperInt;
numd: Double;
code: integer;
TokRec: PSuperTokenerSrec;
evalstack: integer;
p: PSOChar;
function IsEndDelimiter(v: AnsiChar): Boolean;
begin
if tok.depth > 0 then
case tok.stack[tok.depth - 1].state of
tsArrayAdd: Result := v in [',', ']', #0];
tsObjectValueAdd: Result := v in [',', '}', #0];
else
Result := v = #0;
end else
Result := v = #0;
end;
label out, redo_char;
begin
evalstack := 0;
obj := nil;
Result := nil;
TokRec := @tok.stack[tok.depth];
tok.char_offset := 0;
tok.err := teSuccess;
repeat
if (tok.char_offset = len) then
begin
if (tok.depth = 0) and (TokRec^.state = tsEatws) and
(TokRec^.saved_state = tsFinish) then
tok.err := teSuccess else
tok.err := teContinue;
goto out;
end;
v := str^;
case v of
#10:
begin
inc(tok.line);
tok.col := 0;
end;
#9: inc(tok.col, 4);
else
inc(tok.col);
end;
redo_char:
case TokRec^.state of
tsEatws:
begin
if (SOIChar(v) < 256) and (AnsiChar(v) in spaces) then {nop} else
if (v = '/') then
begin
tok.pb.Reset;
tok.pb.Append(@v, 1);
TokRec^.state := tsCommentStart;
end else begin
TokRec^.state := TokRec^.saved_state;
goto redo_char;
end
end;
tsStart:
case v of
'"',
'''':
begin
TokRec^.state := tsString;
tok.pb.Reset;
tok.quote_char := v;
end;
'-':
begin
TokRec^.state := tsNumber;
tok.pb.Reset;
tok.is_double := 0;
tok.floatcount := -1;
goto redo_char;
end;
'0'..'9':
begin
if (tok.depth = 0) then
case ObjectGetType(this) of
stObject:
begin
TokRec^.state := tsIdentifier;
TokRec^.current := this;
goto redo_char;
end;
end;
TokRec^.state := tsNumber;
tok.pb.Reset;
tok.is_double := 0;
tok.floatcount := -1;
goto redo_char;
end;
'{':
begin
TokRec^.state := tsEatws;
TokRec^.saved_state := tsObjectFieldStart;
TokRec^.current := TSuperObject.Create(stObject);
end;
'[':
begin
TokRec^.state := tsEatws;
TokRec^.saved_state := tsArray;
TokRec^.current := TSuperObject.Create(stArray);
end;
{$IFDEF SUPER_METHOD}
'(':
begin
if (tok.depth = 0) and ObjectIsType(this, stMethod) then
begin
TokRec^.current := this;
TokRec^.state := tsParamValue;
end;
end;
{$ENDIF}
'N',
'n':
begin
TokRec^.state := tsNull;
tok.pb.Reset;
tok.st_pos := 0;
goto redo_char;
end;
'T',
't',
'F',
'f':
begin
TokRec^.state := tsBoolean;
tok.pb.Reset;
tok.st_pos := 0;
goto redo_char;
end;
else
TokRec^.state := tsIdentifier;
tok.pb.Reset;
goto redo_char;
end;
tsFinish:
begin
if(tok.depth = 0) then goto out;
obj := TokRec^.current;
tok.ResetLevel(tok.depth);
dec(tok.depth);
TokRec := @tok.stack[tok.depth];
goto redo_char;
end;
tsNull:
begin
tok.pb.Append(@v, 1);
if (StrLComp(TOK_NULL, PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 4)) = 0) then
begin
if (tok.st_pos = 4) then
if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then
TokRec^.state := tsIdentifier else
begin
TokRec^.current := TSuperObject.Create(stNull);
TokRec^.saved_state := tsFinish;
TokRec^.state := tsEatws;
goto redo_char;
end;
end else
begin
TokRec^.state := tsIdentifier;
tok.pb.FBuf[tok.st_pos] := #0;
dec(tok.pb.FBPos);
goto redo_char;
end;
inc(tok.st_pos);
end;
tsCommentStart:
begin
if(v = '*') then
begin
TokRec^.state := tsComment;
end else
if (v = '/') then
begin
TokRec^.state := tsCommentEol;
end else
begin
tok.err := teParseComment;
goto out;
end;
tok.pb.Append(@v, 1);
end;
tsComment:
begin
if(v = '*') then
TokRec^.state := tsCommentEnd;
tok.pb.Append(@v, 1);
end;
tsCommentEol:
begin
if (v = #10) then
TokRec^.state := tsEatws else
tok.pb.Append(@v, 1);
end;
tsCommentEnd:
begin
tok.pb.Append(@v, 1);
if (v = '/') then
TokRec^.state := tsEatws else
TokRec^.state := tsComment;
end;
tsString:
begin
if (v = tok.quote_char) then
begin
TokRec^.current := TSuperObject.Create(SOString(tok.pb.GetString));
TokRec^.saved_state := tsFinish;
TokRec^.state := tsEatws;
end else
if (v = '\') then
begin
TokRec^.saved_state := tsString;
TokRec^.state := tsStringEscape;
end else
begin
tok.pb.Append(@v, 1);
end
end;
tsEvalProperty:
begin
if (TokRec^.current = nil) and (foCreatePath in options) then
begin
TokRec^.current := TSuperObject.Create(stObject);
TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current)
end else
if not ObjectIsType(TokRec^.current, stObject) then
begin
tok.err := teEvalObject;
goto out;
end;
tok.pb.Reset;
TokRec^.state := tsIdentifier;
goto redo_char;
end;
tsEvalArray:
begin
if (TokRec^.current = nil) and (foCreatePath in options) then
begin
TokRec^.current := TSuperObject.Create(stArray);
TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current)
end else
if not ObjectIsType(TokRec^.current, stArray) then
begin
tok.err := teEvalArray;
goto out;
end;
tok.pb.Reset;
TokRec^.state := tsParamValue;
goto redo_char;
end;
{$IFDEF SUPER_METHOD}
tsEvalMethod:
begin
if ObjectIsType(TokRec^.current, stMethod) and assigned(TokRec^.current.AsMethod) then
begin
tok.pb.Reset;
TokRec^.obj := TSuperObject.Create(stArray);
TokRec^.state := tsMethodValue;
goto redo_char;
end else
begin
tok.err := teEvalMethod;
goto out;
end;
end;
tsMethodValue:
begin
case v of
')':
TokRec^.state := tsIdentifier;
else
if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then
begin
tok.err := teDepth;
goto out;
end;
inc(evalstack);
TokRec^.state := tsMethodPut;
inc(tok.depth);
tok.ResetLevel(tok.depth);
TokRec := @tok.stack[tok.depth];
goto redo_char;
end;
end;
tsMethodPut:
begin
TokRec^.obj.AsArray.Add(obj);
case v of
',':
begin
tok.pb.Reset;
TokRec^.saved_state := tsMethodValue;
TokRec^.state := tsEatws;
end;
')':
begin
if TokRec^.obj.AsArray.Length = 1 then
TokRec^.obj := TokRec^.obj.AsArray.GetO(0);
dec(evalstack);
tok.pb.Reset;
TokRec^.saved_state := tsIdentifier;
TokRec^.state := tsEatws;
end;
else
tok.err := teEvalMethod;
goto out;
end;
end;
{$ENDIF}
tsParamValue:
begin
case v of
']':
TokRec^.state := tsIdentifier;
else
if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then
begin
tok.err := teDepth;
goto out;
end;
inc(evalstack);
TokRec^.state := tsParamPut;
inc(tok.depth);
tok.ResetLevel(tok.depth);
TokRec := @tok.stack[tok.depth];
goto redo_char;
end;
end;
tsParamPut:
begin
dec(evalstack);
TokRec^.obj := obj;
tok.pb.Reset;
TokRec^.saved_state := tsIdentifier;
TokRec^.state := tsEatws;
if v <> ']' then
begin
tok.err := teEvalArray;
goto out;
end;
end;
tsIdentifier:
begin
if (this = nil) then
begin
if (SOIChar(v) < 256) and IsEndDelimiter(AnsiChar(v)) then
begin
if not strict then
begin
tok.pb.TrimRight;
TokRec^.current := TSuperObject.Create(tok.pb.Fbuf);
TokRec^.saved_state := tsFinish;
TokRec^.state := tsEatws;
goto redo_char;
end else
begin
tok.err := teParseString;
goto out;
end;
end else
if (v = '\') then
begin
TokRec^.saved_state := tsIdentifier;
TokRec^.state := tsStringEscape;
end else
tok.pb.Append(@v, 1);
end else
begin
if (SOIChar(v) < 256) and (AnsiChar(v) in reserved) then
begin
TokRec^.gparent := TokRec^.parent;
if TokRec^.current = nil then
TokRec^.parent := this else
TokRec^.parent := TokRec^.current;
case ObjectGetType(TokRec^.parent) of
stObject:
case v of
'.':
begin
TokRec^.state := tsEvalProperty;
if tok.pb.FBPos > 0 then
TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
end;
'[':
begin
TokRec^.state := tsEvalArray;
if tok.pb.FBPos > 0 then
TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
end;
'(':
begin
TokRec^.state := tsEvalMethod;
if tok.pb.FBPos > 0 then
TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
end;
else
if tok.pb.FBPos > 0 then
TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
if (foPutValue in options) and (evalstack = 0) then
begin
TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, put);
TokRec^.current := put
end else
if (foDelete in options) and (evalstack = 0) then
begin
TokRec^.current := TokRec^.parent.AsObject.Delete(tok.pb.Fbuf);
end else
if (TokRec^.current = nil) and (foCreatePath in options) then
begin
TokRec^.current := TSuperObject.Create(dt);
TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current);
end;
TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
TokRec^.state := tsFinish;
goto redo_char;
end;
stArray:
begin
if TokRec^.obj <> nil then
begin
if not ObjectIsType(TokRec^.obj, stInt) or (TokRec^.obj.AsInteger < 0) then
begin
tok.err := teEvalInt;
TokRec^.obj := nil;
goto out;
end;
numi := TokRec^.obj.AsInteger;
TokRec^.obj := nil;
TokRec^.current := TokRec^.parent.AsArray.GetO(numi);
case v of
'.':
if (TokRec^.current = nil) and (foCreatePath in options) then
begin
TokRec^.current := TSuperObject.Create(stObject);
TokRec^.parent.AsArray.PutO(numi, TokRec^.current);
end else
if (TokRec^.current = nil) then
begin
tok.err := teEvalObject;
goto out;
end;
'[':
begin
if (TokRec^.current = nil) and (foCreatePath in options) then
begin
TokRec^.current := TSuperObject.Create(stArray);
TokRec^.parent.AsArray.Add(TokRec^.current);
end else
if (TokRec^.current = nil) then
begin
tok.err := teEvalArray;
goto out;
end;
TokRec^.state := tsEvalArray;
end;
'(': TokRec^.state := tsEvalMethod;
else
if (foPutValue in options) and (evalstack = 0) then
begin
TokRec^.parent.AsArray.PutO(numi, put);
TokRec^.current := put;
end else
if (foDelete in options) and (evalstack = 0) then
begin
TokRec^.current := TokRec^.parent.AsArray.Delete(numi);
end else
TokRec^.current := TokRec^.parent.AsArray.GetO(numi);
TokRec^.state := tsFinish;
goto redo_char
end;
end else
begin
case v of
'.':
begin
if (foPutValue in options) then
begin
TokRec^.current := TSuperObject.Create(stObject);
TokRec^.parent.AsArray.Add(TokRec^.current);
end else
TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1);
end;
'[':
begin
if (foPutValue in options) then
begin
TokRec^.current := TSuperObject.Create(stArray);
TokRec^.parent.AsArray.Add(TokRec^.current);
end else
TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1);
TokRec^.state := tsEvalArray;
end;
'(':
begin
if not (foPutValue in options) then
TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1) else
TokRec^.current := nil;
TokRec^.state := tsEvalMethod;
end;
else
if (foPutValue in options) and (evalstack = 0) then
begin
TokRec^.parent.AsArray.Add(put);
TokRec^.current := put;
end else
if tok.pb.FBPos = 0 then
TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1);
TokRec^.state := tsFinish;
goto redo_char
end;
end;
end;
{$IFDEF SUPER_METHOD}
stMethod:
case v of
'.':
begin
TokRec^.current := nil;
sm := TokRec^.parent.AsMethod;
sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);
TokRec^.obj := nil;
end;
'[':
begin
TokRec^.current := nil;
sm := TokRec^.parent.AsMethod;
sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);
TokRec^.state := tsEvalArray;
TokRec^.obj := nil;
end;
'(':
begin
TokRec^.current := nil;
sm := TokRec^.parent.AsMethod;
sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);
TokRec^.state := tsEvalMethod;
TokRec^.obj := nil;
end;
else
if not (foPutValue in options) or (evalstack > 0) then
begin
TokRec^.current := nil;
sm := TokRec^.parent.AsMethod;
sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);
TokRec^.obj := nil;
TokRec^.state := tsFinish;
goto redo_char
end else
begin
tok.err := teEvalMethod;
TokRec^.obj := nil;
goto out;
end;
end;
{$ENDIF}
end;
end else
tok.pb.Append(@v, 1);
end;
end;
tsStringEscape:
case v of
'b',
'n',
'r',
't',
'f':
begin
if(v = 'b') then tok.pb.Append(TOK_BS, 1)
else if(v = 'n') then tok.pb.Append(TOK_LF, 1)
else if(v = 'r') then tok.pb.Append(TOK_CR, 1)
else if(v = 't') then tok.pb.Append(TOK_TAB, 1)
else if(v = 'f') then tok.pb.Append(TOK_FF, 1);
TokRec^.state := TokRec^.saved_state;
end;
'u':
begin
tok.ucs_char := 0;
tok.st_pos := 0;
TokRec^.state := tsEscapeUnicode;
end;
'x':
begin
tok.ucs_char := 0;
tok.st_pos := 0;
TokRec^.state := tsEscapeHexadecimal;
end
else
tok.pb.Append(@v, 1);
TokRec^.state := TokRec^.saved_state;
end;
tsEscapeUnicode:
begin
if ((SOIChar(v) < 256) and (AnsiChar(v) in super_hex_chars_set)) then
begin
inc(tok.ucs_char, (Word(hexdigit(v)) shl ((3-tok.st_pos)*4)));
inc(tok.st_pos);
if (tok.st_pos = 4) then
begin
tok.pb.Append(@tok.ucs_char, 1);
TokRec^.state := TokRec^.saved_state;
end
end else
begin
tok.err := teParseString;
goto out;
end
end;
tsEscapeHexadecimal:
begin
if ((SOIChar(v) < 256) and (AnsiChar(v) in super_hex_chars_set)) then
begin
inc(tok.ucs_char, (Word(hexdigit(v)) shl ((1-tok.st_pos)*4)));
inc(tok.st_pos);
if (tok.st_pos = 2) then
begin
tok.pb.Append(@tok.ucs_char, 1);
TokRec^.state := TokRec^.saved_state;
end
end else
begin
tok.err := teParseString;
goto out;
end
end;
tsBoolean:
begin
tok.pb.Append(@v, 1);
if (StrLComp('true', PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 4)) = 0) then
begin
if (tok.st_pos = 4) then
if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then
TokRec^.state := tsIdentifier else
begin
TokRec^.current := TSuperObject.Create(true);
TokRec^.saved_state := tsFinish;
TokRec^.state := tsEatws;
goto redo_char;
end
end else
if (StrLComp('false', PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 5)) = 0) then
begin
if (tok.st_pos = 5) then
if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then
TokRec^.state := tsIdentifier else
begin
TokRec^.current := TSuperObject.Create(false);
TokRec^.saved_state := tsFinish;
TokRec^.state := tsEatws;
goto redo_char;
end
end else
begin
TokRec^.state := tsIdentifier;
tok.pb.FBuf[tok.st_pos] := #0;
dec(tok.pb.FBPos);
goto redo_char;
end;
inc(tok.st_pos);
end;
tsNumber:
begin
if (SOIChar(v) < 256) and (AnsiChar(v) in super_number_chars_set) then
begin
tok.pb.Append(@v, 1);
if (SOIChar(v) < 256) then
case v of
'.': begin
tok.is_double := 1;
tok.floatcount := 0;
end;
'e','E':
begin
tok.is_double := 1;
tok.floatcount := -1;
end;
'0'..'9':
begin
if (tok.is_double = 1) and (tok.floatcount >= 0) then
begin
inc(tok.floatcount);
if tok.floatcount > 4 then
tok.floatcount := -1;
end;
end;
end;
end else
begin
if (tok.is_double = 0) then
begin
val(tok.pb.FBuf, numi, code);
if ObjectIsType(this, stArray) then
begin
if (foPutValue in options) and (evalstack = 0) then
begin
this.AsArray.PutO(numi, put);
TokRec^.current := put;
end else
if (foDelete in options) and (evalstack = 0) then
TokRec^.current := this.AsArray.Delete(numi) else
TokRec^.current := this.AsArray.GetO(numi);
end else
TokRec^.current := TSuperObject.Create(numi);
end else
if (tok.is_double <> 0) then
begin
if tok.floatcount >= 0 then
begin
p := tok.pb.FBuf;
while p^ <> '.' do inc(p);
for code := 0 to tok.floatcount - 1 do
begin
p^ := p[1];
inc(p);
end;
p^ := #0;
val(tok.pb.FBuf, numi, code);
case tok.floatcount of
0: numi := numi * 10000;
1: numi := numi * 1000;
2: numi := numi * 100;
3: numi := numi * 10;
end;
TokRec^.current := TSuperObject.CreateCurrency(PCurrency(@numi)^);
end else
begin
val(tok.pb.FBuf, numd, code);
TokRec^.current := TSuperObject.Create(numd);
end;
end else
begin
tok.err := teParseNumber;
goto out;
end;
TokRec^.saved_state := tsFinish;
TokRec^.state := tsEatws;
goto redo_char;
end
end;
tsArray:
begin
if (v = ']') then
begin
TokRec^.saved_state := tsFinish;
TokRec^.state := tsEatws;
end else
begin
if(tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then
begin
tok.err := teDepth;
goto out;
end;
TokRec^.state := tsArrayAdd;
inc(tok.depth);
tok.ResetLevel(tok.depth);
TokRec := @tok.stack[tok.depth];
goto redo_char;
end
end;
tsArrayAdd:
begin
TokRec^.current.AsArray.Add(obj);
TokRec^.saved_state := tsArraySep;
TokRec^.state := tsEatws;
goto redo_char;
end;
tsArraySep:
begin
if (v = ']') then
begin
TokRec^.saved_state := tsFinish;
TokRec^.state := tsEatws;
end else
if (v = ',') then
begin
TokRec^.saved_state := tsArray;
TokRec^.state := tsEatws;
end else
begin
tok.err := teParseArray;
goto out;
end
end;
tsObjectFieldStart:
begin
if (v = '}') then
begin
TokRec^.saved_state := tsFinish;
TokRec^.state := tsEatws;
end else
if (SOIChar(v) < 256) and (AnsiChar(v) in ['"', '''']) then
begin
tok.quote_char := v;
tok.pb.Reset;
TokRec^.state := tsObjectField;
end else
if not((SOIChar(v) < 256) and ((AnsiChar(v) in reserved) or strict)) then
begin
TokRec^.state := tsObjectUnquotedField;
tok.pb.Reset;
goto redo_char;
end else
begin
tok.err := teParseObjectKeyName;
goto out;
end
end;
tsObjectField:
begin
if (v = tok.quote_char) then
begin
TokRec^.field_name := tok.pb.FBuf;
TokRec^.saved_state := tsObjectFieldEnd;
TokRec^.state := tsEatws;
end else
if (v = '\') then
begin
TokRec^.saved_state := tsObjectField;
TokRec^.state := tsStringEscape;
end else
begin
tok.pb.Append(@v, 1);
end
end;
tsObjectUnquotedField:
begin
if (SOIChar(v) < 256) and (AnsiChar(v) in [':', #0]) then
begin
TokRec^.field_name := tok.pb.FBuf;
TokRec^.saved_state := tsObjectFieldEnd;
TokRec^.state := tsEatws;
goto redo_char;
end else
if (v = '\') then
begin
TokRec^.saved_state := tsObjectUnquotedField;
TokRec^.state := tsStringEscape;
end else
tok.pb.Append(@v, 1);
end;
tsObjectFieldEnd:
begin
if (v = ':') then
begin
TokRec^.saved_state := tsObjectValue;
TokRec^.state := tsEatws;
end else
begin
tok.err := teParseObjectKeySep;
goto out;
end
end;
tsObjectValue:
begin
if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then
begin
tok.err := teDepth;
goto out;
end;
TokRec^.state := tsObjectValueAdd;
inc(tok.depth);
tok.ResetLevel(tok.depth);
TokRec := @tok.stack[tok.depth];
goto redo_char;
end;
tsObjectValueAdd:
begin
TokRec^.current.AsObject.PutO(TokRec^.field_name, obj);
TokRec^.field_name := '';
TokRec^.saved_state := tsObjectSep;
TokRec^.state := tsEatws;
goto redo_char;
end;
tsObjectSep:
begin
if (v = '}') then
begin
TokRec^.saved_state := tsFinish;
TokRec^.state := tsEatws;
end else
if (v = ',') then
begin
TokRec^.saved_state := tsObjectFieldStart;
TokRec^.state := tsEatws;
end else
begin
tok.err := teParseObjectValueSep;
goto out;
end
end;
end;
inc(str);
inc(tok.char_offset);
until v = #0;
if(TokRec^.state <> tsFinish) and
(TokRec^.saved_state <> tsFinish) then
tok.err := teParseEof;
out:
if(tok.err in [teSuccess]) then
begin
{$IFDEF SUPER_METHOD}
if (foCallMethod in options) and ObjectIsType(TokRec^.current, stMethod) and assigned(TokRec^.current.AsMethod) then
begin
sm := TokRec^.current.AsMethod;
sm(TokRec^.parent, put, Result);
end else
{$ENDIF}
Result := TokRec^.current;
end else
Result := nil;
end;
procedure TSuperObject.PutO(const path: SOString; const Value: ISuperObject);
begin
ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], Value);
end;
procedure TSuperObject.PutB(const path: SOString; Value: Boolean);
begin
ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
end;
procedure TSuperObject.PutD(const path: SOString; Value: Double);
begin
ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
end;
procedure TSuperObject.PutC(const path: SOString; Value: Currency);
begin
ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.CreateCurrency(Value));
end;
procedure TSuperObject.PutI(const path: SOString; Value: SuperInt);
begin
ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
end;
procedure TSuperObject.PutS(const path: SOString; const Value: SOString);
begin
ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
end;
function TSuperObject.QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
begin
if GetInterface(IID, Obj) then
Result := 0
else
Result := E_NOINTERFACE;
end;
function TSuperObject.SaveTo(stream: TStream; indent, escape: boolean): integer;
var
pb: TSuperWriterStream;
begin
if escape then
pb := TSuperAnsiWriterStream.Create(stream) else
pb := TSuperUnicodeWriterStream.Create(stream);
if(Write(pb, indent, escape, 0) < 0) then
begin
pb.Reset;
pb.Free;
Result := 0;
Exit;
end;
Result := stream.Size;
pb.Free;
end;
function TSuperObject.CalcSize(indent, escape: boolean): integer;
var
pb: TSuperWriterFake;
begin
pb := TSuperWriterFake.Create;
if(Write(pb, indent, escape, 0) < 0) then
begin
pb.Free;
Result := 0;
Exit;
end;
Result := pb.FSize;
pb.Free;
end;
function TSuperObject.SaveTo(socket: Integer; indent, escape: boolean): integer;
var
pb: TSuperWriterSock;
begin
pb := TSuperWriterSock.Create(socket);
if(Write(pb, indent, escape, 0) < 0) then
begin
pb.Free;
Result := 0;
Exit;
end;
Result := pb.FSize;
pb.Free;
end;
constructor TSuperObject.Create(const s: SOString);
begin
Create(stString);
FOString := s;
end;
procedure TSuperObject.Clear(all: boolean);
begin
if FProcessing then exit;
FProcessing := true;
try
case FDataType of
stBoolean: FO.c_boolean := false;
stDouble: FO.c_double := 0.0;
stCurrency: FO.c_currency := 0.0;
stInt: FO.c_int := 0;
stObject: FO.c_object.Clear(all);
stArray: FO.c_array.Clear(all);
stString: FOString := '';
{$IFDEF SUPER_METHOD}
stMethod: FO.c_method := nil;
{$ENDIF}
end;
finally
FProcessing := false;
end;
end;
procedure TSuperObject.Pack(all: boolean = false);
begin
if FProcessing then exit;
FProcessing := true;
try
case FDataType of
stObject: FO.c_object.Pack(all);
stArray: FO.c_array.Pack(all);
end;
finally
FProcessing := false;
end;
end;
function TSuperObject.GetN(const path: SOString): ISuperObject;
begin
Result := ParseString(PSOChar(path), False, true, self);
if Result = nil then
Result := TSuperObject.Create(stNull);
end;
procedure TSuperObject.PutN(const path: SOString; const Value: ISuperObject);
begin
if Value = nil then
ParseString(PSOChar(path), False, True, self, [foCreatePath, foPutValue], TSuperObject.Create(stNull)) else
ParseString(PSOChar(path), False, True, self, [foCreatePath, foPutValue], Value);
end;
function TSuperObject.Delete(const path: SOString): ISuperObject;
begin
Result := ParseString(PSOChar(path), False, true, self, [foDelete]);
end;
function TSuperObject.Clone: ISuperObject;
var
ite: TSuperObjectIter;
arr: TSuperArray;
j: integer;
begin
case FDataType of
stBoolean: Result := TSuperObject.Create(FO.c_boolean);
stDouble: Result := TSuperObject.Create(FO.c_double);
stCurrency: Result := TSuperObject.CreateCurrency(FO.c_currency);
stInt: Result := TSuperObject.Create(FO.c_int);
stString: Result := TSuperObject.Create(FOString);
{$IFDEF SUPER_METHOD}
stMethod: Result := TSuperObject.Create(FO.c_method);
{$ENDIF}
stObject:
begin
Result := TSuperObject.Create(stObject);
if ObjectFindFirst(self, ite) then
with Result.AsObject do
repeat
PutO(ite.key, ite.val.Clone);
until not ObjectFindNext(ite);
ObjectFindClose(ite);
end;
stArray:
begin
Result := TSuperObject.Create(stArray);
arr := AsArray;
with Result.AsArray do
for j := 0 to arr.Length - 1 do
Add(arr.GetO(j).Clone);
end;
else
Result := nil;
end;
end;
procedure TSuperObject.Merge(const obj: ISuperObject; reference: boolean);
var
prop1, prop2: ISuperObject;
ite: TSuperObjectIter;
arr: TSuperArray;
j: integer;
begin
if ObjectIsType(obj, FDataType) then
case FDataType of
stBoolean: FO.c_boolean := obj.AsBoolean;
stDouble: FO.c_double := obj.AsDouble;
stCurrency: FO.c_currency := obj.AsCurrency;
stInt: FO.c_int := obj.AsInteger;
stString: FOString := obj.AsString;
{$IFDEF SUPER_METHOD}
stMethod: FO.c_method := obj.AsMethod;
{$ENDIF}
stObject:
begin
if ObjectFindFirst(obj, ite) then
with FO.c_object do
repeat
prop1 := FO.c_object.GetO(ite.key);
if (prop1 <> nil) and (ite.val <> nil) and (prop1.DataType = ite.val.DataType) then
prop1.Merge(ite.val) else
if reference then
PutO(ite.key, ite.val) else
if ite.val <> nil then
PutO(ite.key, ite.val.Clone) else
PutO(ite.key, nil)
until not ObjectFindNext(ite);
ObjectFindClose(ite);
end;
stArray:
begin
arr := obj.AsArray;
with FO.c_array do
for j := 0 to arr.Length - 1 do
begin
prop1 := GetO(j);
prop2 := arr.GetO(j);
if (prop1 <> nil) and (prop2 <> nil) and (prop1.DataType = prop2.DataType) then
prop1.Merge(prop2) else
if reference then
PutO(j, prop2) else
if prop2 <> nil then
PutO(j, prop2.Clone) else
PutO(j, nil);
end;
end;
end;
end;
procedure TSuperObject.Merge(const str: SOString);
begin
Merge(TSuperObject.ParseString(PSOChar(str), False), true);
end;
class function TSuperObject.NewInstance: TObject;
begin
Result := inherited NewInstance;
TSuperObject(Result).FRefCount := 1;
end;
function TSuperObject.ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject;
begin
Result := ParseString(PSOChar(path), False, True, Self, [foCreatePath], nil, dataType);
end;
function TSuperObject.Format(const str: SOString; BeginSep: SOChar; EndSep: SOChar): SOString;
var
p1, p2: PSOChar;
begin
Result := '';
p2 := PSOChar(str);
p1 := p2;
while true do
if p2^ = BeginSep then
begin
if p2 > p1 then
Result := Result + Copy(p1, 0, p2-p1);
inc(p2);
p1 := p2;
while true do
if p2^ = EndSep then Break else
if p2^ = #0 then Exit else
inc(p2);
Result := Result + GetS(copy(p1, 0, p2-p1));
inc(p2);
p1 := p2;
end
else if p2^ = #0 then
begin
if p2 > p1 then
Result := Result + Copy(p1, 0, p2-p1);
Break;
end else
inc(p2);
end;
function TSuperObject.GetO(const path: SOString): ISuperObject;
begin
Result := ParseString(PSOChar(path), False, True, Self);
end;
function TSuperObject.GetA(const path: SOString): TSuperArray;
var
obj: ISuperObject;
begin
obj := ParseString(PSOChar(path), False, True, Self);
if obj <> nil then
Result := obj.AsArray else
Result := nil;
end;
function TSuperObject.GetB(const path: SOString): Boolean;
var
obj: ISuperObject;
begin
obj := GetO(path);
if obj <> nil then
Result := obj.AsBoolean else
Result := false;
end;
function TSuperObject.GetD(const path: SOString): Double;
var
obj: ISuperObject;
begin
obj := GetO(path);
if obj <> nil then
Result := obj.AsDouble else
Result := 0.0;
end;
function TSuperObject.GetC(const path: SOString): Currency;
var
obj: ISuperObject;
begin
obj := GetO(path);
if obj <> nil then
Result := obj.AsCurrency else
Result := 0.0;
end;
function TSuperObject.GetI(const path: SOString): SuperInt;
var
obj: ISuperObject;
begin
obj := GetO(path);
if obj <> nil then
Result := obj.AsInteger else
Result := 0;
end;
function TSuperObject.GetDataPtr: Pointer;
begin
Result := FDataPtr;
end;
function TSuperObject.GetDataType: TSuperType;
begin
Result := FDataType
end;
function TSuperObject.GetS(const path: SOString): SOString;
var
obj: ISuperObject;
begin
obj := GetO(path);
if obj <> nil then
Result := obj.AsString else
Result := '';
end;
function TSuperObject.SaveTo(const FileName: string; indent, escape: boolean): integer;
var
stream: TFileStream;
begin
stream := TFileStream.Create(FileName, fmCreate);
try
Result := SaveTo(stream, indent, escape);
finally
stream.Free;
end;
end;
function TSuperObject.Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean;
begin
Result := Validate(TSuperObject.ParseString(PSOChar(rules), False), TSuperObject.ParseString(PSOChar(defs), False), callback, sender);
end;
function TSuperObject.Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean;
type
TDataType = (dtUnknown, dtStr, dtInt, dtFloat, dtNumber, dtText, dtBool,
dtMap, dtSeq, dtScalar, dtAny);
var
datatypes: ISuperObject;
names: ISuperObject;
function FindInheritedProperty(const prop: PSOChar; p: ISuperObject): ISuperObject;
var
o: ISuperObject;
e: TSuperAvlEntry;
begin
o := p[prop];
if o <> nil then
result := o else
begin
o := p['inherit'];
if (o <> nil) and ObjectIsType(o, stString) then
begin
e := names.AsObject.Search(o.AsString);
if (e <> nil) then
Result := FindInheritedProperty(prop, e.Value) else
Result := nil;
end else
Result := nil;
end;
end;
function FindDataType(o: ISuperObject): TDataType;
var
e: TSuperAvlEntry;
obj: ISuperObject;
begin
obj := FindInheritedProperty('type', o);
if obj <> nil then
begin
e := datatypes.AsObject.Search(obj.AsString);
if e <> nil then
Result := TDataType(e.Value.AsInteger) else
Result := dtUnknown;
end else
Result := dtUnknown;
end;
procedure GetNames(o: ISuperObject);
var
obj: ISuperObject;
f: TSuperObjectIter;
begin
obj := o['name'];
if ObjectIsType(obj, stString) then
names[obj.AsString] := o;
case FindDataType(o) of
dtMap:
begin
obj := o['mapping'];
if ObjectIsType(obj, stObject) then
begin
if ObjectFindFirst(obj, f) then
repeat
if ObjectIsType(f.val, stObject) then
GetNames(f.val);
until not ObjectFindNext(f);
ObjectFindClose(f);
end;
end;
dtSeq:
begin
obj := o['sequence'];
if ObjectIsType(obj, stObject) then
GetNames(obj);
end;
end;
end;
function FindInheritedField(const prop: SOString; p: ISuperObject): ISuperObject;
var
o: ISuperObject;
e: TSuperAvlEntry;
begin
o := p['mapping'];
if ObjectIsType(o, stObject) then
begin
o := o.AsObject.GetO(prop);
if o <> nil then
begin
Result := o;
Exit;
end;
end;
o := p['inherit'];
if ObjectIsType(o, stString) then
begin
e := names.AsObject.Search(o.AsString);
if (e <> nil) then
Result := FindInheritedField(prop, e.Value) else
Result := nil;
end else
Result := nil;
end;
function InheritedFieldExist(const obj: ISuperObject; p: ISuperObject; const name: SOString = ''): boolean;
var
o: ISuperObject;
e: TSuperAvlEntry;
j: TSuperAvlIterator;
begin
Result := true;
o := p['mapping'];
if ObjectIsType(o, stObject) then
begin
j := TSuperAvlIterator.Create(o.AsObject);
try
j.First;
e := j.GetIter;
while e <> nil do
begin
if obj.AsObject.Search(e.Name) = nil then
begin
Result := False;
if assigned(callback) then
callback(sender, veFieldNotFound, name + '.' + e.Name);
end;
j.Next;
e := j.GetIter;
end;
finally
j.Free;
end;
end;
o := p['inherit'];
if ObjectIsType(o, stString) then
begin
e := names.AsObject.Search(o.AsString);
if (e <> nil) then
Result := InheritedFieldExist(obj, e.Value, name) and Result;
end;
end;
function getInheritedBool(f: PSOChar; p: ISuperObject; default: boolean = false): boolean;
var
o: ISuperObject;
begin
o := FindInheritedProperty(f, p);
case ObjectGetType(o) of
stBoolean: Result := o.AsBoolean;
stNull: Result := Default;
else
Result := default;
if assigned(callback) then
callback(sender, veRuleMalformated, f);
end;
end;
procedure GetInheritedFieldList(list: ISuperObject; p: ISuperObject);
var
o: ISuperObject;
e: TSuperAvlEntry;
i: TSuperAvlIterator;
begin
Result := true;
o := p['mapping'];
if ObjectIsType(o, stObject) then
begin
i := TSuperAvlIterator.Create(o.AsObject);
try
i.First;
e := i.GetIter;
while e <> nil do
begin
if list.AsObject.Search(e.Name) = nil then
list[e.Name] := e.Value;
i.Next;
e := i.GetIter;
end;
finally
i.Free;
end;
end;
o := p['inherit'];
if ObjectIsType(o, stString) then
begin
e := names.AsObject.Search(o.AsString);
if (e <> nil) then
GetInheritedFieldList(list, e.Value);
end;
end;
function CheckEnum(o: ISuperObject; p: ISuperObject; name: SOString = ''): boolean;
var
enum: ISuperObject;
i: integer;
begin
Result := false;
enum := FindInheritedProperty('enum', p);
case ObjectGetType(enum) of
stArray:
for i := 0 to enum.AsArray.Length - 1 do
if (o.AsString = enum.AsArray[i].AsString) then
begin
Result := true;
exit;
end;
stNull: Result := true;
else
Result := false;
if assigned(callback) then
callback(sender, veRuleMalformated, '');
Exit;
end;
if (not Result) and assigned(callback) then
callback(sender, veValueNotInEnum, name);
end;
function CheckLength(len: integer; p: ISuperObject; const objpath: SOString): boolean;
var
length, o: ISuperObject;
begin
result := true;
length := FindInheritedProperty('length', p);
case ObjectGetType(length) of
stObject:
begin
o := length.AsObject.GetO('min');
if (o <> nil) and (o.AsInteger > len) then
begin
Result := false;
if assigned(callback) then
callback(sender, veInvalidLength, objpath);
end;
o := length.AsObject.GetO('max');
if (o <> nil) and (o.AsInteger < len) then
begin
Result := false;
if assigned(callback) then
callback(sender, veInvalidLength, objpath);
end;
o := length.AsObject.GetO('minex');
if (o <> nil) and (o.AsInteger >= len) then
begin
Result := false;
if assigned(callback) then
callback(sender, veInvalidLength, objpath);
end;
o := length.AsObject.GetO('maxex');
if (o <> nil) and (o.AsInteger <= len) then
begin
Result := false;
if assigned(callback) then
callback(sender, veInvalidLength, objpath);
end;
end;
stNull: ;
else
Result := false;
if assigned(callback) then
callback(sender, veRuleMalformated, '');
end;
end;
function CheckRange(obj: ISuperObject; p: ISuperObject; const objpath: SOString): boolean;
var
length, o: ISuperObject;
begin
result := true;
length := FindInheritedProperty('range', p);
case ObjectGetType(length) of
stObject:
begin
o := length.AsObject.GetO('min');
if (o <> nil) and (o.Compare(obj) = cpGreat) then
begin
Result := false;
if assigned(callback) then
callback(sender, veInvalidRange, objpath);
end;
o := length.AsObject.GetO('max');
if (o <> nil) and (o.Compare(obj) = cpLess) then
begin
Result := false;
if assigned(callback) then
callback(sender, veInvalidRange, objpath);
end;
o := length.AsObject.GetO('minex');
if (o <> nil) and (o.Compare(obj) in [cpGreat, cpEqu]) then
begin
Result := false;
if assigned(callback) then
callback(sender, veInvalidRange, objpath);
end;
o := length.AsObject.GetO('maxex');
if (o <> nil) and (o.Compare(obj) in [cpLess, cpEqu]) then
begin
Result := false;
if assigned(callback) then
callback(sender, veInvalidRange, objpath);
end;
end;
stNull: ;
else
Result := false;
if assigned(callback) then
callback(sender, veRuleMalformated, '');
end;
end;
function process(o: ISuperObject; p: ISuperObject; objpath: SOString = ''): boolean;
var
ite: TSuperAvlIterator;
ent: TSuperAvlEntry;
p2, o2, sequence: ISuperObject;
s: SOString;
i: integer;
uniquelist, fieldlist: ISuperObject;
begin
Result := true;
if (o = nil) then
begin
if getInheritedBool('required', p) then
begin
if assigned(callback) then
callback(sender, veFieldIsRequired, objpath);
result := false;
end;
end else
case FindDataType(p) of
dtStr:
case ObjectGetType(o) of
stString:
begin
Result := Result and CheckLength(Length(o.AsString), p, objpath);
Result := Result and CheckRange(o, p, objpath);
end;
else
if assigned(callback) then
callback(sender, veInvalidDataType, objpath);
result := false;
end;
dtBool:
case ObjectGetType(o) of
stBoolean:
begin
Result := Result and CheckRange(o, p, objpath);
end;
else
if assigned(callback) then
callback(sender, veInvalidDataType, objpath);
result := false;
end;
dtInt:
case ObjectGetType(o) of
stInt:
begin
Result := Result and CheckRange(o, p, objpath);
end;
else
if assigned(callback) then
callback(sender, veInvalidDataType, objpath);
result := false;
end;
dtFloat:
case ObjectGetType(o) of
stDouble, stCurrency:
begin
Result := Result and CheckRange(o, p, objpath);
end;
else
if assigned(callback) then
callback(sender, veInvalidDataType, objpath);
result := false;
end;
dtMap:
case ObjectGetType(o) of
stObject:
begin
// all objects have and match a rule ?
ite := TSuperAvlIterator.Create(o.AsObject);
try
ite.First;
ent := ite.GetIter;
while ent <> nil do
begin
p2 := FindInheritedField(ent.Name, p);
if ObjectIsType(p2, stObject) then
result := process(ent.Value, p2, objpath + '.' + ent.Name) and result else
begin
if assigned(callback) then
callback(sender, veUnexpectedField, objpath + '.' + ent.Name);
result := false; // field have no rule
end;
ite.Next;
ent := ite.GetIter;
end;
finally
ite.Free;
end;
// all expected field exists ?
Result := InheritedFieldExist(o, p, objpath) and Result;
end;
stNull: {nop};
else
result := false;
if assigned(callback) then
callback(sender, veRuleMalformated, objpath);
end;
dtSeq:
case ObjectGetType(o) of
stArray:
begin
sequence := FindInheritedProperty('sequence', p);
if sequence <> nil then
case ObjectGetType(sequence) of
stObject:
begin
for i := 0 to o.AsArray.Length - 1 do
result := process(o.AsArray.GetO(i), sequence, objpath + '[' + IntToStr(i) + ']') and result;
if getInheritedBool('unique', sequence) then
begin
// type is unique ?
uniquelist := TSuperObject.Create(stObject);
try
for i := 0 to o.AsArray.Length - 1 do
begin
s := o.AsArray.GetO(i).AsString;
if (s <> '') then
begin
if uniquelist.AsObject.Search(s) = nil then
uniquelist[s] := nil else
begin
Result := False;
if Assigned(callback) then
callback(sender, veDuplicateEntry, objpath + '[' + IntToStr(i) + ']');
end;
end;
end;
finally
uniquelist := nil;
end;
end;
// field is unique ?
if (FindDataType(sequence) = dtMap) then
begin
fieldlist := TSuperObject.Create(stObject);
try
GetInheritedFieldList(fieldlist, sequence);
ite := TSuperAvlIterator.Create(fieldlist.AsObject);
try
ite.First;
ent := ite.GetIter;
while ent <> nil do
begin
if getInheritedBool('unique', ent.Value) then
begin
uniquelist := TSuperObject.Create(stObject);
try
for i := 0 to o.AsArray.Length - 1 do
begin
o2 := o.AsArray.GetO(i);
if o2 <> nil then
begin
s := o2.AsObject.GetO(ent.Name).AsString;
if (s <> '') then
if uniquelist.AsObject.Search(s) = nil then
uniquelist[s] := nil else
begin
Result := False;
if Assigned(callback) then
callback(sender, veDuplicateEntry, objpath + '[' + IntToStr(i) + '].' + ent.name);
end;
end;
end;
finally
uniquelist := nil;
end;
end;
ite.Next;
ent := ite.GetIter;
end;
finally
ite.Free;
end;
finally
fieldlist := nil;
end;
end;
end;
stNull: {nop};
else
result := false;
if assigned(callback) then
callback(sender, veRuleMalformated, objpath);
end;
Result := Result and CheckLength(o.AsArray.Length, p, objpath);
end;
else
result := false;
if assigned(callback) then
callback(sender, veRuleMalformated, objpath);
end;
dtNumber:
case ObjectGetType(o) of
stInt,
stDouble, stCurrency:
begin
Result := Result and CheckRange(o, p, objpath);
end;
else
if assigned(callback) then
callback(sender, veInvalidDataType, objpath);
result := false;
end;
dtText:
case ObjectGetType(o) of
stInt,
stDouble,
stCurrency,
stString:
begin
result := result and CheckLength(Length(o.AsString), p, objpath);
Result := Result and CheckRange(o, p, objpath);
end;
else
if assigned(callback) then
callback(sender, veInvalidDataType, objpath);
result := false;
end;
dtScalar:
case ObjectGetType(o) of
stBoolean,
stDouble,
stCurrency,
stInt,
stString:
begin
result := result and CheckLength(Length(o.AsString), p, objpath);
Result := Result and CheckRange(o, p, objpath);
end;
else
if assigned(callback) then
callback(sender, veInvalidDataType, objpath);
result := false;
end;
dtAny:;
else
if assigned(callback) then
callback(sender, veRuleMalformated, objpath);
result := false;
end;
Result := Result and CheckEnum(o, p, objpath)
end;
var
j: integer;
begin
Result := False;
datatypes := TSuperObject.Create(stObject);
names := TSuperObject.Create;
try
datatypes.I['str'] := ord(dtStr);
datatypes.I['int'] := ord(dtInt);
datatypes.I['float'] := ord(dtFloat);
datatypes.I['number'] := ord(dtNumber);
datatypes.I['text'] := ord(dtText);
datatypes.I['bool'] := ord(dtBool);
datatypes.I['map'] := ord(dtMap);
datatypes.I['seq'] := ord(dtSeq);
datatypes.I['scalar'] := ord(dtScalar);
datatypes.I['any'] := ord(dtAny);
if ObjectIsType(defs, stArray) then
for j := 0 to defs.AsArray.Length - 1 do
if ObjectIsType(defs.AsArray[j], stObject) then
GetNames(defs.AsArray[j]) else
begin
if assigned(callback) then
callback(sender, veRuleMalformated, '');
Exit;
end;
if ObjectIsType(rules, stObject) then
GetNames(rules) else
begin
if assigned(callback) then
callback(sender, veRuleMalformated, '');
Exit;
end;
Result := process(self, rules);
finally
datatypes := nil;
names := nil;
end;
end;
function TSuperObject._AddRef: Integer; stdcall;
begin
Result := InterlockedIncrement(FRefCount);
end;
function TSuperObject._Release: Integer; stdcall;
begin
Result := InterlockedDecrement(FRefCount);
if Result = 0 then
Destroy;
end;
function TSuperObject.Compare(const str: SOString): TSuperCompareResult;
begin
Result := Compare(TSuperObject.ParseString(PSOChar(str), False));
end;
function TSuperObject.Compare(const obj: ISuperObject): TSuperCompareResult;
function GetIntCompResult(const i: int64): TSuperCompareResult;
begin
if i < 0 then result := cpLess else
if i = 0 then result := cpEqu else
Result := cpGreat;
end;
function GetDblCompResult(const d: double): TSuperCompareResult;
begin
if d < 0 then result := cpLess else
if d = 0 then result := cpEqu else
Result := cpGreat;
end;
begin
case DataType of
stBoolean:
case ObjectGetType(obj) of
stBoolean: Result := GetIntCompResult(ord(FO.c_boolean) - ord(obj.AsBoolean));
stDouble: Result := GetDblCompResult(ord(FO.c_boolean) - obj.AsDouble);
stCurrency:Result := GetDblCompResult(ord(FO.c_boolean) - obj.AsCurrency);
stInt: Result := GetIntCompResult(ord(FO.c_boolean) - obj.AsInteger);
stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));
else
Result := cpError;
end;
stDouble:
case ObjectGetType(obj) of
stBoolean: Result := GetDblCompResult(FO.c_double - ord(obj.AsBoolean));
stDouble: Result := GetDblCompResult(FO.c_double - obj.AsDouble);
stCurrency:Result := GetDblCompResult(FO.c_double - obj.AsCurrency);
stInt: Result := GetDblCompResult(FO.c_double - obj.AsInteger);
stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));
else
Result := cpError;
end;
stCurrency:
case ObjectGetType(obj) of
stBoolean: Result := GetDblCompResult(FO.c_currency - ord(obj.AsBoolean));
stDouble: Result := GetDblCompResult(FO.c_currency - obj.AsDouble);
stCurrency:Result := GetDblCompResult(FO.c_currency - obj.AsCurrency);
stInt: Result := GetDblCompResult(FO.c_currency - obj.AsInteger);
stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));
else
Result := cpError;
end;
stInt:
case ObjectGetType(obj) of
stBoolean: Result := GetIntCompResult(FO.c_int - ord(obj.AsBoolean));
stDouble: Result := GetDblCompResult(FO.c_int - obj.AsDouble);
stCurrency:Result := GetDblCompResult(FO.c_int - obj.AsCurrency);
stInt: Result := GetIntCompResult(FO.c_int - obj.AsInteger);
stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));
else
Result := cpError;
end;
stString:
case ObjectGetType(obj) of
stBoolean,
stDouble,
stCurrency,
stInt,
stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));
else
Result := cpError;
end;
else
Result := cpError;
end;
end;
{$IFDEF SUPER_METHOD}
function TSuperObject.AsMethod: TSuperMethod;
begin
if FDataType = stMethod then
Result := FO.c_method else
Result := nil;
end;
{$ENDIF}
{$IFDEF SUPER_METHOD}
constructor TSuperObject.Create(m: TSuperMethod);
begin
Create(stMethod);
FO.c_method := m;
end;
{$ENDIF}
{$IFDEF SUPER_METHOD}
function TSuperObject.GetM(const path: SOString): TSuperMethod;
var
v: ISuperObject;
begin
v := ParseString(PSOChar(path), False, True, Self);
if (v <> nil) and (ObjectGetType(v) = stMethod) then
Result := v.AsMethod else
Result := nil;
end;
{$ENDIF}
{$IFDEF SUPER_METHOD}
procedure TSuperObject.PutM(const path: SOString; Value: TSuperMethod);
begin
ParseString(PSOChar(path), False, True, Self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
end;
{$ENDIF}
{$IFDEF SUPER_METHOD}
function TSuperObject.call(const path: SOString; const param: ISuperObject): ISuperObject;
begin
Result := ParseString(PSOChar(path), False, True, Self, [foCallMethod], param);
end;
{$ENDIF}
{$IFDEF SUPER_METHOD}
function TSuperObject.call(const path, param: SOString): ISuperObject;
begin
Result := ParseString(PSOChar(path), False, True, Self, [foCallMethod], TSuperObject.ParseString(PSOChar(param), False));
end;
{$ENDIF}
function TSuperObject.GetProcessing: boolean;
begin
Result := FProcessing;
end;
procedure TSuperObject.SetDataPtr(const Value: Pointer);
begin
FDataPtr := Value;
end;
procedure TSuperObject.SetProcessing(value: boolean);
begin
FProcessing := value;
end;
{ TSuperArray }
function TSuperArray.Add(const Data: ISuperObject): Integer;
begin
Result := FLength;
PutO(Result, data);
end;
function TSuperArray.Delete(index: Integer): ISuperObject;
begin
if (Index >= 0) and (Index < FLength) then
begin
Result := FArray^[index];
FArray^[index] := nil;
Dec(FLength);
if Index < FLength then
begin
Move(FArray^[index + 1], FArray^[index],
(FLength - index) * SizeOf(Pointer));
Pointer(FArray^[FLength]) := nil;
end;
end;
end;
procedure TSuperArray.Insert(index: Integer; const value: ISuperObject);
begin
if (Index >= 0) then
if (index < FLength) then
begin
if FLength = FSize then
Expand(index);
if Index < FLength then
Move(FArray^[index], FArray^[index + 1],
(FLength - index) * SizeOf(Pointer));
Pointer(FArray^[index]) := nil;
FArray^[index] := value;
Inc(FLength);
end else
PutO(index, value);
end;
procedure TSuperArray.Clear(all: boolean);
var
j: Integer;
begin
for j := 0 to FLength - 1 do
if FArray^[j] <> nil then
begin
if all then
FArray^[j].Clear(all);
FArray^[j] := nil;
end;
FLength := 0;
end;
procedure TSuperArray.Pack(all: boolean);
var
PackedCount, StartIndex, EndIndex, j: Integer;
begin
if FLength > 0 then
begin
PackedCount := 0;
StartIndex := 0;
repeat
while (StartIndex < FLength) and (FArray^[StartIndex] = nil) do
Inc(StartIndex);
if StartIndex < FLength then
begin
EndIndex := StartIndex;
while (EndIndex < FLength) and (FArray^[EndIndex] <> nil) do
Inc(EndIndex);
Dec(EndIndex);
if StartIndex > PackedCount then
Move(FArray^[StartIndex], FArray^[PackedCount], (EndIndex - StartIndex + 1) * SizeOf(Pointer));
Inc(PackedCount, EndIndex - StartIndex + 1);
StartIndex := EndIndex + 1;
end;
until StartIndex >= FLength;
FillChar(FArray^[PackedCount], (FLength - PackedCount) * sizeof(Pointer), 0);
FLength := PackedCount;
if all then
for j := 0 to FLength - 1 do
FArray^[j].Pack(all);
end;
end;
constructor TSuperArray.Create;
begin
inherited Create;
FSize := SUPER_ARRAY_LIST_DEFAULT_SIZE;
FLength := 0;
GetMem(FArray, sizeof(Pointer) * FSize);
FillChar(FArray^, sizeof(Pointer) * FSize, 0);
end;
destructor TSuperArray.Destroy;
begin
Clear;
FreeMem(FArray);
inherited;
end;
procedure TSuperArray.Expand(max: Integer);
var
new_size: Integer;
begin
if (max < FSize) then
Exit;
if max < (FSize shl 1) then
new_size := (FSize shl 1) else
new_size := max + 1;
ReallocMem(FArray, new_size * sizeof(Pointer));
FillChar(FArray^[FSize], (new_size - FSize) * sizeof(Pointer), 0);
FSize := new_size;
end;
function TSuperArray.GetO(const index: Integer): ISuperObject;
begin
if(index >= FLength) then
Result := nil else
Result := FArray^[index];
end;
function TSuperArray.GetB(const index: integer): Boolean;
var
obj: ISuperObject;
begin
obj := GetO(index);
if obj <> nil then
Result := obj.AsBoolean else
Result := false;
end;
function TSuperArray.GetD(const index: integer): Double;
var
obj: ISuperObject;
begin
obj := GetO(index);
if obj <> nil then
Result := obj.AsDouble else
Result := 0.0;
end;
function TSuperArray.GetI(const index: integer): SuperInt;
var
obj: ISuperObject;
begin
obj := GetO(index);
if obj <> nil then
Result := obj.AsInteger else
Result := 0;
end;
function TSuperArray.GetS(const index: integer): SOString;
var
obj: ISuperObject;
begin
obj := GetO(index);
if obj <> nil then
Result := obj.AsString else
Result := '';
end;
procedure TSuperArray.PutO(const index: Integer; const Value: ISuperObject);
begin
Expand(index);
FArray^[index] := value;
if(FLength <= index) then FLength := index + 1;
end;
function TSuperArray.GetN(const index: integer): ISuperObject;
begin
Result := GetO(index);
if Result = nil then
Result := TSuperObject.Create(stNull);
end;
procedure TSuperArray.PutN(const index: integer; const Value: ISuperObject);
begin
if Value <> nil then
PutO(index, Value) else
PutO(index, TSuperObject.Create(stNull));
end;
procedure TSuperArray.PutB(const index: integer; Value: Boolean);
begin
PutO(index, TSuperObject.Create(Value));
end;
procedure TSuperArray.PutD(const index: integer; Value: Double);
begin
PutO(index, TSuperObject.Create(Value));
end;
function TSuperArray.GetC(const index: integer): Currency;
var
obj: ISuperObject;
begin
obj := GetO(index);
if obj <> nil then
Result := obj.AsCurrency else
Result := 0.0;
end;
procedure TSuperArray.PutC(const index: integer; Value: Currency);
begin
PutO(index, TSuperObject.CreateCurrency(Value));
end;
procedure TSuperArray.PutI(const index: integer; Value: SuperInt);
begin
PutO(index, TSuperObject.Create(Value));
end;
procedure TSuperArray.PutS(const index: integer; const Value: SOString);
begin
PutO(index, TSuperObject.Create(Value));
end;
{$IFDEF SUPER_METHOD}
function TSuperArray.GetM(const index: integer): TSuperMethod;
var
v: ISuperObject;
begin
v := GetO(index);
if (ObjectGetType(v) = stMethod) then
Result := v.AsMethod else
Result := nil;
end;
{$ENDIF}
{$IFDEF SUPER_METHOD}
procedure TSuperArray.PutM(const index: integer; Value: TSuperMethod);
begin
PutO(index, TSuperObject.Create(Value));
end;
{$ENDIF}
{ TSuperWriterString }
function TSuperWriterString.Append(buf: PSOChar; Size: Integer): Integer;
function max(a, b: Integer): integer; begin if a > b then Result := a else Result := b end;
begin
Result := size;
if Size > 0 then
begin
if (FSize - FBPos <= size) then
begin
FSize := max(FSize * 2, FBPos + size + 8);
ReallocMem(FBuf, FSize * SizeOf(SOChar));
end;
// fast move
case size of
1: FBuf[FBPos] := buf^;
2: PInteger(@FBuf[FBPos])^ := PInteger(buf)^;
4: PInt64(@FBuf[FBPos])^ := PInt64(buf)^;
else
move(buf^, FBuf[FBPos], size * SizeOf(SOChar));
end;
inc(FBPos, size);
FBuf[FBPos] := #0;
end;
end;
function TSuperWriterString.Append(buf: PSOChar): Integer;
begin
Result := Append(buf, strlen(buf));
end;
constructor TSuperWriterString.Create;
begin
inherited;
FSize := 32;
FBPos := 0;
GetMem(FBuf, FSize * SizeOf(SOChar));
end;
destructor TSuperWriterString.Destroy;
begin
inherited;
if FBuf <> nil then
FreeMem(FBuf)
end;
function TSuperWriterString.GetString: SOString;
begin
SetString(Result, FBuf, FBPos);
end;
procedure TSuperWriterString.Reset;
begin
FBuf[0] := #0;
FBPos := 0;
end;
procedure TSuperWriterString.TrimRight;
begin
while (FBPos > 0) and (FBuf[FBPos-1] < #256) and (AnsiChar(FBuf[FBPos-1]) in [#32, #13, #10]) do
begin
dec(FBPos);
FBuf[FBPos] := #0;
end;
end;
{ TSuperWriterStream }
function TSuperWriterStream.Append(buf: PSOChar): Integer;
begin
Result := Append(buf, StrLen(buf));
end;
constructor TSuperWriterStream.Create(AStream: TStream);
begin
inherited Create;
FStream := AStream;
end;
procedure TSuperWriterStream.Reset;
begin
FStream.Size := 0;
end;
{ TSuperWriterStream }
function TSuperAnsiWriterStream.Append(buf: PSOChar; Size: Integer): Integer;
var
Buffer: array[0..1023] of AnsiChar;
pBuffer: PAnsiChar;
i: Integer;
begin
if Size = 1 then
Result := FStream.Write(buf^, Size) else
begin
if Size > SizeOf(Buffer) then
GetMem(pBuffer, Size) else
pBuffer := @Buffer;
try
for i := 0 to Size - 1 do
pBuffer[i] := AnsiChar(buf[i]);
Result := FStream.Write(pBuffer^, Size);
finally
if pBuffer <> @Buffer then
FreeMem(pBuffer);
end;
end;
end;
{ TSuperUnicodeWriterStream }
function TSuperUnicodeWriterStream.Append(buf: PSOChar; Size: Integer): Integer;
begin
Result := FStream.Write(buf^, Size * 2);
end;
{ TSuperWriterFake }
function TSuperWriterFake.Append(buf: PSOChar; Size: Integer): Integer;
begin
inc(FSize, Size);
Result := FSize;
end;
function TSuperWriterFake.Append(buf: PSOChar): Integer;
begin
inc(FSize, Strlen(buf));
Result := FSize;
end;
constructor TSuperWriterFake.Create;
begin
inherited Create;
FSize := 0;
end;
procedure TSuperWriterFake.Reset;
begin
FSize := 0;
end;
{ TSuperWriterSock }
function TSuperWriterSock.Append(buf: PSOChar; Size: Integer): Integer;
var
Buffer: array[0..1023] of AnsiChar;
pBuffer: PAnsiChar;
i: Integer;
begin
if Size = 1 then
{$IFDEF FPC}
Result := fpsend(FSocket, buf, size, 0) else
{$ELSE}
Result := send(FSocket, buf^, size, 0) else
{$ENDIF}
begin
if Size > SizeOf(Buffer) then
GetMem(pBuffer, Size) else
pBuffer := @Buffer;
try
for i := 0 to Size - 1 do
pBuffer[i] := AnsiChar(buf[i]);
{$IFDEF FPC}
Result := fpsend(FSocket, pBuffer, size, 0);
{$ELSE}
Result := send(FSocket, pBuffer^, size, 0);
{$ENDIF}
finally
if pBuffer <> @Buffer then
FreeMem(pBuffer);
end;
end;
inc(FSize, Result);
end;
function TSuperWriterSock.Append(buf: PSOChar): Integer;
begin
Result := Append(buf, StrLen(buf));
end;
constructor TSuperWriterSock.Create(ASocket: Integer);
begin
inherited Create;
FSocket := ASocket;
FSize := 0;
end;
procedure TSuperWriterSock.Reset;
begin
FSize := 0;
end;
{ TSuperTokenizer }
constructor TSuperTokenizer.Create;
begin
pb := TSuperWriterString.Create;
line := 1;
col := 0;
Reset;
end;
destructor TSuperTokenizer.Destroy;
begin
Reset;
pb.Free;
inherited;
end;
procedure TSuperTokenizer.Reset;
var
i: integer;
begin
for i := depth downto 0 do
ResetLevel(i);
depth := 0;
err := teSuccess;
end;
procedure TSuperTokenizer.ResetLevel(adepth: integer);
begin
stack[adepth].state := tsEatws;
stack[adepth].saved_state := tsStart;
stack[adepth].current := nil;
stack[adepth].field_name := '';
stack[adepth].obj := nil;
stack[adepth].parent := nil;
stack[adepth].gparent := nil;
end;
{ TSuperAvlTree }
constructor TSuperAvlTree.Create;
begin
FRoot := nil;
FCount := 0;
// WenTao 用于存储每个节点，以保证顺序
FNodeNames := nil;
end;
destructor TSuperAvlTree.Destroy;
begin
Clear;
// WenTao 用于存储每个节点，以保证顺序
if FNodeNames <> nil then
FreeAndNil(FNodeNames);
inherited;
end;
function TSuperAvlTree.IsEmpty: boolean;
begin
result := FRoot = nil;
end;
function TSuperAvlTree.balance(bal: TSuperAvlEntry): TSuperAvlEntry;
var
deep, old: TSuperAvlEntry;
bf: integer;
begin
if (bal.FBf > 0) then
begin
deep := bal.FGt;
if (deep.FBf < 0) then
begin
old := bal;
bal := deep.FLt;
old.FGt := bal.FLt;
deep.FLt := bal.FGt;
bal.FLt := old;
bal.FGt := deep;
bf := bal.FBf;
if (bf <> 0) then
begin
if (bf > 0) then
begin
old.FBf := -1;
deep.FBf := 0;
end else
begin
deep.FBf := 1;
old.FBf := 0;
end;
bal.FBf := 0;
end else
begin
old.FBf := 0;
deep.FBf := 0;
end;
end else
begin
bal.FGt := deep.FLt;
deep.FLt := bal;
if (deep.FBf = 0) then
begin
deep.FBf := -1;
bal.FBf := 1;
end else
begin
deep.FBf := 0;
bal.FBf := 0;
end;
bal := deep;
end;
end else
begin
(* "Less than" subtree is deeper. *)
deep := bal.FLt;
if (deep.FBf > 0) then
begin
old := bal;
bal := deep.FGt;
old.FLt := bal.FGt;
deep.FGt := bal.FLt;
bal.FGt := old;
bal.FLt := deep;
bf := bal.FBf;
if (bf <> 0) then
begin
if (bf < 0) then
begin
old.FBf := 1;
deep.FBf := 0;
end else
begin
deep.FBf := -1;
old.FBf := 0;
end;
bal.FBf := 0;
end else
begin
old.FBf := 0;
deep.FBf := 0;
end;
end else
begin
bal.FLt := deep.FGt;
deep.FGt := bal;
if (deep.FBf = 0) then
begin
deep.FBf := 1;
bal.FBf := -1;
end else
begin
deep.FBf := 0;
bal.FBf := 0;
end;
bal := deep;
end;
end;
Result := bal;
end;
function TSuperAvlTree.Insert(h: TSuperAvlEntry): TSuperAvlEntry;
var
unbal, parentunbal, hh, parent: TSuperAvlEntry;
depth, unbaldepth: longint;
cmp: integer;
unbalbf: integer;
branch: TSuperAvlBitArray;
p: Pointer;
begin
inc(FCount);
h.FLt := nil;
h.FGt := nil;
h.FBf := 0;
branch := [];
if (FRoot = nil) then begin
FRoot := h;
// WenTao 执行到这里，可以确认这个节点是新增节点。
AddNodeName(h.FName);
end else begin
unbal := nil;
parentunbal := nil;
depth := 0;
unbaldepth := 0;
hh := FRoot;
parent := nil;
repeat
if (hh.FBf <> 0) then
begin
unbal := hh;
parentunbal := parent;
unbaldepth := depth;
end;
if hh.FHash <> h.FHash then
begin
if hh.FHash < h.FHash then cmp := -1 else
if hh.FHash > h.FHash then cmp := 1 else
cmp := 0;
end else
cmp := CompareNodeNode(h, hh);
if (cmp = 0) then
begin
Result := hh;
//exchange data
p := hh.Ptr;
hh.FPtr := h.Ptr;
h.FPtr := p;
doDeleteEntry(h, false);
dec(FCount);
exit;
end;
parent := hh;
if (cmp > 0) then
begin
hh := hh.FGt;
include(branch, depth);
end else
begin
hh := hh.FLt;
exclude(branch, depth);
end;
inc(depth);
until (hh = nil);
// WenTao 执行到这里，可以确认这个节点是新增节点。
AddNodeName(h.FName);
if (cmp < 0) then
parent.FLt := h else
parent.FGt := h;
depth := unbaldepth;
if (unbal = nil) then
hh := FRoot
else
begin
if depth in branch then
cmp := 1 else
cmp := -1;
inc(depth);
unbalbf := unbal.FBf;
if (cmp < 0) then
dec(unbalbf) else
inc(unbalbf);
if cmp < 0 then
hh := unbal.FLt else
hh := unbal.FGt;
if ((unbalbf <> -2) and (unbalbf <> 2)) then
begin
unbal.FBf := unbalbf;
unbal := nil;
end;
end;
if (hh <> nil) then
while (h <> hh) do
begin
if depth in branch then
cmp := 1 else
cmp := -1;
inc(depth);
if (cmp < 0) then
begin
hh.FBf := -1;
hh := hh.FLt;
end else (* cmp > 0 *)
begin
hh.FBf := 1;
hh := hh.FGt;
end;
end;
if (unbal <> nil) then
begin
unbal := balance(unbal);
if (parentunbal = nil) then
FRoot := unbal
else
begin
depth := unbaldepth - 1;
if depth in branch then
cmp := 1 else
cmp := -1;
if (cmp < 0) then
parentunbal.FLt := unbal else
parentunbal.FGt := unbal;
end;
end;
end;
result := h;
end;
function TSuperAvlTree.Search(const k: SOString; st: TSuperAvlSearchTypes): TSuperAvlEntry;
var
cmp, target_cmp: integer;
match_h, h: TSuperAvlEntry;
ha: Cardinal;
begin
ha := TSuperAvlEntry.Hash(k);
match_h := nil;
h := FRoot;
if (stLess in st) then
target_cmp := 1 else
if (stGreater in st) then
target_cmp := -1 else
target_cmp := 0;
while (h <> nil) do
begin
if h.FHash < ha then cmp := -1 else
if h.FHash > ha then cmp := 1 else
cmp := 0;
if cmp = 0 then
cmp := CompareKeyNode(PSOChar(k), h);
if (cmp = 0) then
begin
if (stEqual in st) then
begin
match_h := h;
break;
end;
cmp := -target_cmp;
end
else
if (target_cmp <> 0) then
if ((cmp xor target_cmp) and SUPER_AVL_MASK_HIGH_BIT) = 0 then
match_h := h;
if cmp < 0 then
h := h.FLt else
h := h.FGt;
end;
result := match_h;
end;
function TSuperAvlTree.Delete(const k: SOString): ISuperObject;
var
depth, rm_depth: longint;
branch: TSuperAvlBitArray;
h, parent, child, path, rm, parent_rm: TSuperAvlEntry;
cmp, cmp_shortened_sub_with_path, reduced_depth, bf: integer;
ha: Cardinal;
begin
ha := TSuperAvlEntry.Hash(k);
cmp_shortened_sub_with_path := 0;
branch := [];
depth := 0;
h := FRoot;
parent := nil;
while true do
begin
if (h = nil) then
exit;
if h.FHash < ha then cmp := -1 else
if h.FHash > ha then cmp := 1 else
cmp := 0;
if cmp = 0 then
cmp := CompareKeyNode(k, h);
if (cmp = 0) then
break;
parent := h;
if (cmp > 0) then
begin
h := h.FGt;
include(branch, depth)
end else
begin
h := h.FLt;
exclude(branch, depth)
end;
inc(depth);
cmp_shortened_sub_with_path := cmp;
end;
rm := h;
parent_rm := parent;
rm_depth := depth;
if (h.FBf < 0) then
begin
child := h.FLt;
exclude(branch, depth);
cmp := -1;
end else
begin
child := h.FGt;
include(branch, depth);
cmp := 1;
end;
inc(depth);
if (child <> nil) then
begin
cmp := -cmp;
repeat
parent := h;
h := child;
if (cmp < 0) then
begin
child := h.FLt;
exclude(branch, depth);
end else
begin
child := h.FGt;
include(branch, depth);
end;
inc(depth);
until (child = nil);
if (parent = rm) then
cmp_shortened_sub_with_path := -cmp else
cmp_shortened_sub_with_path := cmp;
if cmp > 0 then
child := h.FLt else
child := h.FGt;
end;
if (parent = nil) then
FRoot := child else
if (cmp_shortened_sub_with_path < 0) then
parent.FLt := child else
parent.FGt := child;
if parent = rm then
path := h else
path := parent;
if (h <> rm) then
begin
h.FLt := rm.FLt;
h.FGt := rm.FGt;
h.FBf := rm.FBf;
if (parent_rm = nil) then
FRoot := h
else
begin
depth := rm_depth - 1;
if (depth in branch) then
parent_rm.FGt := h else
parent_rm.FLt := h;
end;
end;
if (path <> nil) then
begin
h := FRoot;
parent := nil;
depth := 0;
while (h <> path) do
begin
if (depth in branch) then
begin
child := h.FGt;
h.FGt := parent;
end else
begin
child := h.FLt;
h.FLt := parent;
end;
inc(depth);
parent := h;
h := child;
end;
reduced_depth := 1;
cmp := cmp_shortened_sub_with_path;
while true do
begin
if (reduced_depth <> 0) then
begin
bf := h.FBf;
if (cmp < 0) then
inc(bf) else
dec(bf);
if ((bf = -2) or (bf = 2)) then
begin
h := balance(h);
bf := h.FBf;
end else
h.FBf := bf;
reduced_depth := integer(bf = 0);
end;
if (parent = nil) then
break;
child := h;
h := parent;
dec(depth);
if depth in branch then
cmp := 1 else
cmp := -1;
if (cmp < 0) then
begin
parent := h.FLt;
h.FLt := child;
end else
begin
parent := h.FGt;
h.FGt := child;
end;
end;
FRoot := h;
end;
if rm <> nil then
begin
Result := rm.GetValue;
// WenTao 去除节点。
RemoveNode(rm.FName);
doDeleteEntry(rm, false);
dec(FCount);
end;
end;
procedure TSuperAvlTree.Pack(all: boolean);
var
node1, node2: TSuperAvlEntry;
list: TList;
i: Integer;
begin
node1 := FRoot;
list := TList.Create;
while node1 <> nil do
begin
if (node1.FLt = nil) then
begin
node2 := node1.FGt;
if (node1.FPtr = nil) then
list.Add(node1) else
if all then
node1.Value.Pack(all);
end
else
begin
node2 := node1.FLt;
node1.FLt := node2.FGt;
node2.FGt := node1;
end;
node1 := node2;
end;
for i := 0 to list.Count - 1 do
Delete(TSuperAvlEntry(list[i]).FName);
list.Free;
end;
procedure TSuperAvlTree.Clear(all: boolean);
var
node1, node2: TSuperAvlEntry;
begin
// WenTao 清除所有节点。
if FNodeNames <> nil then
FNodeNames.Clear;
node1 := FRoot;
while node1 <> nil do
begin
if (node1.FLt = nil) then
begin
node2 := node1.FGt;
doDeleteEntry(node1, all);
end
else
begin
node2 := node1.FLt;
node1.FLt := node2.FGt;
node2.FGt := node1;
end;
node1 := node2;
end;
FRoot := nil;
FCount := 0;
end;
function TSuperAvlTree.CompareKeyNode(const k: SOString; h: TSuperAvlEntry): integer;
begin
Result := StrComp(PSOChar(k), PSOChar(h.FName));
end;
function TSuperAvlTree.CompareNodeNode(node1, node2: TSuperAvlEntry): integer;
begin
Result := StrComp(PSOChar(node1.FName), PSOChar(node2.FName));
end;
{ TSuperAvlIterator }
(* Initialize depth to invalid value, to indicate iterator is
** invalid. (Depth is zero-base.) It's not necessary to initialize
** iterators prior to passing them to the "start" function.
*)
constructor TSuperAvlIterator.Create(tree: TSuperAvlTree);
begin
FTree := tree;
// WenTao 整个遍历器全部重写，以前是用二叉树的方式，现在改为一个索引即可。
FCurNameIndex := -1;
end;
procedure TSuperAvlIterator.Search(const k: SOString);
begin
// WenTao 整个遍历器全部重写，以前是用二叉树的方式，现在改为一个索引即可。
if FTree.FNodeNames = nil then
FCurNameIndex := -1
else
FCurNameIndex := FTree.FNodeNames.IndexOf(k);
(* WenTao 旧的代码
var
h: TSuperAvlEntry;
d: longint;
cmp, target_cmp: integer;
ha: Cardinal;
begin
ha := TSuperAvlEntry.Hash(k);
h := FTree.FRoot;
d := 0;
FDepth := not 0;
if (h = nil) then
exit;
if (stLess in st) then
target_cmp := 1 else
if (stGreater in st) then
target_cmp := -1 else
target_cmp := 0;
while true do
begin
if h.FHash < ha then cmp := -1 else
if h.FHash > ha then cmp := 1 else
cmp := 0;
if cmp = 0 then
cmp := FTree.CompareKeyNode(k, h);
if (cmp = 0) then
begin
if (stEqual in st) then
begin
FDepth := d;
break;
end;
cmp := -target_cmp;
end
else
if (target_cmp <> 0) then
if ((cmp xor target_cmp) and SUPER_AVL_MASK_HIGH_BIT) = 0 then
FDepth := d;
if cmp < 0 then
h := h.FLt else
h := h.FGt;
if (h = nil) then
break;
if (cmp > 0) then
include(FBranch, d) else
exclude(FBranch, d);
FPath[d] := h;
inc(d);
end;
*)
end;
procedure TSuperAvlIterator.First;
begin
// WenTao 整个遍历器全部重写，以前是用二叉树的方式，现在改为一个索引即可。
FCurNameIndex := 0;
(* WenTao 旧的代码
var
h: TSuperAvlEntry;
begin
h := FTree.FRoot;
FDepth := not 0;
FBranch := [];
while (h <> nil) do
begin
if (FDepth <> not 0) then
FPath[FDepth] := h;
inc(FDepth);
h := h.FLt;
end;
*)
end;
procedure TSuperAvlIterator.Last;
begin
// WenTao 整个遍历器全部重写，以前是用二叉树的方式，现在改为一个索引即可。
if FTree.FNodeNames = nil then
FCurNameIndex := -1
else
FCurNameIndex := FTree.FNodeNames.Count - 1;
(* WenTao 旧的代码
var
h: TSuperAvlEntry;
begin
h := FTree.FRoot;
FDepth := not 0;
FBranch := [0..SUPER_AVL_MAX_DEPTH - 1];
while (h <> nil) do
begin
if (FDepth <> not 0) then
FPath[FDepth] := h;
inc(FDepth);
h := h.FGt;
end;
*)
end;
function TSuperAvlIterator.MoveNext: boolean;
begin
// WenTao 整个遍历器全部重写，以前是用二叉树的方式，现在改为一个索引即可。
if FTree.FNodeNames = nil then
FCurNameIndex := -1
else
Inc(FCurNameIndex);
Result := GetIter <> nil;
(* WenTao 旧的代码
if FDepth = not 0 then
First else
Next;
Result := GetIter <> nil;
*)
end;
function TSuperAvlIterator.GetIter: TSuperAvlEntry;
begin
// WenTao 整个遍历器全部重写，以前是用二叉树的方式，现在改为一个索引即可。
if FTree.FNodeNames = nil then
Result := nil
else if FCurNameIndex < 0 then
Result := nil
else if FCurNameIndex > FTree.FNodeNames.Count - 1 then
Result := nil
else
Result := FTree.Search(FTree.FNodeNames[FCurNameIndex]);
(* WenTao 旧的代码
if (FDepth = not 0) then
begin
result := nil;
exit;
end;
if FDepth = 0 then
Result := FTree.FRoot else
Result := FPath[FDepth - 1];
*)
end;
procedure TSuperAvlIterator.Next;
begin
// WenTao 整个遍历器全部重写，以前是用二叉树的方式，现在改为一个索引即可。
if FTree.FNodeNames = nil then
FCurNameIndex := -1
else
Inc(FCurNameIndex);
(* WenTao 旧的代码
var
h: TSuperAvlEntry;
begin
if (FDepth <> not 0) then
begin
if FDepth = 0 then
h := FTree.FRoot.FGt else
h := FPath[FDepth - 1].FGt;
if (h = nil) then
repeat
if (FDepth = 0) then
begin
FDepth := not 0;
break;
end;
dec(FDepth);
until (not (FDepth in FBranch))
else
begin
include(FBranch, FDepth);
FPath[FDepth] := h;
inc(FDepth);
while true do
begin
h := h.FLt;
if (h = nil) then
break;
exclude(FBranch, FDepth);
FPath[FDepth] := h;
inc(FDepth);
end;
end;
end;
*)
end;
procedure TSuperAvlIterator.Prior;
begin
// WenTao 整个遍历器全部重写，以前是用二叉树的方式，现在改为一个索引即可。
if FTree.FNodeNames = nil then
FCurNameIndex := -1
else
Dec(FCurNameIndex);
(* WenTao 旧的代码
var
h: TSuperAvlEntry;
begin
if (FDepth <> not 0) then
begin
if FDepth = 0 then
h := FTree.FRoot.FLt else
h := FPath[FDepth - 1].FLt;
if (h = nil) then
repeat
if (FDepth = 0) then
begin
FDepth := not 0;
break;
end;
dec(FDepth);
until (FDepth in FBranch)
else
begin
exclude(FBranch, FDepth);
FPath[FDepth] := h;
inc(FDepth);
while true do
begin
h := h.FGt;
if (h = nil) then
break;
include(FBranch, FDepth);
FPath[FDepth] := h;
inc(FDepth);
end;
end;
end;
*)
end;
procedure TSuperAvlTree.doDeleteEntry(Entry: TSuperAvlEntry; all: boolean);
begin
Entry.Free;
end;
function TSuperAvlTree.GetEnumerator: TSuperAvlIterator;
begin
Result := TSuperAvlIterator.Create(Self);
end;
// WenTao 增加了新的函数，用于管理节点。
procedure TSuperAvlTree.AddNodeName(nodeName: SOString);
begin
if FNodeNames = nil then
FNodeNames := TStringList.Create;
FNodeNames.Add(nodeName);
end;
procedure TSuperAvlTree.RemoveNode(nodeName: SOString);
var P: Integer;
begin
if FNodeNames = nil then
Exit;
P := FNodeNames.IndexOf(nodeName);
if P <> -1 then
FNodeNames.Delete(P);
end;
{ TSuperAvlEntry }
constructor TSuperAvlEntry.Create(const AName: SOString; Obj: Pointer);
begin
FName := AName;
FPtr := Obj;
FHash := Hash(FName);
end;
function TSuperAvlEntry.GetValue: ISuperObject;
begin
Result := ISuperObject(FPtr)
end;
class function TSuperAvlEntry.Hash(const k: SOString): Cardinal;
var
h: cardinal;
i: Integer;
begin
h := 0;
for i := 1 to Length(k) do
h := h*129 + ord(k[i]) + $9e370001;
Result := h;
end;
procedure TSuperAvlEntry.SetValue(const val: ISuperObject);
begin
ISuperObject(FPtr) := val;
end;
{ TSuperTableString }
function TSuperTableString.GetValues: ISuperObject;
var
ite: TSuperAvlIterator;
obj: TSuperAvlEntry;
begin
Result := TSuperObject.Create(stArray);
ite := TSuperAvlIterator.Create(Self);
try
ite.First;
obj := ite.GetIter;
while obj <> nil do
begin
Result.AsArray.Add(obj.Value);
ite.Next;
obj := ite.GetIter;
end;
finally
ite.Free;
end;
end;
function TSuperTableString.GetNames: ISuperObject;
var
ite: TSuperAvlIterator;
obj: TSuperAvlEntry;
begin
Result := TSuperObject.Create(stArray);
ite := TSuperAvlIterator.Create(Self);
try
ite.First;
obj := ite.GetIter;
while obj <> nil do
begin
Result.AsArray.Add(TSuperObject.Create(obj.FName));
ite.Next;
obj := ite.GetIter;
end;
finally
ite.Free;
end;
end;
procedure TSuperTableString.doDeleteEntry(Entry: TSuperAvlEntry; all: boolean);
begin
if Entry.Ptr <> nil then
begin
if all then Entry.Value.Clear(true);
Entry.Value := nil;
end;
inherited;
end;
function TSuperTableString.Find(const k: SOString; var value: ISuperObject): Boolean;
var
e: TSuperAvlEntry;
begin
e := Search(k);
if e <> nil then
begin
value := e.Value;
Result := True;
end else
Result := False;
end;
function TSuperTableString.GetO(const k: SOString): ISuperObject;
var
e: TSuperAvlEntry;
begin
e := Search(k);
if e <> nil then
Result := e.Value else
Result := nil
end;
procedure TSuperTableString.PutO(const k: SOString; const value: ISuperObject);
var
entry: TSuperAvlEntry;
begin
entry := Insert(TSuperAvlEntry.Create(k, Pointer(value)));
if entry.FPtr <> nil then
ISuperObject(entry.FPtr)._AddRef;
end;
procedure TSuperTableString.PutS(const k: SOString; const value: SOString);
begin
PutO(k, TSuperObject.Create(Value));
end;
function TSuperTableString.GetS(const k: SOString): SOString;
var
obj: ISuperObject;
begin
obj := GetO(k);
if obj <> nil then
Result := obj.AsString else
Result := '';
end;
procedure TSuperTableString.PutI(const k: SOString; value: SuperInt);
begin
PutO(k, TSuperObject.Create(Value));
end;
function TSuperTableString.GetI(const k: SOString): SuperInt;
var
obj: ISuperObject;
begin
obj := GetO(k);
if obj <> nil then
Result := obj.AsInteger else
Result := 0;
end;
procedure TSuperTableString.PutD(const k: SOString; value: Double);
begin
PutO(k, TSuperObject.Create(Value));
end;
procedure TSuperTableString.PutC(const k: SOString; value: Currency);
begin
PutO(k, TSuperObject.CreateCurrency(Value));
end;
function TSuperTableString.GetC(const k: SOString): Currency;
var
obj: ISuperObject;
begin
obj := GetO(k);
if obj <> nil then
Result := obj.AsCurrency else
Result := 0.0;
end;
function TSuperTableString.GetD(const k: SOString): Double;
var
obj: ISuperObject;
begin
obj := GetO(k);
if obj <> nil then
Result := obj.AsDouble else
Result := 0.0;
end;
procedure TSuperTableString.PutB(const k: SOString; value: Boolean);
begin
PutO(k, TSuperObject.Create(Value));
end;
function TSuperTableString.GetB(const k: SOString): Boolean;
var
obj: ISuperObject;
begin
obj := GetO(k);
if obj <> nil then
Result := obj.AsBoolean else
Result := False;
end;
{$IFDEF SUPER_METHOD}
procedure TSuperTableString.PutM(const k: SOString; value: TSuperMethod);
begin
PutO(k, TSuperObject.Create(Value));
end;
{$ENDIF}
{$IFDEF SUPER_METHOD}
function TSuperTableString.GetM(const k: SOString): TSuperMethod;
var
obj: ISuperObject;
begin
obj := GetO(k);
if obj <> nil then
Result := obj.AsMethod else
Result := nil;
end;
{$ENDIF}
procedure TSuperTableString.PutN(const k: SOString; const value: ISuperObject);
begin
if value <> nil then
PutO(k, TSuperObject.Create(stNull)) else
PutO(k, value);
end;
function TSuperTableString.GetN(const k: SOString): ISuperObject;
var
obj: ISuperObject;
begin
obj := GetO(k);
if obj <> nil then
Result := obj else
Result := TSuperObject.Create(stNull);
end;
{$IFDEF HAVE_RTTI}
{ TSuperAttribute }
constructor TSuperAttribute.Create(const AName: string);
begin
FName := AName;
end;
{ TSuperRttiContext }
constructor TSuperRttiContext.Create;
begin
Context := TRttiContext.Create;
SerialFromJson := TDictionary<PTypeInfo, TSerialFromJson>.Create;
SerialToJson := TDictionary<PTypeInfo, TSerialToJson>.Create;
SerialFromJson.Add(TypeInfo(Boolean), serialfromboolean);
SerialFromJson.Add(TypeInfo(TDateTime), serialfromdatetime);
SerialFromJson.Add(TypeInfo(TGUID), serialfromguid);
SerialToJson.Add(TypeInfo(Boolean), serialtoboolean);
SerialToJson.Add(TypeInfo(TDateTime), serialtodatetime);
SerialToJson.Add(TypeInfo(TGUID), serialtoguid);
end;
destructor TSuperRttiContext.Destroy;
begin
SerialFromJson.Free;
SerialToJson.Free;
Context.Free;
end;
class function TSuperRttiContext.GetFieldName(r: TRttiField): string;
var
o: TCustomAttribute;
begin
for o in r.GetAttributes do
if o is SOName then
Exit(SOName(o).Name);
Result := r.Name;
end;
class function TSuperRttiContext.GetFieldDefault(r: TRttiField; const obj: ISuperObject): ISuperObject;
var
o: TCustomAttribute;
begin
if not ObjectIsType(obj, stNull) then Exit(obj);
for o in r.GetAttributes do
if o is SODefault then
Exit(SO(SODefault(o).Name));
Result := obj;
end;
function TSuperRttiContext.AsType<T>(const obj: ISuperObject): T;
var
ret: TValue;
begin
if FromJson(TypeInfo(T), obj, ret) then
Result := ret.AsType<T> else
raise exception.Create('Marshalling error');
end;
function TSuperRttiContext.AsJson<T>(const obj: T; const index: ISuperObject = nil): ISuperObject;
var
v: TValue;
begin
TValue.Make(@obj, TypeInfo(T), v);
if index <> nil then
Result := ToJson(v, index) else
Result := ToJson(v, so);
end;
function TSuperRttiContext.FromJson(TypeInfo: PTypeInfo; const obj: ISuperObject;
var Value: TValue): Boolean;
procedure FromChar;
begin
if ObjectIsType(obj, stString) and (Length(obj.AsString) = 1) then
begin
Value := string(AnsiString(obj.AsString)[1]);
Result := True;
end else
Result := False;
end;
procedure FromWideChar;
begin
if ObjectIsType(obj, stString) and (Length(obj.AsString) = 1) then
begin
Value := obj.AsString[1];
Result := True;
end else
Result := False;
end;
procedure FromInt64;
var
i: Int64;
begin
case ObjectGetType(obj) of
stInt:
begin
TValue.Make(nil, TypeInfo, Value);
TValueData(Value).FAsSInt64 := obj.AsInteger;
Result := True;
end;
stString:
begin
if TryStrToInt64(obj.AsString, i) then
begin
TValue.Make(nil, TypeInfo, Value);
TValueData(Value).FAsSInt64 := i;
Result := True;
end else
Result := False;
end;
else
Result := False;
end;
end;
procedure FromInt(const obj: ISuperObject);
var
TypeData: PTypeData;
i: Integer;
o: ISuperObject;
begin
case ObjectGetType(obj) of
stInt, stBoolean:
begin
i := obj.AsInteger;
TypeData := GetTypeData(TypeInfo);
if TypeData.MaxValue > TypeData.MinValue then
Result := (i >= TypeData.MinValue) and (i <= TypeData.MaxValue) else
Result := (i >= TypeData.MinValue) and (i <= Int64(PCardinal(@TypeData.MaxValue)^));
if Result then
TValue.Make(@i, TypeInfo, Value);
end;
stString:
begin
o := SO(obj.AsString);
if not ObjectIsType(o, stString) then
FromInt(o) else
Result := False;
end;
else
Result := False;
end;
end;
procedure fromSet;
var
i: Integer;
begin
case ObjectGetType(obj) of
stInt:
begin
TValue.Make(nil, TypeInfo, Value);
TValueData(Value).FAsSLong := obj.AsInteger;
Result := True;
end;
stString:
begin
if TryStrToInt(obj.AsString, i) then
begin
TValue.Make(nil, TypeInfo, Value);
TValueData(Value).FAsSLong := i;
Result := True;
end else
Result := False;
end;
else
Result := False;
end;
end;
procedure FromFloat(const obj: ISuperObject);
var
o: ISuperObject;
begin
case ObjectGetType(obj) of
stInt, stDouble, stCurrency:
begin
TValue.Make(nil, TypeInfo, Value);
case GetTypeData(TypeInfo).FloatType of
ftSingle: TValueData(Value).FAsSingle := obj.AsDouble;
ftDouble: TValueData(Value).FAsDouble := obj.AsDouble;
ftExtended: TValueData(Value).FAsExtended := obj.AsDouble;
ftComp: TValueData(Value).FAsSInt64 := obj.AsInteger;
ftCurr: TValueData(Value).FAsCurr := obj.AsCurrency;
end;
Result := True;
end;
stString:
begin
o := SO(obj.AsString);
if not ObjectIsType(o, stString) then
FromFloat(o) else
Result := False;
end
else
Result := False;
end;
end;
procedure FromString;
begin
case ObjectGetType(obj) of
stObject, stArray:
Result := False;
stnull:
begin
Value := '';
Result := True;
end;
else
Value := obj.AsString;
Result := True;
end;
end;
procedure FromClass;
var
f: TRttiField;
v: TValue;
begin
case ObjectGetType(obj) of
stObject:
begin
Result := True;
if Value.Kind <> tkClass then
Value := GetTypeData(TypeInfo).ClassType.Create;
for f in Context.GetType(Value.AsObject.ClassType).GetFields do
if f.FieldType <> nil then
begin
v := TValue.Empty;
Result := FromJson(f.FieldType.Handle, GetFieldDefault(f, obj.AsObject[GetFieldName(f)]), v);
if Result then
f.SetValue(Value.AsObject, v) else
Exit;
end;
end;
stNull:
begin
Value := nil;
Result := True;
end
else
// error
Value := nil;
Result := False;
end;
end;
procedure FromRecord;
var
f: TRttiField;
p: Pointer;
v: TValue;
begin
Result := True;
TValue.Make(nil, TypeInfo, Value);
for f in Context.GetType(TypeInfo).GetFields do
begin
if ObjectIsType(obj, stObject) and (f.FieldType <> nil) then
begin
{$IFDEF VER210}
p := IValueData(TValueData(Value).FHeapData).GetReferenceToRawData;
{$ELSE}
p := TValueData(Value).FValueData.GetReferenceToRawData;
{$ENDIF}
Result := FromJson(f.FieldType.Handle, GetFieldDefault(f, obj.AsObject[GetFieldName(f)]), v);
if Result then
f.SetValue(p, v) else
begin
Writeln(f.Name);
Exit;
end;
end else
begin
Result := False;
Exit;
end;
end;
end;
procedure FromDynArray;
var
i: Integer;
p: Pointer;
pb: PByte;
val: TValue;
typ: PTypeData;
el: PTypeInfo;
begin
case ObjectGetType(obj) of
stArray:
begin
i := obj.AsArray.Length;
p := nil;
DynArraySetLength(p, TypeInfo, 1, @i);
pb := p;
typ := GetTypeData(TypeInfo);
if typ.elType <> nil then
el := typ.elType^ else
el := typ.elType2^;
Result := True;
for i := 0 to i - 1 do
begin
Result := FromJson(el, obj.AsArray[i], val);
if not Result then
Break;
val.ExtractRawData(pb);
val := TValue.Empty;
Inc(pb, typ.elSize);
end;
if Result then
TValue.MakeWithoutCopy(@p, TypeInfo, Value) else
DynArrayClear(p, TypeInfo);
end;
stNull:
begin
TValue.MakeWithoutCopy(nil, TypeInfo, Value);
Result := True;
end;
else
i := 1;
p := nil;
DynArraySetLength(p, TypeInfo, 1, @i);
pb := p;
typ := GetTypeData(TypeInfo);
if typ.elType <> nil then
el := typ.elType^ else
el := typ.elType2^;
Result := FromJson(el, obj, val);
val.ExtractRawData(pb);
val := TValue.Empty;
if Result then
TValue.MakeWithoutCopy(@p, TypeInfo, Value) else
DynArrayClear(p, TypeInfo);
end;
end;
procedure FromArray;
var
ArrayData: PArrayTypeData;
idx: Integer;
function ProcessDim(dim: Byte; const o: ISuperobject): Boolean;
var
i: Integer;
v: TValue;
a: PTypeData;
begin
if ObjectIsType(o, stArray) and (ArrayData.Dims[dim-1] <> nil) then
begin
a := @GetTypeData(ArrayData.Dims[dim-1]^).ArrayData;
if (a.MaxValue - a.MinValue + 1) <> o.AsArray.Length then
begin
Result := False;
Exit;
end;
Result := True;
if dim = ArrayData.DimCount then
for i := a.MinValue to a.MaxValue do
begin
Result := FromJson(ArrayData.ElType^, o.AsArray[i], v);
if not Result then
Exit;
Value.SetArrayElement(idx, v);
inc(idx);
end
else
for i := a.MinValue to a.MaxValue do
begin
Result := ProcessDim(dim + 1, o.AsArray[i]);
if not Result then
Exit;
end;
end else
Result := False;
end;
var
i: Integer;
v: TValue;
begin
TValue.Make(nil, TypeInfo, Value);
ArrayData := @GetTypeData(TypeInfo).ArrayData;
idx := 0;
if ArrayData.DimCount = 1 then
begin
if ObjectIsType(obj, stArray) and (obj.AsArray.Length = ArrayData.ElCount) then
begin
Result := True;
for i := 0 to ArrayData.ElCount - 1 do
begin
Result := FromJson(ArrayData.ElType^, obj.AsArray[i], v);
if not Result then
Exit;
Value.SetArrayElement(idx, v);
v := TValue.Empty;
inc(idx);
end;
end else
Result := False;
end else
Result := ProcessDim(1, obj);
end;
procedure FromClassRef;
var
r: TRttiType;
begin
if ObjectIsType(obj, stString) then
begin
r := Context.FindType(obj.AsString);
if r <> nil then
begin
Value := TRttiInstanceType(r).MetaclassType;
Result := True;
end else
Result := False;
end else
Result := False;
end;
procedure FromUnknown;
begin
case ObjectGetType(obj) of
stBoolean:
begin
Value := obj.AsBoolean;
Result := True;
end;
stDouble:
begin
Value := obj.AsDouble;
Result := True;
end;
stCurrency:
begin
Value := obj.AsCurrency;
Result := True;
end;
stInt:
begin
Value := obj.AsInteger;
Result := True;
end;
stString:
begin
Value := obj.AsString;
Result := True;
end
else
Value := nil;
Result := False;
end;
end;
procedure FromInterface;
const soguid: TGuid = '{4B86A9E3-E094-4E5A-954A-69048B7B6327}';
var
o: ISuperObject;
begin
if CompareMem(@GetTypeData(TypeInfo).Guid, @soguid, SizeOf(TGUID)) then
begin
if obj <> nil then
TValue.Make(@obj, TypeInfo, Value) else
begin
o := TSuperObject.Create(stNull);
TValue.Make(@o, TypeInfo, Value);
end;
Result := True;
end else
Result := False;
end;
var
Serial: TSerialFromJson;
begin
if TypeInfo <> nil then
begin
if not SerialFromJson.TryGetValue(TypeInfo, Serial) then
case TypeInfo.Kind of
tkChar: FromChar;
tkInt64: FromInt64;
tkEnumeration, tkInteger: FromInt(obj);
tkSet: fromSet;
tkFloat: FromFloat(obj);
tkString, tkLString, tkUString, tkWString: FromString;
tkClass: FromClass;
tkMethod: ;
tkWChar: FromWideChar;
tkRecord: FromRecord;
tkPointer: ;
tkInterface: FromInterface;
tkArray: FromArray;
tkDynArray: FromDynArray;
tkClassRef: FromClassRef;
else
FromUnknown
end else
begin
TValue.Make(nil, TypeInfo, Value);
Result := Serial(Self, obj, Value);
end;
end else
Result := False;
end;
function TSuperRttiContext.ToJson(var value: TValue; const index: ISuperObject): ISuperObject;
procedure ToInt64;
begin
Result := TSuperObject.Create(SuperInt(Value.AsInt64));
end;
procedure ToChar;
begin
Result := TSuperObject.Create(string(Value.AsType<AnsiChar>));
end;
procedure ToInteger;
begin
Result := TSuperObject.Create(TValueData(Value).FAsSLong);
end;
procedure ToFloat;
begin
case Value.TypeData.FloatType of
ftSingle: Result := TSuperObject.Create(TValueData(Value).FAsSingle);
ftDouble: Result := TSuperObject.Create(TValueData(Value).FAsDouble);
ftExtended: Result := TSuperObject.Create(TValueData(Value).FAsExtended);
ftComp: Result := TSuperObject.Create(TValueData(Value).FAsSInt64);
ftCurr: Result := TSuperObject.CreateCurrency(TValueData(Value).FAsCurr);
end;
end;
procedure ToString;
begin
Result := TSuperObject.Create(string(Value.AsType<string>));
end;
procedure ToClass;
var
o: ISuperObject;
f: TRttiField;
v: TValue;
begin
if TValueData(Value).FAsObject <> nil then
begin
o := index[IntToStr(Integer(Value.AsObject))];
if o = nil then
begin
Result := TSuperObject.Create(stObject);
index[IntToStr(Integer(Value.AsObject))] := Result;
for f in Context.GetType(Value.AsObject.ClassType).GetFields do
if f.FieldType <> nil then
begin
v := f.GetValue(Value.AsObject);
Result.AsObject[GetFieldName(f)] := ToJson(v, index);
end
end else
Result := o;
end else
Result := nil;
end;
procedure ToWChar;
begin
Result := TSuperObject.Create(string(Value.AsType<WideChar>));
end;
procedure ToVariant;
begin
Result := SO(Value.AsVariant);
end;
procedure ToRecord;
var
f: TRttiField;
v: TValue;
begin
Result := TSuperObject.Create(stObject);
for f in Context.GetType(Value.TypeInfo).GetFields do
begin
{$IFDEF VER210}
v := f.GetValue(IValueData(TValueData(Value).FHeapData).GetReferenceToRawData);
{$ELSE}
v := f.GetValue(TValueData(Value).FValueData.GetReferenceToRawData);
{$ENDIF}
Result.AsObject[GetFieldName(f)] := ToJson(v, index);
end;
end;
procedure ToArray;
var
idx: Integer;
ArrayData: PArrayTypeData;
procedure ProcessDim(dim: Byte; const o: ISuperObject);
var
dt: PTypeData;
i: Integer;
o2: ISuperObject;
v: TValue;
begin
if ArrayData.Dims[dim-1] = nil then Exit;
dt := GetTypeData(ArrayData.Dims[dim-1]^);
if Dim = ArrayData.DimCount then
for i := dt.MinValue to dt.MaxValue do
begin
v := Value.GetArrayElement(idx);
o.AsArray.Add(toJSon(v, index));
inc(idx);
end
else
for i := dt.MinValue to dt.MaxValue do
begin
o2 := TSuperObject.Create(stArray);
o.AsArray.Add(o2);
ProcessDim(dim + 1, o2);
end;
end;
var
i: Integer;
v: TValue;
begin
Result := TSuperObject.Create(stArray);
ArrayData := @Value.TypeData.ArrayData;
idx := 0;
if ArrayData.DimCount = 1 then
for i := 0 to ArrayData.ElCount - 1 do
begin
v := Value.GetArrayElement(i);
Result.AsArray.Add(toJSon(v, index))
end
else
ProcessDim(1, Result);
end;
procedure ToDynArray;
var
i: Integer;
v: TValue;
begin
Result := TSuperObject.Create(stArray);
for i := 0 to Value.GetArrayLength - 1 do
begin
v := Value.GetArrayElement(i);
Result.AsArray.Add(toJSon(v, index));
end;
end;
procedure ToClassRef;
begin
if TValueData(Value).FAsClass <> nil then
Result := TSuperObject.Create(string(
TValueData(Value).FAsClass.UnitName + '.' +
TValueData(Value).FAsClass.ClassName)) else
Result := nil;
end;
procedure ToInterface;
{$IFNDEF VER210}
var
intf: IInterface;
{$ENDIF}
begin
{$IFDEF VER210}
if TValueData(Value).FHeapData <> nil then
TValueData(Value).FHeapData.QueryInterface(ISuperObject, Result) else
Result := nil;
{$ELSE}
if TValueData(Value).FValueData <> nil then
begin
intf := IInterface(PPointer(TValueData(Value).FValueData.GetReferenceToRawData)^);
if intf <> nil then
intf.QueryInterface(ISuperObject, Result) else
Result := nil;
end else
Result := nil;
{$ENDIF}
end;
var
Serial: TSerialToJson;
begin
if not SerialToJson.TryGetValue(value.TypeInfo, Serial) then
case Value.Kind of
tkInt64: ToInt64;
tkChar: ToChar;
tkSet, tkInteger, tkEnumeration: ToInteger;
tkFloat: ToFloat;
tkString, tkLString, tkUString, tkWString: ToString;
tkClass: ToClass;
tkWChar: ToWChar;
tkVariant: ToVariant;
tkRecord: ToRecord;
tkArray: ToArray;
tkDynArray: ToDynArray;
tkClassRef: ToClassRef;
tkInterface: ToInterface;
else
result := nil;
end else
Result := Serial(Self, value, index);
end;
{ TSuperObjectHelper }
constructor TSuperObjectHelper.FromJson(const obj: ISuperObject; ctx: TSuperRttiContext = nil);
var
v: TValue;
ctxowned: Boolean;
begin
if ctx = nil then
begin
ctx := TSuperRttiContext.Create;
ctxowned := True;
end else
ctxowned := False;
try
v := Self;
if not ctx.FromJson(v.TypeInfo, obj, v) then
raise Exception.Create('Invalid object');
finally
if ctxowned then
ctx.Free;
end;
end;
constructor TSuperObjectHelper.FromJson(const str: string; ctx: TSuperRttiContext = nil);
begin
FromJson(SO(str), ctx);
end;
function TSuperObjectHelper.ToJson(ctx: TSuperRttiContext = nil): ISuperObject;
var
v: TValue;
ctxowned: boolean;
begin
if ctx = nil then
begin
ctx := TSuperRttiContext.Create;
ctxowned := True;
end else
ctxowned := False;
try
v := Self;
Result := ctx.ToJson(v, SO);
finally
if ctxowned then
ctx.Free;
end;
end;
{$ENDIF}
// WenTao 新增加的排序、过滤接口。
procedure TSuperObject.forEachForProperty(eachProp: TProc<{Key}String, {isLast: }Boolean>; eachObj: TProc<{Key}String, {isLast: }Boolean>);
var
item: TSuperObjectIter;
slKeys, slArrays: TStringList;
I: Integer;
begin
slKeys := TStringList.Create;
slArrays := TStringList.Create;
try
if ObjectFindFirst(Self, item) then begin
repeat
if item.val.IsType(stArray) or item.val.IsType(stObject) then
slArrays.Add(item.key)
else
slKeys.Add(item.key);
until ObjectFindNext(item) = False;
for I := 0 to slKeys.Count - 1 do
if Assigned(eachProp) then
eachProp(slKeys[I], (I = slKeys.Count - 1) and (slArrays.Count = 0));
for I := 0 to slArrays.Count - 1 do
if Assigned(eachObj) then
eachObj(slArrays[I], I = slArrays.Count - 1);
end;
finally
ObjectFindClose(item);
slKeys.Free;
slArrays.Free;
end;
end;
procedure TSuperObject.calcMaxLen(lenDict: TDictionary<String, Integer>);
var
I, J, curLen: Integer;
arr: TSuperArray;
item, names: ISuperObject;
curField: String;
begin
// 统计出所有的字段以及字段长度。
arr := AsArray;
for I := 0 to arr.Length - 1 do begin
item := arr.O[I];
names := item.AsObject.GetNames;
for J := 0 to names.AsArray.Length - 1 do begin
curLen := 0;
curField := names.AsArray.S[J];
if item.O[curField].IsType(stObject) or item.O[curField].IsType(stArray) then
Continue;
lenDict.TryGetValue(curField, curLen);
curLen := Max(curLen, Length(AnsiString(item.S[curField])));
lenDict.AddOrSetValue(curField, curLen);
end;
end;
end;
function TSuperObject.forEachForArray(callback: TProc<{Index: }Integer, {item: }ISuperObject, {isLast: }Boolean>): ISuperObject;
var
I: Integer;
arr: TSuperArray;
begin
arr := AsArray;
if arr <> nil then begin
for I := 0 to arr.Length - 1 do begin
callback(I, arr.O[I], I = arr.Length - 1);
end;
end;
end;
{$IFDEF ToStringEx}
class function TSuperObject.escapeValue(valueStr: SOString): SOString;
var
ss: TStringBuilder;
c: WideChar;
I: Integer;
begin
ss := TStringBuilder.Create;
try
for I := 1 to Length(valueStr) do begin
c := valueStr[I];
if False then
else if c = #0 then ss.Append(ESC_ZERO)
else if c = '"' then ss.Append(ESC_QUOT)
else if c = '\' then ss.Append(ESC_SL)
else if c = #9 then ss.Append(ESC_TAB)
else if c = #10 then ss.Append(ESC_LF)
else if c = #13 then ss.Append(ESC_CR)
(*
// 下面这些不转换也行，可读性好。
else if c = #8 then ss.Append(ESC_BS)
else if c = #12 then ss.Append(ESC_FF)
else if c = '/' then ss.Append(ESC_SR)
else if CharInSet(c, [#0..#31]) then ss.Append('\u').Append(IntToHex(Ord(c), 4))
*)
else ss.Append(c);
end;
Result := ss.ToString;
finally
ss.Free;
end;
end;
function TSuperObject.toStringEx(AJsonType: TJsonFormatType): String;
var
jsonStr, resStr: String;
jsonArray: TSuperArray;
jo: ISuperObject;
jsonList: TStringList;
I, J: Integer;
isObject: Boolean;
begin
Result := '';
jsonStr := '';
resStr := '';
isObject := False;
J := 0;
jsonArray := TSuperArray.Create;
jsonList := TStringList.Create;
if False then begin
end else if AJsonType = ftOneLine then begin
Result := AsString;
end else if AJsonType = ftMultiLine then begin
Result := AsJSon(True, False);
end else if AJsonType = ftArray then begin
jsonArray := AsArray;
jsonList.Add('[' + sLineBreak);
for I := 0 to jsonArray.Length - 1 do begin
jo := jsonArray[I];
J := J + 1;
jsonStr := ' { ';
jo.forEachForProperty(procedure {eachProp} (sKeys: String; AIsLast: Boolean) begin
jsonStr := jsonStr + sKeys + ':"' + escapeValue(jo.S[sKeys]) + '"';
if Not AIsLast then begin
jsonStr := jsonStr + ', <Tab>';
end else begin
jsonStr := jsonStr + ' <Tab>},' + sLineBreak;
end;
end, procedure {eachObj} (sKey: String; AIsLast: Boolean) begin
raise Exception.Create('WtJSON.toString的传入参数格式应为JSONArray！');
end);
if J = jsonArray.Length then begin
jsonStr := wtStr.TrimAll(jsonStr, sLineBreak);
jsonStr := wtStr.TrimRight(jsonStr, ',');
jsonStr := jsonStr + sLineBreak;
end;
jsonList.Add(jsonStr);
jsonStr := '';
end;
wtStrList.AdjustTabWidth(jsonList, '<Tab>');
for I := 0 to jsonList.Count - 1 do begin
resStr := resStr + jsonList[I];
end;
resStr := resStr;
Result := wtStr.TrimRight(resStr, ' ') + ']';
end else if AJsonType = ftObjectArray then begin
jsonList.add('{' + sLineBreak);
forEachForProperty(procedure {eachProp} (sKey: String; AIsLast: Boolean) begin
raise Exception.Create('WtJSON.toString的传入参数格式应为JSONArrayObject！');
end,
procedure {eachObj} (sKey: String; AIsLast: Boolean)
var
I: Integer;
jsonObj: ISuperObject;
begin
if Self[sKey].IsType(stArray) then begin
jsonList.Add(' ' + sKey + ': [' + sLineBreak);
jsonArray := A[sKey];
for I := 0 to jsonArray.Length - 1 do begin
jo := jsonArray[I];
J := J + 1;
jsonStr := ' { ';
jo.forEachForProperty(procedure {eachProp} (sKeys: String; AIsLast: Boolean) begin
jsonStr := jsonStr + sKeys + ':"' + escapeValue(jo[sKeys].AsString) + '"';
if Not AIsLast then begin
jsonStr := jsonStr + ', <Tab>';
end else begin
jsonStr := jsonStr + ' <Tab>},' + sLineBreak;
end;
end, procedure {eachObj} (sKey: String; AIsLast: Boolean) begin
raise Exception.Create('WtJSON.toString的传入参数格式应为JSONArray！');
end);
if J = jsonArray.Length then begin
jsonStr := wtStr.TrimAll(jsonStr, sLineBreak);
jsonStr := wtStr.TrimRight(jsonStr, ',');
jsonStr := jsonStr + sLineBreak;
J := 0;
end;
jsonList.Add(jsonStr);
end;
if NOT AIsLast then begin
jsonList.add(' ],' + sLineBreak + sLineBreak);
end else begin
jsonList.add(' ]' + sLineBreak + '}');
end;
wtStrList.AdjustTabWidth(jsonList, '<Tab>');
end else if Self[sKey].IsType(stObject) then begin
isObject := True;
jsonObj := O[sKey];
jsonList.Add(' ' + sKey + ' :{');
jsonObj.forEachForProperty(procedure {eachProp} (sKeys: String; AIsLast: Boolean) begin
jsonStr := jsonStr + sKeys + ': "' + escapeValue(jsonObj.S[sKeys]) + '"';
if Not AIsLast then begin
jsonStr := jsonStr + ', <Tab>';
end else begin
jsonStr := jsonStr + ' <Tab>},' + sLineBreak;
end;
end, procedure {eachObj} (sKey: String; AIsLast: Boolean) begin
raise Exception.Create('WtJSON.toString的传入参数格式应为JSONArray！');
end);
jsonStr := wtStr.TrimAll(jsonStr, sLineBreak);
jsonStr := wtStr.TrimRight(jsonStr, ',');
jsonStr := jsonStr + sLineBreak;
jsonList.Add(jsonStr);
jsonStr := '';
end else begin
raise Exception.Create('WtJSON.toString的传入参数格式有误');
end;
end);
if isObject then begin
wtStrList.AdjustTabWidth(jsonList, '<Tab>');
jsonList.Add('}')
end;
for I := 0 to jsonList.Count - 1 do begin
resStr := resStr + jsonList[I];
end;
Result := resStr;
end;
end;
{$ENDIF}
procedure TSuperObject.needArray;
begin
if FDataType <> stArray then
raise Exception.Create('当前对象类型必须为 JsonArray，才能执行此操作!');
end;
function TSuperObject.reverse: ISuperObject;
var
temp: ISuperObject;
tempArr, arr: TSuperArray;
I: Integer;
begin
temp := SO('[]');
tempArr := temp.AsArray;
arr := AsArray;
for I := arr.Length - 1 downto 0 do begin
tempArr.Add(arr[I]);
end;
Clear;
for I := 0 to tempArr.Length - 1 do begin
arr.Add(tempArr[I]);
end;
end;
function TSuperObject.sortByField(AFieldName: String; ADataType: TSuperType = stString): ISuperObject;
begin
needArray;
Result := sort(function(Left, Right: ISuperObject): Integer
begin
if False then begin
end else if ADataType in [stDouble, stCurrency] then begin
Result := Sign(Left.D[AFieldName] - Right.D[AFieldName]);
end else if ADataType = stInt then begin
Result := Left.I[AFieldName] - Right.I[AFieldName];
end else begin
Result := AnsiCompareStr(Left.S[AFieldName], Right.S[AFieldName]);
end;
end);
end;
function TSuperObject.sort(onCompare: TFunc<ISuperObject, ISuperObject, Integer>): ISuperObject;
var
arr: TSuperArray;
list: TList<ISuperObject>;
jo: ISuperObject;
I: Integer;
begin
needArray;
Result := SO('[]');
list := TList<ISuperObject>.Create(TComparer<ISuperObject>.Construct(function(const Left, Right: ISuperObject): Integer begin
Result := onCompare(Left, Right);
end));
try
arr := AsArray;
for I := 0 to arr.Length - 1 do begin
list.add(arr[I]);
end;
list.Sort;
arr := Result.AsArray;
for jo in list do
arr.Add(jo);
finally
list.Free;
end;
end;
function TSuperObject.filterByField(AFieldName: String; AValue: Variant; ADataType: TSuperType = stString): ISuperObject;
begin
needArray;
Result := filter(function(jo: ISuperObject): Boolean begin
if False then begin
end else if ADataType in [stDouble, stCurrency] then begin
Result := jo.D[AFieldName] = Double(AValue);
end else if ADataType = stInt then begin
Result := jo.I[AFieldName] = Integer(AValue);
end else begin
Result := AnsiCompareStr(jo.S[AFieldName], VarToStr(AValue)) = 0;
end;
end)
end;
function TSuperObject.filter(onCompare: TFunc<ISuperObject, Boolean>): ISuperObject;
var
arr, retArr: TSuperArray;
I: Integer;
begin
needArray;
Result := SO('[]');
arr := AsArray;
retArr := Result.AsArray;
for I := 0 to arr.Length - 1 do
if onCompare(arr[I]) then
retArr.Add(arr[I]);
end;
function TSuperObject.findByField(AFieldName: String; AValue: Variant; ADataType: TSuperType = stString): ISuperObject;
begin
needArray;
Result := find(function(jo: ISuperObject): Boolean begin
if False then begin
end else if ADataType in [stDouble, stCurrency] then begin
Result := jo.D[AFieldName] = Double(AValue);
end else if ADataType = stInt then begin
Result := jo.I[AFieldName] = Integer(AValue);
end else begin
Result := AnsiCompareStr(jo.S[AFieldName], VarToStr(AValue)) = 0;
end;
end)
end;
function TSuperObject.find(onCompare: TFunc<ISuperObject, Boolean>): ISuperObject;
var
arr: TSuperArray;
I: Integer;
begin
needArray;
Result := nil;
arr := AsArray;
for I := 0 to arr.Length - 1 do
if onCompare(arr[I]) then begin
Result := arr[I];
Exit;
end;
end;
{$IFDEF DEBUG}
initialization
finalization
// Assert(debugcount = 0, 'Memory leak');
// 增加这行代码会让数据库监控程序在退出时，提示 N 个“Runtime error 216 at 004060A2”提示框。
(*
可以使用 SEH 解决。
delphi编写的时出现 runtime error 216 at 数字 的解决方法_百度文库 http://wenku.baidu.com/link?url=qoavWEiHryeXGkYlIN29ZBeF1Hk7YexzrzHrDwsaUvGvvun41gPnJfPmFh_QZSROHu8cmnu4_Ybm3XXDWb1j0OFo9Sz1pA0tcRoiclkSOEO
Delphi异常机制与SEH_百度文库 http://wenku.baidu.com/view/ea69faef5ef7ba0d4a733bff.html
*)
{$ENDIF}
end.
标签：
版权申明：本站文章部分自网络，如有侵权，请联系：west999com@outlook.com
特别注意：本站所有转载文章言论不代表本站观点，本站所提供的摄影照片，插画，设计作品，如需使用，请与原作者联系，版权归原作者所有
相关文章
- Delphi10.3的ListView学习(大图标） 2020-06-05
- Delphi10.3的SpeedButton/BitBtn学习 2020-06-05
- Delphi10.3状态栏上显示进度条/图片 2020-06-02
- Delphi10.3下自带系统托盘 TrayIcon的使用 2020-06-01
- delphi10.3安装使用mySQL 2020-05-31
IDC资讯： 主机资讯 注册资讯 托管资讯 vps资讯 网站建设
网站运营： 建站经验 策划盈利 搜索优化 网站推广 免费资源
网络编程： Asp.Net编程 Asp编程 Php编程 Xml编程 Access Mssql Mysql 其它
服务器技术： Web服务器 Ftp服务器 Mail服务器 Dns服务器 安全防护
软件技巧： 其它软件 Word Excel Powerpoint Ghost Vista QQ空间 QQ FlashGet 迅雷
网页制作： FrontPages Dreamweaver Javascript css photoshop fireworks Flash
热门词条
最新资讯
热门关注
热门标签