From 073bb3ce27dba59c191338a4cc14631bdc40165d Mon Sep 17 00:00:00 2001 From: Dgby714 Date: Wed, 29 Sep 2010 06:07:55 -0400 Subject: [PATCH] Updated paste.sex Added superobject unit Added GetJSONValue function to extensions --- Extensions/paster.sex | 259 +- Projects/Simba/psextension.pas | 2 + Units/MMLAddon/PSInc/Wrappers/extensions.inc | 8 + Units/Misc/superobject.pas | 7380 ++++++++++++++++++ 4 files changed, 7552 insertions(+), 97 deletions(-) create mode 100644 Units/Misc/superobject.pas diff --git a/Extensions/paster.sex b/Extensions/paster.sex index c55a354..be66b06 100644 --- a/Extensions/paster.sex +++ b/Extensions/paster.sex @@ -1,18 +1,11 @@ program Paster; - +//{$DEFINE DEV} +{$IFDEF EXTENSION} var - Paster_Menu, Private_MenuItem, Paster_MenuItem, Divider_MenuItem, AltHost_Menu: TMenuItem; + Paster_Menu, GetPaste_MenuItem, Private_MenuItem, Paster_MenuItem, AltHost_Menu: TMenuItem; + Divider_MenuItems: array[1..2] of TMenuItem; AltHost_Menus: array[1..5] of TMenuItem; - AltHost_MenuItems: array[1..5] of array[1..2] of TMenuItem; - -type - TJSON = record - name: string; - value_type: string; - value_string: string; - value_bool: boolean; - end; - TJSONArray = array of TJSON; + AltHost_MenuItems: array[1..5] of array[1..4] of TMenuItem; function EncodeString(Data: string): string; var @@ -27,57 +20,17 @@ begin Result := Replace(Result, Pattern[I], Replacement[I], [rfIgnoreCase, rfReplaceAll]); end; -function CreateJSON(Name: string; Value: variant): TJSON; -begin - Result.name := Name; - case VarType(Value) of //Made it a case incase we add more =) - varString: begin - Result.value_type := 'string'; - Result.value_string := EncodeString(Value); - exit; - end; - varBoolean: begin - Result.value_type := 'boolean'; - Result.value_bool := Value; - end; - varNull: begin - Result.value_type := 'null'; - end; - end; -end; - -function DecodeJSON(JSON: string): TJSONArray; +function DecodeString(Data: string): string; var - StringArray: TStringArray; - AStringArray: array of TStringArray; + Pattern, Replacement: TStringArray; I: integer; begin - JSON := Between('{', '}', JSON); - StringArray := Explode(', ', JSON); - SetArrayLength(AStringArray, Length(StringArray)); - for I := 0 to High(StringArray) do - AStringArray[I] := Explode('": ', StringArray[I]); - SetArrayLength(Result, Length(AStringArray)); - for I := 0 to High(AStringArray) do - Result[I] := CreateJSON(Between('"', '"', AStringArray[I][0] + '"'), Between('"', '"', AStringArray[I][1])); -end; - -function EncodeJSON(JSON: TJSONArray): string; -var - I: integer; -begin - Result := '{'; - for I := 0 to High(JSON) do - begin - Result := Result + '"' + JSON[I].name + '": '; - case JSON[I].value_type of - 'string': Result := Result + '"' + JSON[I].value_string + '"'; - 'boolean': Result := Result + Lowercase(BoolToStr(JSON[I].value_bool)); - end; - if (I < High(JSON)) then - Result := Result + ', '; - end; - Result := Result + '}'; + Pattern := ['\\', '\b', '\t', '\n', '\v', '\f', '\r', '\"', {'\'#39,} '\/']; + Replacement := ['\', #8, #9, #10, #11, #12, #13, '"', {#39,} '/']; + Result := Data; + if (Length(Pattern) = Length(Replacement)) then + for I := Low(Pattern) to High(Pattern) do + Result := Replace(Result, Pattern[I], Replacement[I], [rfIgnoreCase, rfReplaceAll]); end; function GetName: string; @@ -87,29 +40,87 @@ end; function GetVersion: string; begin; - Result := '0.1a'; + Result := '0.2a'; +end; + +function JSONRequest(var Data: string; const HOST, Method: string): boolean; +{$IFDEF DEV}var + I: integer;{$ENDIF} +begin + {$IFDEF DEV} + WriteLn('(HOST, Method) := ('#39 + HOST + #39', '#39 + Method + #39');'); + WriteLn('Data := '#39 + Data + #39';'); + {$ENDIF} + Data := GetPageEx('http://' + HOST + '/json/?method=' + Method, Data, 'application/json'); + {$IFDEF DEV}WriteLn('Data := '#39 + Data + #39';');{$ENDIF} + if (Data = '') then + begin + Data := '{"data": null, "error": "Server unresponsive!"}'; + Result := False; + Exit; + end; + + if (Method = 'pastes.getPaste') then + begin + //Little hack for getPaste too work.... + Data := Replace(Data, '{"data": {', '{', []); + Data := Replace(Data, '}, "error": ', ', "error": ', []); + end; + + Result := True; +end; + +function GetPaste(HOST: string): boolean; +var + Data: string; +begin + if (HOST = '') then + HOST := 'paste.sheeva.villavu.com'; + if (InputQuery(GetName + ' ' + GetVersion + ' Extension', 'Which ID would you like too grab?', Data)) then + begin + if IntToStr(StrToInt(Data)) = Data then + Data := '{"paste_id": ' + Data + '}' + else + Data := '{"paste_id": "' + Data + '"}'; + + if (not (JSONRequest(Data, HOST, 'pastes.getPaste'))) then + begin + WriteLn('[Paster]Error: ' + GetJSONValue(Data, 'error')); + Result := False; + Exit; + end; + + if ((GetJSONValue(Data, 'code') = 'null') and (GetJSONValue(Data, 'error') = 'null')) then + begin + WriteLn('[Paster]Error: Invalid Paste ID!'); + Result := False; + Exit; + end; + + Data := GetJSONValue(Data, 'code'); + WriteLn('[Paster]Info: Sorry guys I can''t open a script from extensions yet...'); + WriteLn(Data); + Result := True; + end; end; function PasteIt(out Data: string; HOST: string): boolean; var - JSONArray: TJSONArray; + is_private: boolean; begin if (HOST = '') then HOST := 'paste.sheeva.villavu.com'; if (MessageDlg(GetName + ' ' + GetVersion + ' Extension', 'Upload this script to ' + HOST + '?', mtConfirmation, [mbYes, mbNo], 0) = mrYes) then begin - Data := EncodeJSON([CreateJSON('language', 'delphi'), CreateJSON('code', ScriptText), CreateJSON('private', (Lowercase(Settings.getKeyValueDef('Private', 'true')) = 'true'))]) - Data := GetPageEx('http://' + HOST + '/json/?method=pastes.newPaste', Data, 'application/json'); - JSONArray := DecodeJSON(Data); //Should be 0 = id and 1 = error - if (JSONArray[0].value_string = '') then + is_private := (Lowercase(Settings.getKeyValueDef('Private', 'true')) = 'true'); + Data := '{"language": "delphi", "code": "' + EncodeString(ScriptText) + '", "private": ' + Lowercase(BoolToStr(is_private)) + '}'; + JSONRequest(Data, HOST, 'pastes.newPaste'); + if (GetJSONValue(Data, 'error') = 'null') then begin - Data := '[Paster]Error: ' + JSONArray[1].value_string - Result := False; - end else - begin - Data := 'http://' + HOST + '/show/' + JSONArray[0].value_string + '/'; + Data := 'http://' + HOST + '/show/' + GetJSONValue(Data, 'data') + '/'; Result := True; - end; + end else + Data := '[Paster]Error: ' + GetJSONValue(Data, 'error'); end; end; @@ -131,34 +142,45 @@ var begin if InputQuery(GetName + ' ' + GetVersion + ' Extension', 'Please input the LodgeIt Host! (Ex: paste.pocoo.org)', Data) then begin + {$IFDEF DEV}WriteLn('Data := '#39 + Data + #39';');{$ENDIF} + if (Data = '') then + begin + WriteLn('[Paster] Error: The server cannot be blank!'); + Exit; + end; AltHost_Menus[I].Caption := Data; AltHost_MenuItems[I][1].Enabled := True; + AltHost_MenuItems[I][2].Enabled := True; Settings.setKeyValue('Host' + IntToStr(I), Data); end; end; procedure OnClick(Sender: TObject); var - I: integer; + I, K: integer; begin; case Sender of Paster_MenuItem: Paste(''); - AltHost_MenuItems[1][1]: Paste(Settings.getKeyValue('Host1')); - AltHost_MenuItems[2][1]: Paste(Settings.getKeyValue('Host2')); - AltHost_MenuItems[3][1]: Paste(Settings.getKeyValue('Host3')); - AltHost_MenuItems[4][1]: Paste(Settings.getKeyValue('Host4')); - AltHost_MenuItems[5][1]: Paste(Settings.getKeyValue('Host5')); - AltHost_MenuItems[1][2]: UpdateHost(1); - AltHost_MenuItems[2][2]: UpdateHost(2); - AltHost_MenuItems[3][2]: UpdateHost(3); - AltHost_MenuItems[4][2]: UpdateHost(4); - AltHost_MenuItems[5][2]: UpdateHost(5); + GetPaste_MenuItem: GetPaste(''); Private_MenuItem: begin Private_MenuItem.Checked := (not (Private_MenuItem.Checked)); - Settings.SetKeyValue('Private', Lowercase(BoolToStr(Private_MenuItem.Checked))); - WriteLn('Private = ' + Lowercase(BoolToStr(Private_MenuItem.Checked))); + Settings.setKeyValue('Private', Lowercase(BoolToStr(Private_MenuItem.Checked))); + {$IFDEF DEV}WriteLn('Private = ' + Lowercase(BoolToStr(Private_MenuItem.Checked)));{$ENDIF} end; end; + for I := 1 to 5 do + for K := 1 to 4 do + if (Sender = AltHost_MenuItems[I][K]) then + begin + {$IFDEF DEV}WriteLn('Sender = ' + IntToStr(I) + ', ' + IntToStr(K));{$ENDIF} + if (K = 4) then + UpdateHost(I); + if (K = 2) then + GetPaste(Settings.getKeyValue('Host' + IntToStr(I))); + if (K = 1) then + Paste(Settings.getKeyValue('Host' + IntToStr(I))); + Break; + end; end; procedure Attach; @@ -167,12 +189,30 @@ begin; Paster_Menu.Visible := True; end; -Procedure Detach; +procedure Detach; begin Paster_Menu.Visible := False; end; -procedure Init; +procedure Free; +var + I, K: integer; +begin + for I := 5 downto 1 do + begin + for K := 4 downto 1 do + AltHost_MenuItems[I][K].Free; + AltHost_Menus[I].Free; + end; + AltHost_Menu.Free; + Private_MenuItem.Free; + for I := 2 downto 1 do + Divider_MenuItems[I].Free; + Paster_MenuItem.Free; + Paster_Menu.Free; +end; + +procedure init; var I, K: integer; begin; @@ -187,7 +227,24 @@ begin; OnClick := @OnClick; end; Paster_Menu.Add(Paster_MenuItem); - + + GetPaste_MenuItem := TMenuItem.Create(Paster_Menu); + with GetPaste_MenuItem do + begin + Caption := 'Get Paste!'; + OnClick := @OnClick; + {$IFNDEF DEV}Visible := False;{$ENDIF} + end; + Paster_Menu.Add(GetPaste_MenuItem); + + for I := 1 to 2 do + begin + Divider_MenuItems[I] := TMenuItem.Create(Paster_Menu); + Divider_MenuItems[I].Caption := '-'; + end; + + Paster_Menu.Add(Divider_MenuItems[1]); + Private_MenuItem := TMenuItem.Create(Paster_Menu); with Private_MenuItem do begin @@ -196,10 +253,8 @@ begin; Checked := (Lowercase(Settings.getKeyValueDef('Private', 'true')) = 'true'); end; Paster_Menu.Add(Private_MenuItem); - - Divider_MenuItem := TMenuItem.Create(Paster_Menu); - Divider_MenuItem.Caption := '-'; - Paster_Menu.Add(Divider_MenuItem); + + Paster_Menu.Add(Divider_MenuItems[2]); AltHost_Menu := TMenuItem.Create(Paster_Menu); AltHost_Menu.Caption := 'Alternate Hosts'; @@ -211,20 +266,30 @@ begin; AltHost_Menus[I].Caption := Settings.getKeyValueDef('Host' + IntToStr(I), 'Host ' + IntToStr(I)); AltHost_Menu.Add(AltHost_Menus[I]); - for K := 1 to 2 do + for K := 1 to 4 do begin AltHost_MenuItems[I][K] := TMenuItem.Create(AltHost_Menus[I]); case K of 1: AltHost_MenuItems[I][1].Caption := 'Paste It!'; - 2: AltHost_MenuItems[I][2].Caption := 'Update Host'; + 2: AltHost_MenuItems[I][2].Caption := 'Get Paste!'; + 3: AltHost_MenuItems[I][3].Caption := '-'; + 4: AltHost_MenuItems[I][4].Caption := 'Update Host'; end; AltHost_MenuItems[I][K].OnClick := @OnClick; - if ((K = 1) and (AltHost_Menus[I].Caption = 'Host ' + IntToStr(I))) then - AltHost_MenuItems[I][1].Enabled := False; + if ((not ((K = 3) or (K = 4))) and (AltHost_Menus[I].Caption = 'Host ' + IntToStr(I))) then + AltHost_MenuItems[I][K].Enabled := False; + + {$IFNDEF DEV}if (K = 2) then + AltHost_MenuItems[I][K].Visible := False;{$ENDIF} + AltHost_Menus[I].Add(AltHost_MenuItems[I][K]); end; end; end; - +{$ENDIF} begin +{$IFNDEF EXTENSION} + WriteLn('This is a Extension for Simba. If you are in Simba click View->Extensions and enable paster.sex!'); +{$ENDIF} end. + diff --git a/Projects/Simba/psextension.pas b/Projects/Simba/psextension.pas index f01a9d5..124b0d4 100644 --- a/Projects/Simba/psextension.pas +++ b/Projects/Simba/psextension.pas @@ -67,6 +67,7 @@ uses SynRegExpr, lclintf, httpsend, + superobject, SimbaUnit,updateform, mmisc, mmlpsthread; // for GetTickCount and others.//Writeln {$ifdef Linux} @@ -185,6 +186,7 @@ begin AddFunction(@ext_ScriptText,'function ScriptText: string;'); AddRegisteredPTRVariable('Settings','TMMLSettingsSandbox'); AddFunction(@ext_GetPageEx,'function GetPageEx(const URL, PostData, MimeType: string): string;'); + AddFunction(@ext_GetJSONValue,'function GetJSONValue(const Data, Value: string): string;'); AddRegisteredVariable('Simba','TForm'); AddRegisteredVariable('Simba_MainMenu','TMainMenu'); AddRegisteredVariable('Client','TClient'); diff --git a/Units/MMLAddon/PSInc/Wrappers/extensions.inc b/Units/MMLAddon/PSInc/Wrappers/extensions.inc index f4eeb01..d554e38 100644 --- a/Units/MMLAddon/PSInc/Wrappers/extensions.inc +++ b/Units/MMLAddon/PSInc/Wrappers/extensions.inc @@ -153,3 +153,11 @@ begin HTTPSend.Free; end; end; + +function ext_GetJSONValue(const Data, Value: string): string; +var + SuperObject: ISuperObject; +begin + SuperObject := SO(Data); + Result := SuperObject.AsObject.S[Value]; +end; diff --git a/Units/Misc/superobject.pas b/Units/Misc/superobject.pas new file mode 100644 index 0000000..86d63b5 --- /dev/null +++ b/Units/Misc/superobject.pas @@ -0,0 +1,7380 @@ +(* + * 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} + +unit superobject; + +interface +uses + Classes +{$IFDEF VER210} + ,Generics.Collections, RTTI, TypInfo +{$ENDIF} + ; + +type +{$IFNDEF FPC} + PtrInt = longint; + PtrUInt = Longword; +{$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(PtrInt) 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 VER210} + 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; + + +{$IFDEF VER210} + +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_STANDARD: Result := tzi.Bias; + TIME_ZONE_ID_DAYLIGHT: Result := 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 - 1]) 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, 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; + + 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; + 'Z', 'z': state := stUTC; + #0: state := stEnd; + else + goto error; + end; + stUTC: // = GMT 0 + begin + //SystemTimeToTzSpecificLocalTime(nil, @st, @st); + inc(p); + if p^ = #0 then + Break else + goto error; + end; + stGMTH: + 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; + 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; + 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 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 VER210} + +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 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 + PutO(ite.key, ite.val.Clone); + 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 + PutO(j, prop2.Clone); + 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; + +{$OVERFLOWCHECKS OFF} +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; +{$OVERFLOWCHECKS ON} + +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 VER210} + +{ 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); + Result := (i >= TypeData.MinValue) and (i <= 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 + 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 + p := IValueData(TValueData(Value).FHeapData).GetReferenceToRawData; + Result := FromJson(f.FieldType.Handle, GetFieldDefault(f, obj.AsObject[GetFieldName(f)]), v); + if Result then + f.SetValue(p, v) else + Exit; + 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 + v := f.GetValue(IValueData(TValueData(Value).FHeapData).GetReferenceToRawData); + 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; + begin + if TValueData(Value).FHeapData <> nil then + TValueData(Value).FHeapData.QueryInterface(ISuperObject, Result) else + Result := nil; + 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. +