(* * 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 * Web site : http://www.progdigy.com * * This unit is inspired from the json c lib: * Michael Clark * http://oss.metaparadigm.com/json-c/ * * CHANGES: * 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]%') * + 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} unit superobject; interface uses Classes {$IFDEF HAVE_RTTI} ,Generics.Collections, RTTI, TypInfo {$ENDIF} ; 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; function balance(bal: TSuperAvlEntry): TSuperAvlEntry; protected 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; FBranch: TSuperAvlBitArray; FDepth: LongInt; FPath: array[0..SUPER_AVL_MAX_DEPTH - 2] of TSuperAvlEntry; public constructor Create(tree: TSuperAvlTree); virtual; 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; 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; 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); 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; 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; SerialToJson: TDictionary; 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(const obj: ISuperObject): T; function AsJson(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 sysutils, {$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; ps: TArray; 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; end; destructor TSuperAvlTree.Destroy; begin Clear; 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 FRoot := h 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); 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; 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 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 FDepth := not 0; FTree := tree; end; procedure TSuperAvlIterator.Search(const k: SOString; st: TSuperAvlSearchTypes); 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; 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; 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 if FDepth = not 0 then First else Next; Result := GetIter <> nil; end; function TSuperAvlIterator.GetIter: TSuperAvlEntry; begin 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; 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; 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; { 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.Create; SerialToJson := TDictionary.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(const obj: ISuperObject): T; var ret: TValue; begin if FromJson(TypeInfo(T), obj, ret) then Result := ret.AsType else raise exception.Create('Marshalling error'); end; function TSuperRttiContext.AsJson(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)); 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)); 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)); 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} {$IFDEF DEBUG} initialization finalization Assert(debugcount = 0, 'Memory leak'); {$ENDIF} end.